Initial population.

1 files changed, 692 insertions, 0 deletions

diff --git a/src/interp/def.lisp.pamphlet b/src/interp/def.lisp.pamphlet
new file mode 100644
index 00000000..6b0228c1
--- /dev/null
+++ b/src/interp/def.lisp.pamphlet
@@ -0,0 +1,692 @@
+%% Oh Emacs, this is a -*- Lisp -*- file, despite appearance.
+\documentclass{article}
+\usepackage{axiom}
+
+\title{\File{src/interp/def.lisp} Pamphlet}
+\author{Timothy Daly}
+
+\begin{document}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+
+\section{License}
+<<license>>=
+;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+;; 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.
+
+@
+<<*>>=
+<<license>>
+
+; NAME:     Def
+; PURPOSE:  Defines BOOT code
+
+(provide 'Boot)
+
+(in-package "BOOT")
+
+;;; Common Block
+
+(defparameter deftran nil)
+(defparameter $macroassoc nil)
+(defparameter $ne nil)
+
+(defparameter $op nil
+"$OP is globalized for construction of local function names, e.g.
+foo defined inside of fum gets renamed as fum,foo.")
+
+(defparameter $opassoc nil
+"$OPASSOC is a renaming accumulator to be used with SUBLIS.")
+
+(defparameter $BODY nil)
+
+(defun DEF (FORM SIGNATURE $BODY)
+  (declare (ignore SIGNATURE))
+  (let* ($opassoc
+         ($op (first form))
+         (argl (rest form))
+         ($body (deftran $body))
+         (argl (DEF-INSERT_LET argl))
+         (arglp (DEF-STRINGTOQUOTE argl))
+	 ($body (|bootTransform| $body)))
+      (COMP (SUBLIS $OPASSOC (list (list $OP (list 'LAM arglp $body)))))))
+
+; We are making shallow binding cells for these functions as well
+
+(mapcar #'(lambda (x) (MAKEPROP (FIRST X) 'DEF-TRAN (SECOND X)))
+         '((\: DEF-\:) (\:\: DEF-\:\:) (ELT DEF-ELT)
+           (SETELT DEF-SETELT) (SPADLET DEF-LET)
+           (SEQ DEF-SEQ) (COLLECT DEF-COLLECT)
+           (REPEAT DEF-REPEAT) (TRACE-LET DEF-TRACE-LET)
+           (CATEGORY DEF-CATEGORY) (EQUAL DEF-EQUAL)
+           (|is| DEF-IS) (|isnt| DEF-ISNT) (|where| DEF-WHERE)))
+
+(defun DEF-EQUAL (X)
+  (COND ((NOT (CDR X)) (CONS 'EQUAL X))
+        ((OR (MEMBER '(|One|) X) (MEMBER '(|Zero|) X)
+             (integerp (FIRST X)) (integerp (SECOND X))) (CONS 'EQL X))
+       ; ((AND (EQCAR (FIRST X) 'QUOTE) (IDENTP (CADAR X))) (CONS 'EQ X))
+        ((NOT (FIRST X)) (LIST 'NULL (SECOND X)))
+        ((NOT (SECOND X)) (LIST 'NULL (FIRST X)))
+       ; ((AND (EQCAR (SECOND X) 'QUOTE) (IDENTP (CADADR X))) (CONS 'EQ X))
+        ($BOOT (CONS 'BOOT-EQUAL X))
+	((CONS 'EQUAL X))))
+ 
+(defun DEF-LESSP (x)
+  (cond ((null (cdr x)) (cons '< x))
+	((eq (cadr x) 0) (list 'minusp (car x)))
+	((and (smint-able (car x)) (smint-able (cadr x)))
+	 (cons 'qslessp x))
+	('t (list '> (CADR x) (CAR x)))))
+
+(defun smint-able (x)
+  (or (smintp x)
+      (and (pairp x) (memq (car x) '(|One| |Zero| LENGTH \# QCSIZE QVSIZE QLENGTH)))))
+
+(defun DEF-PROCESS (X &aux $MACROASSOC)
+  (COND ((EQCAR X 'DEF) (DEF (SECOND X) (THIRD X) (FIRST (CDDDDR X))))
+        ((EQCAR X 'MDEF) (B-MDEF (SECOND X) (THIRD X) (FIRST (CDDDDR X))))
+        ((AND (EQCAR X 'WHERE) (EQCAR (cadr X) 'DEF))
+         (let* ((u (cadr X)) (Y (cdr U)))
+           (DEF-PROCESS (LIST 'DEF
+                              (car Y)
+                              (car (setq Y (cdr Y)))
+                              (car (setq Y (cdr Y)))
+                              (CONS 'WHERE (cons (car (setq Y (cdr Y))) (cddr X)))))))
+	((IS-CONSOLE *STANDARD-OUTPUT*)
+	 (SAY "  VALUE = " (EVAL (DEFTRAN X))))
+        ((print-full (DEFTRAN X)))))
+
+(defun B-MDEF (FORM SIGNATURE $BODY)
+  (declare (ignore SIGNATURE))
+ (let* ($OpAssoc
+        ($op (first form)) (argl (cdr form))
+        (GARGL (MAPCAR '(LAMBDA (X) (GENSYM)) ARGL))
+        ($BODY (SUBLISLIS GARGL ARGL (|bootTransform| (DEFTRAN $BODY))))
+        ($BODY (LIST 'SUBLISLIS (CONS 'LIST GARGL) (LIST 'QUOTE GARGL)
+                     (LIST 'QUOTE $BODY))))
+   (COMP (SUBLIS $OPASSOC
+                 (LIST (LIST $OP (LIST 'MLAMBDA (CONS () GARGL) $BODY)))))))
+
+(defun DEF-INNER (FORM SIGNATURE $BODY)
+  "Same as DEF but assumes body has already been DEFTRANned"
+ (let ($OpAssoc ($op (first form)) (argl (rest form)))
+   (let* ((ARGL (DEF-INSERT_LET ARGL))
+          (ARGLP (DEF-STRINGTOQUOTE ARGL)))
+    (COMP (SUBLIS $OPASSOC `((,$OP (LAM ,ARGLP ,$BODY))))))))
+
+(defun DEF-INSERT_LET (X)
+  (if (ATOM X) X
+      (CONS (DEF-INSERT_LET1 (FIRST X)) (DEF-INSERT_LET (CDR X)))))
+
+(defun DEF-INSERT_LET1 (Y)
+  (if (EQCAR Y 'SPADLET)
+      (COND ((IDENTP (SECOND Y))
+             (setq $BODY
+                   (MKPROGN
+                     (LIST (DEF-LET (THIRD Y) (SECOND Y)) $BODY)))
+             (setq Y (SECOND Y)))
+            ((IDENTP (THIRD Y))
+             (setq $BODY
+                   (MKPROGN (LIST (DEFTRAN Y) $BODY))) (setq Y (THIRD Y)))
+            ((ERRHUH)))
+      Y))
+
+(defun MKPROGN (L) (MKPF L 'PROGN))
+
+(defun DEF-STRINGTOQUOTE (X)
+  (COND ((STRINGP X) (LIST 'QUOTE (INTERN X)))
+        ((ATOM X) X)
+        ((CONS (DEF-ADDLET (FIRST X)) (DEF-STRINGTOQUOTE (CDR X))))))
+
+(defun DEF-ADDLET (X)
+  (if (ATOM X)
+      (if (STRINGP X) `(QUOTE ,(intern x))  X)
+      (let ((g (gensym)))
+        (setq $body (mkprogn
+		     (list (def-let (comp\,fluidize x) g)
+			   $body)))
+        g)))
+
+(mapcar #'(lambda (x) (MAKEPROP (CAR X) 'RENAME (CDR X)))
+        '((|true| 'T) (|otherwise| 'T) (|false| NIL)
+          (|and| AND) (|or| OR) (|is| IS)
+          (|list| LIST) (|cons| CONS) (|car| CAR) (|cdr| CDR)
+          (|setDifference| SETDIFFERENCE) (INTERSECTION |intersection|)
+          (|setIntersection| |intersection|) (|setUnion| |union|)
+          (UNION |union|) (REMOVE |remove|) (MEMBER |member|) (ASSOC |assoc|)
+	  (READ VMREAD) (READ-LINE |read-line|)
+          (|apply| APPLY) (|lastNode| LASTPAIR) (LAST |last|)
+          (|in| |member|) (|strconc| STRCONC) (|append| APPEND)
+          (|copy| COPY) (DELETE |delete|) (RASSOC |rassoc|)
+          (|size| SIZE) (|nconc| NCONC)
+          (|setPart| SETELT) (|where| WHERE)
+          (|first| CAR) (|rest| CDR) (|substitute| MSUBST)
+          (|removeDuplicates| REMDUP) (|reverse| REVERSE) (|nreverse| NREVERSE)
+          (|drop| DROP) (|take| TAKE) (|croak| CROAK) (|genvar| GENVAR)
+          (|mkpf| MKPF) (^= NEQUAL) (= EQUAL) (- SPADDIFFERENCE)
+          (+ PLUS) (* TIMES) (/ QUOTIENT)
+          (** EXPT) (|return| RETURN) (|exit| EXIT) (\| SUCHTHAT)
+          (^ NULL) (|not| NULL) (NOT NULL) (REDUCE spadReduce) (DO spadDo)
+          (|atom| ATOM) (|nil| NIL) (|null| NULL) (GET GETL)
+          (T T$)))
+
+; This two-level call allows DEF-RENAME to be locally bound to do
+; nothing (see boot2Lisp) yet still allow function call (lisp2BootAndComp)
+
+(defun DEF-RENAME (X) (DEF-RENAME1 X))
+
+(defun DEF-RENAME1 (X)
+  (COND ((symbolp X) (let ((y (get x 'rename))) (if y (first y) x)))
+        ((and (listp X) X)
+         (if (EQCAR X 'QUOTE)
+             X
+             (CONS (DEF-RENAME1 (FIRST X)) (DEF-RENAME1 (CDR X)))))
+        (X)))
+
+(defun DEFTRAN (X)
+ (let (op Y)
+   (COND ((STRINGP X) (DEF-STRING X))
+         ((IDENTP X) (COND ((LASSOC X $MACROASSOC)) (X)))
+         ((ATOM X) X)
+         ((EQ (setq OP (FIRST X)) 'WHERE) (DEF-WHERE (CDR X)))
+         ((EQ OP 'REPEAT) (DEF-REPEAT (CDR X)))
+         ((EQ OP 'COLLECT) (DEF-COLLECT (CDR X)))
+         ((EQ OP 'MAKESTRING)
+          (COND ((STRINGP (SECOND X)) X)
+                ((EQCAR (SECOND X) 'QUOTE)
+                 (LIST 'MAKESTRING (STRINGIMAGE (CADADR X))))
+                ((LIST 'MAKESTRING (DEFTRAN (SECOND X)) )) ))
+         ((EQ OP 'QUOTE)
+          (if (STRINGP (setq y (SECOND X))) (LIST 'MAKESTRING y)
+             (if (and (identp y) (char= (elt (pname y) 0) #\.))
+                 `(intern ,(pname y) ,(package-name *package*)) x)))
+         ((EQ OP 'IS) (|defIS| (CADR X) (CADDR X)))
+         ((EQ OP 'SPADLET) (DEF-LET (CADR X) (caddr x)))
+         ((EQ OP 'DCQ) (LIST 'DCQ (SECOND X) (DEFTRAN (THIRD X))))
+         ((EQ OP 'COND) (CONS 'COND (DEF-COND (CDR X))))
+         ((member (FIRST X) '(|sayBrightly| SAY MOAN CROAK) :test #'eq)
+          (DEF-MESSAGE X))
+         ((setq Y (GETL (FIRST X) 'DEF-TRAN))
+          (funcall Y (MAPCAR #'DEFTRAN (CDR X))))
+         ((mapcar #'DEFTRAN X)))))
+
+(defun DEF-SEQ (U) (SEQOPT (CONS 'SEQ U)))
+
+(defun DEF-MESSAGE (U) (CONS (FIRST U) (mapcar #'def-message1 (cdr u))))
+
+(defun DEF-MESSAGE1 (V)
+  (COND ((AND (STRINGP V) (> (SIZE V) 0) (NOT (EQ (ELT V 0) '\%)))
+         (LIST 'MAKESTRING V))
+        ((EQCAR V 'CONS) (LIST 'CONS (DEF-MESSAGE1 (SECOND V))
+                               (DEF-MESSAGE1 (THIRD V))))
+        ((DEFTRAN V))))
+
+(defun |DEF-:| (X &aux Y)
+       (DCQ (x y) x)
+       `(SPADLET ,(if (or (eq y '|fluid|)
+			  (and (identp x) (char= #\$ (ELT (PNAME X) 0))))
+		      `(FLUID ,X) X)
+		 NIL))
+
+(defmacro |DEF-::| (X)
+  (let ((expr (first x)) (type (second x)))
+    (if (EQUAL TYPE '(|Triple|)) EXPR (ERRHUH))))
+
+(defun DEF-COLLECT (L) (DEF-IT 'COLLECT (MAPCAR #'DEFTRAN (HACKFORIS L))))
+
+(defun DEF-REPEAT (L) (DEF-IT 'REPEAT (mapcar #'DEFTRAN (HACKFORIS L))))
+
+(defun HACKFORIS (L) (mapcar #'hackforis1 L))
+
+(defun HACKFORIS1 (X)
+  (if (AND (MEMBER (KAR X) '(IN ON)) (EQCAR (SECOND X) 'IS))
+      (CONS (FIRST X) (CONS (CONS 'SPADLET (CDADR X)) (CDDR X)))
+      X))
+
+(defun DEF-select (L)
+  (cond ((IDENTP (FIRST L)) (DEF-select1 (FIRST L) (SECOND L)))
+        ((LET* ((G (GENSYM))
+                (U (DEF-select1 G (SECOND L))))
+           (LIST 'PROGN (LIST 'SPADLET G (FIRST L)) U)))))
+
+(defun DEF-select1 (X Y)
+  (if (EQCAR Y 'SEQ)
+      (CONS 'COND (DEF-select2 X (CDR Y)))
+      (MOAN (format nil "Unexpected CASE body: ~S" Y))))
+
+(defun DEF-select2 (X Y)
+  (let (u v)
+    (COND ((NOT Y) (MOAN "Unexpected CASE clause termination"))
+          ((EQCAR (setq U (FIRST Y)) 'EXIT)
+           (LIST (LIST ''T (SECOND U))))
+          ((AND (EQCAR U 'COND) (NOT (CDDR U))
+                (EQCAR (SECOND (setq V (SECOND U))) 'EXIT))
+           (CONS (LIST (DEF-IS (LIST X (FIRST V))) (CADADR V))
+                 (DEF-select2 X (CDR Y))))
+          ((MOAN (format nil "Unexpected CASE clause: ~S" (FIRST Y)))))))
+
+(defun DEF-IT (FN L)
+  (setq L (reverse L))
+  (let ((B (first L)))
+    (let ((it (DEF-IN2ON (NREVERSE (rest L)))))
+      (let ((itp
+              (apply #'APPEND
+                     (mapcar
+                       #'(lambda (x &aux OP Y G)
+                           (if (AND (MEMBER (setq OP (FIRST X)) '(IN ON))
+                                    (NOT (ATOM (SECOND X))))
+                               (if (EQCAR (setq Y (SECOND X)) 'SPADLET)
+                                   (if (ATOM (setq G (SECOND Y)))
+                                       (LIST `(,OP ,G
+                                               ,(DEFTRAN (THIRD X)))
+                                             `(RESET
+                                                ,(DEF-LET
+                                                   (DEFTRAN
+                                                     (THIRD Y)) G)))
+                                       (ERRHUH))
+                                   (LIST
+                                     `(,OP ,(setq G (GENSYM))
+                                       ,(DEFTRAN (THIRD X)))
+                                     `(RESET
+                                        ,(DEF-LET (DEFTRAN (SECOND X))
+                                                  G))))
+                               `(,X)))
+                       IT))))
+        (CONS FN (NCONC ITP (LIST B)))))))
+
+(defun DEF-IN2ON (IT)
+  (mapcar #'(lambda (x) (let (u)
+              (COND
+                ((AND (EQCAR X 'IN) (EQCAR (THIRD X) '|tails|))
+                 (LIST 'ON (SECOND X) (SECOND (THIRD X))))
+                ((AND (EQCAR X 'IN) (EQCAR (setq U (THIRD X)) 'SEGMENT))
+                 (COND
+                   ((THIRD U) (LIST 'STEP (SECOND X) (SECOND U) 1 (THIRD U)))
+                   ((LIST 'STEP (SECOND X) (SECOND U) 1))  ))
+		((AND (EQCAR X 'INBY) (EQCAR (setq U (THIRD X)) 'SEGMENT))
+		 (COND
+                   ((THIRD U) (LIST 'STEP (SECOND X) (SECOND U) (|last| x) (THIRD U)))
+                   ((LIST 'STEP (SECOND X) (SECOND U) (|last| x)))  ))
+                (X))))
+          IT))
+
+(defun DEF-COND (L)
+  (COND ((NOT L) NIL)
+        ((CONS (MAPCAR #'DEFTRAN (FIRST L)) (DEF-COND (CDR L))))))
+
+(defun DEF-LET (FORM RHS)
+  (setq FORM (if (EQCAR FORM '\:) FORM (macroexpand FORM)))
+  (prog (F1 F2)
+   (COND ((EQCAR FORM '\:)
+          (SPADLET F1 (DEFTRAN FORM))
+          (SPADLET F2 (DEFTRAN (LIST 'SPADLET (CADR FORM) RHS)))
+          (COND ((AND (EQ (CAR F2) 'SPADLET) (EQUAL (CADR F2) (CADR FORM)))
+                  (RETURN (LIST 'SPADLET (CADR F1) (CADDR F2)) ))
+                ('T (RETURN (LIST 'PROGN F1 F2)) )) )
+        ((EQCAR FORM 'ELT) (RETURN
+           (DEFTRAN (LIST 'SETELT (CADR FORM) (CADDR FORM) RHS)) )))
+   (RETURN 
+     (COND (|$useDCQnotLET| (|defLETdcq| FORM (DEFTRAN RHS)))
+	   ('T            (|defLET| FORM (DEFTRAN RHS)))))))
+
+(defun |defLETdcq| (FORM RHS &AUX G NAME)
+  ;; see defLET in G-BOOT BOOT
+  (COND
+    ((IDENTP FORM) (LIST 'SPADLET FORM RHS))
+    ((IDENTP RHS)
+       (LIST 'COND (LIST (DEFTRAN (LIST 'IS RHS FORM)) RHS)
+                   (LIST ''T (LIST 'LET_ERROR (LIST 'MAKESTRING
+                                                    (MK_LEFORM FORM)) RHS))))
+    ((AND (EQ (CAR RHS) 'SPADLET) (IDENTP (SETQ NAME (CADR RHS)) ))
+       (SPADLET G (GENSYM))
+       (LIST 'COND (LIST (SUBST RHS G (DEFTRAN (LIST 'IS G FORM))) NAME)
+                   (LIST ''T (LIST 'LET_ERROR (LIST 'MAKESTRING
+                                                    (MK_LEFORM FORM)) NAME))))
+    ('T (SPADLET G (GENSYM))
+       (LIST 'COND (LIST (SUBST (LIST 'SPADLET G RHS) G
+                                (DEFTRAN (LIST 'IS G FORM))) G)
+                    (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)))
+
+(defun DEF-ISNT (X) (DEFTRAN (LIST 'NULL (CONS 'IS X))))
+
+(defparameter $IS-GENSYMLIST nil)
+
+(defparameter Initial-Gensym (list (gensym)))
+
+(defun DEF-IS (X)
+  (let (($IS-GENSYMLIST Initial-Gensym))
+    (DEF-IS2 (first X) (second x))))
+
+(defun IS-GENSYM ()
+  (if (NOT (CDR $IS-GENSYMLIST)) (RPLACD $IS-GENSYMLIST (LIST (GENSYM))))
+  (pop $IS-GENSYMLIST))
+
+(defparameter $IS-EQLIST nil)
+(defparameter $IS-SPILL_LIST nil)
+
+(defun DEF-IS2 (FORM STRUCT)
+  (let ($IS-EQLIST $IS-SPILL_LIST (FORM (DEFTRAN FORM)))
+    (if (EQCAR STRUCT '|Tuple|)
+        (MOAN "you must use square brackets around right arg. to" '%b "is" '%d))
+    (let* ((X (DEF-IS-EQLIST (DEF-IS-REMDUP STRUCT)))
+           (CODE (if (IDENTP X)
+                     (MKPF (SUBST FORM X $IS-EQLIST) 'AND)
+                     (MKPF `((DCQ ,X ,FORM) . ,$IS-EQLIST) 'AND))))
+      (let ((CODE (MKPF `(,CODE . ,$IS-SPILL_LIST) 'AND)))
+        (if $TRACELETFLAG
+            (let ((L (remove-if #'gensymp (listofatoms x))))
+              `(PROG1 ,CODE
+                      ,@(mapcar #'(lambda (y) `(/tracelet-print ,y ,y)) L)))
+            CODE)))))
+
+(defun DEF-STRING (X)
+ ;; following patches needed to fix reader bug in Lucid Common Lisp
+  (if (and (> (size x) 0) (or (char= (elt x 0) #\.) (char= (elt x 0) #\Page)))
+      `(INTERN ,X ,(package-name *PACKAGE*))
+      `(QUOTE ,(DEFTRAN (INTERN X)))))
+
+(defun DEF-IS-EQLIST (STR)
+  (let (g e)
+    (COND ((NOT STR) (PUSH `(EQ ,(setq G (IS-GENSYM)) NIL) $IS-EQLIST) G)
+          ((EQ STR '\.) (IS-GENSYM))
+          ((IDENTP STR) STR)
+          ((STRINGP STR)
+           (setq E (DEF-STRING STR))
+           (PUSH (LIST (if (ATOM (SECOND E)) 'EQ 'EQUAL)
+                       (setq G (IS-GENSYM)) E)
+                 $IS-EQLIST)
+           G)
+          ((OR (NUMBERP STR) (MEMBER STR '((|Zero|) (|One|))))
+           (PUSH (LIST 'EQ (setq G (IS-GENSYM)) STR) $IS-EQLIST)
+           G)
+          ((ATOM STR) (ERRHUH))
+          ((EQCAR STR 'SPADLET)
+           (COND ((IDENTP (SECOND STR))
+                  (PUSH (DEF-IS2 (cadr str) (caddr STR)) $IS-SPILL_LIST)
+                  (SECOND STR))
+                 ((IDENTP (THIRD STR))
+                  (PUSH (DEFTRAN STR) $IS-SPILL_LIST) (THIRD STR))
+                 ((ERRHUH)) ))
+          ((EQCAR STR 'QUOTE)
+           (PUSH (LIST (COND ((ATOM (SECOND STR)) 'EQ)
+                             ('EQUAL))
+                       (setq G (IS-GENSYM)) STR) $IS-EQLIST) G)
+          ((EQCAR STR 'LIST) (DEF-IS-EQLIST (LIST2CONS STR)))
+          ((OR (EQCAR STR 'CONS) (EQCAR STR 'VCONS))
+           (CONS (DEF-IS-EQLIST (SECOND STR)) (DEF-IS-EQLIST (THIRD STR))))
+          ((EQCAR STR 'APPEND)
+           (if (NOT (IDENTP (SECOND STR))) (ERROR "CANT!"))
+           (PUSH (DEF-IS2 (LIST 'REVERSE (setq G (IS-GENSYM)))
+                          (DEF-IS-REV (THIRD STR) (SECOND STR)))
+                 $IS-EQLIST)
+           (COND ((EQ (SECOND STR) '\.) ''T)
+                 ((PUSH (SUBST (SECOND STR) 'L '(OR (setq L (NREVERSE L)) T))
+
+                        $IS-SPILL_LIST)))
+           G)
+          ((ERRHUH)))))
+
+(defparameter $vl nil)
+
+(defun def-is-remdup (x) (let ($vl) (def-is-remdup1 x)))
+
+(defun def-is-remdup1 (x)
+  (let (rhs lhs g)
+    (COND ((NOT X) NIL)
+          ((EQ X '\.) X)
+          ((IDENTP X)
+           (COND ((MEMBER X $VL)
+                  (PUSH (LIST 'EQUAL (setq G (IS-GENSYM)) X) $IS-EQLIST) G)
+                 ((PUSH X $VL) X)))
+          ((MEMBER X '((|Zero|) (|One|))) X)
+          ((ATOM X) X)
+          ((EQCAR X 'SPADLET)
+           (setq RHS (DEF-IS-REMDUP1 (THIRD X)))
+           (setq LHS (DEF-IS-REMDUP1 (SECOND X)))
+           (LIST 'SPADLET LHS RHS))
+          ((EQCAR X 'LET)
+           (setq RHS (DEF-IS-REMDUP1 (THIRD X)))
+           (setq LHS (DEF-IS-REMDUP1 (SECOND X)))
+           (LIST 'LET LHS RHS))
+          ((EQCAR X 'QUOTE) X)
+          ((AND (EQCAR X 'EQUAL) (NOT (CDDR X)))
+           (PUSH (LIST 'EQUAL (setq G (IS-GENSYM)) (SECOND X)) $IS-EQLIST) G)
+          ((MEMBER (FIRST X) '(LIST APPEND CONS VCONS))
+           (CONS (COND ((EQ (FIRST X) 'VCONS) 'CONS) ( (FIRST X)))
+                 (mapcar #'def-is-remdup1 (cdr x))))
+          ((ERRHUH)))))
+
+(defun LIST2CONS (X)
+"Produces LISP code for constructing a list, involving only CONS."
+ (LIST2CONS-1 (CDR X)))
+
+(defun LIST2CONS-1 (X)
+  (if (NOT X) NIL (LIST 'CONS (FIRST X) (LIST2CONS-1 (CDR X)))))
+
+(defun DEF-IS-REV (X A)
+  (let (y)
+    (if (EQ (FIRST X) 'CONS)
+        (COND ((NOT (THIRD X)) (LIST 'CONS (SECOND X) A))
+              ((setq Y (DEF-IS-REV (THIRD X) NIL))
+               (setf (THIRD Y) (LIST 'CONS (SECOND X) A))
+               Y))
+        (ERRHUH))))
+
+(defparameter $DEFSTACK nil)
+
+(defun DEF-WHERE (args)
+  (let ((x (car args)) (y (cdr args)) $DEFSTACK)
+    (let ((u (DEF-WHERECLAUSELIST Y)))
+      (mapc #'(lambda (X) (DEF-INNER (FIRST X) NIL
+                              (SUBLIS $OPASSOC (SECOND X))))
+              $DEFSTACK)
+      (MKPROGN (NCONC U (LIST (DEFTRAN X)))))))
+
+(defun DEF-WHERECLAUSELIST (L)
+  (if (NOT (CDR L))
+      (DEF-WHERECLAUSE (DEFTRAN (FIRST L)))
+      (REDUCE #'APPEND
+              (mapcar #'(lambda (u) (def-whereclause (deftran u))) L))))
+
+(defun DEF-WHERECLAUSE (X)
+  (COND ((OR (EQCAR X 'SEQ) (EQCAR X 'PROGN))
+         (reduce #'append (mapcar #'def-whereclause (cdr x))))
+        ((EQCAR X 'DEF) (WHDEF (SECOND X) (FIRST (CDDDDR X))) NIL)
+        ((AND (EQCAR X '|exit|) (EQCAR (SECOND X) 'DEF))
+         (WHDEF (CADADR X) (FIRST (CDDDDR (SECOND X)) )) NIL)
+        ((LIST X))))
+
+(defun WHDEF (X Y)
+  "Returns no value -- side effect is to do a compilation or modify a global."
+  (prog ((XP (if (ATOM X) (LIST X) X)) Op)
+    (COND ((NOT (CDR XP))
+           (RETURN (PUSH (CONS (FIRST XP) Y) $MACROASSOC))))
+    (setq OP (INTERNL (PNAME $OP) "\," (FIRST XP)))
+    (SETQ $OPASSOC (PUSH (CONS (FIRST XP) OP) $OPASSOC))
+    (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)
+          (|aValue| 2)          (|aModeSet| 3)
+          (|aGeneral| 4)        (|expr| CAR)
+          (|mode| CADR)         (|env| CADDR)
+          (|mmDC| CAAR)         (|cacheName| CADR)
+          (|cacheType| CADDR)   (|cacheReset| CADDDR)
+          (|cacheCount| CADDDDR)(|mmSignature| CDAR)
+          (|mmTarget| CADAR)    (|mmCondition| CAADR)
+          (|mmImplementation| CADADR)
+          (|streamName| CADR)   (|streamDef| CADDR)
+          (|streamCode| CADDDR) (|opSig| CADR)
+          (|attributes| CADDR)  (|op| CAR)
+          (|opcode| CADR)       (|sig| CDDR)
+          (|source| CDR)        (|target| CAR)
+          (|first| CAR)         (|rest| CDR)))
+
+(defun DEF-ELT (args)
+  (let ((EXPR (car args)) (SEL (cadr args)))
+    (let (Y)
+      (COND ((and (symbolp sel) (setq Y (GET SEL 'SEL\,FUNCTION)))
+             (COND ((INTEGERP Y) (LIST 'ELT EXPR Y))
+                   ((LIST Y EXPR))))
+            ((LIST 'ELT EXPR SEL))))))
+
+(defun DEF-SETELT (args)
+  (let ((VAR (first args)) (SEL (second args)) (EXPR (third args)))
+    (let ((y (and (symbolp sel) (get sel 'sel\,function))))
+      (COND (y (COND ((INTEGERP Y) (LIST 'SETELT VAR Y EXPR))
+                     ((LIST 'RPLAC (LIST Y VAR) EXPR))))
+            ((LIST 'SETELT VAR SEL EXPR))))))
+
+(defun DEF-CATEGORY (L)
+  (let (siglist atlist)
+    (mapcar #'(lambda (x) (if (EQCAR (KADR X) 'Signature)
+                              (PUSH X SIGLIST)
+                              (PUSH X ATLIST)))
+            L)
+    (LIST 'CATEGORY (MKQ (NREVERSE SIGLIST)) (MKQ (NREVERSE ATLIST)))))
+
+
+(defun LIST2STRING (X)
+"Converts a list to a string which looks like a printed list,
+except that elements are separated by commas."
+  (COND ((ATOM X) (STRINGIMAGE X))
+        ((STRCONC "(" (LIST2STRING (FIRST X)) (LIST2STRING1 (CDR X)) ")"))))
+
+(defun LIST2STRING1 (X)
+  (COND
+    ((NOT X) "")
+    ((STRCONC "\," (LIST2STRING (FIRST X)) (LIST2STRING1 (CDR X))))))
+
+(defvar |$new2OldRenameAssoc|
+        '((\QUAD . \.) (\' . QUOTE) (|nil| . NIL) (|append| . APPEND)
+          (|union| . UNION) (|cons| . CONS)))
+
+(defun |new2OldLisp| (x) (|new2OldTran| (|postTransform| x)))
+
+(defun |new2OldTran| (x)
+  (PROG (G10463 a b G10465 G10466 G10467 G10469 d G10470 c)
+        (RETURN
+          (prog nil
+                (if (atom x)
+                    (RETURN (let ((y (ASSOC x |$new2OldRenameAssoc|)))
+                              (if y (cdr y) x))))
+                (if (AND (dcq (g10463 a b . g10465) x)
+                         (null G10465)
+                         (EQ G10463 '|where|)
+                         (dcq (g10466 . g10467) b)
+                         (dcq ((g10469 d . g10470) . c) (reverse g10467))
+                         (null G10470)
+                         (EQ G10469 '|exit|)
+                         (EQ G10466 'SEQ)
+                         (OR (setq c (NREVERSE c)) 'T))
+                    (RETURN
+                      `(|where| ,(|new2OldTran| a) ,@(|new2OldTran| c)
+                                ,(|new2OldTran| d))))
+                (return
+                  (case (car x)
+                      (QUOTE x)
+                      (DEF (|newDef2Def| x))
+                      (IF (|newIf2Cond| x))
+                      (|construct| (|newConstruct| (|new2OldTran| (cdr x))))
+                      (T `(,(|new2OldTran| (CAR x)) .
+                           ,(|new2OldTran| (CDR x))))))))))
+
+(defun |newDef2Def| (DEF-EXPR)
+  (if (not (AND (= (length def-expr) 5) (eq (car def-expr) 'DEF)))
+      (LET_ERROR "(DEF,form,a,b,c)" DEF-EXPR)
+      (let ((form (second def-expr))
+            (a (third def-expr))
+            (b (fourth def-expr))
+            (c (fifth def-expr)))
+        `(DEF ,(|new2OldDefForm|  form) ,(|new2OldTran| a)
+           ,(|new2OldTran| b) ,(|new2OldTran| c)))))
+
+(defun |new2OldDefForm| (x)
+  (cond ((ATOM x) (|new2OldTran| x))
+        ((and (listp x)
+              (listp (car x))
+              (eq (caar x) '|is|)
+              (= (length (car x)) 3))
+         (let ((a (second (car x))) (b (third (car x))) (y (cdr x)))
+              (|new2OldDefForm| `((SPADLET ,a ,b) ,@y))))
+        ((CONS (|new2OldTran| (CAR x)) (|new2OldDefForm| (CDR x))))))
+
+(defun |newIf2Cond| (COND-EXPR)
+       (if (not (AND (= (length cond-expr) 4) (EQ (car cond-expr) 'IF)))
+           (LET_ERROR "(IF,a,b,c)" COND-EXPR))
+       (let ((a (second COND-EXPR))
+             (b (third COND-EXPR))
+             (c (fourth COND-EXPR)))
+         (setq a (|new2OldTran| a) b (|new2OldTran| b) c (|new2OldTran| c))
+         (cond ((EQ c '|noBranch|) `(if ,a ,b))
+               (t  `(if ,a ,b ,c)))))
+
+(defun |newConstruct| (l)
+  (if (ATOM l) l
+      `(CONS  ,(CAR l) ,(|newConstruct| (CDR l)))))
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}