aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/interp/ChangeLog95
-rw-r--r--src/interp/Makefile.in7
-rw-r--r--src/interp/Makefile.pamphlet7
-rw-r--r--src/interp/def.lisp.pamphlet20
-rw-r--r--src/interp/diagnostics.boot12
-rw-r--r--src/interp/macros.lisp.pamphlet791
-rw-r--r--src/interp/sys-globals.boot18
-rw-r--r--src/interp/sys-macros.lisp1204
8 files changed, 1394 insertions, 760 deletions
diff --git a/src/interp/ChangeLog b/src/interp/ChangeLog
index 1679d370..ea51af87 100644
--- a/src/interp/ChangeLog
+++ b/src/interp/ChangeLog
@@ -1,3 +1,98 @@
+2007-09-09 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * sys-macros.lisp: New.
+ * sys-globals.boot: Import sys-constants.
+ * macros.lisp.pamphlet (|$compilingMape): Move to sys-globals.boot.
+ (|$definingMap|): Likewise.
+ ($TRACELETFLAG): Likewise.
+ ($NEWSPAD): Likewise.
+ ($BOOT): Likewise.
+ (MOAN): Move to diagnostic.boot
+ (FAIL): Likewise.
+ (KAR): move to sys-macros.lisp
+ (KDR): Likewise.
+ (KADR): Likewise.
+ (KADDR): Likewise.
+ (|function|): Likewise.
+ (|dispatchFunction|): Likewise.
+ (QEQCAR): Likewise.
+ (BOOT-EQUAL): Likewise.
+ (IDENT-CHAR-LIT): Likewise.
+ (EQQUAL): Likewise.
+ (NEQUAL): Likewise.
+ (EQUABLE): Likewise.
+ (MKQ): Likewise.
+ (IS): Likewise.
+ (LETT): Likewise.
+ (SPADLET): Likewise.
+ (RPLAC): Likewise.
+ (CARCDREXPAND): Likewise.
+ (RENAME): Likewise.
+ (CARCDRX1): Likewise.
+ (APPLYR): Likewise.
+ (REPEAT): Likewise.
+ (REPEAT-TRAN): Likewise.
+ (MKPF): Likewise.
+ (MKPFFLATTEN): Likewise.
+ (MKPFFLATTEN-1): Likewise.
+ (MKPF1): Likewise.
+ (-REPEAT): Likewise.
+ (SEQOPT): Likewise.
+ (SUCHTHATCLAUSE): Likewise.
+ (SPADDO): Likewise.
+ (SPAD_LET): Likewise.
+ (COLLECT): Likewise.
+ (COLLECTVEC): Likewise.
+ (COLLECTV): Likewise.
+ (MKQSADD1): Likewise.
+ (YIELD): Likewise.
+ (REMFLAG): Likewise.
+ (FLAGP): Likewise.
+ (INTERNL): Likewise.
+ (SPADCATCH): Likewise.
+ (SPADTHROW): Likewise.
+ (IEQUAL): Likewise.
+ (GE): Likewise.
+ (GT): Likewise.
+ (LE): Likewise.
+ (LT): Likewise.
+ (QSADDMOD): Likewise.
+ (QSDIFMOD): Likewise.
+ (QSMULTMOD): Likewise.
+ (NLIST): Likewise.
+ (SPADREDUCE): Likewise.
+ (AND2): Likewise.
+ (OR2): Likewise.
+ (REDUCE-1): Likewise.
+ (-REDUCE): Likewise.
+ (-REDUCE-OP): Likewise.
+ (NREVERSE-N): Likewise.
+ (CONS-N): Likewise.
+ (APPEND-N): Likewise.
+ (REDUCE-N): Likewise.
+ (REDUCE-N-1): Likewise.
+ (REDUCE-N-2): Likewise.
+ (THETA): Likewise.
+ (THETA1): Likewise.
+ (THETA_ERROR): Likewise.
+ (SPADFIRST): Likewise.
+ (FIRST-ERROR): Likewise.
+ (ELEM): Likewise.
+ (TAIL): Likewise.
+ (PARTCODET): Likewise.
+ (SPADCALL): Likewise.
+ (S+): Likewise.
+ (S*): Likewise.
+ (S-): Likewise.
+ (DELASC): Likewise.
+ (|char|): Likewise.
+ (MAKE-BF): Likewise.
+ (MAKE-FLOAT): Likewise.
+ * def.lisp.pamphlet (MK_LEFORM): Move to sys-macros.lisp.
+ (MK_LEFORM-CONS): Likewise.
+ * Makefile.pamphlet (${DEPSYS}): Depend on sys-macros.lisp.
+ (sys-globals.$(FASLEXT)): New rule.
+
2007-09-08 Gabriel Dos Reis <gdr@cs.tamu.edu>
* Makefile.pamphlet (makeint.lisp): Don't print SYS, LISP, BYE.
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index 9a058ca4..d67e86eb 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -338,6 +338,7 @@ ${DEPSYS}: vmlisp.$(FASLEXT) \
sys-constants.$(FASLEXT) \
sys-globals.$(FASLEXT) \
diagnostics.$(FASLEXT) \
+ sys-macros.$(FASLEXT) \
${DEP} \
nocompil.$(FASLEXT) \
bookvol5.$(FASLEXT)\
@@ -417,11 +418,15 @@ bookvol5.$(FASLEXT): bookvol5.lisp boot-pkg.$(FASLEXT)
nocompil.$(FASLEXT): nocompil.lisp boot-pkg.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+sys-macros.$(FASLEXT): sys-macros.lisp diagnostics.$(FASLEXT) \
+ union.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
diagnostics.$(FASLEXT): diagnostics.boot sys-constants.$(FASLEXT) \
sys-globals.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-sys-globals.$(FASLEXT): sys-globals.boot boot-pkg.$(FASLEXT) \
+sys-globals.$(FASLEXT): sys-globals.boot sys-constants.$(FASLEXT) \
hash.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet
index 4bd270f4..8919b8e7 100644
--- a/src/interp/Makefile.pamphlet
+++ b/src/interp/Makefile.pamphlet
@@ -971,6 +971,7 @@ ${DEPSYS}: vmlisp.$(FASLEXT) \
sys-constants.$(FASLEXT) \
sys-globals.$(FASLEXT) \
diagnostics.$(FASLEXT) \
+ sys-macros.$(FASLEXT) \
${DEP} \
nocompil.$(FASLEXT) \
bookvol5.$(FASLEXT)\
@@ -1049,11 +1050,15 @@ bookvol5.$(FASLEXT): bookvol5.lisp boot-pkg.$(FASLEXT)
nocompil.$(FASLEXT): nocompil.lisp boot-pkg.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+sys-macros.$(FASLEXT): sys-macros.lisp diagnostics.$(FASLEXT) \
+ union.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
diagnostics.$(FASLEXT): diagnostics.boot sys-constants.$(FASLEXT) \
sys-globals.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-sys-globals.$(FASLEXT): sys-globals.boot boot-pkg.$(FASLEXT) \
+sys-globals.$(FASLEXT): sys-globals.boot sys-constants.$(FASLEXT) \
hash.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
diff --git a/src/interp/def.lisp.pamphlet b/src/interp/def.lisp.pamphlet
index 6b0228c1..de62641d 100644
--- a/src/interp/def.lisp.pamphlet
+++ b/src/interp/def.lisp.pamphlet
@@ -381,25 +381,6 @@ foo defined inside of fum gets renamed as fum,foo.")
(LIST ''T (LIST 'LET_ERROR (LIST 'MAKESTRING
(MK_LEFORM FORM)) G)) ) )))
-(defun MK_LEFORM (U)
- (COND ((IDENTP U) (PNAME U))
- ((STRINGP U) U)
- ((ATOM U) (STRINGIMAGE U))
- ((MEMBER (FIRST U) '(VCONS CONS) :test #'eq)
- (STRCONC "(" (MK_LEFORM-CONS U) ")") )
- ((EQ (FIRST U) 'LIST) (STRCONC "(" (MK_LEFORM (SECOND U)) ")") )
- ((EQ (FIRST U) 'APPEND) (STRCONC "(" (MK_LEFORM-CONS U) ")") )
- ((EQ (FIRST U) 'QUOTE) (MK_LEFORM (SECOND U)))
- ((EQ (FIRST U) 'EQUAL) (STRCONC "=" (MK_LEFORM (SECOND U)) ))
- ((EQ (FIRST U) 'SPADLET) (MK_LEFORM (THIRD U)))
- ((ERRHUH))))
-
-(defun MK_LEFORM-CONS (U)
- (COND ((ATOM U) (STRCONC ":" (MK_LEFORM U)))
- ((EQ (FIRST U) 'APPEND)
- (STRCONC ":" (MK_LEFORM (SECOND U)) "\," (MK_LEFORM-CONS (THIRD U)) ))
- ((EQ (THIRD U) NIL) (MK_LEFORM (SECOND U)))
- ((STRCONC (MK_LEFORM (SECOND U)) "\," (MK_LEFORM-CONS (THIRD U))))))
(defun LET_ERROR (FORM VAL)
(|systemError| (format nil "~S is not matched by structure ~S~%" FORM VAL)))
@@ -563,7 +544,6 @@ foo defined inside of fum gets renamed as fum,foo.")
(SETQ $DEFSTACK (CONS (LIST (CONS OP (CDR XP)) Y) $DEFSTACK))
NIL))
-(defun ERRHUH () (|systemError| "problem with BOOT to LISP translation"))
(mapcar #'(lambda (x) (MAKEPROP (first X) 'SEL\,FUNCTION (second X)))
'((|aTree| 0) (|aMode| 1)
diff --git a/src/interp/diagnostics.boot b/src/interp/diagnostics.boot
index 2e5163ac..b02f5eb2 100644
--- a/src/interp/diagnostics.boot
+++ b/src/interp/diagnostics.boot
@@ -53,3 +53,15 @@ BUMPERRORCOUNT kind ==
kind = "semantic" => 2
ERROR '"BUMPERRORCOUNT: unknown error kind"
$SPAD__ERRORS.index := 1 + $SPAD__ERRORS.index
+
+FAIL() ==
+ systemError '"Antique error (FAIL ENTERED)"
+
+ERRHUH() ==
+ systemError '"problem with BOOT to LISP translation"
+
+MOAN(:x) ==
+ sayBrightly ['"%l", '"===> ", :x, '"%l"]
+
+THETA__ERROR op ==
+ userError ['"Sorry, do not know the identity element for ", op]
diff --git a/src/interp/macros.lisp.pamphlet b/src/interp/macros.lisp.pamphlet
index 5437ae2d..1cd2f731 100644
--- a/src/interp/macros.lisp.pamphlet
+++ b/src/interp/macros.lisp.pamphlet
@@ -140,16 +140,8 @@ ends up being [[CONTAINED |$EmptyMode| Y]].
<<*>>=
<<license>>
-(import-module "sys-constants")
+(import-module "sys-macros")
(in-package "BOOT")
-
-(defvar |$compilingMap| ())
-(defvar |$definingMap| nil)
-
-(defmacro KAR (ARG) `(ifcar ,arg))
-(defmacro KDR (ARG) `(ifcdr ,arg))
-(defmacro KADR (ARG) `(ifcar (ifcdr ,arg)))
-(defmacro KADDR (ARG) `(ifcar (ifcdr (ifcdr ,arg))))
; 5 PROGRAM STRUCTURE
@@ -159,9 +151,6 @@ ends up being [[CONTAINED |$EmptyMode| Y]].
; 5.3.2 Declaring Global Variables and Named Constants
-(defmacro |function| (name) `(FUNCTION ,name))
-(defmacro |dispatchFunction| (name) `(FUNCTION ,name))
-
(defun |functionp| (fn)
(if (identp fn) (and (fboundp fn) (not (macro-function fn))) (functionp fn)))
(defun |macrop| (fn) (and (identp fn) (macro-function fn)))
@@ -172,20 +161,6 @@ ends up being [[CONTAINED |$EmptyMode| Y]].
; 6.3 Equality Predicates
-;; qeqcar should be used when you know the first arg is a pair
-;; the second arg should either be a literal fixnum or a symbol
-;; the car of the first arg is always of the same type as the second
-;; use eql unless we are sure fixnums are represented canonically
-
-#-lucid
-(defmacro qeqcar (x y)
- (if (integerp y) `(eql (the fixnum (qcar ,x)) (the fixnum ,y))
- `(eq (qcar ,x) ,y)))
-
-#+lucid
-(defmacro qeqcar (x y) `(eq (qcar ,x) ,y))
-
-
(defun COMPARE (X Y)
"True if X is an atom or X and Y are lists and X and Y are equal up to X."
(COND ((ATOM X) T)
@@ -216,208 +191,20 @@ ends up being [[CONTAINED |$EmptyMode| Y]].
((EQUAL U V))
((NOT (string> (write-to-string U) (write-to-string V))))))
-(defmacro boot-equal (a b)
- (cond ((ident-char-lit a)
- `(or (eql ,a ,b) (eql (character ,a) ,b)))
- ((ident-char-lit b)
- `(or (eql ,a ,b) (eql ,a (character ,b))))
- (t `(eqqual ,a ,b))))
-
-(defun ident-char-lit (x)
- (and (eqcar x 'quote) (identp (cadr x)) (= (length (pname (cadr x))) 1)))
-
-(defmacro EQQUAL (a b)
- (cond ((OR (EQUABLE a) (EQUABLE b)) `(eq ,a ,b))
- ((OR (numberp a) (numberp b)) `(eql ,a ,b))
- (t `(equal ,a ,b))))
-
-(defmacro NEQUAL (a b) `(not (BOOT-EQUAL ,a ,b)))
-
-(defun EQUABLE (X)
- (OR (NULL X) (AND (EQCAR X 'QUOTE) (symbolp (CADR X)))))
-
; 7 CONTROL STRUCTURE
; 7.1 Constants and Variables
; 7.1.1 Reference
-(DEFUN MKQ (X)
- "Evaluates an object and returns it with QUOTE wrapped around it."
- (if (NUMBERP X) X (LIST 'QUOTE X)))
-
; 7.2 Generalized Variables
-(defmacro IS (x y) `(dcq ,y ,x))
-
-(defmacro LETT (var val &rest L)
- (COND
- (|$QuickLet| `(SETQ ,var ,val))
- (|$compilingMap|
- ;; map tracing
- `(PROGN
- (SETQ ,var ,val)
- (COND (|$letAssoc|
- (|mapLetPrint| ,(MKQ var)
- ,var
- (QUOTE ,(KAR L))))
- ('T ,var))))
- ;; used for LETs in SPAD code --- see devious trick in COMP,TRAN,1
- ((ATOM var)
- `(PROGN
- (SETQ ,var ,val)
- (IF |$letAssoc|
- ,(cond ((null (cdr l))
- `(|letPrint| ,(MKQ var) ,var (QUOTE ,(KAR L))))
- ((and (eqcar (car l) 'SPADCALL) (= (length (car l)) 3))
- `(|letPrint3| ,(MKQ var) ,var ,(third (car l)) (QUOTE ,(KADR L))))
- (t `(|letPrint2| ,(MKQ var) ,(car l) (QUOTE ,(KADR L))))))
- ,var))
- ('T (ERROR "Cannot compileLET construct"))))
-
-(defmacro SPADLET (A B)
- (if (ATOM A) `(SETQ ,A ,B)
- `(OR (IS ,B ,A) (LET_ERROR ,(MK_LEFORM A) ,(MKQ B) ))))
-
-(defmacro RPLAC (&rest L)
- (if (EQCAR (CAR L) 'ELT)
- (LIST 'SETELT (CADAR L) (CADDR (CAR L)) (CADR L))
- (let ((A (CARCDREXPAND (CAR L) NIL)) (B (CADR L)))
- (COND ((CDDR L) (ERROR 'RPLAC))
- ((EQCAR A 'CAR) (LIST 'RPLACA (CADR A) B))
- ((EQCAR A 'CDR) (LIST 'RPLACD (CADR A) B))
- ((ERROR 'RPLAC))))))
-
-(MAPC #'(LAMBDA (J) (MAKEPROP (CAR J) 'SELCODE (CADR J)))
- '((CAR 2) (CDR 3) (CAAR 4) (CADR 5) (CDAR 6) (CDDR 7)
- (CAAAR 8) (CAADR 9) (CADAR 10) (CADDR 11) (CDAAR 12)
- (CDADR 13) (CDDAR 14) (CDDDR 15) (CAAAAR 16) (CAAADR 17)
- (CAADAR 18) (CAADDR 19) (CADAAR 20) (CADADR 21) (CADDAR 22)
- (CADDDR 23) (CDAAAR 24) (CDAADR 25) (CDADAR 26) (CDADDR 27)
- (CDDAAR 28) (CDDADR 29) (CDDDAR 30) (CDDDDR 31)))
-
-(eval-when (compile eval load)
-(defun CARCDREXPAND (X FG) ; FG = TRUE FOR CAR AND CDR
- (let (n hx)
- (COND ((ATOM X) X)
- ((SETQ N (GET (RENAME (SETQ HX (CARCDREXPAND (CAR X) FG))) 'SELCODE))
- (CARCDRX1 (CARCDREXPAND (CADR X) FG) N FG))
- ((CONS HX (MAPCAR #'(LAMBDA (Y) (CARCDREXPAND Y FG)) (CDR X)))))))
-
-(DEFUN RENAME (U)
- (let (x)
- (if (AND (IDENTP U) (SETQ X (GET U 'NEWNAM))) X U)))
-
-(defun CARCDRX1 (X N FG) ; FG = TRUE FOR CAR AND CDR
- (COND ((< N 1) (fail))
- ((EQL N 1) X)
- ((let ((D (DIVIDE N 2)))
- (CARCDRX1 (LIST (if (EQL (CADR D) 0) (if FG 'CAR 'CAR) (if FG 'CDR 'CDR)) X)
- (CAR D)
- FG))))))
-
-
; 7.3 Function Invocation
-(DEFUN APPLYR (L X) (if (not L) X (LIST (CAR L) (APPLYR (CDR L) X))))
-
; 7.8 Iteration
; 7.8.2 General Iteration
-(defmacro REPEAT (&rest L)
- (let ((U (REPEAT-TRAN L NIL))) (-REPEAT (CDR U) (CAR U))))
-
-(defun REPEAT-TRAN (L LP)
- (COND ((ATOM L) (ERROR "REPEAT FORMAT ERROR"))
- ((MEMBER (KAR (KAR L))
- '(EXIT RESET IN ON GSTEP ISTEP STEP GENERAL UNTIL WHILE SUCHTHAT EXIT))
- (REPEAT-TRAN (CDR L) (CONS (CAR L) LP)))
- ((CONS (NREVERSE LP) (MKPF L 'PROGN)))))
-
-(DEFUN MKPF (L OP)
- (if (FLAGP OP 'NARY) (SETQ L (MKPFFLATTEN-1 L OP NIL)))
- (MKPF1 L OP))
-
-(DEFUN MKPFFLATTEN (X OP)
- (COND ((ATOM X) X)
- ((EQL (CAR X) OP) (CONS OP (MKPFFLATTEN-1 (CDR X) OP NIL)))
- ((CONS (MKPFFLATTEN (CAR X) OP) (MKPFFLATTEN (CDR X) OP)))))
-
-(DEFUN MKPFFLATTEN-1 (L OP R)
- (let (X)
- (if (NULL L)
- R
- (MKPFFLATTEN-1 (CDR L) OP
- (APPEND R (if (EQCAR (SETQ X
- (MKPFFLATTEN (CAR L) OP)) OP)
- (CDR X) (LIST X)))))))
-
-(DEFUN MKPF1 (L OP)
- (let (X) (case OP (PLUS (COND ((EQL 0 (SETQ X (LENGTH
- (SETQ L (S- L '(0 (ZERO))))))) 0)
- ((EQL 1 X) (CAR L))
- ((CONS 'PLUS L)) ))
- (TIMES (COND ((S* L '(0 (ZERO))) 0)
- ((EQL 0 (SETQ X (LENGTH
- (SETQ L (S- L '(1 (ONE))))))) 1)
- ((EQL 1 X) (CAR L))
- ((CONS 'TIMES L)) ))
- (QUOTIENT (COND ((GREATERP (LENGTH L) 2) (fail))
- ((EQL 0 (CAR L)) 0)
- ((EQL (CADR L) 1) (CAR L))
- ((CONS 'QUOTIENT L)) ))
- (MINUS (COND ((CDR L) (FAIL))
- ((NUMBERP (SETQ X (CAR L))) (MINUS X))
- ((EQCAR X 'MINUS) (CADR X))
- ((CONS 'MINUS L)) ))
- (DIFFERENCE (COND ((GREATERP (LENGTH L) 2) (FAIL))
- ((EQUAL (CAR L) (CADR L)) '(ZERO))
- ((|member| (CAR L) '(0 (ZERO))) (MKPF (CDR L) 'MINUS))
- ((|member| (CADR L) '(0 (ZERO))) (CAR L))
- ((EQCAR (CADR L) 'MINUS)
- (MKPF (LIST (CAR L) (CADADR L)) 'PLUS))
- ((CONS 'DIFFERENCE L)) ))
- (EXPT (COND ((GREATERP (LENGTH L) 2) (FAIL))
- ((EQL 0 (CADR L)) 1)
- ((EQL 1 (CADR L)) (CAR L))
- ((|member| (CAR L) '(0 1 (ZERO) (ONE))) (CAR L))
- ((CONS 'EXPT L)) ))
- (OR (COND ((MEMBER 'T L) ''T)
- ((EQL 0 (SETQ X (LENGTH (SETQ L (REMOVE NIL L))))) NIL)
- ((EQL 1 X) (CAR L))
- ((CONS 'OR L)) ))
- (|or| (COND ((MEMBER 'T L) 'T)
- ((EQL 0 (SETQ X (LENGTH (SETQ L (REMOVE NIL L))))) NIL)
- ((EQL 1 X) (CAR L))
- ((CONS 'or L)) ))
- (NULL (COND ((CDR L) (FAIL))
- ((EQCAR (CAR L) 'NULL) (CADAR L))
- ((EQL (CAR L) 'T) NIL)
- ((NULL (CAR L)) ''T)
- ((CONS 'NULL L)) ))
- (|and| (COND ((EQL 0 (SETQ X (LENGTH
- (SETQ L (REMOVE T (REMOVE '|true| L)))))) T)
- ((EQL 1 X) (CAR L))
- ((CONS '|and| L)) ))
- (AND (COND ((EQL 0 (SETQ X (LENGTH
- (SETQ L (REMOVE T (REMOVE '|true| L)))))) ''T)
- ((EQL 1 X) (CAR L))
- ((CONS 'AND L)) ))
- (PROGN (COND ((AND (NOT (ATOM L)) (NULL (LAST L)))
- (if (CDR L) `(PROGN . ,L) (CAR L)))
- ((NULL (SETQ L (REMOVE NIL L))) NIL)
- ((CDR L) (CONS 'PROGN L))
- ((CAR L))))
- (SEQ (COND ((EQCAR (CAR L) 'EXIT) (CADAR L))
- ((CDR L) (CONS 'SEQ L))
- ((CAR L))))
- (LIST (if L (cons 'LIST L)))
- (CONS (if (cdr L) (cons 'CONS L) (car L)))
- (t (CONS OP L) ))))
-
-(defvar $TRACELETFLAG NIL "Also referred to in Comp.Lisp")
-
(defmacro |Zero| (&rest L)
(declare (ignore l))
"Needed by spadCompileOrSetq" 0)
@@ -426,186 +213,7 @@ ends up being [[CONTAINED |$EmptyMode| Y]].
(declare (ignore l))
"Needed by spadCompileOrSetq" 1)
-(defun -REPEAT (BD SPL)
- (let (u g g1 inc final xcl xv il rsl tll funPLUS funGT fun? funIdent
- funPLUSform funGTform)
- (DO ((X SPL (CDR X)))
- ((ATOM X)
- (LIST 'spadDO (NREVERSE IL) (LIST (MKPF (NREVERSE XCL) 'OR) XV)
- (SEQOPT (CONS 'SEQ (NCONC (NREVERSE RSL) (LIST (LIST 'EXIT BD)))))))
- (COND ((ATOM (CAR X)) (FAIL)))
- (COND ((AND (EQ (CAAR X) 'STEP)
- (|member| (CADDAR X) '(2 1 0 (|One|) (|Zero|)))
- (|member| (CADR (CDDAR X)) '(1 (|One|))))
- (SETQ X (CONS (CONS 'ISTEP (CDAR X)) (CDR X))) ))
- ; A hack to increase the likelihood of small integers
- (SETQ U (CDAR X))
- (case (CAAR X)
- (GENERAL (AND (CDDDR U) (PUSH (CADDDR U) XCL))
- (PUSH (LIST (CAR U) (CADR U) (CADDR U)) IL) )
- (GSTEP
- (SETQ tll (CDDDDR U)) ;tll is (+fun >fun type? ident)
- (SETQ funPLUSform (CAR tll))
- (SETQ funGTform (CAR (SETQ tll (QCDR tll))))
- (PUSH (LIST (SETQ funPLUS (GENSYM)) funPLUSform) IL)
- (PUSH (LIST (SETQ funGT (GENSYM)) funGTform) IL)
- (COND ((SETQ tll (CDR tll))
- (SETQ fun? (CAR tll))
- (SETQ funIdent (CAR (SETQ tll (QCDR tll))))))
- (IF (NOT (ATOM (SETQ inc (CADDR U)) ))
- (PUSH (LIST (SETQ inc (GENSYM)) (CADDR U)) IL))
- (SETQ final (CADDDR U))
- (COND (final
- (COND ((ATOM final))
- ((PUSH (LIST (SETQ final (GENSYM)) (CADDDR U)) IL)))
- ; If CADDDR U is not an atom, only compute the value once
- (PUSH
- (if fun?
- (if (FUNCALL fun? INC)
- (if (FUNCALL (EVAL funGTform) INC funIdent)
- (LIST 'FUNCALL funGT (CAR U) FINAL)
- (LIST 'FUNCALL funGT FINAL (CAR U)))
- (LIST 'IF (LIST 'FUNCALL funGT INC funIdent)
- (LIST 'FUNCALL funGT (CAR U) FINAL)
- (LIST 'FUNCALL funGT FINAL (CAR U))))
- (LIST 'FUNCALL funGT (CAR U) final))
- XCL)))
- (PUSH (LIST (CAR U) (CADR U) (LIST 'FUNCALL funPLUS (CAR U) INC)) IL))
- (STEP
- (IF (NOT (ATOM (SETQ inc (CADDR U)) ))
- (PUSH (LIST (SETQ inc (GENSYM)) (CADDR U)) IL))
- (COND ((CDDDR U)
- (COND ((ATOM (SETQ final (CADDDR U)) ))
- ((PUSH (LIST (SETQ final (GENSYM)) (CADDDR U)) IL)))
- ; If CADDDR U is not an atom, only compute the value once
- (PUSH
- (if (INTEGERP INC)
- (LIST (if (MINUSP INC) '< '>) (CAR U) FINAL)
- `(if (MINUSP ,INC)
- (< ,(CAR U) ,FINAL)
- (> ,(CAR U) ,FINAL)))
- XCL)))
- (PUSH (LIST (CAR U) (CADR U) (LIST '+ (CAR U) INC)) IL))
- (ISTEP
- (IF (NOT (ATOM (SETQ inc (CADDR U)) ))
- (PUSH (LIST (SETQ inc (GENSYM)) (CADDR U)) IL))
- (COND ((CDDDR U)
- (COND ((ATOM (SETQ final (CADDDR U)) ))
- ((PUSH (LIST (SETQ final (GENSYM)) (CADDDR U)) IL)))
- ; If CADDDR U is not an atom, only compute the value once
- (PUSH
- (if (INTEGERP INC)
- (LIST (if (QSMINUSP INC) 'QSLESSP 'QSGREATERP)
- (CAR U) FINAL)
- `(if (QSMINUSP ,INC)
- (QSLESSP ,(CAR U) ,FINAL)
- (QSGREATERP ,(CAR U) ,FINAL)))
- XCL)))
- (PUSH (LIST (CAR U) (CADR U)
- (COND ((|member| INC '(1 (|One|)))
- (MKQSADD1 (CAR U)))
- ((LIST 'QSPLUS (CAR U) INC)) ))
- IL))
- (ON (PUSH (LIST 'ATOM (CAR U)) XCL)
- (PUSH (LIST (CAR U) (CADR U) (LIST 'CDR (CAR U))) IL))
- (RESET (PUSH (LIST 'PROGN (CAR U) NIL) XCL))
- (IN
- (PUSH (LIST 'OR
- (LIST 'ATOM (SETQ G (GENSYM)))
- (CONS 'PROGN
- (CONS
- (LIST 'SETQ (CAR U) (LIST 'CAR G))
- (APPEND
- (COND ((AND (symbol-package (car U)) $TRACELETFLAG)
- (LIST (LIST '/TRACELET-PRINT (CAR U)
- (CAR U))))
- (NIL))
- (LIST NIL)))) ) XCL)
- (PUSH (LIST G (CADR U) (LIST 'CDR G)) IL)
- (PUSH (LIST (CAR U) NIL) IL))
- (INDOM (SETQ G (GENSYM))
- (SETQ G1 (GENSYM))
- (PUSH (LIST 'ATOM G) XCL)
- (PUSH (LIST G (LIST 'INDOM-FIRST (CADR U))
- (LIST 'INDOM-NEXT G1)) IL)
- (PUSH (LIST (CAR U) NIL) IL)
- (PUSH (LIST G1 NIL) IL)
- (PUSH (LIST 'SETQ G1 (LIST 'CDR G)) RSL)
- (PUSH (LIST 'SETQ (CAR U) (LIST 'CAR G)) RSL))
- (UNTIL (SETQ G (GENSYM)) (PUSH (LIST G NIL (CAR U)) IL) (PUSH G XCL))
- (WHILE (PUSH (LIST 'NULL (CAR U)) XCL))
- (SUCHTHAT (SETQ BD (LIST 'SUCHTHATCLAUSE BD (CAR U))))
- (EXIT (SETQ XV (CAR U))) (FAIL)))))
-
-
-(defun SEQOPT (U)
- (if (AND (EQCAR U 'SEQ) (EQCAR (CADR U) 'EXIT) (EQCAR (CADADR U) 'SEQ))
- (CADADR U)
- U))
-
-(defmacro SUCHTHATCLAUSE (&rest L) (LIST 'COND (LIST (CADR L) (CAR L))))
-
-(defvar $NEWSPAD NIL)
-(defvar $BOOT NIL)
-
-(defmacro spadDO (&rest OL)
- (PROG (VARS L VL V U INITS U-VARS U-VALS ENDTEST EXITFORMS BODYFORMS)
- (if (OR $BOOT (NOT $NEWSPAD)) (return (CONS 'DO OL)))
- (SETQ L (copy-list OL))
- (if (OR (ATOM L) (ATOM (CDR L))) (GO BADO))
- (setq vl (POP L))
- (COND ((IDENTP VL)
- (SETQ VARS (LIST VL))
- (AND (OR (ATOM L)
- (ATOM (progn (setq inits (POP L)) L))
- (ATOM (progn (setq u-vals (pop L)) L)))
- (GO BADO))
- (SETQ INITS (LIST INITS) U-VARS (LIST (CAR VARS)) U-VALS (LIST U-VALS))
- (setq endtest (POP L)))
- ((prog nil
- (COND ((NULL VL) (GO TG5)) ((ATOM VL) (GO BADO)))
- G180 (AND (NOT (PAIRP (SETQ V (CAR VL)))) (SETQ V (LIST V)))
- (AND (NOT (IDENTP (CAR V))) (GO BADO))
- (PUSH (CAR V) VARS)
- (PUSH (COND ((PAIRP (CDR V)) (CADR V))) INITS)
- (AND (PAIRP (CDR V))
- (PAIRP (CDDR V))
- (SEQ (PUSH (CAR V) U-VARS)
- (PUSH (CADDR V) U-VALS)))
- (AND (PAIRP (progn (POP VL) VL)) (GO G180))
- TG5 (setq exitforms (POP L))
- (and (PAIRP EXITFORMS)
- (progn (setq endtest (POP EXITFORMS)) exitforms)))))
- (AND L
- (COND ((CDR L) (SETQ BODYFORMS (CONS 'SEQ L)))
- ((NULL (EQCAR (CAR L) 'SEQ)) (SETQ BODYFORMS (CONS 'SEQ L)))
- ((SETQ BODYFORMS (CAR L)))))
- (SETQ EXITFORMS `(EXIT ,(MKPF EXITFORMS 'PROGN)))
- (AND ENDTEST (SETQ ENDTEST (LIST 'COND (LIST ENDTEST '(GO G191)))))
- (COND ((NULL U-VARS) (GO XT) )
- ((NULL (CDR U-VARS))
- (SEQ (SETQ U-VARS (LIST 'SETQ (CAR U-VARS) (CAR U-VALS)))
- (GO XT)) ))
- (SETQ VL (LIST 'SETQ (CAR U-VARS) (CAR U-VALS)))
- (SEQ (SETQ V (CDR U-VARS)) (SETQ U (CDR U-VALS)))
- TG (SETQ VL (LIST 'SETQ (CAR V) (LIST 'PROG1 (CAR U) VL)))
- (POP U)
- (AND (progn (POP V) V) (GO TG))
- (SETQ U-VARS VL)
- XT (RETURN (COND
- ((AND $NEWSPAD (NULL $BOOT))
- (CONS 'SEQ (NCONC (DO_LET VARS INITS)
- (LIST 'G190 ENDTEST BODYFORMS U-VARS '(GO G190)
- 'G191 EXITFORMS))))
- ((CONS `(LAMBDA ,(NRECONC VARS NIL)
- (SEQ G190 ,ENDTEST ,BODYFORMS ,U-VARS (GO G190) G191 ,EXITFORMS))
- (NRECONC INITS NIL)))))
- BADO (ERROR (FORMAT NIL "BAD DO FORMAT~%~A" OL))))
-
-(defun DO_LET (VARS INITS)
- (if (OR (NULL VARS) (NULL INITS)) NIL
- (CONS (LIST 'SPADLET (CAR VARS) (CAR INITS))
- (DO_LET (CDR VARS) (CDR INITS)))))
+
#-:CCL
(defun NREVERSE0 (X) ; Already built-in to CCL
@@ -615,96 +223,13 @@ This version is needed so that (COLLECT (IN X Y) ... (RETURN 'JUNK))=>JUNK."
; 7.8.4 Mapping
-(defmacro COLLECT (&rest L)
- (let ((U (REPEAT-TRAN L NIL)))
- (CONS 'THETA (CONS '\, (NCONC (CAR U) (LIST (CDR U)))))))
-
-;; The following was changed to a macro for efficiency in CCL. To change
-;; it back to a function would require recompilation of a large chunk of
-;; the library.
-(defmacro PRIMVEC2ARR (x) x) ;redefine to change Array rep
-
-(defmacro COLLECTVEC (&rest L)
- `(PRIMVEC2ARR (COLLECTV ,@L)))
-
-(defmacro COLLECTV (&rest L)
- (PROG (CONDS BODY ANS COUNTER X Y)
- ;If we can work out how often we will go round
- ;allocate a vector first
- (SETQ CONDS NIL)
- (SETQ BODY (REVERSE L))
- (SETQ ANS (GENSYM))
- (SETQ COUNTER NIL)
- (SETQ X (CDR BODY))
- (SETQ BODY (CAR BODY))
-LP (COND ((NULL X)
- (COND ((NULL COUNTER)
- (SETQ COUNTER (GENSYM))
- (SETQ L (CONS (LIST 'ISTEP COUNTER 0 1) L)) ))
- (RETURN (LIST 'PROGN
- (LIST 'SPADLET ANS
- (LIST 'GETREFV
- (COND ((NULL CONDS) (fail))
- ((NULL (CDR CONDS))
- (CAR CONDS))
- ((CONS 'MIN CONDS)) ) ))
- (CONS 'REPEAT (NCONC (CDR (REVERSE L))
- (LIST (LIST 'SETELT ANS COUNTER BODY))))
- ANS)) ))
- (SETQ Y (CAR X))
- (SETQ X (CDR X))
- (COND ((MEMQ (CAR Y) '(SUCHTHAT WHILE UNTIL))
- (RETURN (LIST 'LIST2VEC (CONS 'COLLECT L)) ))
- ((member (CAR Y) '(IN ON) :test #'eq)
- (SETQ CONDS (CONS (LIST 'SIZE (CADDR Y)) CONDS))
- (GO LP))
- ((member (CAR Y) '(STEP ISTEP) :test #'eq)
- (if (AND (EQL (CADDR Y) 0) (EQL (CADDDR Y) 1))
- (SETQ COUNTER (CADR Y)) )
- (COND ((CDDDDR Y) ; there may not be a limit
- (SETQ CONDS (CONS
- (COND ((EQL 1 (CADDDR Y))
- (COND ((EQL 1 (CADDR Y)) (CAR (CDDDDR Y)))
- ((EQL 0 (CADDR Y)) (MKQSADD1 (CAR (CDDDDR Y))))
- ((MKQSADD1 `(- ,(CAR (CDDDDR Y)) ,(CADDR Y))))))
- ((EQL 1 (CADDR Y)) `(/ ,(CAR (CDDDDR Y)) ,(CADDR Y)))
- ((EQL 0 (CADDR Y))
- `(/ ,(MKQSADD1 (CAR (CDDDDR Y))) ,(CADDR Y)))
- (`(/ (- ,(MKQSADD1 (CAR (CDDDDR Y))) ,(CADDR Y))
- ,(CADDR Y))))
- CONDS))))
- (GO LP)))
- (ERROR "Cannot handle macro expansion")))
-
-(defun MKQSADD1 (X)
- (COND ((ATOM X) `(QSADD1 ,X))
- ((AND (member (CAR X) '(-DIFFERENCE QSDIFFERENCE -) :test #'eq)
- (EQL 1 (CADDR X)))
- (CADR X))
- (`(QSADD1 ,X))))
-; 7.10 Dynamic Non-local Exits
-(defmacro yield (L)
- (let ((g (gensym)))
- `(let ((,g (state)))
- (if (statep ,g) (throw 'yield (list 'pair ,L) ,g)))))
+; 7.10 Dynamic Non-local Exits
; 10.1 The Property List
-(DEFUN FLAG (L KEY)
- "Set the KEY property of every item in list L to T."
- (mapc #'(lambda (item) (makeprop item KEY T)) L))
-
-(FLAG '(* + AND OR PROGN) 'NARY) ; flag for MKPF
-
-(DEFUN REMFLAG (L KEY)
- "Set the KEY property of every item in list L to NIL."
- (OR (ATOM L) (SEQ (REMPROP (CAR L) KEY) (REMFLAG (CDR L) KEY))))
-(DEFUN FLAGP (X KEY)
- "If X has a KEY property, then FLAGP is true."
- (GET X KEY))
(defun PROPERTY (X IND N)
"Returns the Nth element of X's IND property, if it exists."
@@ -712,7 +237,6 @@ LP (COND ((NULL X)
; 10.3 Creating Symbols
-(defmacro INTERNL (a &rest b) (if (not b) `(intern ,a) `(intern (strconc ,a . ,b))))
(defvar $GENNO 0)
@@ -730,46 +254,18 @@ LP (COND ((NULL X)
; 10.7 CATCH and THROW
-(defmacro SPADCATCH (&rest form) (CONS 'CATCH form))
-
-(defmacro SPADTHROW (&rest form) (CONS 'THROW form))
-
; 12 NUMBERS
; 12.3 Comparisons on Numbers
-(defmacro IEQUAL (&rest L) `(eql . ,L))
-(defmacro GE (&rest L) `(>= . ,L))
-(defmacro GT (&rest L) `(> . ,L))
-(defmacro LE (&rest L) `(<= . ,L))
-(defmacro LT (&rest L) `(< . ,L))
-
; 12.4 Arithmetic Operations
-(defmacro SPADDIFFERENCE (&rest x) `(- . ,x))
-
; 12.5 Irrational and Transcendental Functions
; 12.5.1 Exponential and Logarithmic Functions
-(define-function 'QSEXPT #'expt)
-
; 12.6 Small Finite Field ops with vector trimming
-;; following macros assume 0 <= x,y < z
-
-(defmacro qsaddmod (x y z)
- `(let* ((sum (qsplus ,x ,y))
- (rsum (qsdifference sum ,z)))
- (if (qsminusp rsum) sum rsum)))
-
-(defmacro qsdifmod (x y z)
- `(let ((dif (qsdifference ,x ,y)))
- (if (qsminusp dif) (qsplus dif ,z) dif)))
-
-(defmacro qsmultmod (x y z)
- `(rem (* ,x ,y) ,z))
-
(defun TRIMLZ (vec)
(declare (simple-vector vec))
(let ((n (position 0 vec :from-end t :test-not #'eql)))
@@ -785,11 +281,6 @@ LP (COND ((NULL X)
; 14.1 Simple Sequence Functions
-(DEFUN NLIST (N FN)
- "Returns a list of N items, each initialized to the value of an
- invocation of FN"
- (if (LT N 1) NIL (CONS (EVAL FN) (NLIST (SUB1 N) FN))))
-
(define-function 'getchar #'elt)
(defun GETCHARN (A M) "Return the code of the Mth character of A"
@@ -808,14 +299,6 @@ LP (COND ((NULL X)
(defun NSTRCONC (s1 s2) (concatenate 'string (string s1) (string s2)))
-(defmacro spadREDUCE (OP AXIS BOD) (REDUCE-1 OP AXIS BOD))
-
-(MAPC #'(LAMBDA (X) (MAKEPROP (CAR X) 'THETA (CDR X)))
- '((PLUS 0) (+ (|Zero|)) (|lcm| (|One|)) (STRCONC "") (|strconc| "")
- (MAX -999999) (MIN 999999) (TIMES 1) (* (|One|)) (CONS NIL)
- (APPEND NIL) (|append| NIL) (UNION NIL) (UNIONQ NIL) (|gcd| (|Zero|))
- (|union| NIL) (NCONC NIL) (|and| |true|) (|or| |false|) (AND 'T)
- (OR NIL)))
(define-function '|append| #'APPEND)
@@ -829,189 +312,31 @@ LP (COND ((NULL X)
((and (atom item) (not (arrayp item))) (remove item sequence))
(T (remove item sequence :test #'equalp))))
-(MAPC #'(LAMBDA (J) (MAKEPROP (CAR J) 'UNMACRO (CADR J)))
- '( (AND AND2) (OR OR2)))
-
-(defun and2 (x y) (and x y))
-
-(defun or2 (x y) (or x y))
-
-(MAKEPROP 'CONS 'RIGHT-ASSOCIATIVE T)
-
-(defun REDUCE-1 (OP AXIS BOD)
- (let (u op1 tran iden)
- (SEQ (SETQ OP1 (cond ((EQ OP '\,) 'CONS)
- ((EQCAR OP 'QUOTE) (CADR OP))
- (OP)))
- (SETQ IDEN (if (SETQ U (GET OP1 'THETA)) (CAR U) 'NO_THETA_PROPERTY))
- (SETQ TRAN (if (EQCAR BOD 'COLLECT)
- (PROG (L BOD1 ITL)
- (SETQ L (REVERSE (CDR BOD)))
- (SETQ BOD1 (CAR L))
- (SETQ ITL (NREVERSE (CDR L)))
- (RETURN (-REDUCE OP1 AXIS IDEN BOD1 ITL)) )
- (progn (SETQ U (-REDUCE-OP OP1 AXIS))
- (LIST 'REDUCE-N (MKQ (OR (GET U 'UNMACRO) U))
- (GET OP1 'RIGHT-ASSOCIATIVE)
- BOD IDEN))))
- (if (EQ OP '\,) (LIST 'NREVERSE-N TRAN AXIS) TRAN))))
-
-(defun -REDUCE (OP AXIS Y BODY SPL)
- (PROG (X G AUX EXIT VALUE PRESET CONSCODE RESETCODE)
- (SETQ G (GENSYM))
- ; create preset of accumulate
- (SETQ PRESET (COND
- ((EQ Y 'NO_THETA_PROPERTY) (LIST 'SPADLET G (MKQ G)))
- ((LIST 'SPADLET G Y)) ))
- (SETQ EXIT (COND
- ((SETQ X (ASSOC 'EXIT SPL))(SETQ SPL (DELASC 'EXIT SPL)) (COND
- ((MEMBER OP '(AND OR)) (LIST 'AND G (CADR X))) ((CADR X)) ))
- ((EQ Y 'NO_THETA_PROPERTY) (LIST 'THETACHECK G (MKQ G)(MKQ OP)))
- (G) ))
- (COND ((EQ OP 'CONS) (SETQ EXIT (LIST 'NREVERSE0 EXIT))))
- ; CONSCODE= code which conses a member onto the list
- (SETQ VALUE (COND ((EQ Y 'NO_THETA_PROPERTY) (GENSYM))
- (BODY)))
- (SETQ CONSCODE (CONS (-REDUCE-OP OP AXIS) (COND
- ((FLAGP OP 'RIGHT-ASSOCIATIVE) (LIST VALUE G))
- ((LIST G VALUE) ) ) ) )
- ; next reset code which varies if THETA property is|/is not given
- (SETQ RESETCODE (LIST 'SETQ G (COND
- ((EQ Y 'NO_THETA_PROPERTY)
- (LIST 'COND (LIST (LIST 'EQ G (MKQ G)) VALUE)
- (LIST ''T CONSCODE)) )
- (CONSCODE) )))
- ; create body
- (SETQ BODY (COND ((EQ VALUE BODY) RESETCODE)
- ((LIST 'PROGN (LIST 'SPADLET VALUE BODY) RESETCODE)) ))
- (SETQ AUX (CONS (LIST 'EXIT EXIT) (COND
- ((EQ OP 'AND) (LIST (LIST 'UNTIL (LIST 'NULL G))))
- ((EQ OP 'OR) (LIST (LIST 'UNTIL G)))
- (NIL) )))
- (RETURN (COND
- ((AND $NEWSPAD (NULL $BOOT)) (LIST 'PROGN PRESET
- (CONS 'REPEAT (APPEND AUX (APPEND SPL (LIST BODY))) )))
- ((LIST 'PROG
- (COND ((EQ RESETCODE BODY) (LIST G)) ((LIST G VALUE)))
- PRESET (LIST 'RETURN
- (CONS 'REPEAT (APPEND AUX (APPEND SPL (LIST BODY)))))))))))
-
-(defun -REDUCE-OP (OP AXIS)
- (COND ((EQL AXIS 0) OP)
- ((EQL AXIS 1)
- (COND ((EQ OP 'CONS) 'CONS-N)
- ((EQ OP 'APPEND) 'APPEND-N)
- ((FAIL))))
- ((FAIL))))
-
-(defun NREVERSE-N (X AXIS)
- (COND ((EQL AXIS 0) (NREVERSE X))
- ((MAPCAR #'(LAMBDA (Y) (NREVERSE-N Y (SUB1 AXIS))) X))))
-
-(defun CONS-N (X Y)
- (COND ((NULL Y) (CONS-N X (NLIST (LENGTH X) NIL)))
- ((MAPCAR #'CONS X Y))))
-
-(defun APPEND-N (X Y)
- (COND ((NULL X) (APPEND-N (NLIST (LENGTH Y) NIL) Y))
- ((MAPCAR #'APPEND X Y))))
-
-(defun REDUCE-N (OP RIGHT L ACC)
- (COND (RIGHT (PROG (U L1)
- (SETQ L1 (NREVERSE L))
- (SETQ U (REDUCE-N-1 OP 'T L1 ACC))
- (NREVERSE L1)
- (RETURN U) ))
- ((REDUCE-N-1 OP NIL L ACC))))
-
-(defun REDUCE-N-1 (OP RIGHT L ACC)
- (COND ((EQ ACC 'NO_THETA_PROPERTY)
- (COND ((NULL L) (THETA_ERROR OP))
- ((REDUCE-N-2 OP RIGHT (CDR L) (CAR L))) ))
- ((REDUCE-N-2 OP RIGHT L ACC))))
-
-(defun REDUCE-N-2 (OP RIGHT L ACC)
- (COND ((NULL L) ACC)
- (RIGHT (REDUCE-N-2 OP RIGHT (CDR L) (funcall (symbol-function OP) (CAR L) ACC)))
- ((REDUCE-N-2 OP RIGHT (CDR L) (funcall (symbol-function OP) ACC (CAR L))))))
-
-(defmacro THETA (&rest LL)
- (let (U (L (copy-list LL)))
- (if (EQ (KAR L) '\,) `(theta CONS . ,(CDR L))
- (progn
- (if (EQCAR (CAR L) 'QUOTE) (RPLAC (CAR L) (CADAR L)))
- (-REDUCE (CAR L) 0
- (if (SETQ U (GET (CAR L) 'THETA)) (CAR U)
- (MOAN "NO THETA PROPERTY"))
- (CAR (SETQ L (NREVERSE (CDR L))))
- (NREVERSE (CDR L)))))))
-
-(defmacro THETA1 (&rest LL)
- (let (U (L (copy-list LL)))
- (if (EQ (KAR L) '\,)
- (LIST 'NREVERSE-N (CONS 'THETA1 (CONS 'CONS (CDR L))) 1)
- (-REDUCE (CAR L) 1
- (if (SETQ U (GET (CAR L) 'THETA)) (CAR U)
- (MOAN "NO THETA PROPERTY"))
- (CAR (SETQ L (NREVERSE (CDR L))))
- (NREVERSE (CDR L))))))
-(defun THETACHECK (VAL VAR OP) (if (EQL VAL VAR) (THETA_ERROR OP) val))
-(defun THETA_ERROR (OP)
- (Boot::|userError|
- (LIST "Sorry, do not know the identity element for " OP)))
-; 15 LISTS
-; 15.1 Conses
+(defun THETACHECK (VAL VAR OP) (if (EQL VAL VAR) (THETA_ERROR OP) val))
+; 15 LISTS
-(defmacro |SPADfirst| (l)
- (let ((tem (gensym)))
- `(let ((,tem ,l)) (if ,tem (car ,tem) (first-error)))))
+; 15.1 Conses
-(defun first-error () (error "Cannot take first of an empty list"))
; 15.2 Lists
-(defmacro ELEM (val &rest indices)
- (if (null indices) val `(ELEM (nth (1- ,(car indices)) ,val) ,@(cdr indices))))
-
(defun ELEMN (X N DEFAULT)
(COND ((NULL X) DEFAULT)
((EQL N 1) (CAR X))
((ELEMN (CDR X) (SUB1 N) DEFAULT))))
-(defmacro TAIL (&rest L)
- (let ((x (car L)) (n (if (cdr L) (cadr L) 1)))
- (COND ((EQL N 0) X)
- ((EQL N 1) (LIST 'CDR X))
- ((GT N 1) (APPLYR (PARTCODET N) X))
- ((LIST 'TAILFN X N)))))
-
-(defun PARTCODET (N)
- (COND ((OR (NULL (INTEGERP N)) (LT N 1)) (ERROR 'PARTCODET))
- ((EQL N 1) '(CDR))
- ((EQL N 2) '(CDDR))
- ((EQL N 3) '(CDDDR))
- ((EQL N 4) '(CDDDDR))
- ((APPEND (PARTCODET (PLUS N -4)) '(CDDDDR)))))
-
(defmacro TL (&rest L) `(tail . ,L))
-(defun TAILFN (X N) (if (LT N 1) X (TAILFN (CDR X) (SUB1 N))))
(defmacro SPADCONST (&rest L) (cons 'qrefelt L))
-(defmacro SPADCALL (&rest L)
- (let ((args (butlast l)) (fn (car (last l))) (gi (gensym)))
- ;; (values t) indicates a single return value
- `(let ((,gi ,fn)) (the (values t) (funcall (car ,gi) ,@args (cdr ,gi))))
- ))
-
(DEFUN LASTELEM (X) (car (last X)))
(defun LISTOFATOMS (X)
@@ -1089,14 +414,6 @@ LP (COND ((NULL X)
; 15.5 Using Lists as Sets
<<DEFUN CONTAINED>>
-(DEFUN S+ (X Y)
- (COND ((ATOM Y) X)
- ((ATOM X) Y)
- ((MEMBER (CAR X) Y :test #'equal) (S+ (CDR X) Y))
- ((S+ (CDR X) (CONS (CAR X) Y)))))
-
-(defun S* (l1 l2) (INTERSECTION l1 l2 :test #'equal))
-(defun S- (l1 l2) (set-difference l1 l2 :test #'equal))
(DEFUN PREDECESSOR (TL L)
"Returns the sublist of L whose CDR is EQ to TL."
@@ -1110,48 +427,62 @@ LP (COND ((NULL X)
; 15.6 Association Lists
-(defun DelAsc (u v) "Returns a copy of a-list V in which any pair with key U is deleted."
- (cond ((atom v) nil)
- ((or (atom (car v))(not (equal u (caar v))))
- (cons (car v) (DelAsc u (cdr v))))
- ((cdr v))))
+
+;; FIXME: Should not this be named `alistAllKeys'?
+(DEFUN ASSOCLEFT (X)
+ "Returns all the keys of association list X."
+ (if (ATOM X)
+ X
+ (mapcar #'car x)))
+
+;; FIXME: Should not this be named `alistAllValues'?
+(DEFUN ASSOCRIGHT (X)
+ "Returns all the datums of association list X."
+ (if (ATOM X)
+ X
+ (mapcar #'cdr x)))
+
(DEFUN ADDASSOC (X Y L)
"Put the association list pair (X . Y) into L, erasing any previous association for X"
- (COND ((ATOM L) (CONS (CONS X Y) L))
- ((EQUAL X (CAAR L)) (CONS (CONS X Y) (CDR L)))
+ (COND ((ATOM L)
+ (CONS (CONS X Y) L))
+ ((EQUAL X (CAAR L))
+ (CONS (CONS X Y) (CDR L)))
((CONS (CAR L) (ADDASSOC X Y (CDR L))))))
(DEFUN DELLASOS (U V)
"Remove any assocation pair (U . X) from list V."
(COND ((ATOM V) NIL)
- ((EQUAL U (CAAR V)) (CDR V))
+ ((EQUAL U (CAAR V))
+ (CDR V))
((CONS (CAR V) (DELLASOS U (CDR V))))))
+
-(DEFUN ASSOCLEFT (X)
- "Returns all the keys of association list X."
- (if (ATOM X) X (mapcar #'car x)))
-
-(DEFUN ASSOCRIGHT (X)
- "Returns all the datums of association list X."
- (if (ATOM X) X (mapcar #'cdr x)))
-
+;; FIXME: Should not this be named `alistValue'?
(DEFUN LASSOC (X Y)
"Return the datum associated with key X in association list Y."
(PROG NIL
- A (COND ((ATOM Y) (RETURN NIL))
- ((EQUAL (CAAR Y) X) (RETURN (CDAR Y))) )
+ A
+ (COND ((ATOM Y)
+ (RETURN NIL))
+ ((EQUAL (CAAR Y) X)
+ (RETURN (CDAR Y))) )
(SETQ Y (CDR Y))
(GO A)))
-
+
+;; FIXME: Should not this be named `alistKey'?
(DEFUN |rassoc| (X Y)
- "Return the datum associated with key X in association list Y."
+ "Return the key associated with datum X in association list Y."
(PROG NIL
- A (COND ((ATOM Y) (RETURN NIL))
- ((EQUAL (CDAR Y) X) (RETURN (CAAR Y))) )
+ A
+ (COND ((ATOM Y)
+ (RETURN NIL))
+ ((EQUAL (CDAR Y) X)
+ (RETURN (CAAR Y))) )
(SETQ Y (CDR Y))
(GO A)))
-
+
; (defun QLASSQ (p a-list) (let ((y (assoc p a-list :test #'eq))) (if y (cdr y))))
(defun QLASSQ (p a-list) (cdr (assq p a-list)))
@@ -1392,10 +723,6 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size
; 24.2 Specialized Error-Signalling Forms and Macros
-(defun MOAN (&rest x) (|sayBrightly| `(|%l| "===> " ,@X |%l|)))
-
-(DEFUN FAIL () (|systemError| '"Antique error (FAIL ENTERED)"))
-
(defun CROAK (&rest x) (|systemError| x))
; 25 MISCELLANEOUS FEATURES
@@ -1432,12 +759,6 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size
(defmacro |do| (&rest args) (CONS 'PROGN args))
-(defmacro |char| (arg)
- (cond ((stringp arg) (character arg))
- ((integerp arg) (code-char arg))
- ((and (consp arg) (eq (car arg) 'quote)) (character (cadr arg)))
- (t `(character ,arg))))
-
(defun DROPTRAILINGBLANKS (LINE) (string-right-trim " " LINE))
; # Gives the number of elements of a list, 0 for atoms.
@@ -1503,11 +824,6 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size
(defun compile-defun (name body) (eval body) (compile name))
-(defmacro |Record| (&rest x)
- `(|Record0| (LIST ,@(COLLECT (IN Y X)
- (list 'CONS (MKQ (CADR Y)) (CADDR Y))))))
-
-(defmacro |:| (tag expr) `(LIST '|:| ,(MKQ tag) ,expr))
(defun |deleteWOC| (item list) (lisp::delete item list :test #'equal))
@@ -1517,16 +833,6 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size
(DEFUN |rightBindingPowerOf| (X IND &AUX (Y (GETL X IND)))
(IF Y (ELEMN Y 4 105) 105))
-(defmacro make-bf (MT EP) `(CONS |$BFtag| (CONS ,MT ,EP)))
-
-(defun MAKE-FLOAT (int frac fraclen exp)
- (if (AND $SPAD |$useBFasDefault|)
- (if (= frac 0)
- (MAKE-BF int exp)
- (MAKE-BF (+ (* int (expt 10 fraclen)) frac) (- exp fraclen)) )
- (read-from-string
- (format nil "~D.~v,'0De~D" int fraclen frac exp))) )
-
;;---- Added by WFS.
(proclaim '(ftype (function (t t) t) |subWord|)) ;hack for bug in akcl-478
@@ -1722,6 +1028,17 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size
(defmacro |shoeread-line| (st)
`(read-line ,st nil nil))
+;;
+;; -*- Record Structures -*-
+;;
+
+(defmacro |Record| (&rest x)
+ `(|Record0| (LIST ,@(COLLECT (IN Y X)
+ (list 'CONS (MKQ (CADR Y)) (CADDR Y))))))
+
+(defmacro |:| (tag expr)
+ `(LIST '|:| ,(MKQ tag) ,expr))
+
@
\eject
diff --git a/src/interp/sys-globals.boot b/src/interp/sys-globals.boot
index 6ea1d04a..6f16b49c 100644
--- a/src/interp/sys-globals.boot
+++ b/src/interp/sys-globals.boot
@@ -38,7 +38,7 @@
--
import '"hash"
-import '"boot-pkg"
+import '"sys-constants"
)package "BOOT"
++ FIXME
@@ -336,3 +336,19 @@ $CategoryFrame :=
++
$spadLibFT := "NRLIB"
+
+++
+$compilingMap := false
+
+++
+$definingMap := false
+
+++
+$TRACELETFLAG := false
+
+++
+$NEWSPAD := false
+
+++
+$BOOT := false
+
diff --git a/src/interp/sys-macros.lisp b/src/interp/sys-macros.lisp
new file mode 100644
index 00000000..8c8699bb
--- /dev/null
+++ b/src/interp/sys-macros.lisp
@@ -0,0 +1,1204 @@
+;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+;; All rights reserved.
+;; Copyright (C) 2007, Gabriel Dos Reis.
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in
+;; the documentation and/or other materials provided with the
+;; distribution.
+;;
+;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+;; names of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;
+
+
+(IMPORT-MODULE "union")
+(IMPORT-MODULE "sys-globals")
+(IMPORT-MODULE "diagnostics")
+(in-package "BOOT")
+
+;;
+;; -*- Charcters and Strings -*-
+;;
+
+(defmacro |char| (arg)
+ (cond ((stringp arg)
+ (character arg))
+ ((integerp arg)
+ (code-char arg))
+ ((and (consp arg)
+ (eq (car arg) 'quote))
+ (character (cadr arg)))
+ (t `(character ,arg))))
+
+;;
+;; -*- BigFloat Constructors -*-
+;;
+
+(defmacro MAKE-BF (MT EP)
+ `(CONS |$BFtag| (CONS ,MT ,EP)))
+
+(defun MAKE-FLOAT (int frac fraclen exp)
+ (if (AND $SPAD |$useBFasDefault|)
+ (if (= frac 0)
+ (MAKE-BF int exp)
+ (MAKE-BF (+ (* int (expt 10 fraclen)) frac)
+ (- exp fraclen)) )
+ (read-from-string
+ (format nil "~D.~v,'0De~D" int fraclen frac exp))) )
+
+
+;;
+;; -*- Symbols and Properties -*-
+;;
+
+(defmacro INTERNL (a &rest b)
+ (if (not b)
+ `(intern ,a)
+ `(intern (strconc ,a . ,b))))
+
+;;
+;; -*- Equality Predicates -*-
+;;
+
+;; QEQCAR should be used when you know the first arg is a pair
+;; the second arg should either be a literal fixnum or a symbol
+;; the car of the first arg is always of the same type as the second
+;; use eql unless we are sure fixnums are represented canonically
+(defmacro QEQCAR (x y)
+ (if (integerp y)
+ `(eql (the fixnum (QCAR ,x)) (the fixnum ,y))
+ `(eq (QCAR ,x) ,y)))
+
+(eval-when
+ #+:common-lisp (:compile-toplevel :load-toplevel :execute)
+ #-:common-lisp (compile load eval)
+ (defun IDENT-CHAR-LIT (x)
+ (and (EQCAR x 'quote)
+ (IDENTP (cadr x))
+ (= (length (PNAME (cadr x))) 1))))
+
+(defmacro BOOT-EQUAL (a b)
+ (cond ((IDENT-CHAR-LIT a)
+ `(or (eql ,a ,b) (eql (character ,a) ,b)))
+ ((IDENT-CHAR-LIT b)
+ `(or (eql ,a ,b) (eql ,a (character ,b))))
+ (t `(EQQUAL ,a ,b))))
+
+
+(eval-when
+ #+:common-lisp (:compile-toplevel :load-toplevel :execute)
+ #-:common-lisp (compile load eval)
+ (defun EQUABLE (X)
+ (OR (NULL X)
+ (AND (EQCAR X 'QUOTE) (symbolp (CADR X))))))
+
+(defmacro EQQUAL (a b)
+ (cond ((OR (EQUABLE a) (EQUABLE b))
+ `(eq ,a ,b))
+ ((OR (numberp a) (numberp b))
+ `(eql ,a ,b))
+ (t `(equal ,a ,b))))
+
+(defmacro NEQUAL (a b)
+ `(not (BOOT-EQUAL ,a ,b)))
+
+(defmacro IEQUAL (&rest L)
+ `(eql . ,L))
+
+(defmacro GE (&rest L)
+ `(>= . ,L))
+
+(defmacro GT (&rest L)
+ `(> . ,L))
+
+(defmacro LE (&rest L)
+ `(<= . ,L))
+
+(defmacro LT (&rest L)
+ `(< . ,L))
+
+;;
+;; -*- Cons Cell Accessors -*-
+;;
+(defmacro KAR (ARG)
+ `(IFCAR ,arg))
+
+(defmacro KDR (ARG)
+ `(IFCDR ,arg))
+
+(defmacro KADR (ARG)
+ `(IFCAR (IFCDR ,arg)))
+
+(defmacro KADDR (ARG)
+ `(IFCAR (IFCDR (IFCDR ,arg))))
+
+(eval-when
+ #+:common-lisp (:compile-toplevel :load-toplevel :execute)
+ #-:common-lisp (compile load eval)
+ (defun FIRST-ERROR ()
+ (error "Cannot take first of an empty list")))
+
+(defmacro |SPADfirst| (l)
+ (let ((tem (gensym)))
+ `(let ((,tem ,l))
+ (if ,tem
+ (car ,tem)
+ (FIRST-ERROR)))))
+
+(defmacro ELEM (val &rest indices)
+ (if (null indices)
+ val
+ `(ELEM (nth (1- ,(car indices)) ,val) ,@(cdr indices))))
+
+(eval-when
+ #+:common-lisp (:compile-toplevel :load-toplevel :execute)
+ #-:common-lisp (compile load eval)
+ (progn
+
+ (DEFUN APPLYR (L X)
+ (if (not L)
+ X
+ (LIST (CAR L) (APPLYR (CDR L) X))))
+
+ (defun PARTCODET (N)
+ (COND ((OR (NULL (INTEGERP N))
+ (LT N 1))
+ (ERROR 'PARTCODET))
+ ((EQL N 1)
+ '(CDR))
+ ((EQL N 2)
+ '(CDDR))
+ ((EQL N 3)
+ '(CDDDR))
+ ((EQL N 4)
+ '(CDDDDR))
+ ((APPEND (PARTCODET (PLUS N -4)) '(CDDDDR)))))
+
+ (defun NLIST (N FN)
+ "Returns a list of N items, each initialized to the value of an
+ invocation of FN"
+ (if (LT N 1)
+ NIL
+ (CONS (EVAL FN) (NLIST (SUB1 N) FN))))
+
+ (defun TAILFN (X N)
+ (if (LT N 1)
+ X
+ (TAILFN (CDR X) (SUB1 N))))
+
+ ))
+
+
+(defmacro TAIL (&rest L)
+ (let ((x (car L))
+ (n (if (cdr L)
+ (cadr L)
+ 1)))
+ (COND ((EQL N 0)
+ X)
+ ((EQL N 1)
+ (LIST 'CDR X))
+ ((GT N 1)
+ (APPLYR (PARTCODET N) X))
+ ((LIST 'TAILFN X N)))))
+
+
+;;
+;; -*- Cons Cell Manipulators -*-
+;;
+
+(eval-when
+ #+:common-lisp (:compile-toplevel :load-toplevel :execute)
+ #-:common-lisp (compile load eval)
+ (progn
+ (MAPC #'(LAMBDA (J) (MAKEPROP (CAR J) 'SELCODE (CADR J)))
+ '((CAR 2) (CDR 3) (CAAR 4) (CADR 5) (CDAR 6) (CDDR 7)
+ (CAAAR 8) (CAADR 9) (CADAR 10) (CADDR 11) (CDAAR 12)
+ (CDADR 13) (CDDAR 14) (CDDDR 15) (CAAAAR 16) (CAAADR 17)
+ (CAADAR 18) (CAADDR 19) (CADAAR 20) (CADADR 21) (CADDAR 22)
+ (CADDDR 23) (CDAAAR 24) (CDAADR 25) (CDADAR 26) (CDADDR 27)
+ (CDDAAR 28) (CDDADR 29) (CDDDAR 30) (CDDDDR 31)))
+
+ (DEFUN RENAME (U)
+ (let (x)
+ (if (AND (IDENTP U) (SETQ X (GET U 'NEWNAM)))
+ X
+ U)))
+
+ (defun CARCDRX1 (X N FG) ; FG = TRUE FOR CAR AND CDR
+ (COND ((< N 1)
+ (fail))
+ ((EQL N 1)
+ X)
+ ((let ((D (DIVIDE N 2)))
+ (CARCDRX1 (LIST (if (EQL (CADR D) 0)
+ (if FG 'CAR 'CAR)
+ (if FG 'CDR 'CDR)) X)
+ (CAR D)
+ FG)))))
+
+ (defun CARCDREXPAND (X FG) ; FG = TRUE FOR CAR AND CDR
+ (let (n hx)
+ (COND ((ATOM X)
+ X)
+ ((SETQ N
+ (GET (RENAME (SETQ HX (CARCDREXPAND (CAR X) FG)))
+ 'SELCODE))
+ (CARCDRX1 (CARCDREXPAND (CADR X) FG) N FG))
+ ((CONS HX (MAPCAR #'(LAMBDA (Y) (CARCDREXPAND Y FG)) (CDR X)))))))
+ ))
+
+
+(defmacro RPLAC (&rest L)
+ (if (EQCAR (CAR L) 'ELT)
+ (LIST 'SETELT (CADAR L) (CADDR (CAR L)) (CADR L))
+ (let ((A (CARCDREXPAND (CAR L) NIL)) (B (CADR L)))
+ (COND ((CDDR L) (ERROR 'RPLAC))
+ ((EQCAR A 'CAR) (LIST 'RPLACA (CADR A) B))
+ ((EQCAR A 'CDR) (LIST 'RPLACD (CADR A) B))
+ ((ERROR 'RPLAC))))))
+
+;;
+;; -*- Association Lists -*-
+;;
+
+;;
+;; -*- Functions -*-
+;;
+
+(defmacro |function| (name)
+ `(FUNCTION ,name))
+
+(defmacro |dispatchFunction| (name)
+ `(FUNCTION ,name))
+
+(defmacro SPADCALL (&rest L)
+ (let ((args (butlast l))
+ (fn (car (last l)))
+ (gi (gensym)))
+ ;; (values t) indicates a single return value
+ `(let ((,gi ,fn))
+ (the (values t) (funcall (car ,gi) ,@args (cdr ,gi))))))
+
+;;
+;; -*- Arithmetics -*-
+;;
+
+(defmacro SPADDIFFERENCE (&rest x)
+ `(- . ,x))
+
+(define-function 'QSEXPT #'expt)
+
+;; following macros assume 0 <= x,y < z
+
+(defmacro QSADDMOD (x y z)
+ `(let* ((sum (QSPLUS ,x ,y))
+ (rsum (QSDIFFERENCE sum ,z)))
+ (if (QSMINUSP rsum)
+ sum
+ rsum)))
+
+(defmacro QSDIFMOD (x y z)
+ `(let ((dif (QSDIFFERENCE ,x ,y)))
+ (if (QSMINUSP dif)
+ (QSPLUS dif ,z)
+ dif)))
+
+(defmacro QSMULTMOD (x y z)
+ `(REM (* ,x ,y) ,z))
+
+
+;;
+;; -*- Pattern Matching -*-
+;;
+
+(defmacro IS (x y) `(DCQ ,y ,x))
+
+;;
+;; -*- Evaluation Strategies -*-
+;;
+
+(eval-when
+ #+:common-lisp (:compile-toplevel :load-toplevel :execute)
+ #-:common-lisp (compile load eval)
+ (DEFUN MKQ (X)
+ "Evaluates an object and returns it with QUOTE wrapped around it."
+ (if (NUMBERP X)
+ X
+ (LIST 'QUOTE X))))
+
+;;
+;; -*- Assignments -*-
+;;
+
+(defmacro LETT (var val &rest L)
+ (COND
+ (|$QuickLet| `(SETQ ,var ,val))
+ (|$compilingMap|
+ ;; map tracing
+ `(PROGN
+ (SETQ ,var ,val)
+ (COND (|$letAssoc|
+ (|mapLetPrint| ,(MKQ var)
+ ,var
+ (QUOTE ,(KAR L))))
+ ('T ,var))))
+ ;; used for LETs in SPAD code --- see devious trick in COMP,TRAN,1
+ ((ATOM var)
+ `(PROGN
+ (SETQ ,var ,val)
+ (IF |$letAssoc|
+ ,(cond ((null (cdr l))
+ `(|letPrint| ,(MKQ var) ,var (QUOTE ,(KAR L))))
+ ((and (eqcar (car l) 'SPADCALL)
+ (= (length (car l)) 3))
+ `(|letPrint3| ,(MKQ var) ,var ,(third (car l))
+ (QUOTE ,(KADR L))))
+ (t `(|letPrint2| ,(MKQ var) ,(car l) (QUOTE ,(KADR L))))))
+ ,var))
+ ('T (ERROR "Cannot compileLET construct"))))
+
+
+(defmacro SPADLET (A B)
+ (if (ATOM A)
+ `(SETQ ,A ,B)
+ `(OR (IS ,B ,A)
+ (LET_ERROR ,(MK_LEFORM A) ,(MKQ B) ))))
+
+
+;;
+;; -*- Helper Functions For Iteration Control Structures -*-
+;;
+
+(eval-when
+ #+:common-lisp (:compile-toplevel :load-toplevel :execute)
+ #-:common-lisp (compile load eval)
+ (progn
+ (DEFUN S+ (X Y)
+ (COND ((ATOM Y)
+ X)
+ ((ATOM X)
+ Y)
+ ((MEMBER (CAR X) Y :test #'equal)
+ (S+ (CDR X) Y))
+ ((S+ (CDR X) (CONS (CAR X) Y)))))
+
+ (defun S* (l1 l2)
+ (INTERSECTION l1 l2 :test #'equal))
+
+ (defun S- (l1 l2)
+ (set-difference l1 l2 :test #'equal))
+
+ (defun MKPFFLATTEN (X OP)
+ (COND ((ATOM X) X)
+ ((EQL (CAR X) OP)
+ (CONS OP (MKPFFLATTEN-1 (CDR X) OP NIL)))
+ ((CONS (MKPFFLATTEN (CAR X) OP) (MKPFFLATTEN (CDR X) OP)))))
+
+ (defun MKPFFLATTEN-1 (L OP R)
+ (let (X)
+ (if (NULL L)
+ R
+ (MKPFFLATTEN-1 (CDR L)
+ OP
+ (APPEND R
+ (if (EQCAR (SETQ X (MKPFFLATTEN (CAR L) OP))
+ OP)
+ (CDR X) (LIST X)))))))
+
+ (defun MKPF1 (L OP)
+ (let (X)
+ (case OP
+ (PLUS
+ (COND ((EQL 0 (SETQ X (LENGTH (SETQ L (S- L '(0 (ZERO)))))))
+ 0)
+ ((EQL 1 X)
+ (CAR L))
+ ((CONS 'PLUS L)) ))
+ (TIMES
+ (COND ((S* L '(0 (ZERO)))
+ 0)
+ ((EQL 0 (SETQ X (LENGTH (SETQ L (S- L '(1 (ONE)))))))
+ 1)
+ ((EQL 1 X)
+ (CAR L))
+ ((CONS 'TIMES L)) ))
+ (QUOTIENT
+ (COND ((GREATERP (LENGTH L) 2)
+ (fail))
+ ((EQL 0 (CAR L))
+ 0)
+ ((EQL (CADR L) 1)
+ (CAR L))
+ ((CONS 'QUOTIENT L)) ))
+ (MINUS
+ (COND ((CDR L)
+ (FAIL))
+ ((NUMBERP (SETQ X (CAR L)))
+ (MINUS X))
+ ((EQCAR X 'MINUS)
+ (CADR X))
+ ((CONS 'MINUS L)) ))
+ (DIFFERENCE
+ (COND ((GREATERP (LENGTH L) 2)
+ (FAIL))
+ ((EQUAL (CAR L) (CADR L))
+ '(ZERO))
+ ((|member| (CAR L) '(0 (ZERO)))
+ (MKPF (CDR L) 'MINUS))
+ ((|member| (CADR L) '(0 (ZERO)))
+ (CAR L))
+ ((EQCAR (CADR L) 'MINUS)
+ (MKPF (LIST (CAR L) (CADADR L)) 'PLUS))
+ ((CONS 'DIFFERENCE L)) ))
+ (EXPT
+ (COND ((GREATERP (LENGTH L) 2)
+ (FAIL))
+ ((EQL 0 (CADR L))
+ 1)
+ ((EQL 1 (CADR L))
+ (CAR L))
+ ((|member| (CAR L) '(0 1 (ZERO) (ONE)))
+ (CAR L))
+ ((CONS 'EXPT L)) ))
+ (OR
+ (COND ((MEMBER 'T L)
+ ''T)
+ ((EQL 0 (SETQ X (LENGTH (SETQ L (REMOVE NIL L)))))
+ NIL)
+ ((EQL 1 X)
+ (CAR L))
+ ((CONS 'OR L)) ))
+ (|or|
+ (COND ((MEMBER 'T L) 'T)
+ ((EQL 0 (SETQ X (LENGTH (SETQ L (REMOVE NIL L)))))
+ NIL)
+ ((EQL 1 X)
+ (CAR L))
+ ((CONS 'or L)) ))
+ (NULL
+ (COND ((CDR L)
+ (FAIL))
+ ((EQCAR (CAR L) 'NULL)
+ (CADAR L))
+ ((EQL (CAR L) 'T)
+ NIL)
+ ((NULL (CAR L))
+ ''T)
+ ((CONS 'NULL L)) ))
+ (|and|
+ (COND ((EQL 0 (SETQ X
+ (LENGTH
+ (SETQ L (REMOVE T (REMOVE '|true| L))))))
+ T)
+ ((EQL 1 X)
+ (CAR L))
+ ((CONS '|and| L)) ))
+ (AND
+ (COND ((EQL 0 (SETQ X (LENGTH
+ (SETQ L (REMOVE T (REMOVE '|true| L))))))
+ ''T)
+ ((EQL 1 X)
+ (CAR L))
+ ((CONS 'AND L)) ))
+ (PROGN
+ (COND ((AND (NOT (ATOM L))
+ (NULL (LAST L)))
+ (if (CDR L) `(PROGN . ,L) (CAR L)))
+ ((NULL (SETQ L (REMOVE NIL L)))
+ NIL)
+ ((CDR L)
+ (CONS 'PROGN L))
+ ((CAR L))))
+ (SEQ
+ (COND ((EQCAR (CAR L) 'EXIT)
+ (CADAR L))
+ ((CDR L)
+ (CONS 'SEQ L))
+ ((CAR L))))
+ (LIST
+ (if L
+ (cons 'LIST L)))
+ (CONS
+ (if (cdr L) (cons 'CONS L) (car L)))
+ (t (CONS OP L) ))))
+
+
+ (defun FLAG (L KEY)
+ "Set the KEY property of every item in list L to T."
+ (mapc #'(lambda (item) (makeprop item KEY T)) L))
+
+ (defun FLAGP (X KEY)
+ "If X has a KEY property, then FLAGP is true."
+ (GET X KEY))
+
+ (DEFUN REMFLAG (L KEY)
+ "Set the KEY property of every item in list L to NIL."
+ (OR (ATOM L)
+ (SEQ
+ (REMPROP (CAR L) KEY)
+ (REMFLAG (CDR L) KEY))))
+
+
+ (FLAG '(* + AND OR PROGN) 'NARY) ; flag for MKPF
+
+
+ (defun MKPF (L OP)
+ (if (FLAGP OP 'NARY)
+ (SETQ L (MKPFFLATTEN-1 L OP NIL)))
+ (MKPF1 L OP))
+
+ (defun MKQSADD1 (X)
+ (COND ((ATOM X)
+ `(QSADD1 ,X))
+ ((AND (member (CAR X) '(-DIFFERENCE QSDIFFERENCE -) :test #'eq)
+ (EQL 1 (CADDR X)))
+ (CADR X))
+ (`(QSADD1 ,X))))
+
+
+ (defun SEQOPT (U)
+ (if (AND (EQCAR U 'SEQ)
+ (EQCAR (CADR U) 'EXIT)
+ (EQCAR (CADADR U) 'SEQ))
+ (CADADR U)
+ U))
+
+ (defun -REPEAT (BD SPL)
+ (let (u g g1 inc final xcl xv il rsl tll funPLUS funGT fun? funIdent
+ funPLUSform funGTform)
+ (DO ((X SPL (CDR X)))
+ ((ATOM X)
+ (LIST 'spadDO
+ (NREVERSE IL)
+ (LIST (MKPF (NREVERSE XCL) 'OR) XV)
+ (SEQOPT (CONS 'SEQ (NCONC (NREVERSE RSL)
+ (LIST (LIST 'EXIT BD)))))))
+ (COND ((ATOM (CAR X))
+ (FAIL)))
+ (COND ((AND (EQ (CAAR X) 'STEP)
+ (|member| (CADDAR X) '(2 1 0 (|One|) (|Zero|)))
+ (|member| (CADR (CDDAR X)) '(1 (|One|))))
+ (SETQ X (CONS (CONS 'ISTEP (CDAR X)) (CDR X))) ))
+ ;; A hack to increase the likelihood of small integers
+ (SETQ U (CDAR X))
+ (case (CAAR X)
+ (GENERAL
+ (AND (CDDDR U) (PUSH (CADDDR U) XCL))
+ (PUSH (LIST (CAR U) (CADR U) (CADDR U)) IL) )
+ (GSTEP
+ (SETQ tll (CDDDDR U)) ;tll is (+fun >fun type? ident)
+ (SETQ funPLUSform (CAR tll))
+ (SETQ funGTform (CAR (SETQ tll (QCDR tll))))
+ (PUSH (LIST (SETQ funPLUS (GENSYM)) funPLUSform) IL)
+ (PUSH (LIST (SETQ funGT (GENSYM)) funGTform) IL)
+ (COND ((SETQ tll (CDR tll))
+ (SETQ fun? (CAR tll))
+ (SETQ funIdent (CAR (SETQ tll (QCDR tll))))))
+ (IF (NOT (ATOM (SETQ inc (CADDR U)) ))
+ (PUSH (LIST (SETQ inc (GENSYM)) (CADDR U)) IL))
+ (SETQ final (CADDDR U))
+ (COND (final
+ (COND ((ATOM final))
+ ((PUSH (LIST (SETQ final (GENSYM)) (CADDDR U))
+ IL)))
+ ;; If CADDDR U is not an atom, only compute the value once
+ (PUSH
+ (if fun?
+ (if (FUNCALL fun? INC)
+ (if (FUNCALL (EVAL funGTform) INC funIdent)
+ (LIST 'FUNCALL funGT (CAR U) FINAL)
+ (LIST 'FUNCALL funGT FINAL (CAR U)))
+ (LIST 'IF (LIST 'FUNCALL funGT INC funIdent)
+ (LIST 'FUNCALL funGT (CAR U) FINAL)
+ (LIST 'FUNCALL funGT FINAL (CAR U))))
+ (LIST 'FUNCALL funGT (CAR U) final))
+ XCL)))
+ (PUSH (LIST (CAR U)
+ (CADR U)
+ (LIST 'FUNCALL funPLUS (CAR U) INC))
+ IL))
+ (STEP
+ (IF (NOT (ATOM (SETQ inc (CADDR U)) ))
+ (PUSH (LIST (SETQ inc (GENSYM)) (CADDR U)) IL))
+ (COND ((CDDDR U)
+ (COND ((ATOM (SETQ final (CADDDR U)) ))
+ ((PUSH (LIST (SETQ final (GENSYM)) (CADDDR U))
+ IL)))
+ ;; If CADDDR U is not an atom, only compute the value once
+ (PUSH
+ (if (INTEGERP INC)
+ (LIST (if (MINUSP INC) '< '>) (CAR U) FINAL)
+ `(if (MINUSP ,INC)
+ (< ,(CAR U) ,FINAL)
+ (> ,(CAR U) ,FINAL)))
+ XCL)))
+ (PUSH (LIST (CAR U) (CADR U) (LIST '+ (CAR U) INC)) IL))
+ (ISTEP
+ (IF (NOT (ATOM (SETQ inc (CADDR U)) ))
+ (PUSH (LIST (SETQ inc (GENSYM)) (CADDR U)) IL))
+ (COND ((CDDDR U)
+ (COND ((ATOM (SETQ final (CADDDR U)) ))
+ ((PUSH (LIST (SETQ final (GENSYM)) (CADDDR U))
+ IL)))
+ ;; If CADDDR U is not an atom, only compute the value once
+ (PUSH
+ (if (INTEGERP INC)
+ (LIST (if (QSMINUSP INC)
+ 'QSLESSP
+ 'QSGREATERP)
+ (CAR U)
+ FINAL)
+ `(if (QSMINUSP ,INC)
+ (QSLESSP ,(CAR U) ,FINAL)
+ (QSGREATERP ,(CAR U) ,FINAL)))
+ XCL)))
+ (PUSH (LIST (CAR U) (CADR U)
+ (COND ((|member| INC '(1 (|One|)))
+ (MKQSADD1 (CAR U)))
+ ((LIST 'QSPLUS (CAR U) INC)) ))
+ IL))
+ (ON
+ (PUSH (LIST 'ATOM (CAR U)) XCL)
+ (PUSH (LIST (CAR U) (CADR U) (LIST 'CDR (CAR U))) IL))
+ (RESET
+ (PUSH (LIST 'PROGN (CAR U) NIL) XCL))
+ (IN
+ (PUSH (LIST 'OR
+ (LIST 'ATOM (SETQ G (GENSYM)))
+ (CONS 'PROGN
+ (CONS
+ (LIST 'SETQ (CAR U) (LIST 'CAR G))
+ (APPEND
+ (COND ((AND (symbol-package (car U))
+ $TRACELETFLAG)
+ (LIST (LIST '/TRACELET-PRINT
+ (CAR U)
+ (CAR U))))
+ (NIL))
+ (LIST NIL)))) ) XCL)
+ (PUSH (LIST G (CADR U) (LIST 'CDR G)) IL)
+ (PUSH (LIST (CAR U) NIL) IL))
+ (INDOM
+ (SETQ G (GENSYM))
+ (SETQ G1 (GENSYM))
+ (PUSH (LIST 'ATOM G) XCL)
+ (PUSH (LIST G (LIST 'INDOM-FIRST (CADR U))
+ (LIST 'INDOM-NEXT G1)) IL)
+ (PUSH (LIST (CAR U) NIL) IL)
+ (PUSH (LIST G1 NIL) IL)
+ (PUSH (LIST 'SETQ G1 (LIST 'CDR G)) RSL)
+ (PUSH (LIST 'SETQ (CAR U) (LIST 'CAR G)) RSL))
+ (UNTIL
+ (SETQ G (GENSYM))
+ (PUSH (LIST G NIL (CAR U)) IL)
+ (PUSH G XCL))
+ (WHILE
+ (PUSH (LIST 'NULL (CAR U)) XCL))
+ (SUCHTHAT
+ (SETQ BD (LIST 'SUCHTHATCLAUSE BD (CAR U))))
+ (EXIT
+ (SETQ XV (CAR U))) (FAIL)))))
+
+ (defun REPEAT-TRAN (L LP)
+ (COND ((ATOM L)
+ (ERROR "REPEAT FORMAT ERROR"))
+ ((MEMBER (KAR (KAR L))
+ '(EXIT RESET IN ON GSTEP ISTEP STEP
+ GENERAL UNTIL WHILE SUCHTHAT EXIT))
+ (REPEAT-TRAN (CDR L) (CONS (CAR L) LP)))
+ ((CONS (NREVERSE LP) (MKPF L 'PROGN)))))
+
+ (defun MK_LEFORM (U)
+ (COND ((IDENTP U)
+ (PNAME U))
+ ((STRINGP U)
+ U)
+ ((ATOM U)
+ (STRINGIMAGE U))
+ ((MEMBER (FIRST U) '(VCONS CONS) :test #'eq)
+ (STRCONC "(" (MK_LEFORM-CONS U) ")") )
+ ((EQ (FIRST U) 'LIST)
+ (STRCONC "(" (MK_LEFORM (SECOND U)) ")") )
+ ((EQ (FIRST U) 'APPEND)
+ (STRCONC "(" (MK_LEFORM-CONS U) ")") )
+ ((EQ (FIRST U) 'QUOTE)
+ (MK_LEFORM (SECOND U)))
+ ((EQ (FIRST U) 'EQUAL)
+ (STRCONC "=" (MK_LEFORM (SECOND U)) ))
+ ((EQ (FIRST U) 'SPADLET)
+ (MK_LEFORM (THIRD U)))
+ ((ERRHUH))))
+
+ (defun MK_LEFORM-CONS (U)
+ (COND ((ATOM U)
+ (STRCONC ":" (MK_LEFORM U)))
+ ((EQ (FIRST U) 'APPEND)
+ (STRCONC ":"
+ (MK_LEFORM (SECOND U))
+ "\,"
+ (MK_LEFORM-CONS (THIRD U)) ))
+ ((EQ (THIRD U) NIL)
+ (MK_LEFORM (SECOND U)))
+ ((STRCONC (MK_LEFORM (SECOND U))
+ "\,"
+ (MK_LEFORM-CONS (THIRD U))))))
+
+
+ (defun DO_LET (VARS INITS)
+ (if (OR (NULL VARS)
+ (NULL INITS))
+ NIL
+ (CONS (LIST 'SPADLET (CAR VARS) (CAR INITS))
+ (DO_LET (CDR VARS) (CDR INITS)))))
+
+
+ ;; cons-cell constructor is a righ associative.
+ (MAKEPROP 'CONS 'RIGHT-ASSOCIATIVE T)
+
+ ;; monoid operators -- leading to reduction. Each operator is
+ ;; is paired with its neutral element.
+ (MAPC #'(LAMBDA (X) (MAKEPROP (CAR X) 'THETA (CDR X)))
+ '((PLUS 0)
+ (+ (|Zero|))
+ (|lcm| (|One|))
+ (STRCONC "")
+ (|strconc| "")
+ (MAX -999999)
+ (MIN 999999)
+ (TIMES 1)
+ (* (|One|))
+ (CONS NIL)
+ (APPEND NIL)
+ (|append| NIL)
+ (UNION NIL)
+ (UNIONQ NIL)
+ (|gcd| (|Zero|))
+ (|union| NIL)
+ (NCONC NIL)
+ (|and| |true|)
+ (|or| |false|)
+ (AND 'T)
+ (OR NIL)))
+
+
+ (MAPC #'(LAMBDA (J) (MAKEPROP (CAR J) 'UNMACRO (CADR J)))
+ '( (AND AND2)
+ (OR OR2)))
+
+
+ (defun AND2 (x y)
+ (and x y))
+
+ (defun OR2 (x y) (or x y))
+
+ (defun NREVERSE-N (X AXIS)
+ (COND ((EQL AXIS 0)
+ (NREVERSE X))
+ ((MAPCAR #'(LAMBDA (Y) (NREVERSE-N Y (SUB1 AXIS))) X))))
+
+
+ (defun REDUCE-1 (OP AXIS BOD)
+ (let (u op1 tran iden)
+ (SEQ
+ (SETQ OP1 (cond ((EQ OP '\,)
+ 'CONS)
+ ((EQCAR OP 'QUOTE)
+ (CADR OP))
+ (OP)))
+ (SETQ IDEN (if (SETQ U (GET OP1 'THETA))
+ (CAR U)
+ 'NO_THETA_PROPERTY))
+ (SETQ TRAN (if (EQCAR BOD 'COLLECT)
+ (PROG (L BOD1 ITL)
+ (SETQ L (REVERSE (CDR BOD)))
+ (SETQ BOD1 (CAR L))
+ (SETQ ITL (NREVERSE (CDR L)))
+ (RETURN (-REDUCE OP1 AXIS IDEN BOD1 ITL)) )
+ (progn
+ (SETQ U (-REDUCE-OP OP1 AXIS))
+ (LIST 'REDUCE-N (MKQ (OR (GET U 'UNMACRO) U))
+ (GET OP1 'RIGHT-ASSOCIATIVE)
+ BOD IDEN))))
+ (if (EQ OP '\,)
+ (LIST 'NREVERSE-N TRAN AXIS)
+ TRAN))))
+
+ (defun REDUCE-N (OP RIGHT L ACC)
+ (COND (RIGHT
+ (PROG (U L1)
+ (SETQ L1 (NREVERSE L))
+ (SETQ U (REDUCE-N-1 OP 'T L1 ACC))
+ (NREVERSE L1)
+ (RETURN U) ))
+ ((REDUCE-N-1 OP NIL L ACC))))
+
+ (defun REDUCE-N-1 (OP RIGHT L ACC)
+ (COND ((EQ ACC 'NO_THETA_PROPERTY)
+ (COND ((NULL L)
+ (THETA_ERROR OP))
+ ((REDUCE-N-2 OP RIGHT (CDR L) (CAR L))) ))
+ ((REDUCE-N-2 OP RIGHT L ACC))))
+
+ (defun REDUCE-N-2 (OP RIGHT L ACC)
+ (COND ((NULL L) ACC)
+ (RIGHT
+ (REDUCE-N-2 OP
+ RIGHT
+ (CDR L)
+ (funcall (symbol-function OP) (CAR L) ACC)))
+ ((REDUCE-N-2 OP
+ RIGHT
+ (CDR L)
+ (funcall (symbol-function OP) ACC (CAR L))))))
+
+
+ (defun DELASC (u v)
+ "Returns a copy of a-list V in which any pair with key U is deleted."
+ (cond ((atom v) nil)
+ ((or (atom (car v))
+ (not (equal u (caar v))))
+ (cons (car v) (DelAsc u (cdr v))))
+ ((cdr v))))
+
+ (defun -REDUCE (OP AXIS Y BODY SPL)
+ (PROG (X G AUX EXIT VALUE PRESET CONSCODE RESETCODE)
+ (SETQ G (GENSYM))
+ ;; create preset of accumulate
+ (SETQ PRESET
+ (COND ((EQ Y 'NO_THETA_PROPERTY)
+ (LIST 'SPADLET G (MKQ G)))
+ ((LIST 'SPADLET G Y)) ))
+ (SETQ EXIT
+ (COND ((SETQ X (ASSOC 'EXIT SPL))
+ (SETQ SPL (DELASC 'EXIT SPL))
+ (COND ((MEMBER OP '(AND OR))
+ (LIST 'AND G (CADR X)))
+ ((CADR X)) ))
+ ((EQ Y 'NO_THETA_PROPERTY)
+ (LIST 'THETACHECK G (MKQ G)(MKQ OP)))
+ (G) ))
+ (COND ((EQ OP 'CONS)
+ (SETQ EXIT (LIST 'NREVERSE0 EXIT))))
+ ;; CONSCODE= code which conses a member onto the list
+ (SETQ VALUE
+ (COND ((EQ Y 'NO_THETA_PROPERTY)
+ (GENSYM))
+ (BODY)))
+ (SETQ CONSCODE
+ (CONS (-REDUCE-OP OP AXIS)
+ (COND ((FLAGP OP 'RIGHT-ASSOCIATIVE)
+ (LIST VALUE G))
+ ((LIST G VALUE) ) ) ) )
+ ;; next reset code which varies if THETA property is|/is not given
+ (SETQ RESETCODE (LIST 'SETQ
+ G
+ (COND ((EQ Y 'NO_THETA_PROPERTY)
+ (LIST 'COND
+ (LIST (LIST 'EQ G (MKQ G)) VALUE)
+ (LIST ''T CONSCODE)) )
+ (CONSCODE) )))
+ ;; create body
+ (SETQ BODY
+ (COND ((EQ VALUE BODY)
+ RESETCODE)
+ ((LIST 'PROGN
+ (LIST 'SPADLET VALUE BODY)
+ RESETCODE)) ))
+ (SETQ AUX
+ (CONS (LIST 'EXIT EXIT)
+ (COND ((EQ OP 'AND)
+ (LIST (LIST 'UNTIL (LIST 'NULL G))))
+ ((EQ OP 'OR)
+ (LIST (LIST 'UNTIL G)))
+ (NIL) )))
+ (RETURN (COND ((AND $NEWSPAD (NULL $BOOT))
+ (LIST 'PROGN
+ PRESET
+ (CONS 'REPEAT
+ (APPEND AUX (APPEND SPL (LIST BODY))) )))
+ ((LIST 'PROG
+ (COND ((EQ RESETCODE BODY)
+ (LIST G))
+ ((LIST G VALUE)))
+ PRESET
+ (LIST 'RETURN
+ (CONS 'REPEAT
+ (APPEND AUX
+ (APPEND SPL (LIST BODY)))))))))))
+
+ (defun CONS-N (X Y)
+ (COND ((NULL Y)
+ (CONS-N X (NLIST (LENGTH X) NIL)))
+ ((MAPCAR #'CONS X Y))))
+
+ (defun APPEND-N (X Y)
+ (COND ((NULL X)
+ (APPEND-N (NLIST (LENGTH Y) NIL) Y))
+ ((MAPCAR #'APPEND X Y))))
+
+ (defun -REDUCE-OP (OP AXIS)
+ (COND ((EQL AXIS 0)
+ OP)
+ ((EQL AXIS 1)
+ (COND ((EQ OP 'CONS)
+ 'CONS-N)
+ ((EQ OP 'APPEND)
+ 'APPEND-N)
+ ((FAIL))))
+ ((FAIL))))
+
+ ))
+
+;;
+;; -*- Iteration -*-
+;;
+
+(defmacro REPEAT (&rest L)
+ (let ((U (REPEAT-TRAN L NIL)))
+ (-REPEAT (CDR U) (CAR U))))
+
+(defmacro SUCHTHATCLAUSE (&rest L)
+ (LIST 'COND (LIST (CADR L) (CAR L))))
+
+(defmacro SPADDO (&rest OL)
+ (PROG (VARS L VL V U INITS U-VARS U-VALS ENDTEST EXITFORMS BODYFORMS)
+ (if (OR $BOOT (NOT $NEWSPAD))
+ (return (CONS 'DO OL)))
+ (SETQ L (COPY-LIST OL))
+ (if (OR (ATOM L) (ATOM (CDR L)))
+ (GO BADO))
+ (setq vl (POP L))
+ (COND ((IDENTP VL)
+ (SETQ VARS (LIST VL))
+ (AND (OR (ATOM L)
+ (ATOM (progn (setq inits (POP L)) L))
+ (ATOM (progn (setq u-vals (pop L)) L)))
+ (GO BADO))
+ (SETQ INITS (LIST INITS)
+ U-VARS (LIST (CAR VARS))
+ U-VALS (LIST U-VALS))
+ (setq endtest (POP L)))
+ ((prog nil
+ (COND ((NULL VL)
+ (GO TG5))
+ ((ATOM VL)
+ (GO BADO)))
+ G180
+ (AND (NOT (PAIRP (SETQ V (CAR VL))))
+ (SETQ V (LIST V)))
+ (AND (NOT (IDENTP (CAR V)))
+ (GO BADO))
+ (PUSH (CAR V) VARS)
+ (PUSH (COND ((PAIRP (CDR V)) (CADR V))) INITS)
+ (AND (PAIRP (CDR V))
+ (PAIRP (CDDR V))
+ (SEQ (PUSH (CAR V) U-VARS)
+ (PUSH (CADDR V) U-VALS)))
+ (AND (PAIRP (progn (POP VL) VL))
+ (GO G180))
+ TG5
+ (setq exitforms (POP L))
+ (and (PAIRP EXITFORMS)
+ (progn
+ (setq endtest (POP EXITFORMS))
+ exitforms)))))
+ (AND L
+ (COND ((CDR L)
+ (SETQ BODYFORMS (CONS 'SEQ L)))
+ ((NULL (EQCAR (CAR L) 'SEQ))
+ (SETQ BODYFORMS (CONS 'SEQ L)))
+ ((SETQ BODYFORMS (CAR L)))))
+ (SETQ EXITFORMS `(EXIT ,(MKPF EXITFORMS 'PROGN)))
+ (AND ENDTEST
+ (SETQ ENDTEST (LIST 'COND (LIST ENDTEST '(GO G191)))))
+ (COND ((NULL U-VARS)
+ (GO XT) )
+ ((NULL (CDR U-VARS))
+ (SEQ
+ (SETQ U-VARS (LIST 'SETQ (CAR U-VARS) (CAR U-VALS)))
+ (GO XT)) ))
+ (SETQ VL (LIST 'SETQ (CAR U-VARS) (CAR U-VALS)))
+ (SEQ
+ (SETQ V (CDR U-VARS))
+ (SETQ U (CDR U-VALS)))
+ TG
+ (SETQ VL (LIST 'SETQ (CAR V) (LIST 'PROG1 (CAR U) VL)))
+ (POP U)
+ (AND (progn (POP V) V)
+ (GO TG))
+ (SETQ U-VARS VL)
+ XT
+ (RETURN (COND
+ ((AND $NEWSPAD (NULL $BOOT))
+ (CONS 'SEQ
+ (NCONC (DO_LET VARS INITS)
+ (LIST 'G190
+ ENDTEST
+ BODYFORMS
+ U-VARS
+ '(GO G190)
+ 'G191
+ EXITFORMS))))
+ ((CONS `(LAMBDA ,(NRECONC VARS NIL)
+ (SEQ
+ G190
+ ,ENDTEST
+ ,BODYFORMS
+ ,U-VARS
+ (GO G190)
+ G191
+ ,EXITFORMS))
+ (NRECONC INITS NIL)))))
+ BADO
+ (ERROR (FORMAT NIL "BAD DO FORMAT~%~A" OL))))
+
+(defmacro THETA (&rest LL)
+ (let (U (L (copy-list LL)))
+ (if (EQ (KAR L) '\,)
+ `(theta CONS . ,(CDR L))
+ (progn
+ (if (EQCAR (CAR L) 'QUOTE)
+ (RPLAC (CAR L) (CADAR L)))
+ (-REDUCE (CAR L) 0
+ (if (SETQ U (GET (CAR L) 'THETA))
+ (CAR U)
+ (MOAN "NO THETA PROPERTY"))
+ (CAR (SETQ L (NREVERSE (CDR L))))
+ (NREVERSE (CDR L)))))))
+
+(defmacro THETA1 (&rest LL)
+ (let (U (L (copy-list LL)))
+ (if (EQ (KAR L) '\,)
+ (LIST 'NREVERSE-N (CONS 'THETA1 (CONS 'CONS (CDR L))) 1)
+ (-REDUCE (CAR L)
+ 1
+ (if (SETQ U (GET (CAR L) 'THETA))
+ (CAR U)
+ (MOAN "NO THETA PROPERTY"))
+ (CAR (SETQ L (NREVERSE (CDR L))))
+ (NREVERSE (CDR L))))))
+
+(defmacro SPADREDUCE (OP AXIS BOD)
+ (REDUCE-1 OP AXIS BOD))
+
+;;
+;; -*- List Comprehension -*-
+;;
+
+(defmacro COLLECT (&rest L)
+ (let ((U (REPEAT-TRAN L NIL)))
+ (CONS 'THETA (CONS '\, (NCONC (CAR U) (LIST (CDR U)))))))
+
+;; The following was changed to a macro for efficiency in CCL. To change
+;; it back to a function would require recompilation of a large chunk of
+;; the library.
+(defmacro PRIMVEC2ARR (x)
+ x) ;redefine to change Array rep
+
+(defmacro COLLECTVEC (&rest L)
+ `(PRIMVEC2ARR (COLLECTV ,@L)))
+
+(defmacro COLLECTV (&rest L)
+ (PROG (CONDS BODY ANS COUNTER X Y)
+ ;;If we can work out how often we will go round
+ ;; allocate a vector first
+ (SETQ CONDS NIL)
+ (SETQ BODY (REVERSE L))
+ (SETQ ANS (GENSYM))
+ (SETQ COUNTER NIL)
+ (SETQ X (CDR BODY))
+ (SETQ BODY (CAR BODY))
+ LP
+ (COND ((NULL X)
+ (COND ((NULL COUNTER)
+ (SETQ COUNTER (GENSYM))
+ (SETQ L (CONS (LIST 'ISTEP COUNTER 0 1) L)) ))
+ (RETURN (LIST 'PROGN
+ (LIST 'SPADLET
+ ANS
+ (LIST 'GETREFV
+ (COND ((NULL CONDS)
+ (fail))
+ ((NULL (CDR CONDS))
+ (CAR CONDS))
+ ((CONS 'MIN CONDS)) ) ))
+ (CONS 'REPEAT
+ (NCONC (CDR (REVERSE L))
+ (LIST (LIST 'SETELT
+ ANS
+ COUNTER
+ BODY))))
+ ANS)) ))
+ (SETQ Y (CAR X))
+ (SETQ X (CDR X))
+ (COND ((MEMQ (CAR Y) '(SUCHTHAT WHILE UNTIL))
+ (RETURN (LIST 'LIST2VEC (CONS 'COLLECT L)) ))
+ ((member (CAR Y) '(IN ON) :test #'eq)
+ (SETQ CONDS (CONS (LIST 'SIZE (CADDR Y)) CONDS))
+ (GO LP))
+ ((member (CAR Y) '(STEP ISTEP) :test #'eq)
+ (if (AND (EQL (CADDR Y) 0)
+ (EQL (CADDDR Y) 1))
+ (SETQ COUNTER (CADR Y)) )
+ (COND ((CDDDDR Y) ; there may not be a limit
+ (SETQ CONDS
+ (CONS
+ (COND ((EQL 1 (CADDDR Y))
+ (COND ((EQL 1 (CADDR Y))
+ (CAR (CDDDDR Y)))
+ ((EQL 0 (CADDR Y))
+ (MKQSADD1 (CAR (CDDDDR Y))))
+ ((MKQSADD1 `(- ,(CAR (CDDDDR Y))
+ ,(CADDR Y))))))
+ ((EQL 1 (CADDR Y))
+ `(/ ,(CAR (CDDDDR Y)) ,(CADDR Y)))
+ ((EQL 0 (CADDR Y))
+ `(/ ,(MKQSADD1 (CAR (CDDDDR Y)))
+ ,(CADDR Y)))
+ (`(/ (- ,(MKQSADD1 (CAR (CDDDDR Y)))
+ ,(CADDR Y))
+ ,(CADDR Y))))
+ CONDS))))
+ (GO LP)))
+ (ERROR "Cannot handle macro expansion")))
+
+
+;;
+;; -*- Non-Local Gotos -*-
+;;
+
+(defmacro SPADCATCH (&rest form)
+ (CONS 'CATCH form))
+
+(defmacro SPADTHROW (&rest form)
+ (CONS 'THROW form))
+
+(defmacro YIELD (L)
+ (let ((g (gensym)))
+ `(let ((,g (state)))
+ (if (STATEP ,g)
+ (throw 'YIELD (list 'pair ,L) ,g)))))
+