* Makefile.pamphlet (DEP): Adjust path to comp.lisp.

	(${DEPSYS}): Likewise for def.lisp, bootlex.lisp, postprop.lisp,
	metalex.lisp.  Use |compileLispFile| instead of COMPILE-FILE.
	* Makefile.in: Regenerate.
	* union.lisp: New.
	* union.lisp.pamphlet: Move content to union.lisp.  Remove.
	* obey.lisp: New.
	* obey.lisp.pamphlet: Move content to obey.lisp.  Remove.
	* nspadaux.lisp: New.
	* nspadaux.lisp.pamphlet: Move content to nspadaux.lisp.  Remove.
	* fname.lisp: New.
	* fname.lisp.pamphlet: Move content to fname.lisp.  Remove.
	* def.lisp: New.
	* def.lisp.pamphlet: Move content to def.lisp.  Remove.
	* comp.lisp: New.
	* comp.lisp.pamphlet: Move content to comp.lisp.  Remove.
	* bootlex.lisp: New.
	* bootlex.lisp.pamphlet: Move content to bootlex.lisp.  Remove.
	* postprop.lisp: New.
	* postprop.lisp.pamphlet: Move content to postprop.lisp.  Remove.
	* metalex.lisp: New.
	* metalex.lisp.pamphlet: Move content to metalex.lisp.  Remove.
	* parsing.lisp: New.
	* parsing.lisp.pamphlet: Move content to parsing.lisp. Remove.

1 files changed, 409 insertions, 0 deletions

