diff --git a/changelog b/changelog index 600b39f..fbf66fa 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,8 @@ +20090806 tpd src/axiom-website/patches.html 20090807.01.tpd.patch +20090806 tpd src/interp/Makefile remove comp.lisp +20090806 tpd src/interp/comp.lisp remove macros reference +20090806 tpd src/interp/vmlisp.lisp merge comp.lisp +20090806 tpd src/interp/comp.lisp removed, merged with vmlisp.lisp 20090806 tpd src/axiom-website/patches.html 20090806.01.tpd.patch 20090806 tpd src/interp/Makefile remove macros.lisp 20090806 tpd src/interp/debugsys.lisp remove macros reference diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index a9f4901..23d5292 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1750,6 +1750,8 @@ vmlisp.lisp and union.lisp merged
vmlisp.lisp and nlib.lisp merged
20090806.01.tpd.patch vmlisp.lisp and macros.lisp merged
+20090807.01.tpd.patch +vmlisp.lisp and comp.lisp merged
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 3777415..79cb8c4 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -128,7 +128,6 @@ expanded in later compiles. All macros are assumed to be in this list of files. <>= DEP= ${MID}/vmlisp.lisp \ - ${MID}/comp.lisp \ ${MID}/spaderror.lisp ${MID}/debug.lisp \ ${MID}/spad.lisp ${MID}/bits.lisp \ ${MID}/setq.lisp ${MID}/property.lisp \ @@ -182,7 +181,6 @@ OBJS= ${OUT}/vmlisp.${O} \ ${OUT}/cattable.${O} \ ${OUT}/cformat.${O} ${OUT}/cfuns.${O} \ ${OUT}/clam.${O} ${OUT}/clammed.${O} \ - ${OUT}/comp.${O} \ ${OUT}/compat.${O} ${OUT}/compress.${O} \ ${OUT}/cparse.${O} ${OUT}/cstream.${O} \ ${OUT}/database.${O} \ @@ -428,7 +426,7 @@ DOCFILES=${DOC}/alql.boot.dvi \ ${DOC}/c-doc.boot.dvi ${DOC}/cformat.boot.dvi \ ${DOC}/cfuns.lisp.dvi ${DOC}/clam.boot.dvi \ ${DOC}/clammed.boot.dvi ${DOC}/compat.boot.dvi \ - ${DOC}/compiler.boot.dvi ${DOC}/comp.lisp.dvi \ + ${DOC}/compiler.boot.dvi \ ${DOC}/compress.boot.dvi \ ${DOC}/cparse.boot.dvi ${DOC}/cstream.boot.dvi \ ${DOC}/c-util.boot.dvi ${DOC}/daase.lisp.dvi \ @@ -982,40 +980,6 @@ ${DOC}/cfuns.lisp.dvi: ${IN}/cfuns.lisp.pamphlet @ -\subsection{comp.lisp \cite{11}} -<>= -${OUT}/comp.${O}: ${MID}/comp.lisp - @ echo 27 making ${OUT}/comp.${O} from ${MID}/comp.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/comp.lisp"' \ - ':output-file "${OUT}/comp.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/comp.lisp"' \ - ':output-file "${OUT}/comp.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${MID}/comp.lisp: ${IN}/comp.lisp.pamphlet - @ echo 28 making ${MID}/comp.lisp from ${IN}/comp.lisp.pamphlet - @ (cd ${MID} ; \ - ${TANGLE} ${IN}/comp.lisp.pamphlet >comp.lisp ) - -@ -<>= -${DOC}/comp.lisp.dvi: ${IN}/comp.lisp.pamphlet - @echo 29 making ${DOC}/comp.lisp.dvi from ${IN}/comp.lisp.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/comp.lisp.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} comp.lisp ; \ - rm -f ${DOC}/comp.lisp.pamphlet ; \ - rm -f ${DOC}/comp.lisp.tex ; \ - rm -f ${DOC}/comp.lisp ) - -@ - \subsection{construc.lisp \cite{12}} <>= ${OUT}/construc.${O}: ${MID}/construc.lisp @@ -7245,10 +7209,6 @@ clean: <> <> -<> -<> -<> - <> <> <> @@ -7816,7 +7776,6 @@ pp \bibitem{6} {\bf www.aldor.org} \bibitem{8} {\bf \$SPAD/src/interp/bits.lisp.pamphlet} \bibitem{10} {\bf \$SPAD/src/interp/cfuns.lisp.pamphlet} -\bibitem{11} {\bf \$SPAD/src/interp/comp.lisp.pamphlet} \bibitem{12} {\bf \$SPAD/src/interp/construc.lisp.pamphlet} \bibitem{13} {\bf \$SPAD/src/interp/daase.lisp.pamphlet} \bibitem{14} {\bf \$SPAD/src/interp/debug.lisp.pamphlet} diff --git a/src/interp/comp.lisp.pamphlet b/src/interp/comp.lisp.pamphlet deleted file mode 100644 index 9e9deed..0000000 --- a/src/interp/comp.lisp.pamphlet +++ /dev/null @@ -1,382 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp comp.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{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. - -@ -<<*>>= -<> - -; 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 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| (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))) - -;; 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| (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 -> 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)) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/debugsys.lisp.pamphlet b/src/interp/debugsys.lisp.pamphlet index 36574dd..a6e17d0 100644 --- a/src/interp/debugsys.lisp.pamphlet +++ b/src/interp/debugsys.lisp.pamphlet @@ -96,7 +96,6 @@ loaded by hand we need to establish a value. (thesymb (concatenate 'string "/obj/" *sys* "/interp/cfuns.o")) (thesymb "/int/interp/clam.clisp") (thesymb "/int/interp/clammed.clisp") - (thesymb "/int/interp/comp.lisp") (thesymb "/int/interp/compat.clisp") (thesymb "/int/interp/compress.clisp") (thesymb "/int/interp/cparse.clisp") diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet index 4324b22..6759138 100644 --- a/src/interp/vmlisp.lisp.pamphlet +++ b/src/interp/vmlisp.lisp.pamphlet @@ -4817,6 +4817,333 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size ('t (hput ht key n)) ) nil)) +; 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. + +(export '(Comp FluidVars LocVars OptionList SLAM SPADSLAM ILAM FLUID)) + +;;; Common Block section + +(defparameter FluidVars nil) +(defparameter LocVars nil) +(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| (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))) + +;; 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| (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 -> 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)) + @ \eject \begin{thebibliography}{99}