* 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.

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)))))
+