diff --git a/src/interp/comp.lisp b/src/interp/comp.lisp
new file mode 100644
index 00000000..f46dc474
--- /dev/null
+++ b/src/interp/comp.lisp
@@ -0,0 +1,409 @@
+;; 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.
+
+
+; NAME:    Compiler Utilities Package
+
+; PURPOSE: Comp is a modified version of Compile which is a preprocessor for
+;          calls to Lisp Compile.  It searches for variable assignments that use
+;          (SPADLET a b). It allows you to create local variables without
+;          declaring them local by moving them into a PROG variable list.
+;          This is not an ordinary SPADLET.  It looks and is used like a SETQ.
+;          This preprocessor then collects the uses and creates the PROG.
+;
+;          SPADLET is defined in Macro.Lisp.
+;
+;          Comp recognizes as new lambda types the forms ILAM, SPADSLAM, SLAM,
+;          and entries on $clamList.  These cache results.  ("Saving LAMbda".)
+;          If the function is called with EQUAL arguments, returns the previous
+;          result computed.
+;
+;          The package also causes traced things which are recompiled to
+;          become untraced.
+
+(in-package "BOOT")
+
+(export '(Comp FluidVars LocVars OptionList SLAM SPADSLAM ILAM FLUID))
+
+;;; Common Block section
+
+(defparameter FluidVars nil)
+(defparameter LocVars nil)
+; (defparameter OptionList nil) defined in nlib.lisp
+(defparameter SpecialVars nil)
+
+(defun |compAndDefine| (L)
+  (let ((*comp370-apply* (function print-and-eval-defun)))
+    (declare (special *comp370-apply*))
+    (COMP L)))
+
+(defun COMP (L) (MAPCAR #'COMP-2 (MAPCAN #'COMP-1 L)))
+
+;;(defun |compQuietly| (L)
+;;  (let (U CUROUTSTREAM)
+;;    (declare (special CUROUTSTREAM))
+;;    (ADDOPTIONS 'LISTING NULLOUTSTREAM)                     
+;;    (SETQ CUROUTSTREAM NULLOUTSTREAM)                       
+;;    (setq U (COMP L))
+;;    (setq OPTIONLIST (CDDR OPTIONLIST))
+;;    U))
+
+(defun |compQuietly| (fn)
+  (let ((*comp370-apply*
+         (if |$InteractiveMode|
+             (if |$compileDontDefineFunctions| #'compile-defun #'eval-defun)
+           #'print-defun))
+     ;; following creates a null outputstream if $InteractiveMode
+        (*standard-output*
+         (if |$InteractiveMode| (make-broadcast-stream)
+           *standard-output*)))
+    (COMP fn)))
+
+#-:CCL
+(defun |compileFileQuietly| (fn) 
+  (let (
+     ;; following creates a null outputstream if $InteractiveMode
+        (*standard-output*
+         (if |$InteractiveMode| (make-broadcast-stream)
+           *standard-output*)))
+    (COMPILE-FILE fn)))
+
+#+:CCL
+(defun |compileFileQuietly| (fn)
+  (let (
+     ;; following creates a null outputstream if $InteractiveMode
+     (*standard-output*
+       (if |$InteractiveMode| (make-broadcast-stream) *standard-output*)))
+     ;; The output-library is not opened before use unless set explicitly
+     (if (null output-library)
+         (|openOutputLibrary| 
+           (setq |$outputLibraryName|
+            (if (null |$outputLibraryName|)
+                (make-pathname :directory (get-current-directory)
+                               :name "user.lib")
+                (if (filep |$outputLibraryName|) (truename |$outputLibraryName|)
+                                                 |$outputLibraryName|)))))
+     (compile-lib-file fn)))
+
+;; The following are used mainly in setvars.boot
+(defun notEqualLibs (u v)
+  (if (string= u (library-name v)) (seq (close-library v) t) nil))
+
+(defun |dropInputLibrary| (lib) 
+  ;; Close any existing copies of this library on the input path
+ (setq input-libraries
+  (delete lib input-libraries :test #'notEqualLibs )))
+
+(defun |openOutputLibrary| (lib)
+  (|dropInputLibrary| lib)
+  (setq output-library (open-library lib 't))
+  (setq input-libraries (cons output-library input-libraries)) )
+
+(defun |addInputLibrary| (lib)
+  (|dropInputLibrary| lib)
+   (setq input-libraries (cons (open-library lib) input-libraries)) )
+
+
+
+;;(defun |compileQuietly| (L) (PROG (U CUROUTSTREAM)
+;;  ;; calls lisp system COMPILE or DEFINE                  
+;;  (ADDOPTIONS 'QUIET 'T)                                  
+;;  (ADDOPTIONS 'LISTING NULLOUTSTREAM)                     
+;;  (SETQ CUROUTSTREAM NULLOUTSTREAM)                       
+;;  (SETQ U (COND                                           
+;;    (|$compileDontDefineFunctions| (COMPILE L))           
+;;    ('T (DEFINE L))))                                     
+;;  (SETQ OPTIONLIST (CDDR OPTIONLIST))                     
+;;  (RETURN U)   ))                                       
+
+(defun |compileQuietly| (fn)
+  (let ((*comp370-apply*
+         (if |$InteractiveMode|
+             (if |$compileDontDefineFunctions| #'compile-defun #'eval-defun)
+           #'print-defun))
+     ;; following creates a null outputstream if $InteractiveMode
+        (*standard-output*
+         (if |$InteractiveMode| (make-broadcast-stream)
+           *standard-output*)))
+    (COMP370 fn)))
+
+(defun COMP-1 (X)
+  (let* ((FNAME (car X))
+         ($FUNNAME FNAME)
+         ($FUNNAME_TAIL (LIST FNAME))
+         (LAMEX (second X))
+         ($closedfns nil))
+    (declare (special $FUNNAME $FUNNAME_TAIL $CLOSEDFNS))
+    (setq LAMEX (COMP-TRAN LAMEX))
+    (COMP-NEWNAM LAMEX)
+    (if (fboundp FNAME)
+        (format t "~&~%;;;     ***       ~S REDEFINED~%" FNAME))
+    (CONS (LIST FNAME LAMEX) $CLOSEDFNS)))
+
+(defun Comp-2 (args &aux name type argl bodyl junk)
+    (dsetq (NAME (TYPE ARGL . BODYL) . JUNK) args)
+    (cond (JUNK (MOAN (format nil "******pren error in (~S (~S ...) ...)" NAME TYPE)))
+          ((eq TYPE 'SLAM) (COMP-SLAM NAME ARGL BODYL))
+          ((LASSQ NAME |$clamList|) (|compClam| NAME ARGL BODYL |$clamList|))
+          ((eq TYPE 'SPADSLAM) (COMP-SPADSLAM NAME ARGL BODYL))
+          ((eq TYPE 'ILAM) (COMP-ILAM NAME ARGL BODYL))
+          ((setq BODYL (LIST NAME (CONS TYPE (CONS ARGL BODYL))))
+           (if |$PrettyPrint| (pprint bodyl))
+           (if (null $COMPILE) (SAY "No Compilation")
+               (COMP370 (LIST BODYL)))
+           NAME)))
+
+;; used to be called POSN - but that interfered with a CCL function
+(DEFUN POSN1 (X L) (position x l :test #'equal))
+
+(DEFUN COMP-ILAM (NAME ARGL BODYL)
+  (let* ((FARGL (NLIST (LENGTH ARGL) '(GENSYM)))
+         (BODYLP (SUBLISLIS FARGL ARGL BODYL)))
+        (MAKEPROP NAME 'ILAM T)
+        (SET NAME (CONS 'LAMBDA (CONS FARGL BODYLP)))
+        NAME))
+
+(DEFUN COMP-SPADSLAM (NAME ARGL BODYL)
+  (let* ((AL (INTERNL NAME ";AL"))
+         (AUXFN (INTERNL NAME ";"))
+         (G1 (GENSYM))
+         (G2 (GENSYM))
+         (U (COND ((NOT ARGL) (LIST NIL NIL (LIST AUXFN)))
+                  ((NOT (CDR ARGL))
+                   (LIST (LIST G1) (LIST '|devaluate| G1) (LIST AUXFN G1)))
+                  ((LIST G1
+                         (LIST '|devaluateList| G1)
+                         (LIST 'APPLY (LIST 'FUNCTION AUXFN) G1)))))
+         (ARG (first U))
+         (ARGTRAN (second U))
+         (APP (third U))
+         (LAMEX  `(lam ,ARG
+                       (let (,g2)
+                         (cond ,(COND (ARGL `((setq ,g2 (|assoc| ,argtran ,al))
+                                              (cdr ,g2)))
+                                      ((LIST AL)))
+                               ,(COND (ARGL
+                                       `(t(setq ,al(|cons5|(cons ,argtran
+                                                                 (setq ,g2 ,app))
+                                                           ,al))
+                                          ,g2))
+                                      (`(t (setq ,al ,app)))))))))
+    (setandfile AL NIL)
+    (setq U (LIST NAME LAMEX))
+    (if |$PrettyPrint| (PRETTYPRINT U))
+    (COMP370 (LIST U))
+    (setq U (LIST AUXFN (CONS 'LAMBDA (CONS ARGL BODYL))))
+    (COND (|$PrettyPrint| (PRETTYPRINT U)))
+    (COMP370 (LIST U))
+    NAME))
+
+(DEFUN COMP-SLAM (NAME ARGL BODYL)
+  (let* ((AL (INTERNL NAME ";AL"))
+         (AUXFN (INTERNL NAME ";"))
+         (G1 (GENSYM))
+         (G2 (GENSYM))
+         (U (COND ((NOT ARGL) `(nil (,auxfn)))
+                  ((NOT (CDR ARGL)) `((,g1)(,auxfn ,g1)))
+                  (`(,g1 (applx (function ,auxfn) ,g1)))))
+         (ARG (CAR U))
+         (APP (CADR U))
+         (LAMEX
+           (LIST 'LAM ARG
+                 (LIST 'PROG (LIST G2)
+                       (LIST 'RETURN
+                             (LIST 'COND
+                                   (COND (ARGL
+                                          `((setq ,G2 (|assoc| ,G1 ,AL))
+                                            (CDR ,G2)))
+                                         ((LIST AL)))
+                                   (COND (ARGL (LIST ''T `(setq ,G2 ,APP)
+                                                     (LIST 'SETQ AL
+                                                           `(CONS
+                                                              (CONS ,G1 ,G2) ,AL))
+                                                     G2))
+                                         ((LIST ''T `(setq ,AL ,APP))))))))))
+    (set AL NIL)
+    (setq U (LIST NAME LAMEX))
+    (if |$PrettyPrint| (PRETTYPRINT U))
+    (COMP370 (LIST U))
+    (setq U (LIST AUXFN (CONS 'LAMBDA (CONS ARGL BODYL))))
+    (if |$PrettyPrint| (PRETTYPRINT U))
+    (COMP370 (LIST U))
+    NAME))
+
+(DEFUN COMP-NEWNAM (X)
+  (let (y u)
+    (cond ((ATOM X) NIL)
+          ((ATOM (setq Y (CAR X)))
+          ;; (AND (IDENTP Y) (setq U (GET Y 'NEWNAM)) (RPLACA X U))
+           (AND (NOT (eq Y 'QUOTE)) (COMP-NEWNAM (CDR X)))
+           (WHEN (and (EQ Y 'CLOSEDFN) (boundp '$closedfns))
+                 (SETQ U (MAKE-CLOSEDFN-NAME))
+                 (PUSH (list U (CADR X)) $closedfns)
+                 (rplaca x 'FUNCTION)
+                 (rplaca (cdr x) u)))
+          (t (COMP-NEWNAM (CAR X)) (COMP-NEWNAM (CDR X))))))
+
+(defun make-closedfn-name ()
+  (internl $FUNNAME "!" (STRINGIMAGE (LENGTH $CLOSEDFNS))))
+
+(DEFUN COMP-TRAN (X)
+  "SEXPR<FN. BODY> -> SEXPR"
+  (let ((X (COMP-EXPAND X)) FluidVars LocVars SpecialVars)
+    (COMP-TRAN-1 (CDDR X))
+    (setq X (list (first x) (second x)
+                  (if (and (null (cdddr x))
+                           (or (atom (third x))
+                               (eq (car (third x)) 'SEQ)
+                               (not (contained 'EXIT (third x)))))
+                      (caddr x)
+                      (cons 'SEQ (cddr x))))) ;catch naked EXITs
+    (let* ((FluidVars (REMDUP (NREVERSE FLUIDVARS)))
+           (LOCVARS (S- (S- (REMDUP (NREVERSE LOCVARS)) FLUIDVARS)
+                        (LISTOFATOMS (CADR X))))
+           (LVARS (append fluidvars LOCVARS)))
+      (let ((fluids (S+ fluidvars SpecialVars)))
+        (setq x
+              (if fluids
+                  `(,(first x) ,(second x)
+                    (prog ,lvars (declare (special . ,fluids))
+                      (return ,(third x))))
+                  (list (first x) (second x)
+                     (if (or lvars (contained 'RETURN (third x)))
+                         `(prog ,lvars (return ,(third x)))
+                         (third x)) )))))
+    (let ((fluids (S+ (comp-fluidize (second x)) SpecialVars)))
+      (if fluids
+          `(,(first x) ,(second x) (declare (special . ,fluids)) . ,(cddr x))
+          `(,(first x) ,(second x) . ,(cddr x))))))
+
+; Fluidize: Returns a list of fluid variables in X
+
+(DEFUN COMP-FLUIDIZE (X)
+  (COND ((AND (symbolp X)
+              (NE X '$)
+              (NE X '$$)
+              (char= #\$ (ELT (PNAME X) 0))
+              (NOT (DIGITP (ELT (PNAME X) 1))))
+         x)
+        ((atom x) nil)
+        ((eq (first X) 'FLUID) (second X))
+        ((let ((a (comp-fluidize (first x)))
+               (b (comp-fluidize (rest x))))
+           (if a (cons a b) b)))))
+
+(DEFUN COMP\,FLUIDIZE  (X) (COND
+  ((AND (IDENTP X)
+        (NE X '$)
+        (NE X '$$)
+        (char= #\$ (ELT (PNAME X) 0)) (NULL (DIGITP (ELT (PNAME X) 1))))
+    (LIST 'FLUID X))
+  ((ATOM X) X)
+  ((EQ (QCAR X) 'FLUID) X)
+  ('T (PROG (A B)
+      (SETQ A (COMP\,FLUIDIZE (QCAR X)))
+      (SETQ B (COMP\,FLUIDIZE (QCDR X)))
+      (COND ((AND (EQ A (QCAR X)) (EQ B (QCDR X)))
+              (RETURN X))
+            ('T (RETURN (CONS A B)) )) )    )))
+
+; NOTE: It is potentially dangerous to assume every occurrence of element of
+; $COMP-MACROLIST is actually a macro call
+
+(defparameter $COMP-MACROLIST
+  '(COLLECT REPEAT SUCHTHATCLAUSE THETA COLLECTV COLLECTVEC
+            THETA1 SPADREDUCE SPADDO)
+  "???")
+
+(DEFUN COMP-EXPAND (X)
+  (COND ((atom x) x)
+        ((eq (CAR X) 'QUOTE) X)
+        ((memq (CAR X) $COMP-MACROLIST)
+         (comp-expand (macroexpand-1 x)))
+        ((let ((a (comp-expand (car x)))
+               (b (comp-expand (cdr x))))
+           (if (AND (eq A (CAR X)) (eq B (CDR X)))
+               x
+               (CONS A B))))))
+
+(DEFUN COMP-TRAN-1 (X)
+  (let (u)
+    (cond ((ATOM X) NIL)
+          ((eq (setq U (CAR X)) 'QUOTE) NIL)
+          ((AND (eq U 'MAKEPROP) $TRACELETFLAG (RPLAC (CAR X) 'MAKEPROP-SAY) NIL)
+           NIL)
+           ; temporarily make TRACELET cause MAKEPROPs to be reported
+          ((MEMQ U '(DCQ RELET PRELET SPADLET SETQ LET) )
+           (COND ((NOT (eq U 'DCQ))
+                  (COND ((OR (AND (eq $NEWSPAD T) (NOT $BOOT))
+                             (MEMQ $FUNNAME |$traceletFunctions|))
+                         (NCONC X $FUNNAME_TAIL)
+                         (RPLACA X 'LETT))
+                        ; this devious trick (due to RDJ) is needed since the compile
+                        ; looks only at global variables in top-level environment;
+                        ; thus SPADLET cannot itself test for such flags (7/83).
+                        ($TRACELETFLAG (RPLACA X '/TRACE-LET))
+                        ((eq U 'LET) (RPLACA X 'SPADLET)))))
+           (COMP-TRAN-1 (CDDR X))
+           (AND (NOT (MEMQ U '(setq RELET)))
+                (COND ((IDENTP (CADR X)) (PUSHLOCVAR (CADR X)))
+                      ((EQCAR (CADR X) 'FLUID)
+                       (PUSH (CADADR X) FLUIDVARS)
+                       (RPLAC (CADR X) (CADADR X)))
+                      ((mapc #'pushlocvar (listofatoms (cadr x))) nil))))
+          ((and (symbolp u) (GET U 'ILAM))
+           (RPLACA X (EVAL U)) (COMP-TRAN-1 X))
+          ((MEMQ U '(PROG LAMBDA))
+           (PROG (NEWBINDINGS RES)
+                 (setq NEWBINDINGS NIL)
+                 (mapcar #'(lambda (Y)
+                             (COND ((NOT (MEMQ Y LOCVARS))
+                                    (setq LOCVARS (CONS Y LOCVARS))
+                                    (setq NEWBINDINGS (CONS Y NEWBINDINGS)))))
+                         (second x))
+                 (setq RES (COMP-TRAN-1 (CDDR X)))
+                 (setq locvars (remove-if #'(lambda (y) (memq y newbindings))
+                                          locvars))
+                 (RETURN (CONS U (CONS (CADR X) RES)) )) )
+          ((PROGN (COMP-TRAN-1 U) (COMP-TRAN-1 (CDR X)))))))
+
+(DEFUN PUSHLOCVAR (X)
+  (let (p)
+    (cond ((AND (NE X '$)
+                (char= #\$ (ELT (setq P (PNAME X)) 0))
+                (NOT (char= #\, (ELT P 1)))
+                (NOT (DIGITP (ELT P 1)))) NIL)
+          ((PUSH X LOCVARS)))))
+
+(defmacro PRELET (L) `(spadlet . ,L))
+(defmacro RELET (L) `(spadlet . ,L))
+(defmacro PRESET (L) `(spadlet . ,L))
+(defmacro RESET (L) `(spadlet . ,L))