diff options
Diffstat (limited to 'src/interp/comp.lisp')
| -rw-r--r-- | src/interp/comp.lisp | 409 |
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)) |