diff options
Diffstat (limited to 'src/interp/comp.lisp')
| -rw-r--r-- | src/interp/comp.lisp | 102 |
1 files changed, 0 insertions, 102 deletions
diff --git a/src/interp/comp.lisp b/src/interp/comp.lisp index 46499b85..ad6b6520 100644 --- a/src/interp/comp.lisp +++ b/src/interp/comp.lisp @@ -58,13 +58,6 @@ ;;; Common Block section -(defparameter FluidVars nil) -(defparameter LocVars nil) -; (defparameter OptionList nil) defined in nlib.lisp -(defparameter SpecialVars nil) - -(defvar $closedfns nil) - ;; The following are used mainly in setvars.boot (defun notEqualLibs (u v) (if (string= u (library-name v)) (seq (close-library v) t) nil)) @@ -86,52 +79,6 @@ ;; used to be called POSN - but that interfered with a CCL function (DEFUN POSN1 (X L) (position x l :test #'equal)) -(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 (|middleEndExpand| 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+ (|backendFluidize| (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 @@ -149,55 +96,6 @@ (RETURN X)) ('T (RETURN (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)) - (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)) |