From fa667bf64cfac55a9d34245f286cc5058c6860d0 Mon Sep 17 00:00:00 2001 From: Lars Brinkhoff Date: Mon, 26 Mar 2018 18:18:42 +0200 Subject: [PATCH] RABBIT Scheme compiler, latest MIT version 570 dated June 30 1980. This version was found in ALAN. Version 569 in QUUX has timestamp May 17 1978. --- src/alan/rabbit.570 | 3739 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 3739 insertions(+) create mode 100755 src/alan/rabbit.570 diff --git a/src/alan/rabbit.570 b/src/alan/rabbit.570 new file mode 100755 index 00000000..ff3deb63 --- /dev/null +++ b/src/alan/rabbit.570 @@ -0,0 +1,3739 @@ +;;; RABBIT COMPILER -*-LISP-*- + +(DECLARE (FASLOAD (QUUX) SCHMAC)) +(DECLARE (MACROS T) (NEWIO T)) +(DECLARE (ALLOC '(LIST (300000 450000 .2) FIXNUM 50000 SYMBOL 24000))) +(DECLARE (DEFUN DISPLACE (X Y) Y)) + +(DECLARE (SPECIAL EMPTY TRIVFN GENTEMP GENFLUSH GEN-GLOBAL-NAME PRINT-WARNING ADDPROP DELPROP SETPROP + ADJOIN UNION INTERSECT REMOVE SETDIFF PAIRLIS COMPILE PASS1-ANALYZE TEST-COMPILE + NODIFY ALPHATIZE ALPHA-ATOM ALPHA-LAMBDA ALPHA-IF ALPHA-ASET ALPHA-CATCH + ALPHA-LABELS ALPHA-LABELS-DEFN ALPHA-BLOCK MACRO-EXPAND ALPHA-COMBINATION + ENV-ANALYZE TRIV-ANALYZE TRIV-ANALYZE-FN-P EFFS-ANALYZE EFFS-UNION EFFS-ANALYZE-IF + EFFS-ANALYZE-COMBINATION CHECK-COMBINATION-PEFFS ERASE-NODES META-EVALUATE + META-IF-FUDGE META-COMBINATION-TRIVFN META-COMBINATION-LAMBDA SUBST-CANDIDATE + REANALYZE1 EFFS-INTERSECT EFFECTLESS EFFECTLESS-EXCEPT-CONS PASSABLE + META-SUBSTITUTE COPY-CODE COPY-NODES CNODIFY CONVERT MAKE-RETURN CONVERT-LAMBDA-FM + CONVERT-IF CONVERT-ASET CONVERT-CATCH CONVERT-LABELS CONVERT-COMBINATION + CENV-ANALYZE CENV-TRIV-ANALYZE CENV-CCOMBINATION-ANALYZE BIND-ANALYZE REFD-VARS + BIND-ANALYZE-CLAMBDA BIND-ANALYZE-CONTINUATION BIND-ANALYZE-CIF BIND-ANALYZE-CASET + BIND-ANALYZE-CLABELS BIND-ANALYZE-RETURN BIND-ANALYZE-CCOMBINATION + BIND-CCOMBINATION-ANALYZE DEPTH-ANALYZE FILTER-CLOSEREFS CLOSE-ANALYZE COMPILATE + DEPROGNIFY1 TEMPLOC ENVCARCDR REGSLIST SET-UP-ASETVARS COMP-BODY PRODUCE-IF + PRODUCE-ASET PRODUCE-LABELS PRODUCE-LAMBDA-COMBINATION PRODUCE-TRIVFN-COMBINATION + PRODUCE-TRIVFN-COMBINATION-CONTINUATION PRODUCE-TRIVFN-COMBINATION-CVARIABLE + PRODUCE-COMBINATION PRODUCE-COMBINATION-VARIABLE ADJUST-KNOWNFN-CENV + PRODUCE-CONTINUATION-RETURN PRODUCE-RETURN PRODUCE-RETURN-1 LAMBDACATE PSETQIFY + PSETQIFY-METHOD-2 PSETQIFY-METHOD-3 PSETQ-ARGS PSETQ-ARGS-ENV PSETQ-TEMPS + MAPANALYZE ANALYZE ANALYZE-CLAMBDA ANALYZE-CONTINUATION ANALYZE-CIF ANALYZE-CLABELS + ANALYZE-CCOMBINATION ANALYZE-RETURN LOOKUPICATE CONS-CLOSEREFS OUTPUT-ASET + CONDICATE DECARCDRATE TRIVIALIZE TRIV-LAMBDACATE COMPILATE-ONE-FUNCTION + COMPILATE-LOOP USED-TEMPLOCS REMARK-ON MAP-USER-NAMES COMFILE TRANSDUCE + PROCESS-FORM PROCESS-DEFINE-FORM PROCESS-DEFINITION CLEANUP SEXPRFY CSEXPRFY + CHECK-NUMBER-OF-ARGS DUMPIT STATS RESET-STATS INIT-RABBIT)) + +(DECLARE (SPECIAL *EMPTY* *GENTEMPNUM* *GENTEMPLIST* *GLOBAL-GEN-PREFIX* *ERROR-COUNT* *ERROR-LIST* + *TEST* *TESTING* *OPTIMIZE* *REANALYZE* *SUBSTITUTE* *FUDGE* *NEW-FUDGE* + *SINGLE-SUBST* *LAMBDA-SUBST* *FLUSH-ARGS* *STAT-VARS* *DEAD-COUNT* *FUDGE-COUNT* + *FOLD-COUNT* *FLUSH-COUNT* *CONVERT-COUNT* *SUBST-COUNT* *DEPROGNIFY-COUNT* + *LAMBDA-BODY-SUBST* *LAMBDA-BODY-SUBST-TRY-COUNT* *LAMBDA-BODY-SUBST-SUCCESS-COUNT* + *CHECK-PEFFS* **CONT+ARG-REGS** **ENV+CONT+ARG-REGS** **ARGUMENT-REGISTERS** + **NUMBER-OF-ARG-REGS** *BUFFER-RANDOM-FORMS* *DISPLACE-SW*)) + +(PROCLAIM (*EXPR PRINT-SHORT) + (SET' *BUFFER-RANDOM-FORMS* NIL) + (ALLOC '(LIST (240000 340000 1000) FIXNUM (30000 40000 1000) + SYMBOL (14000 24000 NIL) HUNK4 (20000 53000 NIL) + HUNK8 (20000 50000 NIL) HUNK16 (20000 60000 NIL)))) + +(SET' *STAT-VARS* '(*DEAD-COUNT* *FUDGE-COUNT* *FOLD-COUNT* *FLUSH-COUNT* *CONVERT-COUNT* + *SUBST-COUNT* *DEPROGNIFY-COUNT* *LAMBDA-BODY-SUBST-TRY-COUNT* + *LAMBDA-BODY-SUBST-SUCCESS-COUNT*)) + +(ALLOC '(LIST (240000 340000 1000) FIXNUM (30000 40000 1000) + SYMBOL (14000 24000 NIL) HUNK4 (20000 50000 NIL) + HUNK8 (20000 50000 NIL) HUNK16 (20000 70000 NIL))) + +(APPLY 'GCTWA '(T)) ;GC USELESS ATOMS (CAN'T SAY (EVAL' (GCTWA T)) BECAUSE OF NCOMPLR) +(REPLACE) ;UNDO ANY DISPLACED MACROS +(SET' *DISPLACE-SW* NIL) ;DON'T LET MACROS SELF-DISPLACE +(GRINDEF) ;LOAD THE GRINDER (PRETTY-PRINTER) + +(DECLARE (/@DEFINE DEFINE |SCHEME FUNCTION|)) ;DECLARATIONS FOR LISTING PROGRAM +(DECLARE (/@DEFINE DEFMAC |MACLISP MACRO|)) +(DECLARE (/@DEFINE SCHMAC |PDP-10 SCHEME MACRO|)) +(DECLARE (/@DEFINE MACRO |SCHEME MACRO|)) + +(COND ((NOT (BOUNDP '*EMPTY*)) + (SET' *EMPTY* (LIST '*EMPTY*)))) + +(DEFINE EMPTY + (LAMBDA (X) (EQ X *EMPTY*))) + + +(DEFINE TRIVFN + (LAMBDA (SYM) + (GETL SYM '(EXPR SUBR LSUBR *EXPR *LEXPR)))) + + +(DEFMAC INCREMENT (X) `(ASET' ,X (+ ,X 1))) + +(DEFMAC CATENATE ARGS + `(IMPLODE (APPEND ,@(MAPCAR '(LAMBDA (X) + (COND ((OR (ATOM X) (NOT (EQ (CAR X) 'QUOTE))) + `(EXPLODEN ,X)) + (T `(QUOTE ,(EXPLODEN (CADR X)))))) + ARGS)))) + + +(COND ((NOT (BOUNDP '*GENTEMPNUM*)) + (SET' *GENTEMPNUM* 0))) + +(COND ((NOT (BOUNDP '*GENTEMPLIST*)) + (SET' *GENTEMPLIST* NIL))) + +(DEFINE GENTEMP + (LAMBDA (X) + (BLOCK (INCREMENT *GENTEMPNUM*) + (LET ((SYM (CATENATE X '|-| *GENTEMPNUM*))) + (ASET' *GENTEMPLIST* (CONS SYM *GENTEMPLIST*)) SYM)))) + +(DEFINE GENFLUSH + (LAMBDA () + (BLOCK (AMAPC REMOB *GENTEMPLIST*) + (ASET' *GENTEMPLIST* NIL)))) + +(DEFINE GEN-GLOBAL-NAME + (LAMBDA () (GENTEMP *GLOBAL-GEN-PREFIX*))) + +(SET' *GLOBAL-GEN-PREFIX* '|?|) + +(DEFMAC WARN (MSG . STUFF) + `(PRINT-WARNING ',MSG (LIST ,@STUFF))) + +(DEFINE PRINT-WARNING + (LAMBDA (MSG STUFF) + (BLOCK (INCREMENT *ERROR-COUNT*) + (ASET' *ERROR-LIST* (CONS (CONS MSG STUFF) *ERROR-LIST*)) + (TYO 7 (SYMEVAL 'TYO)) ;BELL + (TERPRI (SYMEVAL 'TYO)) + (PRINC '|;Warning: | (SYMEVAL 'TYO)) + (TYO 7 (SYMEVAL 'TYO)) ;BELL + (PRINC MSG (SYMEVAL 'TYO)) + (AMAPC PRINT-SHORT STUFF)))) + +(DEFUN PRINT-SHORT (X) + ((LAMBDA (PRINLEVEL PRINLENGTH TERPRI) + (TERPRI (SYMEVAL 'TYO)) + (PRINC '|; | (SYMEVAL 'TYO)) + (PRIN1 X (SYMEVAL 'TYO))) + 3 8 T)) + + +(SCHMAC ASK (MSG) + `(BLOCK (TERPRI) (PRINC ',MSG) (TYO 40) (READ))) + + +(DEFMAC SX (X) `(SPRINTER (SEXPRFY ,X NIL))) ;DEBUGGING AID +(DEFMAC CSX (X) `(SPRINTER (CSEXPRFY ,X))) ;DEBUGGING AID + + +(DEFMAC EQCASE (OBJ . CASES) + `(COND ,@(MAPCAR '(LAMBDA (CASE) + (OR (ATOM (CAR CASE)) + (ERROR '|Losing EQCASE clause|)) + `((EQ ,OBJ ',(CAR CASE)) ,@(CDR CASE))) + CASES) + (T (ERROR '|Losing EQCASE| ,OBJ 'FAIL-ACT)))) + +(DECLARE (/@DEFINE ACCESSFN |ACCESS MACRO|)) + +(DEFMAC ACCESSFN (NAME UVARS FETCH . PUT) + ((LAMBDA (VARS CNAME) + (DO ((A VARS (CDR A)) + (B '*Z* `(CDR ,B)) + (C NIL (CONS `(CAR ,B) C))) + ((NULL A) + `(PROGN 'COMPILE + (DEFMAC ,NAME *Z* + ((LAMBDA ,(NREVERSE (CDR (REVERSE VARS))) + ,FETCH) + ,@(REVERSE (CDR C)))) + (DEFMAC ,CNAME *Z* + ((LAMBDA ,VARS + ,(COND (PUT (CAR PUT)) + (T ``(CLOBBER ,,FETCH + ,THE-NEW-VALUE)))) + ,@(REVERSE C))))))) + (COND (PUT UVARS) + (T (APPEND UVARS '(THE-NEW-VALUE)))) + (CATENATE '|CLOBBER-| NAME))) + +(DEFMAC CLOBBER (X Y) + `(,(CATENATE '|CLOBBER-| (CAR X)) ,@(CDR X) ,Y)) + +(DECLARE (/@DEFINE HUNKFN |HUNK ACCESS MACRO|)) + +(DEFMAC HUNKFN (NAME SLOT) + `(ACCESSFN ,NAME (THE-HUNK NEW-VALUE) + `(CXR ,,SLOT ,THE-HUNK) + `(RPLACX ,,SLOT ,THE-HUNK ,NEW-VALUE))) + +(DECLARE (/@DEFINE DEFTYPE |DATA TYPE|)) + +;;; SLOT 0 IS ALWAYS THE PROPERTY LIST, AND SLOT 1 THE HUNK TYPE. + +(HUNKFN TYPE 1) + +(DEFMAC DEFTYPE (NAME SLOTS SUPP) + `(PROGN 'COMPILE + (DEFMAC ,(CATENATE '|CONS-| NAME) KWDS + (PROGN (DO ((K KWDS (CDR K))) + ((NULL K)) + (OR ,(COND ((CDR SLOTS) `(MEMQ (CAAR K) ',SLOTS)) + (T `(EQ (CAAR K) ',(CAR SLOTS)))) + (ERROR ',(CATENATE '|Invalid Keyword Argument to CONS-| + NAME) + (CAR K) + 'FAIL-ACT))) + `(HUNK ',',NAME + ,@(DO ((S ',SLOTS (CDR S)) + (X NIL + (CONS ((LAMBDA (KWD) + (COND (KWD (CAR (LAST KWD))) + (T '*EMPTY*))) + (ASSQ (CAR S) KWDS)) + X))) + ((NULL S) (NREVERSE X))) + NIL))) + (DEFMAC ,(CATENATE '|ALTER-| NAME) (OBJ . KWDS) + (PROGN (DO ((K KWDS (CDR K))) + ((NULL K)) + (OR ,(COND ((CDR SLOTS) `(MEMQ (CAAR K) ',SLOTS)) + (T `(EQ (CAAR K) ',(CAR SLOTS)))) + (ERROR ',(CATENATE '|Invalid Keyword Argument to ALTER-| + NAME) + (CAR K) + 'FAIL-ACT))) + (DO ((I (+ (LENGTH KWDS) 1) (- I 1)) + (VARS NIL (CONS (GENSYM) VARS))) + ((= I 0) + `((LAMBDA ,VARS + ,(BLOCKIFY + (MAPCAR '(LAMBDA (K V) + `(CLOBBER (,(CATENATE ',NAME + '|\| + (CAR K)) + (,(CAR VARS))) + (,V))) + KWDS + (CDR VARS)))) + (LAMBDA () ,OBJ) + ,@(MAPCAR '(LAMBDA (K) `(LAMBDA () ,(CAR (LAST K)))) + KWDS)))))) + ,@(DO ((S SLOTS (CDR S)) + (N 2 (+ N 1)) + (X NIL (CONS `(HUNKFN ,(CATENATE NAME '|\| (CAR S)) + ,N) + X))) + ((NULL S) (NREVERSE X))) + (DEFPROP ,NAME ,SLOTS COMPONENT-NAMES) + (DEFPROP ,NAME ,SUPP SUPPRESSED-COMPONENT-NAMES) + '(TYPE ,NAME DEFINED))) + +;;; ADD TO A PROPERTY WHICH IS A LIST OF THINGS + +(DEFINE ADDPROP + (LAMBDA (SYM VAL PROP) + (LET ((L (GET SYM PROP))) + (IF (NOT (MEMQ VAL L)) + (PUTPROP SYM (CONS VAL L) PROP))))) + +;;; INVERSE OF ADDPROP + +(DEFINE DELPROP + (LAMBDA (SYM VAL PROP) + (PUTPROP SYM (DELQ VAL (GET SYM PROP)) PROP))) + +;;; LIKE PUTPROP, BUT INSIST ON NOT CHANGING A VALUE ALREADY THERE + +(DEFINE SETPROP + (LAMBDA (SYM VAL PROP) + (LET ((L (GETL SYM (LIST PROP)))) + (IF (AND L (NOT (EQ VAL (CADR L)))) + (ERROR '|Attempt to redefine a unique property| + (LIST 'SETPROP SYM VAL PROP) + 'FAIL-ACT) + (PUTPROP SYM VAL PROP))))) + +;;; OPERATIONS ON SETS, REPRESENTED AS LISTS + +(DEFINE ADJOIN + (LAMBDA (X S) + (IF (MEMQ X S) S (CONS X S)))) + +(DEFINE UNION + (LAMBDA (X Y) + (DO ((Z Y (CDR Z)) + (V X (ADJOIN (CAR Z) V))) + ((NULL Z) V)))) + +(DEFINE INTERSECT + (LAMBDA (X Y) + (IF (NULL X) + NIL + (IF (MEMQ (CAR X) Y) + (CONS (CAR X) (INTERSECT (CDR X) Y)) + (INTERSECT (CDR X) Y))))) + +(DEFINE REMOVE + (LAMBDA (X S) + (IF (NULL S) + S + (IF (EQ X (CAR S)) + (CDR S) + ((LAMBDA (Y) + (IF (EQ Y (CDR S)) S + (CONS (CAR S) Y))) + (REMOVE X (CDR S))))))) + +(DEFINE SETDIFF + (LAMBDA (X Y) + (DO ((Z X (CDR Z)) + (W NIL (IF (MEMQ (CAR Z) Y) + W + (CONS (CAR Z) W)))) + ((NULL Z) W)))) + +(DEFINE PAIRLIS + (LAMBDA (L1 L2 L) + (DO ((V L1 (CDR V)) + (U L2 (CDR U)) + (E L (CONS (LIST (CAR V) (CAR U)) E))) + ((NULL V) E)))) + + +(DEFINE COMPILE + (LAMBDA (NAME LAMBDA-EXP SEE-CRUD OPTIMIZE) + (BLOCK (CHECK-NUMBER-OF-ARGS NAME + (LENGTH (CADR LAMBDA-EXP)) + T) + (LET ((ALPHA-VERSION (ALPHATIZE LAMBDA-EXP NIL))) + (IF (AND SEE-CRUD (ASK |See alpha-conversion?|)) + (SX ALPHA-VERSION)) + (LET ((OPT (IF (EQ OPTIMIZE 'MAYBE) + (ASK |Optimize?|) + OPTIMIZE))) + (LET ((META-VERSION + (IF OPT + (META-EVALUATE ALPHA-VERSION) + (PASS1-ANALYZE ALPHA-VERSION NIL NIL)))) + (OR (AND (NULL (NODE\REFS META-VERSION)) + (NULL (NODE\ASETS META-VERSION))) + (ERROR '|ENV-ANALYZE lost - COMPILE| + NAME + 'FAIL-ACT)) + (IF (AND SEE-CRUD OPT (ASK |See meta-evaluation?|)) + (SX META-VERSION)) + (LET ((CPS-VERSION (CONVERT META-VERSION NIL (NOT (NULL OPT))))) + (IF (AND SEE-CRUD (ASK |See CPS-conversion?|)) + (CSX CPS-VERSION)) + (CENV-ANALYZE CPS-VERSION NIL NIL) + (BIND-ANALYZE CPS-VERSION NIL NIL) + (DEPTH-ANALYZE CPS-VERSION 0) + (CLOSE-ANALYZE CPS-VERSION NIL) + (COMPILATE-ONE-FUNCTION CPS-VERSION NAME)))))))) + +(DEFINE PASS1-ANALYZE + (LAMBDA (NODE REDO OPT) + (BLOCK (ENV-ANALYZE NODE REDO) + (TRIV-ANALYZE NODE REDO) + (IF OPT (EFFS-ANALYZE NODE REDO)) + NODE))) + + +(SCHMAC CL (FNNAME) `(TEST-COMPILE ',FNNAME)) + +(DEFINE TEST-COMPILE + (LAMBDA (FNNAME) + (LET ((FN (GET FNNAME 'SCHEME!FUNCTION))) + (COND (FN (ASET' *TESTING* T) + (ASET' *TEST* NIL) ;PURELY TO RELEASE FORMER GARBAGE + (ASET' *ERROR-COUNT* 0) + (ASET' *ERROR-LIST* NIL) + (ASET' *TEST* (COMPILE FNNAME FN T 'MAYBE)) + (SPRINTER *TEST*) + `(,(IF (ZEROP *ERROR-COUNT*) 'NO *ERROR-COUNT*) ERRORS)) + (T `(,FNNAME NOT DEFINED)))))) + +;;; ALPHA-CONVERSION + +;;; HERE WE RENAME ALL VARIABLES, AND CONVERT THE EXPRESSION TO AN EQUIVALENT TREE-LIKE FORM +;;; WITH EXTRA SLOTS TO BE FILLED IN LATER. AFTER THIS POINT, THE NEW NAMES ARE USED FOR +;;; VARIABLES, AND THE USER NAMES ARE USED ONLY FOR ERROR MESSAGES AND THE LIKE. THE TREE-LIKE +;;; FORM WILL BE USED AND AUGMENTED UNTIL IT IS CONVERTED TO CONTINUATION-PASSING STYLE. + +;;; WE ALSO FIND ALL USER-NAMED LAMBDA-FORMS AND SET UP APPROPRIATE PROPERTIES. +;;; THE USER CAN NAME A LAMBDA-FORM BY WRITING (LAMBDA (X) BODY NAME). + +(DEFTYPE NODE (NAME SEXPR ENV REFS ASETS TRIVP EFFS AFFD PEFFS PAFFD METAP SUBSTP FORM) (SEXPR)) + ;NAME: A GENSYM WHICH NAMES THE NODE'S VALUE + ;SEXPR: THE S-EXPRESSION WHICH WAS ALPHATIZED TO MAKE THIS NODE + ; (USED ONLY FOR WARNING MESSAGES AND DEBUGGING) + ;ENV: THE ENVIRONMENT OF THE NODE (USED ONLY FOR DEBUGGING) + ;REFS: ALL VARIABLES BOUND ABOVE AND REFERENCED BELOW OR BY THE NODE + ;ASETS: ALL LOCAL VARIABLES SEEN IN AN ASET BELOW THIS NODE (A SUBSET OF REFS) + ;TRIVP: NON-NIL IFF EVALUATION OF THIS NODE IS TRIVIAL + ;EFFS: SET OF SIDE EFFECTS POSSIBLY OCCURRING AT THIS NODE OR BELOW + ;AFFD: SET OF SIDE EFFECTS WHICH CAN POSSIBLY AFFECT THIS NODE OR BELOW + ;PEFFS: ABSOLUTELY PROVABLE SET OF EFFS + ;PAFFD: ABSOLUTELY PROVABLE SET OF AFFD + ;METAP: NON-NIL IFF THIS NODE HAS BEEN EXAMINED BY THE META-EVALUATOR + ;SUBSTP:FLAG INDICATING WHETHER META-SUBSTITUTE ACTUALLY MADE A SUBSTITUTION + ;FORM: ONE OF THE BELOW TYPES + +(DEFTYPE CONSTANT (VALUE)) + ;VALUE: THE S-EXPRESSION VALUE OF THE CONSTANT +(DEFTYPE VARIABLE (VAR GLOBALP)) + ;VAR: THE NEW UNIQUE NAME FOR THE VARIABLE, GENERATED BY ALPHATIZE. + ; THE USER NAME AND OTHER INFORMATION IS ON ITS PROPERTY LIST. + ;GLOBALP: NIL UNLESS THE VARIABLE IS GLOBAL (IN WHICH CASE VAR IS THE ACTUAL NAME) +(DEFTYPE LAMBDA (UVARS VARS BODY)) + ;UVARS: THE USER NAMES FOR THE BOUND VARIABLES (STRICTLY FOR DEBUGGING (SEE SEXPRFY)) + ;VARS: A LIST OF THE GENERATED UNIQUE NAMES FOR THE BOUND VARIABLES + ;BODY: THE NODE FOR THE BODY OF THE LAMBDA-EXPRESSION +(DEFTYPE IF (PRED CON ALT)) + ;PRED: THE NODE FOR THE PREDICATE + ;CON: THE NODE FOR THE CONSEQUENT + ;ALT: THE NODE FOR THE ALTERNATIVE +(DEFTYPE ASET (VAR BODY GLOBALP)) + ;VAR: THE GENERATED UNIQUE NAME FOR THE ASET VARIABLE + ;BODY: THE NODE FOR THE BODY OF THE ASET + ;GLOBALP: NIL UNLESS THE VARIABLE IS GLOBAL (IN WHICH CASE VAR IS THE ACTUAL NAME) +(DEFTYPE CATCH (UVAR VAR BODY)) + ;UVAR: THE USER NAME FOR THE BOUND VARIABLE (STRICTLY FOR DEBUGGING (SEE SEXPRFY)) + ;VAR: THE GENERATED UNIQUE NAME FOR THE BOUND VARIABLE + ;BODY: THE NODE FOR THE BODY OF THE CATCH +(DEFTYPE LABELS (UFNVARS FNVARS FNDEFS BODY)) + ;UFNVARS: THE USER NAMES FOR THE BOUND LABELS VARIABLES + ;FNVARS: A LIST OF THE GENERATED UNIQUE NAMES FOR THE LABELS VARIABLES + ;FNDEFS: A LIST OF THE NODES FOR THE LAMBDA-EXPRESSIONS + ;BODY: THE NODE FOR THE BOY OF THE LABELS +(DEFTYPE COMBINATION (ARGS WARNP)) + ;ARGS: A LIST OF THE NODES FOR THE ARGUMENTS (THE FIRST IS THE FUNCTION) + ;WARNP: NON-NIL IFF CHECK-COMBINATION-PEFFS HAS DETECTED A CONFLICT IN THIS COMBINATION + +(DEFINE NODIFY + (LAMBDA (FORM SEXPR ENV) + (LET ((N (CONS-NODE (NAME = (GENTEMP 'NODE)) + (FORM = FORM) + (SEXPR = SEXPR) + (ENV = ENV) + (METAP = NIL)))) + (PUTPROP (NODE\NAME N) N 'NODE) + N))) + +;;; ON NODE NAMES THESE PROPERTIES ARE CREATED: +;;; NODE THE CORRESPONDING NODE + +(DEFINE ALPHATIZE + (LAMBDA (SEXPR ENV) + (COND ((ATOM SEXPR) + (ALPHA-ATOM SEXPR ENV)) + ((HUNKP SEXPR) + (IF (EQ (TYPE SEXPR) 'NODE) + SEXPR + (ERROR '|Peculiar hunk - ALPHATIZE| SEXPR 'FAIL-ACT))) + ((EQ (CAR SEXPR) 'QUOTE) + (NODIFY (CONS-CONSTANT (VALUE = (CADR SEXPR))) SEXPR ENV)) + ((EQ (CAR SEXPR) 'LAMBDA) + (ALPHA-LAMBDA SEXPR ENV)) + ((EQ (CAR SEXPR) 'IF) + (ALPHA-IF SEXPR ENV)) + ((EQ (CAR SEXPR) 'ASET) + (ALPHA-ASET SEXPR ENV)) + ((EQ (CAR SEXPR) 'CATCH) + (ALPHA-CATCH SEXPR ENV)) + ((EQ (CAR SEXPR) 'LABELS) + (ALPHA-LABELS SEXPR ENV)) + ((EQ (CAR SEXPR) 'BLOCK) + (ALPHA-BLOCK SEXPR ENV)) + ((AND (ATOM (CAR SEXPR)) + (EQ (GET (CAR SEXPR) 'AINT) 'AMACRO)) + (ALPHATIZE (MACRO-EXPAND SEXPR) ENV)) + (T (ALPHA-COMBINATION SEXPR ENV))))) + +(DEFINE ALPHA-ATOM + (LAMBDA (SEXPR ENV) + (IF (OR (NUMBERP SEXPR) (NULL SEXPR) (EQ SEXPR 'T)) + (NODIFY (CONS-CONSTANT (VALUE = SEXPR)) SEXPR ENV) + (LET ((SLOT (ASSQ SEXPR ENV))) + (NODIFY (CONS-VARIABLE (VAR = (IF SLOT (CADR SLOT) SEXPR)) + (GLOBALP = (NULL SLOT))) + SEXPR + ENV))))) + +(DEFINE ALPHA-LAMBDA + (LAMBDA (SEXPR ENV) + (LET ((VARS (DO ((I (LENGTH (CADR SEXPR)) (- I 1)) + (V NIL (CONS (GENTEMP 'VAR) V))) + ((= I 0) (NREVERSE V))))) + (IF (CDDDR SEXPR) + (WARN |Malformed LAMBDA expression| SEXPR)) + (NODIFY (CONS-LAMBDA (UVARS = (APPEND (CADR SEXPR) NIL)) + ;;SEE META-COMBINATION-LAMBDA + (VARS = VARS) + (BODY = (ALPHATIZE (CADDR SEXPR) + (PAIRLIS (CADR SEXPR) + VARS + ENV)))) + SEXPR + ENV)))) + +(DEFINE ALPHA-IF + (LAMBDA (SEXPR ENV) + (NODIFY (CONS-IF (PRED = (ALPHATIZE (CADR SEXPR) ENV)) + (CON = (ALPHATIZE (CADDR SEXPR) ENV)) + (ALT = (ALPHATIZE (CADDDR SEXPR) ENV))) + SEXPR + ENV))) + +(DEFINE ALPHA-ASET + (LAMBDA (SEXPR ENV) + (LET ((VAR (COND ((OR (ATOM (CADR SEXPR)) + (NOT (EQ (CAADR SEXPR) 'QUOTE))) + (ERROR '|Can't Compile Non-quoted ASET Variable| + SEXPR + 'FAIL-ACT)) + (T (CADADR SEXPR))))) + (LET ((SLOT (ASSQ VAR ENV))) + (IF (AND (NULL SLOT) (TRIVFN VAR)) + (ERROR '|Illegal to ASET a MacLISP primitive| + SEXPR + 'FAIL-ACT)) + (NODIFY (CONS-ASET (VAR = (IF SLOT (CADR SLOT) VAR)) + (GLOBALP = (NULL SLOT)) + (BODY = (ALPHATIZE (CADDR SEXPR) ENV))) + SEXPR + ENV))))) + +(DEFINE ALPHA-CATCH + (LAMBDA (SEXPR ENV) + (LET ((VAR (GENTEMP 'CATCHVAR))) + (NODIFY (CONS-CATCH (VAR = VAR) + (UVAR = (CADR SEXPR)) + (BODY = (ALPHATIZE (CADDR SEXPR) + (CONS (LIST (CADR SEXPR) VAR) + ENV)))) + SEXPR + ENV)))) + +(DEFINE ALPHA-LABELS + (LAMBDA (SEXPR ENV) + (LET ((UFNVARS (AMAPCAR (LAMBDA (X) + (IF (ATOM (CAR X)) + (CAR X) + (CAAR X))) + (CADR SEXPR)))) + (LET ((FNVARS (DO ((I (LENGTH UFNVARS) (- I 1)) + (V NIL (CONS (GENTEMP 'FNVAR) V))) + ((= I 0) (NREVERSE V))))) + (LET ((LENV (PAIRLIS UFNVARS FNVARS ENV))) + (NODIFY (CONS-LABELS (UFNVARS = UFNVARS) + (FNVARS = FNVARS) + (FNDEFS = (AMAPCAR + (LAMBDA (X) + (ALPHA-LABELS-DEFN X LENV)) + (CADR SEXPR))) + (BODY = (ALPHATIZE (CADDR SEXPR) LENV))) + SEXPR + ENV)))))) + +(DEFINE ALPHA-LABELS-DEFN + (LAMBDA (LDEF LENV) + (ALPHATIZE (IF (ATOM (CAR LDEF)) + (IF (CDDR LDEF) + `(LAMBDA ,(CADR LDEF) ,(BLOCKIFY (CDDR LDEF))) + (CADR LDEF)) + `(LAMBDA ,(CDAR LDEF) ,(BLOCKIFY (CDR LDEF)))) + LENV))) + +(DEFINE ALPHA-BLOCK + (LAMBDA (SEXPR ENV) + (COND ((NULL (CDR SEXPR)) + (WARN |BLOCK with no forms| + `(ENV = ,(AMAPCAR CAR ENV))) + (ALPHATIZE NIL ENV)) + (T (LABELS ((MUNG + (LAMBDA (BODY) + (IF (NULL (CDR BODY)) + (CAR BODY) + `((LAMBDA (A B) (B)) + ,(CAR BODY) + (LAMBDA () ,(MUNG (CDR BODY)))))))) + (ALPHATIZE (MUNG (CDR SEXPR)) ENV)))))) + +(DEFINE MACRO-EXPAND + (LAMBDA (SEXPR) + (LET ((M (GETL (CAR SEXPR) '(MACRO AMACRO SMACRO)))) + (IF (NULL M) + (BLOCK (WARN |missing macro definition| SEXPR) + `(ERROR '|Undefined Macro Form| ',SEXPR 'FAIL-ACT)) + (EQCASE (CAR M) + (MACRO (FUNCALL (CADR M) SEXPR)) + (AMACRO (FUNCALL (CADR M) SEXPR)) + (SMACRO ((SYMEVAL (CADR M)) SEXPR))))))) + +(DEFINE ALPHA-COMBINATION + (LAMBDA (SEXPR ENV) + (LET ((N (NODIFY (CONS-COMBINATION + (WARNP = NIL) + (ARGS = (AMAPCAR (LAMBDA (X) (ALPHATIZE X ENV)) + SEXPR))) + SEXPR + ENV))) + (LET ((M (NODE\FORM (CAR (COMBINATION\ARGS (NODE\FORM N)))))) + (IF (AND (EQ (TYPE M) 'VARIABLE) + (VARIABLE\GLOBALP M)) + (CHECK-NUMBER-OF-ARGS + (VARIABLE\VAR M) + (LENGTH (CDR (COMBINATION\ARGS (NODE\FORM N)))) + NIL)) + N)))) + +;;; ENVIRONMENT ANALYSIS. + +;;; FOR NODES ENCOUNTERED WE FILL IN: +;;; REFS +;;; ASETS +;;; ON VARIABLE NAMES THESE PROPERTIES ARE CREATED: +;;; BINDING THE NODE WHERE THE VARIABLE IS BOUND +;;; USER-NAME THE USER'S NAME FOR THE VARIABLE (WHERE BOUND) +;;; READ-REFS VARIABLE NODES WHICH READ THE VARIABLE +;;; WRITE-REFS ASET NODES WHICH SET THE VARIABLE + +;;; NORMALLY, ON RECURRING TO A LOWER NODE WE STOP IF THE INFORMATION +;;; IS ALREADY THERE. MAKING THE PARAMETER `REDOTHIS` BE `ALL` FORCES +;;; RE-COMPUTATION TO ALL LEVELS; MAKING IT `ONCE` FORCES +;;; RECOMPUTATION OF THIS NODE BUT NOT OF SUBNODES. + +(DEFINE ENV-ANALYZE + (LAMBDA (NODE REDOTHIS) + (IF (OR REDOTHIS (EMPTY (NODE\REFS NODE))) + (LET ((FM (NODE\FORM NODE)) + (REDO (IF (EQ REDOTHIS 'ALL) 'ALL NIL))) + (EQCASE (TYPE FM) + (CONSTANT + (ALTER-NODE NODE + (REFS := NIL) + (ASETS := NIL))) + (VARIABLE + (ADDPROP (VARIABLE\VAR FM) NODE 'READ-REFS) + (IF (VARIABLE\GLOBALP FM) + (SETPROP (VARIABLE\VAR FM) (VARIABLE\VAR FM) 'USER-NAME)) + (ALTER-NODE NODE + (REFS := (AND (NOT (VARIABLE\GLOBALP FM)) + (LIST (VARIABLE\VAR FM)))) + (ASETS := NIL))) + (LAMBDA + (DO ((V (LAMBDA\VARS FM) (CDR V)) + (UV (LAMBDA\UVARS FM) (CDR UV))) + ((NULL V)) + (SETPROP (CAR V) (CAR UV) 'USER-NAME) + (SETPROP (CAR V) NODE 'BINDING)) + (LET ((B (LAMBDA\BODY FM))) + (ENV-ANALYZE B REDO) + (ALTER-NODE NODE + (REFS := (SETDIFF (NODE\REFS B) + (LAMBDA\VARS FM))) + (ASETS := (SETDIFF (NODE\ASETS B) + (LAMBDA\VARS FM)))))) + (IF + (LET ((PRED (IF\PRED FM)) + (CON (IF\CON FM)) + (ALT (IF\ALT FM))) + (ENV-ANALYZE PRED REDO) + (ENV-ANALYZE CON REDO) + (ENV-ANALYZE ALT REDO) + (ALTER-NODE NODE + (REFS := (UNION (NODE\REFS PRED) + (UNION (NODE\REFS CON) + (NODE\REFS ALT)))) + (ASETS := (UNION (NODE\ASETS PRED) + (UNION (NODE\ASETS CON) + (NODE\ASETS ALT))))))) + (ASET + (LET ((B (ASET\BODY FM)) + (V (ASET\VAR FM))) + (ENV-ANALYZE B REDO) + (ADDPROP V NODE 'WRITE-REFS) + (IF (ASET\GLOBALP FM) + (ALTER-NODE NODE + (REFS := (NODE\REFS B)) + (ASETS := (NODE\ASETS B))) + (ALTER-NODE NODE + (REFS := (ADJOIN V (NODE\REFS B))) + (ASETS := (ADJOIN V (NODE\ASETS B))))))) + (CATCH + (LET ((B (CATCH\BODY FM)) + (V (CATCH\VAR FM))) + (SETPROP V (CATCH\UVAR FM) 'USER-NAME) + (SETPROP V NODE 'BINDING) + (ENV-ANALYZE B REDO) + (ALTER-NODE NODE + (REFS := (REMOVE V (NODE\REFS B))) + (ASETS := (REMOVE V (NODE\ASETS B)))))) + (LABELS + (DO ((V (LABELS\FNVARS FM) (CDR V)) + (UV (LABELS\UFNVARS FM) (CDR UV)) + (D (LABELS\FNDEFS FM) (CDR D)) + (R NIL (UNION R (NODE\REFS (CAR D)))) + (A NIL (UNION A (NODE\ASETS (CAR D))))) + ((NULL V) + (LET ((B (LABELS\BODY FM))) + (ENV-ANALYZE B REDO) + (ALTER-NODE NODE + (REFS := (SETDIFF + (UNION R (NODE\REFS B)) + (LABELS\FNVARS FM))) + (ASETS := (SETDIFF + (UNION A (NODE\ASETS B)) + (LABELS\FNVARS FM)))))) + (SETPROP (CAR V) (CAR UV) 'USER-NAME) + (SETPROP (CAR V) NODE 'BINDING) + (ENV-ANALYZE (CAR D) REDO))) + (COMBINATION + (LET ((ARGS (COMBINATION\ARGS FM))) + (AMAPC (LAMBDA (X) (ENV-ANALYZE X REDO)) ARGS) + (DO ((A ARGS (CDR A)) + (R NIL (UNION R (NODE\REFS (CAR A)))) + (S NIL (UNION S (NODE\ASETS (CAR A))))) + ((NULL A) + (ALTER-NODE NODE + (REFS := R) + (ASETS := S))))))))))) + +;;; TRIVIALITY ANALYSIS + +;;; FOR NODES ENCOUNTERED WE FILL IN: +;;; TRIVP + +;;; A COMBINATION IS TRIVIAL IFF ALL ARGUMENTS ARE TRIVIAL, AND +;;; THE FUNCTION CAN BE PROVED TO BE TRIVIAL. WE ASSUME CLOSURES +;;; TO BE NON-TRIVIAL IN THIS CONTEXT, SO THAT THE CONVERT FUNCTION +;;; WILL BE FORCED TO EXAMINE THEM. + +(DEFINE TRIV-ANALYZE + (LAMBDA (NODE REDOTHIS) + (IF (OR REDOTHIS (EMPTY (NODE\TRIVP NODE))) + (LET ((FM (NODE\FORM NODE)) + (REDO (IF (EQ REDOTHIS 'ALL) 'ALL NIL))) + (EQCASE (TYPE FM) + (CONSTANT + (ALTER-NODE NODE (TRIVP := T))) + (VARIABLE + (ALTER-NODE NODE (TRIVP := T))) + (LAMBDA + (TRIV-ANALYZE (LAMBDA\BODY FM) REDO) + (ALTER-NODE NODE (TRIVP := NIL))) + (IF + (TRIV-ANALYZE (IF\PRED FM) REDO) + (TRIV-ANALYZE (IF\CON FM) REDO) + (TRIV-ANALYZE (IF\ALT FM) REDO) + (ALTER-NODE NODE + (TRIVP := (AND (NODE\TRIVP (IF\PRED FM)) + (NODE\TRIVP (IF\CON FM)) + (NODE\TRIVP (IF\ALT FM)))))) + (ASET + (TRIV-ANALYZE (ASET\BODY FM) REDO) + (ALTER-NODE NODE (TRIVP := (NODE\TRIVP (ASET\BODY FM))))) + (CATCH + (TRIV-ANALYZE (CATCH\BODY FM) REDO) + (ALTER-NODE NODE (TRIVP := NIL))) + (LABELS + (AMAPC (LAMBDA (F) (TRIV-ANALYZE F REDO)) + (LABELS\FNDEFS FM)) + (TRIV-ANALYZE (LABELS\BODY FM) REDO) + (ALTER-NODE NODE (TRIVP := NIL))) + (COMBINATION + (LET ((ARGS (COMBINATION\ARGS FM))) + (TRIV-ANALYZE (CAR ARGS) REDO) + (DO ((A (CDR ARGS) (CDR A)) + (SW T (AND SW (NODE\TRIVP (CAR A))))) + ((NULL A) + (ALTER-NODE NODE + (TRIVP := (AND SW + (TRIV-ANALYZE-FN-P + (CAR ARGS)))))) + (TRIV-ANALYZE (CAR A) REDO))))))))) + +(DEFINE TRIV-ANALYZE-FN-P + (LAMBDA (FN) + (OR (AND (EQ (TYPE (NODE\FORM FN)) 'VARIABLE) + (TRIVFN (VARIABLE\VAR (NODE\FORM FN)))) + (AND (EQ (TYPE (NODE\FORM FN)) 'LAMBDA) + (NODE\TRIVP (LAMBDA\BODY (NODE\FORM FN))))))) + +;;; SIDE-EFFECTS ANALYSIS +;;; FOR NODES ENCOUNTERED WE FILL IN: EFFS, AFFD, PEFFS, PAFFD +;;; A SET OF SIDE EFFECTS MAY BE EITHER 'NONE OR 'ANY, OR A SET. + +(DEFINE EFFS-ANALYZE + (LAMBDA (NODE REDOTHIS) + (IF (OR REDOTHIS (EMPTY (NODE\EFFS NODE))) + (LET ((FM (NODE\FORM NODE)) + (REDO (IF (EQ REDOTHIS 'ALL) 'ALL NIL))) + (EQCASE (TYPE FM) + (CONSTANT + (ALTER-NODE NODE + (EFFS := 'NONE) + (AFFD := 'NONE) + (PEFFS := 'NONE) + (PAFFD := 'NONE))) + (VARIABLE + (LET ((A (COND ((VARIABLE\GLOBALP FM) '(SETQ)) + ((GET (VARIABLE\VAR FM) 'WRITE-REFS) '(ASET)) + (T 'NONE)))) + (ALTER-NODE NODE + (EFFS := 'NONE) + (AFFD := A) + (PEFFS := 'NONE) + (PAFFD := A)))) + (LAMBDA + (EFFS-ANALYZE (LAMBDA\BODY FM) REDO) + (ALTER-NODE NODE + (EFFS := '(CONS)) + (AFFD := NIL) + (PEFFS := '(CONS)) + (PAFFD := NIL))) + (IF (EFFS-ANALYZE-IF NODE FM REDO)) + (ASET + (EFFS-ANALYZE (ASET\BODY FM) REDO) + (LET ((ASETEFFS (IF (ASET\GLOBALP FM) + '(SETQ) + '(ASET)))) + (ALTER-NODE NODE + (EFFS := (EFFS-UNION ASETEFFS + (NODE\EFFS (ASET\BODY FM)))) + (AFFD := (NODE\AFFD (ASET\BODY FM))) + (PEFFS := (EFFS-UNION ASETEFFS + (NODE\PEFFS (ASET\BODY FM)))) + (PAFFD := (NODE\PAFFD (ASET\BODY FM)))))) + (CATCH + (EFFS-ANALYZE (CATCH\BODY FM) REDO) + (ALTER-NODE NODE + (EFFS := (NODE\EFFS (CATCH\BODY FM))) + (AFFD := (NODE\AFFD (CATCH\BODY FM))) + (PEFFS := (NODE\PEFFS (CATCH\BODY FM))) + (PAFFD := (NODE\PAFFD (CATCH\BODY FM))))) + (LABELS + (AMAPC (LAMBDA (F) (EFFS-ANALYZE F REDO)) + (LABELS\FNDEFS FM)) + (EFFS-ANALYZE (LABELS\BODY FM) REDO) + (ALTER-NODE NODE + (EFFS := (EFFS-UNION '(CONS) + (NODE\EFFS (LABELS\BODY FM)))) + (AFFD := (NODE\AFFD (LABELS\BODY FM))) + (PEFFS := (EFFS-UNION '(CONS) + (NODE\PEFFS (LABELS\BODY FM)))) + (PAFFD := (NODE\PAFFD (LABELS\BODY FM))))) + (COMBINATION + (EFFS-ANALYZE-COMBINATION NODE FM REDO))))))) + +(DEFINE EFFS-UNION + (LAMBDA (A B) + (COND ((EQ A 'NONE) B) + ((EQ B 'NONE) A) + ((EQ A 'ANY) 'ANY) + ((EQ B 'ANY) 'ANY) + (T (UNION A B))))) + +(DEFINE EFFS-ANALYZE-IF + (LAMBDA (NODE FM REDO) + (BLOCK (EFFS-ANALYZE (IF\PRED FM) REDO) + (EFFS-ANALYZE (IF\CON FM) REDO) + (EFFS-ANALYZE (IF\ALT FM) REDO) + (ALTER-NODE NODE + (EFFS := (EFFS-UNION (NODE\EFFS (IF\PRED FM)) + (EFFS-UNION (NODE\EFFS (IF\CON FM)) + (NODE\EFFS (IF\ALT FM))))) + (AFFD := (EFFS-UNION (NODE\AFFD (IF\PRED FM)) + (EFFS-UNION (NODE\AFFD (IF\CON FM)) + (NODE\AFFD (IF\ALT FM))))) + (PEFFS := (EFFS-UNION (NODE\PEFFS (IF\PRED FM)) + (EFFS-UNION (NODE\PEFFS (IF\CON FM)) + (NODE\PEFFS (IF\ALT FM))))) + (PAFFD := (EFFS-UNION (NODE\PAFFD (IF\PRED FM)) + (EFFS-UNION (NODE\PAFFD (IF\CON FM)) + (NODE\PAFFD (IF\ALT FM))))))))) + +(SET' *CHECK-PEFFS* NIL) + +(DEFINE EFFS-ANALYZE-COMBINATION + (LAMBDA (NODE FM REDO) + (LET ((ARGS (COMBINATION\ARGS FM))) + (EFFS-ANALYZE (CAR ARGS) REDO) + (DO ((A (CDR ARGS) (CDR A)) + (EF 'NONE (EFFS-UNION EF (NODE\EFFS (CAR A)))) + (AF 'NONE (EFFS-UNION AF (NODE\AFFD (CAR A)))) + (PEF 'NONE (EFFS-UNION PEF (NODE\PEFFS (CAR A)))) + (PAF 'NONE (EFFS-UNION PAF (NODE\PAFFD (CAR A))))) + ((NULL A) + (IF *CHECK-PEFFS* (CHECK-COMBINATION-PEFFS FM)) + (COND ((EQ (TYPE (NODE\FORM (CAR ARGS))) 'VARIABLE) + (LET ((V (VARIABLE\VAR (NODE\FORM (CAR ARGS))))) + (LET ((VE (GET V 'FN-SIDE-EFFECTS)) + (VA (GET V 'FN-SIDE-AFFECTED))) + (ALTER-NODE NODE + (EFFS := (IF VE (EFFS-UNION EF VE) 'ANY)) + (AFFD := (IF VA (EFFS-UNION AF VA) 'ANY)) + (PEFFS := (EFFS-UNION PEF VE)) + (PAFFD := (EFFS-UNION PAF VA)))))) + ((EQ (TYPE (NODE\FORM (CAR ARGS))) 'LAMBDA) + (LET ((B (LAMBDA\BODY (NODE\FORM (CAR ARGS))))) + (ALTER-NODE NODE + (EFFS := (EFFS-UNION EF (NODE\EFFS B))) + (AFFD := (EFFS-UNION AF (NODE\AFFD B))) + (PEFFS := (EFFS-UNION PEF (NODE\PEFFS B))) + (PAFFD := (EFFS-UNION PAF (NODE\PAFFD B)))))) + (T (ALTER-NODE NODE + (EFFS := 'ANY) + (AFFD := 'ANY) + (PEFFS := (EFFS-UNION PEF + (NODE\PEFFS (CAR ARGS)))) + (PAFFD := (EFFS-UNION PAF + (NODE\PAFFD (CAR ARGS)))))))) + (EFFS-ANALYZE (CAR A) REDO))))) + +(DEFINE CHECK-COMBINATION-PEFFS + (LAMBDA (FM) + (IF (NOT (COMBINATION\WARNP FM)) + (DO ((A (COMBINATION\ARGS FM) (CDR A))) + ((NULL A)) + (DO ((B (CDR A) (CDR B))) + ((NULL B)) + (IF (NOT (EFFECTLESS (EFFS-INTERSECT (NODE\PEFFS (CAR A)) + (NODE\PAFFD (CAR B))))) + (BLOCK (WARN |co-argument may affect later one| + (NODE\SEXPR (CAR A)) + `(EFFECTS = ,(NODE\PEFFS (CAR A))) + (NODE\SEXPR (CAR B)) + `(AFFECTED BY ,(NODE\PAFFD (CAR B)))) + (ALTER-COMBINATION FM (WARNP := T)))) + (IF (NOT (EFFECTLESS (EFFS-INTERSECT (NODE\PEFFS (CAR B)) + (NODE\PAFFD (CAR A))))) + (BLOCK (WARN |co-argument may affect earlier one| + (NODE\SEXPR (CAR B)) + `(EFFECTS = ,(NODE\PEFFS (CAR B))) + (NODE\SEXPR (CAR A)) + `(AFFECTED BY ,(NODE\PAFFD (CAR A)))) + (ALTER-COMBINATION FM (WARNP := T)))) + (IF (NOT (EFFECTLESS-EXCEPT-CONS (EFFS-INTERSECT (NODE\PEFFS (CAR A)) + (NODE\PEFFS (CAR B))))) + (BLOCK (WARN |co-arguments may have interfering effects| + (NODE\SEXPR (CAR A)) + `(EFFECTS = ,(NODE\PEFFS (CAR A))) + (NODE\SEXPR (CAR B)) + `(EFFECTS = ,(NODE\PEFFS (CAR B)))) + (ALTER-COMBINATION FM (WARNP := T))))))))) + +(DEFMAC EFFDEF (FN EFFS AFFD . FOLD) + `(PROGN (DEFPROP ,FN ,EFFS FN-SIDE-EFFECTS) + (DEFPROP ,FN ,AFFD FN-SIDE-AFFECTED) + ,(AND FOLD `(DEFPROP ,FN T OKAY-TO-FOLD)))) + +(DECLARE (/@DEFINE EFFDEF |SIDE EFFECTS|)) + +(PROGN 'COMPILE + (EFFDEF + NONE NONE) + (EFFDEF - NONE NONE) + (EFFDEF * NONE NONE) + (EFFDEF // NONE NONE) + (EFFDEF = NONE NONE) + (EFFDEF < NONE NONE) + (EFFDEF > NONE NONE) + (EFFDEF CAR NONE (RPLACA)) + (EFFDEF CDR NONE (RPLACD)) + (EFFDEF CAAR NONE (RPLACA)) + (EFFDEF CADR NONE (RPLACA RPLACD)) + (EFFDEF CDAR NONE (RPLACA RPLACD)) + (EFFDEF CDDR NONE (RPLACD)) + (EFFDEF CAAAR NONE (RPLACA)) + (EFFDEF CAADR NONE (RPLACA RPLACD)) + (EFFDEF CADAR NONE (RPLACA RPLACD)) + (EFFDEF CADDR NONE (RPLACA RPLACD)) + (EFFDEF CDAAR NONE (RPLACA RPLACD)) + (EFFDEF CDADR NONE (RPLACA RPLACD)) + (EFFDEF CDDAR NONE (RPLACA RPLACD)) + (EFFDEF CDDDR NONE (RPLACD)) + (EFFDEF CAAAAR NONE (RPLACA)) + (EFFDEF CAAADR NONE (RPLACA RPLACD)) + (EFFDEF CAADAR NONE (RPLACA RPLACD)) + (EFFDEF CAADDR NONE (RPLACA RPLACD)) + (EFFDEF CADAAR NONE (RPLACA RPLACD)) + (EFFDEF CADADR NONE (RPLACA RPLACD)) + (EFFDEF CADDAR NONE (RPLACA RPLACD)) + (EFFDEF CADDDR NONE (RPLACA RPLACD)) + (EFFDEF CDAAAR NONE (RPLACA RPLACD)) + (EFFDEF CDAADR NONE (RPLACA RPLACD)) + (EFFDEF CDADAR NONE (RPLACA RPLACD)) + (EFFDEF CDADDR NONE (RPLACA RPLACD)) + (EFFDEF CDDAAR NONE (RPLACA RPLACD)) + (EFFDEF CDDADR NONE (RPLACA RPLACD)) + (EFFDEF CDDDAR NONE (RPLACA RPLACD)) + (EFFDEF CDDDDR NONE (RPLACD)) + (EFFDEF CXR NONE (RPLACA RPLACD)) + (EFFDEF RPLACA (RPLACA) NONE) + (EFFDEF RPLACD (RPLACA) NONE) + (EFFDEF RPLACX (RPLACA RPLACD) NONE) + (EFFDEF EQ NONE NONE) + (EFFDEF ATOM NONE NONE) + (EFFDEF NUMBERP NONE NONE) + (EFFDEF TYPEP NONE NONE) + (EFFDEF SYMBOLP NONE NONE) + (EFFDEF HUNKP NONE NONE) + (EFFDEF FIXP NONE NONE) + (EFFDEF FLOATP NONE NONE) + (EFFDEF BIGP NONE NONE) + (EFFDEF NOT NONE NONE) + (EFFDEF NULL NONE NONE) + (EFFDEF CONS (CONS) NONE) + (EFFDEF LIST (CONS) NONE) + (EFFDEF APPEND (CONS) (RPLACD)) + (EFFDEF MEMQ NONE (RPLACA RPLACD) T) + (EFFDEF ASSQ NONE (RPLACA RPLACD) T) + (EFFDEF PRINT (FILE) (FILE RPLACA RPLACD)) + (EFFDEF PRIN1 (FILE) (FILE RPLACA RPLACD)) + (EFFDEF PRINC (FILE) (FILE RPLACA RPLACD)) + (EFFDEF TERPRI (FILE) (FILE)) + (EFFDEF TYO (FILE) (FILE)) + (EFFDEF READ ANY (FILE)) + (EFFDEF TYI ANY (FILE)) + 'SIDE-EFFECTS-PROPERTIES) + +;;; THIS ROUTINE IS USED TO UNDO ANY PASS 1 ANALYSIS ON A NODE. + +(DEFMAC ERASE-NODE (NODE) `(ERASE-NODES ,NODE NIL)) +(DEFMAC ERASE-ALL-NODES (NODE) `(ERASE-NODES ,NODE T)) + +(DEFINE ERASE-NODES + (LAMBDA (NODE ALLP) + (LET ((FM (NODE\FORM NODE))) + (OR (EQ (TYPE NODE) 'NODE) + (ERROR '|Cannot erase a non-node| NODE 'FAIL-ACT)) + (EQCASE (TYPE FM) + (CONSTANT) + (VARIABLE + (DELPROP (VARIABLE\VAR FM) NODE 'READ-REFS)) + (LAMBDA + (IF ALLP (ERASE-ALL-NODES (LAMBDA\BODY FM))) + (IF (NOT *TESTING*) + (AMAPC (LAMBDA (V) (REMPROP V 'BINDING)) (LAMBDA\VARS FM)))) + (IF (COND (ALLP (ERASE-ALL-NODES (IF\PRED FM)) + (ERASE-ALL-NODES (IF\CON FM)) + (ERASE-ALL-NODES (IF\ALT FM))))) + (ASET + (IF ALLP (ERASE-ALL-NODES (ASET\BODY FM))) + (DELPROP (ASET\VAR FM) NODE 'WRITE-REFS)) + (CATCH + (IF ALLP (ERASE-ALL-NODES (CATCH\BODY FM))) + (IF (NOT *TESTING*) + (REMPROP (CATCH\VAR FM) 'BINDING))) + (LABELS + (COND (ALLP (AMAPC (LAMBDA (D) (ERASE-ALL-NODES D)) + (LABELS\FNDEFS FM)) + (ERASE-ALL-NODES (LABELS\BODY FM)))) + (IF (NOT *TESTING*) + (AMAPC (LAMBDA (V) (REMPROP V 'BINDING)) (LABELS\FNVARS FM)))) + (COMBINATION + (IF ALLP (AMAPC (LAMBDA (A) (ERASE-ALL-NODES A)) + (COMBINATION\ARGS FM))))) + (IF (NOT *TESTING*) + (REMPROP (NODE\NAME NODE) 'NODE))))) + +;;; THE VALUE OF META-EVALUATE IS THE (POSSIBLY NEW) NODE RESULTING FROM THE GIVEN ONE. + +(SET' *FUDGE* T) ;SWITCH TO CONTROL META-IF-FUDGE +(SET' *DEAD-COUNT* 0) ;COUNT OF DEAD-CODE ELIMINATIONS + +(DEFINE META-EVALUATE + (LAMBDA (NODE) + (IF (NODE\METAP NODE) + NODE + (LET ((FM (NODE\FORM NODE))) + (EQCASE (TYPE FM) + (CONSTANT + (REANALYZE1 NODE) + (ALTER-NODE NODE (METAP := T))) + (VARIABLE + (REANALYZE1 NODE) + (ALTER-NODE NODE (METAP := T))) + (LAMBDA + (ALTER-LAMBDA FM (BODY := (META-EVALUATE (LAMBDA\BODY FM)))) + (REANALYZE1 NODE) + (ALTER-NODE NODE (METAP := T))) + (IF + (ALTER-IF FM + (PRED := (META-EVALUATE (IF\PRED FM))) + (CON := (META-EVALUATE (IF\CON FM))) + (ALT := (META-EVALUATE (IF\ALT FM)))) + (IF (AND *FUDGE* (EQ (TYPE (NODE\FORM (IF\PRED FM))) 'IF)) + (META-IF-FUDGE NODE) + (IF (EQ (TYPE (NODE\FORM (IF\PRED FM))) 'CONSTANT) + (LET ((CON (IF\CON FM)) + (ALT (IF\ALT FM)) + (VAL (CONSTANT\VALUE (NODE\FORM (IF\PRED FM))))) + (ERASE-NODE NODE) + (ERASE-ALL-NODES (IF\PRED FM)) + (INCREMENT *DEAD-COUNT*) + (IF VAL + (BLOCK (ERASE-ALL-NODES ALT) CON) + (BLOCK (ERASE-ALL-NODES CON) ALT))) + (BLOCK (REANALYZE1 NODE) + (ALTER-NODE NODE (METAP := T)))))) + (ASET + (ALTER-ASET FM (BODY := (META-EVALUATE (ASET\BODY FM)))) + (REANALYZE1 NODE) + (ALTER-NODE NODE (METAP := T))) + (CATCH + (ALTER-CATCH FM (BODY := (META-EVALUATE (CATCH\BODY FM)))) + (REANALYZE1 NODE) + (ALTER-NODE NODE (METAP := T))) + (LABELS + (DO ((D (LABELS\FNDEFS FM) (CDR D))) + ((NULL D)) + (RPLACA D (META-EVALUATE (CAR D)))) + (ALTER-LABELS FM (BODY := (META-EVALUATE (LABELS\BODY FM)))) + (REANALYZE1 NODE) + (ALTER-NODE NODE (METAP := T))) + (COMBINATION + (LET ((FN (NODE\FORM (CAR (COMBINATION\ARGS FM))))) + (COND ((AND (EQ (TYPE FN) 'VARIABLE) + (TRIVFN (VARIABLE\VAR FN))) + (META-COMBINATION-TRIVFN NODE)) + ((EQ (TYPE FN) 'LAMBDA) + (META-COMBINATION-LAMBDA NODE)) + (T (DO ((A (COMBINATION\ARGS FM) (CDR A))) + ((NULL A)) + (RPLACA A (META-EVALUATE (CAR A)))) + (REANALYZE1 NODE) + (ALTER-NODE NODE (METAP := T))))))))))) + +;;; TRANSFORM (IF (IF A B C) D E) INTO: +;;; ((LAMBDA (D1 E1) +;;; (IF A (IF B (D1) (E1)) (IF C (D1) (E1)))) +;;; (LAMBDA () D) +;;; (LAMBDA () E)) + +(SET' *FUDGE-COUNT* 0) ;COUNT OF IF-FUDGES + +(DEFINE META-IF-FUDGE + (LAMBDA (NODE) + (LET ((FM (NODE\FORM NODE))) + (LET ((PFM (NODE\FORM (IF\PRED FM)))) + (LET ((N (ALPHATIZE (LET ((CONVAR (GENTEMP 'META-CON)) + (ALTVAR (GENTEMP 'META-ALT))) + `((LAMBDA (,CONVAR ,ALTVAR) + (IF ,(IF\PRED PFM) + (IF ,(IF\CON PFM) + (,CONVAR) + (,ALTVAR)) + (IF ,(IF\ALT PFM) + (,CONVAR) + (,ALTVAR)))) + (LAMBDA () ,(IF\CON FM)) + (LAMBDA () ,(IF\ALT FM)))) + (NODE\ENV NODE)))) ;DOESN'T MATTER + (ERASE-NODE NODE) + (ERASE-NODE (IF\PRED FM)) + (INCREMENT *FUDGE-COUNT*) + (META-EVALUATE N)))))) + +;;; REDUCE A COMBINATION WITH A SIDE-EFFECT-LESS TRIVIAL +;;; FUNCTION AND CONSTANT ARGUMENTS TO A CONSTANT. + +(SET' *FOLD-COUNT* 0) ;COUNT OF CONSTANT FOLDINGS + +(DEFINE META-COMBINATION-TRIVFN + (LAMBDA (NODE) + (LET ((FM (NODE\FORM NODE))) + (LET ((ARGS (COMBINATION\ARGS FM))) + (RPLACA ARGS (META-EVALUATE (CAR ARGS))) + (DO ((A (CDR ARGS) (CDR A)) + (CONSTP (LET ((FNNAME (VARIABLE\VAR (NODE\FORM (CAR ARGS))))) + (OR (AND (EQ (GET FNNAME + 'FN-SIDE-EFFECTS) + 'NONE) + (EQ (GET FNNAME + 'FN-SIDE-AFFECTED) + 'NONE)) + (GET FNNAME 'OKAY-TO-FOLD))) + (AND CONSTP (EQ (TYPE (NODE\FORM (CAR A))) 'CONSTANT)))) + ((NULL A) + (COND (CONSTP + (LET ((VAL (APPLY (VARIABLE\VAR (NODE\FORM (CAR ARGS))) + (AMAPCAR (LAMBDA (X) + (CONSTANT\VALUE + (NODE\FORM X))) + (CDR ARGS))))) + (ERASE-ALL-NODES NODE) + (INCREMENT *FOLD-COUNT*) + (META-EVALUATE (ALPHATIZE `(QUOTE ,VAL) NIL)))) + (T (REANALYZE1 NODE) + (ALTER-NODE NODE (METAP := T))))) + (RPLACA A (META-EVALUATE (CAR A)))))))) + +(SET' *FLUSH-ARGS* T) ;SWITCH TO CONTROL VARIABLE ELIMINATION +(SET' *FLUSH-COUNT* 0) ;COUNT OF VARIABLES ELIMINATED +(SET' *CONVERT-COUNT* 0) ;COUNT OF FULL BETA-CONVERSIONS + +(DEFINE + META-COMBINATION-LAMBDA + (LAMBDA (NODE) + (LET ((FM (NODE\FORM NODE))) + (LET ((ARGS (COMBINATION\ARGS FM))) + (DO ((A (CDR ARGS) (CDR A))) + ((NULL A)) + (RPLACA A (META-EVALUATE (CAR A))) + (ALTER-NODE (CAR A) (SUBSTP := NIL))) + (LET ((FN (NODE\FORM (CAR ARGS)))) + (DO ((V (LAMBDA\VARS FN) (CDR V)) + (A (CDR ARGS) (CDR A)) + (B (META-EVALUATE (LAMBDA\BODY FN)) + (IF (SUBST-CANDIDATE (CAR A) (CAR V) B) + (META-SUBSTITUTE (CAR A) (CAR V) B) + B))) + ((NULL V) + (ALTER-LAMBDA FN (BODY := (META-EVALUATE B))) + (DO ((V (LAMBDA\VARS FN) (CDR V)) + (A (CDR ARGS) (CDR A))) + ((NULL A)) + (IF (AND *FLUSH-ARGS* + (NULL (GET (CAR V) 'READ-REFS)) + (NULL (GET (CAR V) 'WRITE-REFS)) + (OR (EFFECTLESS-EXCEPT-CONS (NODE\EFFS (CAR A))) + (NODE\SUBSTP (CAR A)))) + (BLOCK (IF (OR (MEMQ V (NODE\REFS (LAMBDA\BODY FN))) + (MEMQ V (NODE\ASETS (LAMBDA\BODY FN)))) + (ERROR '|Reanalysis lost - META-COMBINATION-LAMBDA| + NODE + 'FAIL-ACT)) + (DELQ (CAR A) ARGS) + (ERASE-ALL-NODES (CAR A)) + (INCREMENT *FLUSH-COUNT*) + (ALTER-LAMBDA FN + (VARS := (DELQ (CAR V) (LAMBDA\VARS FN))) + (UVARS := (DELQ (GET (CAR V) 'USER-NAME) + (LAMBDA\UVARS FN))))))) + (COND ((NULL (LAMBDA\VARS FN)) + (OR (NULL (CDR ARGS)) + (ERROR '|Too many args in META-COMBINATION-LAMBDA| + NODE + 'FAIL-ACT)) + (LET ((BOD (LAMBDA\BODY FN))) + (ERASE-NODE (CAR ARGS)) + (ERASE-NODE NODE) + (INCREMENT *CONVERT-COUNT*) + BOD)) + (T (REANALYZE1 (CAR ARGS)) + (ALTER-NODE (CAR ARGS) (METAP := T)) + (REANALYZE1 NODE) + (ALTER-NODE NODE (METAP := T))))))))))) + +(SET' *SUBSTITUTE* T) ;SWITCH TO CONTROL SUBSTITUTION +(SET' *SINGLE-SUBST* T) ;SWITCH TO CONTROL SUBSTITUTION OF EXPRESSIONS WITH SIDE EFFECTS +(SET' *LAMBDA-SUBST* T) ;SWITCH TO CONTROL SUBSTITUTION OF LAMBDA-EXPRESSIONS + +(DEFINE SUBST-CANDIDATE + (LAMBDA (ARG VAR BOD) + (AND *SUBSTITUTE* + (NOT (GET VAR 'WRITE-REFS)) ;BE PARANOID FOR NOW + (OR (AND *SINGLE-SUBST* + (NULL (CDR (GET VAR 'READ-REFS)))) + (MEMQ (TYPE (NODE\FORM ARG)) '(CONSTANT VARIABLE)) + (AND *LAMBDA-SUBST* + (EQ (TYPE (NODE\FORM ARG)) 'LAMBDA) + (OR (NULL (CDR (GET VAR 'READ-REFS))) + (LET ((B (NODE\FORM (LAMBDA\BODY (NODE\FORM ARG))))) + (OR (MEMQ (TYPE B) '(CONSTANT VARIABLE)) + (AND (EQ (TYPE B) 'COMBINATION) + (NOT (> (LENGTH (CDR (COMBINATION\ARGS B))) + (LENGTH (LAMBDA\VARS (NODE\FORM ARG))))) + (DO ((A (COMBINATION\ARGS B) (CDR A)) + (P T (AND P (MEMQ (TYPE (NODE\FORM (CAR A))) + '(CONSTANT VARIABLE))))) + ((NULL A) P))))))))))) + +(DEFINE REANALYZE1 + (LAMBDA (NODE) + (PASS1-ANALYZE NODE *REANALYZE* T))) + +(SET' *REANALYZE* 'ONCE) + + + +;;; HERE WE DETERMINE, FOR EACH VARIABLE NODE WHOSE VAR IS THE ONE +;;; GIVEN, WHETHER IT IS POSSIBLE TO SUBSTITUTE IN FOR IT; THIS IS +;;; DETERMINED ON THE BASIS OF SIDE EFFECTS. THIS IS DONE BY +;;; WALKING THE PROGRAM, STOPPING WHEN A SIDE-EFFECT BLOCKS IT. +;;; A SUBSTITUTION IS MADE IFF IS VARIABLE NODE IS REACHED IN THE WALK. + +;;; THERE IS A BUG IN THIS THEORY TO THE EFFECT THAT A CATCH +;;; WHICH RETURNS MULTIPLY CAN CAUSE AN EXPRESSION EXTERNAL +;;; TO THE CATCH TO BE EVALUATED TWICE. THIS IS A DYNAMIC PROBLEM +;;; WHICH CANNOT BE RESOLVED AT COMPILE TIME, AND SO WE SHALL +;;; IGNORE IT FOR NOW. + +;;; WE ALSO RESET THE METAP FLAG ON ALL NODES WHICH HAVE A +;;; SUBSTITUTION AT OR BELOW THEM, SO THAT THE META-EVALUATOR WILL +;;; RE-PENETRATE TO SUBSTITUTION POINTS, WHICH MAY ADMIT FURTHER +;;; OPTIMIZATIONS. + + +(DEFINE EFFS-INTERSECT + (LAMBDA (A B) + (COND ((EQ A 'ANY) B) + ((EQ B 'ANY) A) + ((EQ A 'NONE) A) + ((EQ B 'NONE) B) + (T (INTERSECT A B))))) + +(DEFINE EFFECTLESS + (LAMBDA (X) (OR (NULL X) (EQ X 'NONE)))) + +(DEFINE EFFECTLESS-EXCEPT-CONS + (LAMBDA (X) (OR (EFFECTLESS X) (EQUAL X '(CONS))))) + +(DEFINE PASSABLE + (LAMBDA (NODE EFFS AFFD) + (BLOCK (IF (EMPTY (NODE\EFFS NODE)) + (ERROR '|Pass 1 Analysis Missing - PASSABLE| + NODE + 'FAIL-ACT)) + (AND (EFFECTLESS (EFFS-INTERSECT EFFS (NODE\AFFD NODE))) + (EFFECTLESS (EFFS-INTERSECT AFFD (NODE\EFFS NODE))) + (EFFECTLESS-EXCEPT-CONS (EFFS-INTERSECT EFFS (NODE\EFFS NODE))))))) + +(SET' *SUBST-COUNT* 0) ;COUNT OF SUBSTITUTIONS +(SET' *LAMBDA-BODY-SUBST* T) ;SWITCH TO CONTROL SUBSTITUTION IN LAMBDA BODIES +(SET' *LAMBDA-BODY-SUBST-TRY-COUNT* 0) ;COUNT THEREOF - TRIES +(SET' *LAMBDA-BODY-SUBST-SUCCESS-COUNT* 0) ;COUNT THEREOF - SUCCESSES + + +(DEFINE + META-SUBSTITUTE + (LAMBDA + (ARG VAR BOD) + (LET ((EFFS (NODE\EFFS ARG)) + (AFFD (NODE\AFFD ARG))) + (IF (EMPTY EFFS) + (ERROR '|Pass 1 Analysis Screwed Up - META-SUBSTITUTE| ARG 'FAIL-ACT)) + (LABELS + ((SUBSTITUTE + (LAMBDA (NODE) + (IF (OR (EMPTY (NODE\REFS NODE)) + (NOT (MEMQ VAR (NODE\REFS NODE)))) ;EFFICIENCY HACK + NODE + (LET ((FM (NODE\FORM NODE))) + (EQCASE (TYPE FM) + (CONSTANT NODE) + (VARIABLE + (IF (EQ (VARIABLE\VAR FM) VAR) + (BLOCK (ERASE-ALL-NODES NODE) + (INCREMENT *SUBST-COUNT*) + (ALTER-NODE ARG (SUBSTP := T)) + (COPY-CODE ARG)) + NODE)) + (LAMBDA + (IF (AND (EFFECTLESS-EXCEPT-CONS EFFS) (EFFECTLESS AFFD)) + (ALTER-LAMBDA FM (BODY := (SUBSTITUTE (LAMBDA\BODY FM))))) + (IF (NODE\METAP NODE) + (ALTER-NODE NODE (METAP := (NODE\METAP (LAMBDA\BODY FM))))) + NODE) + (IF + (ALTER-IF FM (PRED := (SUBSTITUTE (IF\PRED FM)))) + (IF (PASSABLE (IF\PRED FM) EFFS AFFD) + (ALTER-IF FM + (CON := (SUBSTITUTE (IF\CON FM))) + (ALT := (SUBSTITUTE (IF\ALT FM))))) + (IF (NODE\METAP NODE) + (ALTER-NODE NODE + (METAP := (AND (NODE\METAP (IF\PRED FM)) + (NODE\METAP (IF\CON FM)) + (NODE\METAP (IF\ALT FM)))))) + NODE) + (ASET + (ALTER-ASET FM (BODY := (SUBSTITUTE (ASET\BODY FM)))) + (IF (NODE\METAP NODE) + (ALTER-NODE NODE (METAP := (NODE\METAP (ASET\BODY FM))))) + NODE) + (CATCH + (ALTER-CATCH FM (BODY := (SUBSTITUTE (CATCH\BODY FM)))) + (IF (NODE\METAP NODE) + (ALTER-NODE NODE (METAP := (NODE\METAP (CATCH\BODY FM))))) + NODE) + (LABELS + (ALTER-LABELS FM (BODY := (SUBSTITUTE (LABELS\BODY FM)))) + (DO ((D (LABELS\FNDEFS FM) (CDR D)) + (MP (NODE\METAP (LABELS\BODY FM)) + (AND MP (NODE\METAP (CAR D))))) + ((NULL D) + (IF (NODE\METAP NODE) + (ALTER-NODE NODE (METAP := MP)))) + (RPLACA D (SUBSTITUTE (CAR D)))) + NODE) + (COMBINATION + (LET ((ARGS (COMBINATION\ARGS FM))) + (DO ((A ARGS (CDR A)) + (X T (AND X (PASSABLE (CAR A) EFFS AFFD)))) + ((NULL A) + (IF X (DO ((A (CDR ARGS) (CDR A))) + ((NULL A)) + (RPLACA A (SUBSTITUTE (CAR A))))) + (IF (AND *LAMBDA-BODY-SUBST* + (EQ (TYPE (NODE\FORM (CAR ARGS))) 'LAMBDA)) + (LET ((FN (NODE\FORM (CAR ARGS)))) + (INCREMENT *LAMBDA-BODY-SUBST-TRY-COUNT*) + (COND (X + (INCREMENT + *LAMBDA-BODY-SUBST-SUCCESS-COUNT*) + (ALTER-LAMBDA + FN + (BODY := (SUBSTITUTE + (LAMBDA\BODY FN)))))) + (IF (NODE\METAP (CAR ARGS)) + (ALTER-NODE + (CAR ARGS) + (METAP := (NODE\METAP + (LAMBDA\BODY FN)))))) + (IF X (RPLACA ARGS (SUBSTITUTE (CAR ARGS))))))) + (DO ((A ARGS (CDR A)) + (MP T (AND MP (NODE\METAP (CAR A))))) + ((NULL A) + (IF (NODE\METAP NODE) + (ALTER-NODE NODE (METAP := MP)))))) + NODE))))))) + (SUBSTITUTE BOD))))) + +(DEFINE COPY-CODE + (LAMBDA (NODE) + (REANALYZE1 (COPY-NODES NODE (NODE\ENV NODE) NIL)))) + +(DEFINE + COPY-NODES + (LAMBDA (NODE ENV RNL) + (NODIFY + (LET ((FM (NODE\FORM NODE))) + (EQCASE (TYPE FM) + (CONSTANT + (CONS-CONSTANT (VALUE = (CONSTANT\VALUE FM)))) + (VARIABLE + (CONS-VARIABLE (VAR = (LET ((SLOT (ASSQ (VARIABLE\VAR FM) RNL))) + (IF SLOT (CADR SLOT) (VARIABLE\VAR FM)))) + (GLOBALP = (VARIABLE\GLOBALP FM)))) + (LAMBDA + (LET ((VARS (AMAPCAR GENTEMP (LAMBDA\VARS FM)))) + (CONS-LAMBDA (UVARS = (APPEND (LAMBDA\UVARS FM) NIL)) + (VARS = VARS) + (BODY = (COPY-NODES + (LAMBDA\BODY FM) + (PAIRLIS (LAMBDA\UVARS FM) VARS ENV) + (PAIRLIS (LAMBDA\VARS FM) VARS RNL)))))) + (IF (CONS-IF (PRED = (COPY-NODES (IF\PRED FM) ENV RNL)) + (CON = (COPY-NODES (IF\CON FM) ENV RNL)) + (ALT = (COPY-NODES (IF\ALT FM) ENV RNL)))) + (ASET + (CONS-ASET (VAR = (LET ((SLOT (ASSQ (ASET\VAR FM) RNL))) + (IF SLOT (CADR SLOT) (ASET\VAR FM)))) + (GLOBALP = (ASET\GLOBALP FM)) + (BODY = (COPY-NODES (ASET\BODY FM) ENV RNL)))) + (CATCH + (LET ((VAR (GENTEMP (CATCH\VAR FM))) + (UVAR (CATCH\UVAR FM))) + (CONS-CATCH (UVAR = (CATCH\UVAR FM)) + (VAR = VAR) + (BODY = (COPY-NODES + (CATCH\BODY FM) + (CONS (LIST UVAR VAR) ENV) + (CONS (LIST (CATCH\VAR FM) VAR) RNL)))))) + (LABELS + (LET ((FNVARS (AMAPCAR GENTEMP (LABELS\FNVARS FM)))) + (LET ((LENV (PAIRLIS (LABELS\UFNVARS FM) FNVARS ENV)) + (LRNL (PAIRLIS (LABELS\FNVARS FM) FNVARS RNL))) + (CONS-LABELS (UFNVARS = (LABELS\UFNVARS FM)) + (FNVARS = FNVARS) + (FNDEFS = (AMAPCAR + (LAMBDA (N) (COPY-NODES N LENV LRNL)) + (LABELS\FNDEFS FM))) + (BODY = (COPY-NODES (LABELS\BODY FM) + LENV + LRNL)))))) + (COMBINATION + (CONS-COMBINATION (ARGS = (AMAPCAR (LAMBDA (N) (COPY-NODES N ENV RNL)) + (COMBINATION\ARGS FM))) + (WARNP = (COMBINATION\WARNP FM)))))) + (NODE\SEXPR NODE) + ENV))) + +;;; CONVERSION TO CONTINUATION-PASSING STYLE + +;;; THIS INVOLVES MAKING A COMPLETE COPY OF THE PROGRAM IN TERMS +;;; OF THE FOLLOWING NEW DATA STRUCTURES: + +(DEFTYPE CNODE (ENV REFS CLOVARS CFORM)) + ;ENV ENVIRONMENT (A LIST OF VARIABLES, NOT A MAPPING; DEBUGGING ONLY) + ;REFS VARIABLES BOUND ABOVE AND REFERENCED BELOW THIS CNODE + ;CLOVARS VARIABLES REFERRED TO AT OR BELOW THIS CNODE BY CLOSURES + ; (SHOULD BE A SUBSET OF REFS) + ;CFORM ONE OF THE BELOW TYPES +(DEFTYPE TRIVIAL (NODE)) + ;NODE A PASS-1 NODE TREE +(DEFTYPE CVARIABLE (VAR)) + ;VAR GENERATED VARIABLE NAME +(DEFTYPE CLAMBDA (VARS BODY FNP TVARS NAME DEP MAXDEP CONSENV CLOSEREFS ASETVARS)) + ;FNP NON-NIL => NEEDN'T MAKE A FULL CLOSURE OF THIS + ; CLAMBDA. MAY BE 'NOCLOSE OR 'EZCLOSE (THE FORMER + ; MEANING NO CLOSURE IS NECESSARY AT ALL, THE LATTER + ; THAT THE CLOSURE IS MERELY THE ENVIRONMENT). + ;TVARS THE VARIABLES WHICH ARE PASSED THROUGH TEMP LOCATIONS + ; ON ENTRY. NON-NIL ONLY IF FNP='NOCLOSE; THEN IS + ; NORMALLY THE LAMBDA VARS, BUT MAY BE DECREASED + ; TO ACCOUNT FOR ARGS WHICH ARE THEMSELVES KNOWN NOCLOSE'S, + ; OR WHOSE CORRESPONDING PARAMETERS ARE NEVER REFERENCED. + ; THE TEMP VARS INVOLVED START IN NUMBER AT DEP. + ;NAME THE PROG TAG USED TO LABEL THE FINAL OUTPUT CODE FOR THE CLAMBDA + ;DEP DEPTH OF TEMPORARY REGISTER USAGE WHEN THE CLAMBDA IS INVOKED + ;MAXDEP MAXIMUM DEPTH OF REGISTER USAGE WITHIN CLAMBDA BODY + ;CONSENV THE `CONSED ENVIRONMENT` WHEN THE CLAMBDA IS EVALUATED + ;CLOSEREFS VARIABLES REFERENCED BY THE CLAMBDA WHICH ARE NOT IN + ; THE CONSED ENVIRONMENT AT EVALUATION TIME, AND SO MUST BE + ; ADDED TO CONSENV AT THAT POINT TO MAKE THE CLOSURE + ;ASETVARS THE ELEMENTS OF VARS WHICH ARE EVER SEEN IN A CASET +(DEFTYPE CONTINUATION (VAR BODY FNP TVARS NAME DEP MAXDEP CONSENV CLOSEREFS)) + ;COMPONENTS ARE AS FOR CLAMBDA +(DEFTYPE CIF (PRED CON ALT)) +(DEFTYPE CASET (CONT VAR BODY)) +(DEFTYPE CLABELS (FNVARS FNDEFS FNENV EASY CONSENV BODY)) + ;FNENV A LIST OF VARIABLES TO CONS ONTO THE ENVIRONMENT BEFORE + ; CREATING THE CLOSURES AND EXECUTING THE BODY + ;EASY NON-NIL IFF NO LABELED FUNCTION IS REFERRED TO + ; AS A VARIABLE. CAN BE 'NOCLOSE OR 'EZCLOSE + ; (REFLECTING THE STATUS OF ALL THE LABELLED FUNCTIONS) + ;CONSENV AS FOR CLAMBDA +(DEFTYPE CCOMBINATION (ARGS)) + ;ARGS LIST OF CNODES REPRESENTING ARGUMENTS +(DEFTYPE RETURN (CONT VAL)) + ;CONT CNODE FOR CONTINUATION + ;VAL CNODE FOR VALUE + +(DEFINE CNODIFY + (LAMBDA (CFORM) + (CONS-CNODE (CFORM = CFORM)))) + +(DEFINE CONVERT + (LAMBDA (NODE CONT MP) + (LET ((FM (NODE\FORM NODE))) + (IF (EMPTY (NODE\TRIVP NODE)) + (ERROR '|Pass 1 analysis missing| NODE 'FAIL-ACT)) + (OR (EQ (NODE\METAP NODE) MP) + (ERROR '|Meta-evaluation Screwed Up METAP| NODE 'FAIL-ACT)) + (EQCASE (TYPE FM) + (CONSTANT + (OR (NODE\TRIVP NODE) + (ERROR '|Non-trivial Constant| NODE 'FAIL-ACT)) + (MAKE-RETURN (CONS-TRIVIAL (NODE = NODE)) CONT)) + (VARIABLE + (OR (NODE\TRIVP NODE) + (ERROR '|Non-trivial Variable| 'FAIL-ACT)) + (MAKE-RETURN (CONS-TRIVIAL (NODE = NODE)) CONT)) + (LAMBDA (MAKE-RETURN (CONVERT-LAMBDA-FM NODE NIL MP) CONT)) + (IF (OR CONT (ERROR '|Null Continuation to IF| NODE 'FAIL-ACT)) + (CONVERT-IF NODE FM CONT MP)) + (ASET (OR CONT (ERROR '|Null Continuation to ASET| NODE 'FAIL-ACT)) + (CONVERT-ASET NODE FM CONT MP)) + (CATCH (OR CONT (ERROR '|Null Continuation to CATCH| NODE 'FAIL-ACT)) + (CONVERT-CATCH NODE FM CONT MP)) + (LABELS (OR CONT (ERROR '|Null Continuation to LABELS| NODE 'FAIL-ACT)) + (CONVERT-LABELS NODE FM CONT MP)) + (COMBINATION (OR CONT (ERROR '|Null Continuation to Combination| + NODE + 'FAIL-ACT)) + (CONVERT-COMBINATION NODE FM CONT MP)))))) + +(DEFINE MAKE-RETURN + (LAMBDA (CFORM CONT) + (LET ((CN (CNODIFY CFORM))) + (IF CONT + (CNODIFY (CONS-RETURN (CONT = CONT) (VAL = CN))) + CN)))) + +(DEFINE CONVERT-LAMBDA-FM + (LAMBDA (NODE CNAME MP) + (LET ((CV (GENTEMP 'CONT)) + (FM (NODE\FORM NODE))) + (CONS-CLAMBDA (VARS = (CONS CV (LAMBDA\VARS FM))) + (BODY = (CONVERT (LAMBDA\BODY FM) + (CNODIFY + (CONS-CVARIABLE (VAR = (OR CNAME CV)))) + MP)))))) + +;;; ISSUES FOR CONVERTING IF: +;;; (1) IF WHOLE IF IS TRIVIAL, MAY JUST CREATE A CTRIVIAL. +;;; (2) IF CONTINUATION IS NON-CVARIABLE, MUST BIND A VARIABLE TO IT. +;;; (3) IF PREDICATE IS TRIVIAL, MAY JUST STICK IT IN SIMPLE CIF. + +(DEFINE CONVERT-IF + (LAMBDA (NODE FM CONT MP) + (IF (NODE\TRIVP NODE) + (MAKE-RETURN (CONS-TRIVIAL (NODE = NODE)) CONT) + (LET ((CVAR (IF (EQ (TYPE (CNODE\CFORM CONT)) 'CVARIABLE) + NIL + (GENTEMP 'CONT))) + (PVAR (IF (NODE\TRIVP (IF\PRED FM)) + NIL + (NODE\NAME (IF\PRED FM))))) + (LET ((ICONT (IF CVAR + (CNODIFY (CONS-CVARIABLE (VAR = CVAR))) + CONT)) + (IPRED (IF PVAR + (CNODIFY (CONS-CVARIABLE (VAR = PVAR))) + (CNODIFY (CONS-TRIVIAL (NODE = (IF\PRED FM))))))) + (LET ((CIF (CNODIFY + (CONS-CIF + (PRED = IPRED) + (CON = (CONVERT (IF\CON FM) ICONT MP)) + (ALT = (CONVERT (IF\ALT FM) + (CNODIFY + (CONS-CVARIABLE + (VAR = (CVARIABLE\VAR + (CNODE\CFORM ICONT))))) + MP)))))) + (LET ((FOO (IF PVAR + (CONVERT (IF\PRED FM) + (CNODIFY (CONS-CONTINUATION (VAR = PVAR) + (BODY = CIF))) + MP) + CIF))) + (IF CVAR + (CNODIFY + (CONS-CCOMBINATION + (ARGS = (LIST (CNODIFY + (CONS-CLAMBDA + (VARS = (LIST CVAR)) + (BODY = FOO))) + CONT)))) + FOO)))))))) + +(DEFINE CONVERT-ASET + (LAMBDA (NODE FM CONT MP) + (IF (NODE\TRIVP NODE) + (MAKE-RETURN (CONS-TRIVIAL (NODE = NODE)) CONT) + (CONVERT (ASET\BODY FM) + (LET ((NM (NODE\NAME (ASET\BODY FM)))) + (CNODIFY + (CONS-CONTINUATION + (VAR = NM) + (BODY = (CNODIFY + (CONS-CASET + (CONT = CONT) + (VAR = (ASET\VAR FM)) + (BODY = (CNODIFY (CONS-CVARIABLE + (VAR = NM)))))))))) + MP)))) + +;;; ISSUES FOR CONVERTING CATCH: +;;; (1) MUST BIND THE CATCH VARIABLE TO A FUNNY FUNCTION WHICH IGNORES ITS CONTINUATION: +;;; (2) IF CONTINUATION IS NON-CVARIABLE, MUST BIND A VARIABLE TO IT. + +(DEFINE + CONVERT-CATCH + (LAMBDA (NODE FM CONT MP) + (LET ((CVAR (IF (EQ (TYPE (CNODE\CFORM CONT)) 'CVARIABLE) + NIL + (GENTEMP 'CONT)))) + (LET ((ICONT (IF CVAR + (CNODIFY (CONS-CVARIABLE (VAR = CVAR))) + CONT))) + (LET ((CP (CNODIFY + (CONS-CCOMBINATION + (ARGS = (LIST (CNODIFY + (CONS-CLAMBDA + (VARS = (LIST (CATCH\VAR FM))) + (BODY = (CONVERT (CATCH\BODY FM) ICONT MP)))) + (CNODIFY + (CONS-CLAMBDA + (VARS = '(*IGNORE* V)) + (BODY = (MAKE-RETURN + (CONS-CVARIABLE (VAR = 'V)) + (CNODIFY + (CONS-CVARIABLE + (VAR = (CVARIABLE\VAR + (CNODE\CFORM ICONT))))))))))))))) + (IF CVAR (CNODIFY + (CONS-CCOMBINATION + (ARGS = (LIST (CNODIFY + (CONS-CLAMBDA (VARS = (LIST CVAR)) + (BODY = CP))) + CONT)))) + CP)))))) + +;;; ISSUES FOR CONVERTING LABELS: +;;; (1) MUST CONVERT ALL THE NAMED LAMBDA-EXPRESSIONS, USING A NULL CONTINUATION. +;;; (2) TO MAKE THINGS EASIER LATER, WE FORBID ASET ON A LABELS VARIABLE. + +(DEFINE CONVERT-LABELS + (LAMBDA (NODE FM CONT MP) + (DO ((F (LABELS\FNDEFS FM) (CDR F)) + (V (LABELS\FNVARS FM) (CDR V)) + (CF NIL (CONS (CONVERT (CAR F) NIL MP) CF))) + ((NULL F) + (CNODIFY (CONS-CLABELS (FNVARS = (LABELS\FNVARS FM)) + (FNDEFS = (NREVERSE CF)) + (BODY = (CONVERT (LABELS\BODY FM) CONT MP))))) + (AND (GET (CAR V) 'WRITE-REFS) + (ERROR '|Are you crazy, using ASET on a LABELS variable?| + (CAR V) + 'FAIL-ACT))))) + +;;; ISSUES FOR CONVERTING COMBINATIONS: +;;; (1) TRIVIAL ARGUMENT EVALUATIONS ARE DELAYED AND ARE NOT BOUND TO THE VARIABLE OF +;;; A CONTINUATION. WE ASSUME THEREBY THAT THE COMPILER IS PERMITTED TO EVALUATE +;;; OPERANDS IN ANY ORDER. +;;; (2) ALL NON-DELAYABLE COMPUTATIONS ARE ASSIGNED NAMES AND STRUNG OUT WITH CONTINUATIONS. +;;; (3) IF CONT IS A CVARIABLE AND THE COMBINATION IS ((LAMBDA ...) ...) THEN WHEN CONVERTING +;;; THE LAMBDA-EXPRESSION WE ARRANGE FOR ITS BODY TO REFER TO THE CVARIABLE CONT RATHER +;;; THAN TO ITS OWN CONTINUATION. THIS CROCK EFFECTIVELY PERFORMS THE OPTIMIZATION OF +;;; SUBSTITUTING ONE VARIABLE FOR ANOTHER, ONLY ON CONTINUATION VARIABLES (WHICH COULDN'T +;;; BE CAUGHT BY META-EVALUATE). + +(DEFINE + CONVERT-COMBINATION + (LAMBDA (NODE FM CONT MP) + (IF (NODE\TRIVP NODE) + (MAKE-RETURN (CONS-TRIVIAL (NODE = NODE)) CONT) + (DO ((A (COMBINATION\ARGS FM) (CDR A)) + (DELAY-FLAGS NIL + (CONS (OR (NODE\TRIVP (CAR A)) + (EQ (TYPE (NODE\FORM (CAR A))) 'LAMBDA)) + DELAY-FLAGS))) + ((NULL A) + (DO ((A (REVERSE (COMBINATION\ARGS FM)) (CDR A)) + (D DELAY-FLAGS (CDR D)) + (F (CNODIFY + (CONS-CCOMBINATION + (ARGS = (DO ((A (REVERSE (COMBINATION\ARGS FM)) (CDR A)) + (D DELAY-FLAGS (CDR D)) + (Z NIL (CONS (IF (CAR D) + (IF (EQ (TYPE (NODE\FORM (CAR A))) + 'LAMBDA) + (CNODIFY + (CONVERT-LAMBDA-FM + (CAR A) + (AND (NULL (CDR A)) + (EQ (TYPE + (CNODE\CFORM CONT)) + 'CVARIABLE) + (CVARIABLE\VAR + (CNODE\CFORM CONT))) + MP)) + (CNODIFY + (CONS-TRIVIAL + (NODE = (CAR A))))) + (CNODIFY + (CONS-CVARIABLE + (VAR = (NODE\NAME (CAR A)))))) + Z))) + ((NULL A) (CONS (CAR Z) (CONS CONT (CDR Z)))))))) + (IF (CAR D) F + (CONVERT (CAR A) + (CNODIFY (CONS-CONTINUATION + (VAR = (NODE\NAME (CAR A))) + (BODY = F))) + MP)))) + ((NULL A) F))))))) + +;;; ENVIRONMENT ANALYSIS FOR CPS VERSION + +;;; WE WISH TO DETERMINE THE ENVIRONMENT AT EACH CNODE, +;;; AND DETERMINE WHAT VARIABLES ARE BOUND ABOVE AND +;;; REFERRED TO BELOW EACH CNODE. + +;;; FOR EACH CNODE WE FILL IN THESE SLOTS: +;;; ENV THE ENVIRONMENT SEEN AT THAT CNODE (A LIST OF VARS) +;;; REFS VARIABLES BOUND ABOVE AND REFERRED TO BELOW THAT CNODE +;;; FOR EACH VARIABLE REFERRED TO IN NON-FUNCTION POSITION +;;; BY A CVARIABLE OR CTRIVIAL CNODE WE GIVE A NON-NIL VALUE TO THE PROPERTY: +;;; VARIABLE-REFP + +;;; FNP IS NON-NIL IFF CNODE OCCURS IN FUNCTIONAL POSITION + +(DEFINE + CENV-ANALYZE + (LAMBDA (CNODE ENV FNP) + (LET ((CFM (CNODE\CFORM CNODE))) + (ALTER-CNODE CNODE (ENV := ENV)) + (EQCASE (TYPE CFM) + (TRIVIAL + (CENV-TRIV-ANALYZE (TRIVIAL\NODE CFM) FNP) + (ALTER-CNODE CNODE + (REFS := (NODE\REFS (TRIVIAL\NODE CFM))))) + (CVARIABLE + (LET ((V (CVARIABLE\VAR CFM))) + (ADDPROP V CNODE 'READ-REFS) + (OR FNP (PUTPROP V T 'VARIABLE-REFP)) + (ALTER-CNODE CNODE + (REFS := (AND (MEMQ V ENV) + (LIST (CVARIABLE\VAR CFM))))))) + (CLAMBDA + (LET ((B (CLAMBDA\BODY CFM))) + (CENV-ANALYZE B (APPEND (CLAMBDA\VARS CFM) ENV) NIL) + (LET ((REFS (SETDIFF (CNODE\REFS B) (CLAMBDA\VARS CFM)))) + (ALTER-CNODE CNODE (REFS := REFS))))) + (CONTINUATION + (LET ((B (CONTINUATION\BODY CFM))) + (CENV-ANALYZE B (CONS (CONTINUATION\VAR CFM) ENV) NIL) + (LET ((REFS (REMOVE (CONTINUATION\VAR CFM) (CNODE\REFS B)))) + (ALTER-CNODE CNODE (REFS := REFS))))) + (CIF + (LET ((PRED (CIF\PRED CFM)) + (CON (CIF\CON CFM)) + (ALT (CIF\ALT CFM))) + (CENV-ANALYZE PRED ENV NIL) + (CENV-ANALYZE CON ENV NIL) + (CENV-ANALYZE ALT ENV NIL) + (ALTER-CNODE CNODE + (REFS := (UNION (CNODE\REFS PRED) + (UNION (CNODE\REFS CON) + (CNODE\REFS ALT))))))) + (CASET + (LET ((V (CASET\VAR CFM)) + (CN (CASET\CONT CFM)) + (B (CASET\BODY CFM))) + (PUTPROP (CASET\VAR CFM) T 'VARIABLE-REFP) + (CENV-ANALYZE CN ENV T) + (CENV-ANALYZE B ENV NIL) + (ALTER-CNODE CNODE + (REFS := (LET ((R (UNION (CNODE\REFS CN) + (CNODE\REFS B)))) + (IF (MEMQ V ENV) (ADJOIN V R) R)))))) + (CLABELS + (LET ((LENV (APPEND (CLABELS\FNVARS CFM) ENV))) + (DO ((F (CLABELS\FNDEFS CFM) (CDR F)) + (R NIL (UNION R (CNODE\REFS (CAR F))))) + ((NULL F) + (LET ((B (CLABELS\BODY CFM))) + (CENV-ANALYZE B LENV NIL) + (ALTER-CNODE CNODE + (REFS := (SETDIFF (UNION R (CNODE\REFS B)) + (CLABELS\FNVARS CFM)))))) + (CENV-ANALYZE (CAR F) LENV NIL)))) + (CCOMBINATION + (LET ((ARGS (CCOMBINATION\ARGS CFM))) + (CENV-ANALYZE (CAR ARGS) ENV T) + (COND ((AND (EQ (TYPE (CNODE\CFORM (CAR ARGS))) 'TRIVIAL) + (EQ (TYPE (NODE\FORM (TRIVIAL\NODE + (CNODE\CFORM (CAR ARGS))))) + 'VARIABLE) + (TRIVFN (VARIABLE\VAR + (NODE\FORM + (TRIVIAL\NODE + (CNODE\CFORM + (CAR ARGS))))))) + (CENV-ANALYZE (CADR ARGS) ENV T) + (CENV-CCOMBINATION-ANALYZE CNODE + ENV + (CDDR ARGS) + (UNION (CNODE\REFS (CAR ARGS)) + (CNODE\REFS (CADR ARGS))))) + (T (CENV-CCOMBINATION-ANALYZE CNODE + ENV + (CDR ARGS) + (CNODE\REFS (CAR ARGS))))))) + (RETURN + (LET ((C (RETURN\CONT CFM)) + (V (RETURN\VAL CFM))) + (CENV-ANALYZE C ENV T) + (CENV-ANALYZE V ENV NIL) + (ALTER-CNODE CNODE + (REFS := (UNION (CNODE\REFS C) (CNODE\REFS V)))))))))) + +;;; THIS FUNCTION MUST GO THROUGH AND LOCATE VARIABLES APPEARING IN NON-FUNCTION POSITION. + +(DEFINE CENV-TRIV-ANALYZE + (LAMBDA (NODE FNP) + (LET ((FM (NODE\FORM NODE))) + (EQCASE (TYPE FM) + (CONSTANT NIL) + (VARIABLE + (OR FNP (PUTPROP (VARIABLE\VAR FM) T 'VARIABLE-REFP))) + (LAMBDA + (OR FNP + (ERROR '|Trivial closure - CENV-TRIV-ANALYZE| NODE 'FAIL-ACT)) + (CENV-TRIV-ANALYZE (LAMBDA\BODY FM) NIL)) + (IF + (CENV-TRIV-ANALYZE (IF\PRED FM) NIL) + (CENV-TRIV-ANALYZE (IF\CON FM) NIL) + (CENV-TRIV-ANALYZE (IF\ALT FM) NIL)) + (ASET + (PUTPROP (ASET\VAR FM) T 'VARIABLE-REFP) + (CENV-TRIV-ANALYZE (ASET\BODY FM) NIL)) + (COMBINATION + (DO ((A (COMBINATION\ARGS FM) (CDR A)) + (F T NIL)) + ((NULL A)) + (CENV-TRIV-ANALYZE (CAR A) F))))))) + +(DEFINE CENV-CCOMBINATION-ANALYZE + (LAMBDA (CNODE ENV ARGS FREFS) + (DO ((A ARGS (CDR A)) + (R FREFS (UNION R (CNODE\REFS (CAR A))))) + ((NULL A) + (ALTER-CNODE CNODE (REFS := R))) + (CENV-ANALYZE (CAR A) ENV NIL)))) + +;;; BINDING ANALYSIS. + +;;; FOR EACH CNODE WE FILL IN: +;;; CLOVARS THE SET OF VARIABLES REFERRED TO BY CLOSURES +;;; AT OR BELOW THIS NODE (SHOULD ALWAYS BE A +;;; SUBSET OF REFS) +;;; FOR EACH CLAMBDA AND CONTINUATION WE FILL IN: +;;; FNP NON-NIL IFF REFERENCED ONLY AS A FUNCTION. +;;; WILL BE 'EZCLOSE IF REFERRED TO BY A CLOSURE, +;;; AND OTHERWISE 'NOCLOSE. +;;; TVARS VARIABLES PASSED THROUGH TEMP LOCATIONS WHEN CALLING +;;; THIS FUNCTION +;;; NAME THE NAME OF THE FUNCTION (USED FOR THE PROG TAG) +;;; FOR EACH CLABELS WE FILL IN: +;;; EASY REFLECTS FNP STATUS OF ALL THE LABELLED FUNCTIONS +;;; FOR EACH VARIABLE WHICH ALWAYS DENOTES A CERTAIN FUNCTION WE +;;; PUT THE PROPERTIES: +;;; KNOWN-FUNCTION IFF THE VARIABLE IS NEVER ASET +;;; THE VALUE OF THE KNOWN-FUNCTION PROPERTY IS THE CNODE FOR +;;; THE FUNCTION DEFINITION. +;;; FOR EACH LABELS VARIABLE IN A LABELS OF THE 'EZCLOSE VARIETY +;;; WE PUT THE PROPERTY: +;;; LABELS-FUNCTION +;;; TO INDICATE THAT ITS `EASY` CLOSURE MUST BE CDR'D TO GET THE +;;; CORRECT ENVIRONMENT (SEE PRODUCE-LABELS). + +;;; NAME, IF NON-NIL, IS A SUGGESTED NAME FOR THE FUNCTION + +(DEFINE BIND-ANALYZE + (LAMBDA (CNODE FNP NAME) + (LET ((CFM (CNODE\CFORM CNODE))) + (EQCASE (TYPE CFM) + (TRIVIAL + (ALTER-CNODE CNODE (CLOVARS := NIL))) + (CVARIABLE + (ALTER-CNODE CNODE (CLOVARS := NIL))) + (CLAMBDA + (BIND-ANALYZE-CLAMBDA CNODE FNP NAME CFM)) + (CONTINUATION + (BIND-ANALYZE-CONTINUATION CNODE FNP NAME CFM)) + (CIF + (BIND-ANALYZE-CIF CNODE CFM)) + (CASET + (BIND-ANALYZE-CASET CNODE CFM)) + (CLABELS + (BIND-ANALYZE-CLABELS CNODE CFM)) + (CCOMBINATION + (BIND-ANALYZE-CCOMBINATION CNODE CFM)) + (RETURN + (BIND-ANALYZE-RETURN CNODE CFM)))))) + +(DEFINE REFD-VARS + (LAMBDA (VARS) + (DO ((V VARS (CDR V)) + (W NIL (IF (OR (GET (CAR V) 'READ-REFS) + (GET (CAR V) 'WRITE-REFS)) + (CONS (CAR V) W) + W))) + ((NULL V) (NREVERSE W))))) + +(DEFINE BIND-ANALYZE-CLAMBDA + (LAMBDA (CNODE FNP NAME CFM) + (BLOCK (BIND-ANALYZE (CLAMBDA\BODY CFM) NIL NIL) + (ALTER-CNODE CNODE + (CLOVARS := (IF (EQ FNP 'NOCLOSE) + (CNODE\CLOVARS (CLAMBDA\BODY CFM)) + (CNODE\REFS CNODE)))) + (ALTER-CLAMBDA CFM + (FNP := FNP) + (TVARS := (IF (EQ FNP 'NOCLOSE) + (REFD-VARS (CLAMBDA\VARS CFM)) + NIL)) + (NAME := (OR NAME (GENTEMP 'F))))))) + +(DEFINE BIND-ANALYZE-CONTINUATION + (LAMBDA (CNODE FNP NAME CFM) + (BLOCK (BIND-ANALYZE (CONTINUATION\BODY CFM) NIL NIL) + (ALTER-CNODE CNODE + (CLOVARS := (IF (EQ FNP 'NOCLOSE) + (CNODE\CLOVARS (CONTINUATION\BODY CFM)) + (CNODE\REFS CNODE)))) + (ALTER-CONTINUATION CFM + (FNP := FNP) + (TVARS := (IF (EQ FNP 'NOCLOSE) + (REFD-VARS (LIST (CONTINUATION\VAR CFM))) + NIL)) + (NAME := (OR NAME (GENTEMP 'C))))))) + +(DEFINE BIND-ANALYZE-CIF + (LAMBDA (CNODE CFM) + (BLOCK (BIND-ANALYZE (CIF\PRED CFM) NIL NIL) + (BIND-ANALYZE (CIF\CON CFM) NIL NIL) + (BIND-ANALYZE (CIF\ALT CFM) NIL NIL) + (ALTER-CNODE CNODE + (CLOVARS := (UNION (CNODE\CLOVARS (CIF\PRED CFM)) + (UNION (CNODE\CLOVARS (CIF\CON CFM)) + (CNODE\CLOVARS (CIF\ALT CFM))))))))) + +(DEFINE BIND-ANALYZE-CASET + (LAMBDA (CNODE CFM) + (LET ((CN (CASET\CONT CFM)) + (VAL (CASET\BODY CFM))) + (BIND-ANALYZE CN 'NOCLOSE NIL) + (COND ((AND (EQ (TYPE (CNODE\CFORM CN)) 'CONTINUATION) + (EQ (TYPE (CNODE\CFORM VAL)) 'CLAMBDA)) + (LET ((VAR (CONTINUATION\VAR (CNODE\CFORM CN)))) + (PUTPROP VAR VAL 'KNOWN-FUNCTION) + (BIND-ANALYZE VAL + (AND (NOT (GET VAR 'VARIABLE-REFP)) + (IF (MEMQ VAR + (CNODE\CLOVARS + (CONTINUATION\BODY + (CNODE\CFORM CN)))) + 'EZCLOSE + (BLOCK (ALTER-CONTINUATION (CNODE\CFORM CN) + (TVARS := NIL)) + 'NOCLOSE))) + NIL))) + (T (BIND-ANALYZE VAL NIL NIL))) + (ALTER-CNODE CNODE + (CLOVARS := (UNION (CNODE\CLOVARS CN) + (CNODE\CLOVARS VAL))))))) + +(DEFINE BIND-ANALYZE-CLABELS + (LAMBDA (CNODE CFM) + (BLOCK (BIND-ANALYZE (CLABELS\BODY CFM) NIL NIL) + (DO ((V (CLABELS\FNVARS CFM) (CDR V)) + (D (CLABELS\FNDEFS CFM) (CDR D)) + (EZ 'NOCLOSE (AND (NULL (GET (CAR V) 'VARIABLE-REFP)) EZ))) + ((NULL V) + (ALTER-CLABELS CFM (EASY := EZ)) + (DO ((V (CLABELS\FNVARS CFM) (CDR V)) + (D (CLABELS\FNDEFS CFM) (CDR D)) + (CV (CNODE\CLOVARS (CLABELS\BODY CFM)) + (UNION CV (CNODE\CLOVARS (CAR D))))) + ((NULL D) + (ALTER-CNODE CNODE (CLOVARS := CV)) + (COND ((AND EZ (INTERSECT CV (LABELS\FNVARS CFM))) + (DO ((D (CLABELS\FNDEFS CFM) (CDR D)) + (CV (CNODE\CLOVARS (CLABELS\BODY CFM)) + (UNION CV (CNODE\CLOVARS (CAR D))))) + ((NULL D) + (ALTER-CNODE CNODE (CLOVARS := CV))) + (ALTER-CLAMBDA (CNODE\CFORM (CAR D)) + (FNP := 'EZCLOSE) + (TVARS := NIL)) + (ALTER-CNODE (CAR D) + (CLOVARS := (CNODE\REFS (CAR D))))) + (AMAPC (LAMBDA (V) (PUTPROP V T 'LABELS-FUNCTION)) + (CLABELS\FNVARS CFM)) + (ALTER-CLABELS CFM (EASY := 'EZCLOSE))))) + (BIND-ANALYZE (CAR D) EZ (CAR V)))) + (PUTPROP (CAR V) (CAR D) 'KNOWN-FUNCTION))))) + +(DEFINE BIND-ANALYZE-RETURN + (LAMBDA (CNODE CFM) + (LET ((CN (RETURN\CONT CFM)) + (VAL (RETURN\VAL CFM))) + (BIND-ANALYZE CN 'NOCLOSE NIL) + (COND ((AND (EQ (TYPE (CNODE\CFORM CN)) 'CONTINUATION) + (EQ (TYPE (CNODE\CFORM VAL)) 'CLAMBDA)) + (LET ((VAR (CONTINUATION\VAR (CNODE\CFORM CN)))) + (PUTPROP VAR VAL 'KNOWN-FUNCTION) + (BIND-ANALYZE VAL + (AND (NOT (GET VAR 'VARIABLE-REFP)) + (IF (MEMQ VAR + (CNODE\CLOVARS + (CONTINUATION\BODY + (CNODE\CFORM CN)))) + 'EZCLOSE + (BLOCK (ALTER-CONTINUATION (CNODE\CFORM CN) + (TVARS := NIL)) + 'NOCLOSE))) + NIL))) + (T (BIND-ANALYZE VAL NIL NIL))) + (ALTER-CNODE CNODE + (CLOVARS := (UNION (CNODE\CLOVARS CN) + (CNODE\CLOVARS VAL))))))) + +(DEFINE BIND-ANALYZE-CCOMBINATION + (LAMBDA (CNODE CFM) + (LET ((ARGS (CCOMBINATION\ARGS CFM))) + (BIND-ANALYZE (CAR ARGS) 'NOCLOSE NIL) + (LET ((FN (CNODE\CFORM (CAR ARGS)))) + (COND ((AND (EQ (TYPE FN) 'TRIVIAL) + (EQ (TYPE (NODE\FORM (TRIVIAL\NODE FN))) + 'VARIABLE) + (TRIVFN (VARIABLE\VAR (NODE\FORM (TRIVIAL\NODE FN))))) + (BIND-ANALYZE (CADR ARGS) 'NOCLOSE NIL) + (BIND-CCOMBINATION-ANALYZE CNODE + (CDDR ARGS) + NIL + (CNODE\CLOVARS (CADR ARGS)))) + ((EQ (TYPE FN) 'CLAMBDA) + (BIND-CCOMBINATION-ANALYZE CNODE + (CDR ARGS) + (CLAMBDA\VARS FN) + (CNODE\CLOVARS (CAR ARGS))) + (AMAPC (LAMBDA (V) + (IF (LET ((KFN (GET V 'KNOWN-FUNCTION))) + (AND KFN + (EQ (EQCASE (TYPE (CNODE\CFORM KFN)) + (CLAMBDA + (CLAMBDA\FNP + (CNODE\CFORM KFN))) + (CONTINUATION + (CONTINUATION\FNP + (CNODE\CFORM KFN)))) + 'NOCLOSE))) + (ALTER-CLAMBDA + FN + (TVARS := (DELQ V (CLAMBDA\TVARS FN)))))) + (CLAMBDA\TVARS FN))) + (T (BIND-CCOMBINATION-ANALYZE CNODE + (CDR ARGS) + NIL + (CNODE\CLOVARS (CAR ARGS))))))))) + +;;; VARS MAY BE NIL - WE DEPEND ON (CDR NIL)=NIL. + +(DEFINE BIND-CCOMBINATION-ANALYZE + (LAMBDA (CNODE ARGS VARS FCV) + (DO ((A ARGS (CDR A)) + (V VARS (CDR V)) + (CV FCV (UNION CV (CNODE\CLOVARS (CAR A))))) + ((NULL A) + (ALTER-CNODE CNODE (CLOVARS := CV))) + (COND ((AND VARS + (MEMQ (TYPE (CNODE\CFORM (CAR A))) '(CLAMBDA CONTINUATION)) + (NOT (GET (CAR V) 'WRITE-REFS))) + (PUTPROP (CAR V) (CAR A) 'KNOWN-FUNCTION) + (BIND-ANALYZE (CAR A) + (AND (NOT (GET (CAR V) 'VARIABLE-REFP)) + (IF (MEMQ (CAR V) FCV) + 'EZCLOSE + 'NOCLOSE)) + NIL)) + (T (BIND-ANALYZE (CAR A) NIL NIL)))))) + +;;; DEPTH ANALYSIS FOR CPS VERSION. + +;;; FOR EACH CLAMBDA AND CONTINUATION WE FILL IN: +;;; DEP DEPTH OF TEMP VAR USAGE AT THIS POINT +;;; MAXDEP MAX DEPTH BELOW THIS POINT + +;;; VALUE OF DEPTH-ANALYZE IS THE MAX DEPTH + +(DEFINE DEPTH-ANALYZE + (LAMBDA (CNODE DEP) + (LET ((CFM (CNODE\CFORM CNODE))) + (EQCASE (TYPE CFM) + (TRIVIAL DEP) + (CVARIABLE DEP) + (CLAMBDA + (LET ((MD (DEPTH-ANALYZE (CLAMBDA\BODY CFM) + (IF (EQ (CLAMBDA\FNP CFM) 'NOCLOSE) + (+ DEP (LENGTH (CLAMBDA\TVARS CFM))) + (MIN (LENGTH (CLAMBDA\VARS CFM)) + (+ 1 **NUMBER-OF-ARG-REGS**)))))) + (ALTER-CLAMBDA + CFM + (DEP := (IF (EQ (CLAMBDA\FNP CFM) 'NOCLOSE) DEP 0)) + (MAXDEP := MD)) + MD)) + (CONTINUATION + (LET ((MD (DEPTH-ANALYZE + (CONTINUATION\BODY CFM) + (IF (EQ (CONTINUATION\FNP CFM) 'NOCLOSE) + (+ DEP (LENGTH (CONTINUATION\TVARS CFM))) + 2)))) + (ALTER-CONTINUATION + CFM + (DEP := (IF (EQ (CONTINUATION\FNP CFM) 'NOCLOSE) DEP 0)) + (MAXDEP := MD)) + MD)) + (CIF + (MAX (DEPTH-ANALYZE (CIF\PRED CFM) DEP) + (DEPTH-ANALYZE (CIF\CON CFM) DEP) + (DEPTH-ANALYZE (CIF\ALT CFM) DEP))) + (CASET + (MAX (DEPTH-ANALYZE (CASET\CONT CFM) DEP) + (DEPTH-ANALYZE (CASET\BODY CFM) DEP))) + (CLABELS + (LET ((DP (IF (EQ (CLABELS\EASY CFM) 'NOCLOSE) + DEP + (+ DEP (LENGTH (CLABELS\FNVARS CFM)))))) + (DO ((D (CLABELS\FNDEFS CFM) (CDR D)) + (MD (DEPTH-ANALYZE (CLABELS\BODY CFM) DP) + (MAX MD (DEPTH-ANALYZE (CAR D) DP)))) + ((NULL D) MD)))) + (CCOMBINATION + (DO ((A (CCOMBINATION\ARGS CFM) (CDR A)) + (MD 0 (MAX MD (DEPTH-ANALYZE (CAR A) DEP)))) + ((NULL A) MD))) + (RETURN + (MAX (DEPTH-ANALYZE (RETURN\CONT CFM) DEP) + (DEPTH-ANALYZE (RETURN\VAL CFM) DEP))))))) + +;;; CLOSURE ANALYSIS FOR CPS VERSION + +;;; FOR EACH CLAMBDA, CONTINUATION, AND CLABELS WE FILL IN: +;;; CONSENV THE CONSED ENVIRONMENT OF THE CLAMBDA, +;;; CONTINUATION, OR CLABELS (BEFORE ANY +;;; CLOSEREFS HAVE BEEN CONSED ON) +;;; FOR EACH CLAMBDA AND CONTINUATION WE FILL IN: +;;; CLOSEREFS A LIST OF VARIABLES REFERENCED BY THE CLAMBDA +;;; OR CONTINUATION WHICH ARE NOT IN THE CONSED +;;; ENVIRONMENT AT THE POINT OF THE CLAMBDA OR +;;; CONTINUATION AND SO MUST BE CONSED ONTO THE +;;; ENVIRONMENT AT CLOSURE TIME; HOWEVER, THESE +;;; NEED NOT BE CONSED ON IF THE CLAMBDA OR +;;; CONTINUATION IS IN FUNCTION POSITION OF +;;; A FATHER WHICH IS A CCOMBINATION OR RETURN +;;; FOR THE CLAMBDA'S IN THE FNDEFS OF A CLABELS, THESE MAY BE +;;; SLIGHTLY ARTIFICIAL FOR THE SAKE OF OPTIMIZATION (SEE BELOW). +;;; FOR EACH CLAMBDA WE FILL IN: +;;; ASETVARS A LIST OF THE VARIABLES BOUND IN THE CLAMBDA +;;; WHICH ARE EVER ASET AND SO MUST BE CONSED +;;; ONTO THE ENVIRONMENT IMMEDIATELY IF ANY +;;; CLOSURES OCCUR IN THE BODY +;;; FOR EACH CLABELS WE FILL IN: +;;; FNENV VARIABLES TO BE CONSED ONTO THE CURRENT CONSENV +;;; BEFORE CLOSING THE LABELS FUNCTIONS + +;;; CENV IS THE CONSED ENVIRONMENT (A LIST OF VARIABLES) + +(DEFINE FILTER-CLOSEREFS + (LAMBDA (REFS CENV) + (DO ((X REFS (CDR X)) + (Y NIL + (IF (OR (MEMQ (CAR X) CENV) + (LET ((KFN (GET (CAR X) 'KNOWN-FUNCTION))) + (AND KFN + (EQ (EQCASE (TYPE (CNODE\CFORM KFN)) + (CLAMBDA + (CLAMBDA\FNP (CNODE\CFORM KFN))) + (CONTINUATION + (CONTINUATION\FNP (CNODE\CFORM KFN)))) + 'NOCLOSE)))) + Y + (CONS (CAR X) Y)))) + ((NULL X) (NREVERSE Y))))) + +(DEFINE CLOSE-ANALYZE + (LAMBDA (CNODE CENV) + (LET ((CFM (CNODE\CFORM CNODE))) + (EQCASE (TYPE CFM) + (TRIVIAL NIL) + (CVARIABLE NIL) + (CLAMBDA + (LET ((CR (AND (NOT (EQ (CLAMBDA\FNP CFM) 'NOCLOSE)) + (FILTER-CLOSEREFS (CNODE\REFS CNODE) CENV))) + (AV (DO ((V (CLAMBDA\VARS (CNODE\CFORM CNODE)) (CDR V)) + (A NIL (IF (AND (GET (CAR V) 'WRITE-REFS) + (MEMQ (CAR V) + (CNODE\CLOVARS + (CLAMBDA\BODY CFM)))) + (CONS (CAR V) A) + A))) + ((NULL V) A)))) + (ALTER-CLAMBDA CFM + (CONSENV := CENV) + (CLOSEREFS := CR) + (ASETVARS := AV)) + (CLOSE-ANALYZE (CLAMBDA\BODY CFM) + (APPEND AV CR CENV)))) + (CONTINUATION + (AND (GET (CONTINUATION\VAR CFM) 'WRITE-REFS) + (ERROR '|How could an ASET refer to a continuation variable?| + CNODE + 'FAIL-ACT)) + (LET ((CR (AND (NOT (EQ (CONTINUATION\FNP CFM) 'NOCLOSE)) + (FILTER-CLOSEREFS (CNODE\REFS CNODE) CENV)))) + (ALTER-CONTINUATION CFM + (CONSENV := CENV) + (CLOSEREFS := CR)) + (CLOSE-ANALYZE (CONTINUATION\BODY CFM) + (APPEND CR CENV)))) + (CIF + (CLOSE-ANALYZE (CIF\PRED CFM) CENV) + (CLOSE-ANALYZE (CIF\CON CFM) CENV) + (CLOSE-ANALYZE (CIF\ALT CFM) CENV)) + (CASET + (CLOSE-ANALYZE (CASET\CONT CFM) CENV) + (CLOSE-ANALYZE (CASET\BODY CFM) CENV)) + (CLABELS + ((LAMBDA (CENV) + (BLOCK (AMAPC (LAMBDA (D) (CLOSE-ANALYZE D CENV)) + (CLABELS\FNDEFS CFM)) + (CLOSE-ANALYZE (CLABELS\BODY CFM) CENV))) + (COND ((CLABELS\EASY CFM) + (DO ((D (CLABELS\FNDEFS CFM) (CDR D)) + (R NIL (UNION R (CNODE\REFS (CAR D))))) + ((NULL D) + (LET ((E (FILTER-CLOSEREFS R CENV))) + (ALTER-CLABELS CFM + (FNENV := E) + (CONSENV := CENV)) + (APPEND E CENV))))) + (T (ALTER-CLABELS CFM + (FNENV := NIL) + (CONSENV := CENV)) + CENV)))) + (CCOMBINATION + (AMAPC (LAMBDA (A) (CLOSE-ANALYZE A CENV)) + (CCOMBINATION\ARGS CFM))) + (RETURN + (CLOSE-ANALYZE (RETURN\CONT CFM) CENV) + (CLOSE-ANALYZE (RETURN\VAL CFM) CENV)))))) + +;;; CODE GENERATION ROUTINES + +;;; PROGNAME: NAME OF A VARIABLE WHICH AT RUN TIME WILL HAVE +;;; AS VALUE THE SUBR POINTER FOR THE PROG +;;; FN: THE FUNCTION TO COMPILE (A CLAMBDA OR CONTINUATION CNODE) +;;; EXTERNALP: NON-NIL IF THE FUNCTION IS EXTERNAL +;;; RNL: INITIAL RENAME LIST (NON-NIL ONLY FOR NOCLOSE FNS). +;;; ENTRIES ARE: (VAR . CODE) +;;; BLOCKFNS: AN ALIST OF FUNCTIONS IN THIS BLOCK. +;;; ENTRIES ARE: (USERNAME CNODE) +;;; FNS: A LIST OF TUPLES FOR FUNCTIONS YET TO BE COMPILED; +;;; EACH TUPLE IS (PROGNAME FN RNL) +;;; C: A CONTINUATION, TAKING: +;;; CODE: THE PIECE OF MACLISP CODE FOR THE FUNCTION +;;; FNS: AN AUGMENTED FNS LIST + +(DEFINE COMPILATE + (LAMBDA (PROGNAME FN RNL BLOCKFNS FNS C) + (LET ((CFM (CNODE\CFORM FN))) + (EQCASE (TYPE CFM) + (CLAMBDA + (LET ((CENV (APPEND (CLAMBDA\ASETVARS CFM) + (CLAMBDA\CLOSEREFS CFM) + (CLAMBDA\CONSENV CFM)))) + (COMP-BODY (CLAMBDA\BODY CFM) + (REGSLIST CFM T (ENVCARCDR CENV RNL)) + PROGNAME + BLOCKFNS + CENV + FNS + (LAMBDA (CODE FNS) + (C (SET-UP-ASETVARS CODE + (CLAMBDA\ASETVARS CFM) + (REGSLIST CFM NIL NIL)) + FNS))))) + (CONTINUATION + (LET ((CENV (APPEND (CONTINUATION\CLOSEREFS CFM) + (CONTINUATION\CONSENV CFM)))) + (COMP-BODY (CONTINUATION\BODY CFM) + (IF (EQ (CONTINUATION\FNP CFM) 'NOCLOSE) + (IF (NULL (CONTINUATION\TVARS CFM)) + (ENVCARCDR CENV RNL) + (CONS (CONS (CONTINUATION\VAR CFM) + (TEMPLOC (CONTINUATION\DEP CFM))) + (ENVCARCDR CENV RNL))) + (CONS (CONS (CONTINUATION\VAR CFM) + (CAR **ARGUMENT-REGISTERS**)) + (ENVCARCDR CENV RNL))) + PROGNAME + BLOCKFNS + CENV + FNS + C))))))) + +;;; DEPROGNIFY IS USED ONLY TO MAKE THE OUTPUT PRETTY BY ELIMINATING +;;; UNNECESSARY OCCURRENCES OF `PROGN`. + +(DEFMAC DEPROGNIFY (FORM) `(DEPROGNIFY1 ,FORM NIL)) + +(SET' *DEPROGNIFY-COUNT* 0) + +(DEFINE DEPROGNIFY1 + (LAMBDA (FORM ATOMFLUSHP) + (IF (OR (ATOM FORM) (NOT (EQ (CAR FORM) 'PROGN))) + (LIST FORM) + (DO ((X (CDR FORM) (CDR X)) + (Z NIL (COND ((NULL (CDR X)) (CONS (CAR X) Z)) + ((NULL (CAR X)) + (INCREMENT *DEPROGNIFY-COUNT*) + Z) + ((ATOM (CAR X)) + (COND (ATOMFLUSHP + (INCREMENT *DEPROGNIFY-COUNT*) + Z) + (T (CONS (CAR X) Z)))) + ((EQ (CAAR X) 'QUOTE) + (INCREMENT *DEPROGNIFY-COUNT*) + Z) + (T (CONS (CAR X) Z))))) + ((NULL X) (NREVERSE Z)))))) + +(DEFINE TEMPLOC + (LAMBDA (N) + (LABELS ((LOOP + (LAMBDA (REGS J) + (IF (NULL REGS) + (IMPLODE (APPEND '(-) (EXPLODEN N) '(-))) + (IF (= J 0) + (CAR REGS) + (LOOP (CDR REGS) (- J 1))))))) + (LOOP **CONT+ARG-REGS** N)))) + +(DEFINE ENVCARCDR + (LAMBDA (VARS RNL) + (DO ((X '**ENV** `(CDR ,X)) + (V VARS (CDR V)) + (R RNL (CONS (CONS (CAR V) (DECARCDRATE `(CAR ,X))) R))) + ((NULL V) R)))) + +;;; AVP NON-NIL MEANS THAT ASETVARS ARE TO BE EXCLUDED FROM THE CONSED LIST. + +(DEFINE REGSLIST + (LAMBDA (CLAM AVP RNL) + (LET ((AV (AND AVP (CLAMBDA\ASETVARS CLAM)))) + (IF (EQ (CLAMBDA\FNP CLAM) 'NOCLOSE) + (DO ((J (CLAMBDA\DEP CLAM) (+ J 1)) + (TV (CLAMBDA\TVARS CLAM) (CDR TV)) + (R RNL + (IF (MEMQ (CAR TV) AV) + R + (CONS (CONS (CAR TV) (TEMPLOC J)) R)))) + ((NULL TV) R)) + (LET ((VARS (CLAMBDA\VARS CLAM))) + (IF (> (LENGTH (CDR VARS)) **NUMBER-OF-ARG-REGS**) + (DO ((X (CAR **ARGUMENT-REGISTERS**) `(CDR ,X)) + (V (CDR VARS) (CDR V)) + (R (CONS (CONS (CAR VARS) '**CONT**) RNL) + (IF (MEMQ (CAR V) AV) + R + (CONS (CONS (CAR V) (DECARCDRATE `(CAR ,X))) R)))) + ((NULL V) R)) + (DO ((V VARS (CDR V)) + (X **CONT+ARG-REGS** (CDR X)) + (R RNL + (IF (MEMQ (CAR V) AV) + R + (CONS (CONS (CAR V) (CAR X)) R)))) + ((NULL V) R)))))))) + +(DEFINE SET-UP-ASETVARS + (LAMBDA (CODE AV RNL) + (IF (NULL AV) + CODE + `(PROGN (SETQ **ENV** + ,(DO ((A (REVERSE AV) (CDR A)) + (E '**ENV** `(CONS ,(LOOKUPICATE (CAR A) RNL) ,E))) + ((NULL A) E))) + ,@(DEPROGNIFY CODE))))) + +;;; RNL IS THE `RENAME LIST`: AN ALIST DESCRIBING HOW TO REFER TO THE VARIABLES IN THE +;;; ENVIRONMENT. CENV IS THE CONSED ENVIRONMENT SEEN BY THE BODY. + +(DEFINE + COMP-BODY + (LAMBDA (BODY RNL PROGNAME BLOCKFNS CENV FNS C) + (LET ((CFM (CNODE\CFORM BODY))) + (EQCASE (TYPE CFM) + (CIF + (PRODUCE-IF BODY RNL PROGNAME BLOCKFNS CENV FNS C)) + (CASET + (PRODUCE-ASET BODY RNL PROGNAME BLOCKFNS CENV FNS C)) + (CLABELS + (OR (EQUAL CENV (CLABELS\CONSENV CFM)) + (ERROR '|Environment disagreement| BODY 'FAIL-ACT)) + (LET ((LCENV (APPEND (CLABELS\FNENV CFM) CENV))) + (COMP-BODY + (CLABELS\BODY CFM) + (ENVCARCDR LCENV RNL) + PROGNAME + BLOCKFNS + LCENV + FNS + (LAMBDA (LBOD FNS) + (PRODUCE-LABELS BODY LBOD RNL PROGNAME BLOCKFNS FNS C))))) + (CCOMBINATION + (LET ((FN (CNODE\CFORM (CAR (CCOMBINATION\ARGS CFM))))) + (COND ((EQ (TYPE FN) 'CLAMBDA) + (PRODUCE-LAMBDA-COMBINATION BODY RNL PROGNAME BLOCKFNS CENV FNS C)) + ((AND (EQ (TYPE FN) 'TRIVIAL) + (EQ (TYPE (NODE\FORM (TRIVIAL\NODE FN))) 'VARIABLE) + (TRIVFN (VARIABLE\VAR (NODE\FORM (TRIVIAL\NODE FN))))) + (PRODUCE-TRIVFN-COMBINATION BODY RNL PROGNAME BLOCKFNS CENV FNS C)) + (T (PRODUCE-COMBINATION BODY RNL PROGNAME BLOCKFNS CENV FNS C))))) + (RETURN + (LET ((FN (CNODE\CFORM (RETURN\CONT CFM)))) + (IF (EQ (TYPE FN) 'CONTINUATION) + (PRODUCE-CONTINUATION-RETURN BODY RNL PROGNAME BLOCKFNS CENV FNS C) + (PRODUCE-RETURN BODY RNL PROGNAME BLOCKFNS CENV FNS C)))))))) + +(DEFINE PRODUCE-IF + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C) + (LET ((CFM (CNODE\CFORM CNODE))) + (ANALYZE (CIF\PRED CFM) + RNL + PROGNAME + BLOCKFNS + FNS + (LAMBDA (PRED FNS) + (COMP-BODY (CIF\CON CFM) + RNL + PROGNAME + BLOCKFNS + CENV + FNS + (LAMBDA (CON FNS) + (COMP-BODY (CIF\ALT CFM) + RNL + PROGNAME + BLOCKFNS + CENV + FNS + (LAMBDA (ALT FNS) + (C (CONDICATE PRED + CON + ALT) + FNS)))))))))) + +(DEFINE + PRODUCE-ASET + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C) + (LET ((CFM (CNODE\CFORM CNODE))) + (ANALYZE (CASET\BODY CFM) + RNL + PROGNAME + BLOCKFNS + FNS + (LAMBDA (BODY FNS) + (LET ((CONTCFM (CNODE\CFORM (CASET\CONT CFM)))) + (IF (EQ (TYPE CONTCFM) 'CONTINUATION) + (COMP-BODY (CONTINUATION\BODY CONTCFM) + (IF (CONTINUATION\TVARS CONTCFM) + (CONS (CONS (CAR (CONTINUATION\TVARS CONTCFM)) + (TEMPLOC (CONTINUATION\DEP + CONTCFM))) + (ENVCARCDR CENV RNL)) + (ENVCARCDR CENV RNL)) + PROGNAME + BLOCKFNS + CENV + FNS + (LAMBDA (CODE FNS) + (C (LAMBDACATE + (LIST (CONTINUATION\VAR CONTCFM)) + (CONTINUATION\TVARS CONTCFM) + (CONTINUATION\DEP CONTCFM) + (LIST (OUTPUT-ASET + (LOOKUPICATE (CASET\VAR CFM) + RNL) + BODY)) + (REMARK-ON (CASET\CONT CFM)) + '**ENV** + CODE) + FNS))) + (ANALYZE + (CASET\CONT CFM) + RNL + PROGNAME + BLOCKFNS + FNS + (LAMBDA (CONT FNS) + (C `(PROGN (SETQ **FUN** ,CONT) + (SETQ ,(CAR **ARGUMENT-REGISTERS**) + ,(OUTPUT-ASET + (LOOKUPICATE (CASET\VAR CFM) + RNL) + BODY)) + (RETURN NIL)) + FNS)))))))))) + +(DEFINE + PRODUCE-LABELS + (LAMBDA (CNODE LBOD RNL PROGNAME BLOCKFNS FNS C) + (LET ((CFM (CNODE\CFORM CNODE))) + (LET ((VARS (CLABELS\FNVARS CFM)) + (DEFS (CLABELS\FNDEFS CFM)) + (FNENV (CLABELS\FNENV CFM))) + (LET ((FNENV-FIX (IF FNENV `((SETQ **ENV** ,(CONS-CLOSEREFS FNENV RNL)))))) + (EQCASE (CLABELS\EASY CFM) + (NIL + (DO ((V VARS (CDR V)) + (D DEFS (CDR D)) + (FNS FNS (CONS (LIST PROGNAME (CAR D) NIL) FNS)) + (RP NIL (CONS `(RPLACD (CDDR ,(CAR V)) + ,(CONS-CLOSEREFS + (CLAMBDA\CLOSEREFS + (CNODE\CFORM (CAR D))) + RNL)) + RP)) + (CB NIL (CONS `(LIST 'CBETA ,PROGNAME ',(CAR V)) CB))) + ((NULL V) + (C `((LAMBDA ,VARS + ,@FNENV-FIX + ,@RP + ,@(DEPROGNIFY LBOD)) + ,@(NREVERSE CB)) + FNS)))) + (EZCLOSE + (DO ((V VARS (CDR V)) + (D DEFS (CDR D)) + (FNS FNS (CONS (LIST PROGNAME (CAR D) NIL) FNS)) + (RP NIL (CONS `(RPLACD ,(CAR V) + ,(CONS-CLOSEREFS + (CLAMBDA\CLOSEREFS + (CNODE\CFORM (CAR D))) + RNL)) + RP)) + (CB NIL (CONS `(LIST ',(CAR V)) CB))) + ((NULL V) + (C `((LAMBDA ,VARS + ,@FNENV-FIX + ,@RP + ,@(DEPROGNIFY LBOD)) + ,@(NREVERSE CB)) + FNS)))) + (NOCLOSE + (C `(PROGN ,@FNENV-FIX ,@(DEPROGNIFY LBOD)) + (DO ((V VARS (CDR V)) + (D DEFS (CDR D)) + (FNS FNS (CONS (LIST PROGNAME (CAR D) RNL) FNS))) + ((NULL V) FNS)))))))))) + +(DEFINE + PRODUCE-LAMBDA-COMBINATION + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C) + (LET ((CFM (CNODE\CFORM CNODE))) + (LET ((FN (CNODE\CFORM (CAR (CCOMBINATION\ARGS CFM))))) + (AND (CLAMBDA\CLOSEREFS FN) + (ERROR '|Functional LAMBDA has CLOSEREFS| CNODE 'FAIL-ACT)) + (OR (EQUAL CENV (CLAMBDA\CONSENV FN)) + (ERROR '|Environment disagreement| CNODE 'FAIL-ACT)) + (OR (EQ (CLAMBDA\FNP FN) 'NOCLOSE) + (ERROR '|Non-NOCLOSE LAMBDA in function position| CNODE 'FAIL-ACT)) + (COMP-BODY + (CLAMBDA\BODY FN) + (ENVCARCDR (CLAMBDA\ASETVARS FN) + (REGSLIST FN T (ENVCARCDR CENV RNL))) + PROGNAME + BLOCKFNS + (APPEND (CLAMBDA\ASETVARS FN) CENV) + FNS + (LAMBDA (BODY FNS) + (MAPANALYZE (CDR (CCOMBINATION\ARGS CFM)) + RNL + PROGNAME + BLOCKFNS + FNS + (LAMBDA (ARGS FNS) + (C (LAMBDACATE (CLAMBDA\VARS FN) + (CLAMBDA\TVARS FN) + (CLAMBDA\DEP FN) + ARGS + (REMARK-ON + (CAR (CCOMBINATION\ARGS CFM))) + '**ENV** + (SET-UP-ASETVARS + BODY + (CLAMBDA\ASETVARS FN) + (REGSLIST FN NIL NIL))) + FNS))))))))) + +(DEFINE PRODUCE-TRIVFN-COMBINATION + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C) + (LET ((CFM (CNODE\CFORM CNODE))) + (LET ((FN (CNODE\CFORM (CAR (CCOMBINATION\ARGS CFM)))) + (CONT (CNODE\CFORM (CADR (CCOMBINATION\ARGS CFM))))) + (MAPANALYZE (CDDR (CCOMBINATION\ARGS CFM)) + RNL + PROGNAME + BLOCKFNS + FNS + (LAMBDA (ARGS FNS) + (EQCASE (TYPE CONT) + (CONTINUATION + (PRODUCE-TRIVFN-COMBINATION-CONTINUATION + CNODE RNL PROGNAME BLOCKFNS CENV + FNS C CFM FN CONT ARGS)) + (CVARIABLE + (PRODUCE-TRIVFN-COMBINATION-CVARIABLE + CNODE RNL PROGNAME BLOCKFNS CENV + FNS C CFM FN CONT ARGS))))))))) + +(DEFINE PRODUCE-TRIVFN-COMBINATION-CONTINUATION + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C CFM FN CONT ARGS) + (BLOCK (AND (CONTINUATION\CLOSEREFS CONT) + (ERROR '|CONTINUATION for TRIVFN has CLOSEREFS| CNODE 'FAIL-ACT)) + (OR (EQ (CONTINUATION\FNP CONT) 'NOCLOSE) + (ERROR '|Non-NOCLOSE CONTINUATION for TRIVFN| CNODE 'FAIL-ACT)) + (COMP-BODY (CONTINUATION\BODY CONT) + (IF (CONTINUATION\TVARS CONT) + (CONS (CONS (CAR (CONTINUATION\TVARS CONT)) + (TEMPLOC (CONTINUATION\DEP CONT))) + (ENVCARCDR CENV RNL)) + (ENVCARCDR CENV RNL)) + PROGNAME + BLOCKFNS + CENV + FNS + (LAMBDA (BODY FNS) + (C (LAMBDACATE + (LIST (CONTINUATION\VAR CONT)) + (CONTINUATION\TVARS CONT) + (CONTINUATION\DEP CONT) + (LIST `(,(VARIABLE\VAR (NODE\FORM (TRIVIAL\NODE FN))) + ,@ARGS)) + (REMARK-ON (CADR (CCOMBINATION\ARGS CFM))) + '**ENV** + BODY) + FNS)))))) + +(DEFINE PRODUCE-TRIVFN-COMBINATION-CVARIABLE + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C CFM FN CONT ARGS) + (ANALYZE + (CADR (CCOMBINATION\ARGS CFM)) + RNL + PROGNAME + BLOCKFNS + FNS + (LAMBDA (CONTF FNS) + (LET ((KF (GET (CVARIABLE\VAR CONT) 'KNOWN-FUNCTION)) + (VAL `(,(VARIABLE\VAR (NODE\FORM (TRIVIAL\NODE FN))) ,@ARGS))) + (IF KF + (LET ((KCFM (CNODE\CFORM KF))) + (LET ((ENVADJ + (ADJUST-KNOWNFN-CENV CENV + (CVARIABLE\VAR CONT) + CONTF + (CONTINUATION\FNP KCFM) + (APPEND + (CONTINUATION\CLOSEREFS KCFM) + (CONTINUATION\CONSENV KCFM))))) + (C `(PROGN + ,@(IF (EQ (CONTINUATION\FNP KCFM) + 'NOCLOSE) + (DEPROGNIFY + (LAMBDACATE (LIST (CONTINUATION\VAR KCFM)) + (CONTINUATION\TVARS KCFM) + (CONTINUATION\DEP KCFM) + (LIST VAL) + (REMARK-ON KF) + ENVADJ + NIL)) + (PSETQIFY (LIST ENVADJ VAL) + (LIST '**ENV** + (CAR **ARGUMENT-REGISTERS**)))) + (GO ,(CONTINUATION\NAME KCFM))) + FNS))) + (C `(PROGN (SETQ **FUN** ,CONTF) + (SETQ ,(CAR **ARGUMENT-REGISTERS**) ,VAL) + (RETURN NIL)) + FNS))))))) + +(DEFINE PRODUCE-COMBINATION + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C) + (MAPANALYZE (CCOMBINATION\ARGS (CNODE\CFORM CNODE)) + RNL + PROGNAME + BLOCKFNS + FNS + (LAMBDA (FORM FNS) + (C (LET ((F (CNODE\CFORM (CAR (CCOMBINATION\ARGS + (CNODE\CFORM CNODE)))))) + (IF (AND (EQ (TYPE F) 'TRIVIAL) + (EQ (TYPE (NODE\FORM (TRIVIAL\NODE F))) + 'VARIABLE)) + (LET ((V (VARIABLE\VAR + (NODE\FORM (TRIVIAL\NODE F))))) + (PRODUCE-COMBINATION-VARIABLE + CNODE RNL PROGNAME BLOCKFNS CENV + FNS C FORM V (GET V 'KNOWN-FUNCTION))) + `(PROGN (SETQ **FUN** ,(CAR FORM)) + ,@(PSETQ-ARGS (CDR FORM)) + (SETQ **NARGS** ',(LENGTH (CDDR FORM))) + (RETURN NIL)))) + FNS))))) + +(DEFINE PRODUCE-COMBINATION-VARIABLE + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C FORM V KFN) + (IF KFN + (LET ((ENVADJ + (ADJUST-KNOWNFN-CENV CENV + V + (CAR FORM) + (CLAMBDA\FNP (CNODE\CFORM KFN)) + (APPEND (CLAMBDA\CLOSEREFS (CNODE\CFORM KFN)) + (CLAMBDA\CONSENV (CNODE\CFORM KFN)))))) + (OR (EQ (TYPE (CNODE\CFORM KFN)) 'CLAMBDA) + (ERROR '|Known function not CLAMBDA| CNODE 'FAIL-ACT)) + `(PROGN ,@(IF (EQ (CLAMBDA\FNP (CNODE\CFORM KFN)) 'NOCLOSE) + (DEPROGNIFY + (LAMBDACATE (CLAMBDA\VARS (CNODE\CFORM KFN)) + (CLAMBDA\TVARS (CNODE\CFORM KFN)) + (CLAMBDA\DEP (CNODE\CFORM KFN)) + (CDR FORM) + (REMARK-ON KFN) + ENVADJ + NIL)) + (PSETQ-ARGS-ENV (CDR FORM) ENVADJ)) + (GO ,(CLAMBDA\NAME (CNODE\CFORM KFN))))) + (IF (ASSQ V BLOCKFNS) + `(PROGN ,@(PSETQ-ARGS (CDR FORM)) + ,@(IF (NOT (EQUAL (CLAMBDA\CONSENV + (CNODE\CFORM + (CADR (ASSQ V BLOCKFNS)))) + CENV)) + `((SETQ **ENV** (CDDDR ,(CAR FORM))))) + (GO ,(CLAMBDA\NAME (CNODE\CFORM (CADR (ASSQ V BLOCKFNS)))))) + `(PROGN (SETQ **FUN** ,(CAR FORM)) + ,@(PSETQ-ARGS (CDR FORM)) + (SETQ **NARGS** ',(LENGTH (CDDR FORM))) + (RETURN NIL)))))) + +(DEFINE ADJUST-KNOWNFN-CENV + (LAMBDA (CENV VAR VARREF FNP LCENV) + (COND ((EQUAL LCENV CENV) '**ENV**) + ((NULL LCENV) 'NIL) + (T (EQCASE FNP + (NOCLOSE + (DO ((X CENV (CDR X)) + (Y '**ENV** `(CDR ,Y)) + (I (- (LENGTH CENV) (LENGTH LCENV)) (- I 1))) + ((< I 1) + (IF (EQUAL X LCENV) + (DECARCDRATE Y) + (ERROR '|Cannot recover environment for known function| + VAR + 'FAIL-ACT))))) + (EZCLOSE + (IF (GET VAR 'LABELS-FUNCTION) + `(CDR ,VARREF) + VARREF)) + (NIL `(CDDDR ,VARREF))))))) + +(DEFINE PRODUCE-CONTINUATION-RETURN + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C) + (LET ((CFM (CNODE\CFORM CNODE))) + (LET ((FN (CNODE\CFORM (RETURN\CONT CFM)))) + (AND (CONTINUATION\CLOSEREFS FN) + (ERROR '|Functional CONTINUATION has CLOSEREFS| CNODE 'FAIL-ACT)) + (OR (EQUAL CENV (CONTINUATION\CONSENV FN)) + (ERROR '|Environment disagreement| CNODE 'FAIL-ACT)) + (OR (EQ (CONTINUATION\FNP FN) 'NOCLOSE) + (ERROR '|Non-NOCLOSE CONTINUATION in function position| + CNODE + 'FAIL-ACT)) + (COMP-BODY (CONTINUATION\BODY FN) + (IF (CONTINUATION\TVARS FN) + (CONS (CONS (CAR (CONTINUATION\TVARS FN)) + (TEMPLOC (CONTINUATION\DEP FN))) + (ENVCARCDR CENV RNL)) + (ENVCARCDR CENV RNL)) + PROGNAME + BLOCKFNS + CENV + FNS + (LAMBDA (BODY FNS) + (ANALYZE (RETURN\VAL CFM) + RNL + PROGNAME + BLOCKFNS + FNS + (LAMBDA (VAL FNS) + (C (LAMBDACATE + (LIST (CONTINUATION\VAR FN)) + (CONTINUATION\TVARS FN) + (CONTINUATION\DEP FN) + (LIST VAL) + (REMARK-ON (RETURN\CONT CFM)) + '**ENV** + BODY) + FNS))))))))) + +(DEFINE PRODUCE-RETURN + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C) + (LET ((CFM (CNODE\CFORM CNODE))) + (ANALYZE (RETURN\VAL CFM) + RNL + PROGNAME + BLOCKFNS + FNS + (LAMBDA (VAL FNS) + (ANALYZE (RETURN\CONT CFM) + RNL + PROGNAME + BLOCKFNS + FNS + (LAMBDA (CONT FNS) + (PRODUCE-RETURN-1 + CNODE RNL PROGNAME BLOCKFNS + CENV FNS C CFM VAL CONT)))))))) + +(DEFINE PRODUCE-RETURN-1 + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C CFM VAL CONT) + (IF (AND (EQ (TYPE (CNODE\CFORM (RETURN\CONT CFM))) 'CVARIABLE) + (GET (CVARIABLE\VAR (CNODE\CFORM (RETURN\CONT CFM))) + 'KNOWN-FUNCTION)) + (LET ((KCFM (CNODE\CFORM + (GET (CVARIABLE\VAR + (CNODE\CFORM (RETURN\CONT CFM))) + 'KNOWN-FUNCTION)))) + (OR (EQ (TYPE KCFM) 'CONTINUATION) + (ERROR '|Known function not CONTINUATION| CNODE 'FAIL-ACT)) + (LET ((ENVADJ + (ADJUST-KNOWNFN-CENV CENV + (CVARIABLE\VAR (CNODE\CFORM (RETURN\CONT CFM))) + CONT + (CONTINUATION\FNP KCFM) + (APPEND + (CONTINUATION\CLOSEREFS KCFM) + (CONTINUATION\CONSENV KCFM))))) + (C `(PROGN ,@(IF (EQ (CONTINUATION\FNP KCFM) 'NOCLOSE) + (DEPROGNIFY + (LAMBDACATE (LIST (CONTINUATION\VAR KCFM)) + (CONTINUATION\TVARS KCFM) + (CONTINUATION\DEP KCFM) + (LIST VAL) + (REMARK-ON + (GET (CVARIABLE\VAR + (CNODE\CFORM (RETURN\CONT CFM))) + 'KNOWN-FUNCTION)) + ENVADJ + NIL)) + (PSETQIFY (LIST ENVADJ VAL) + (LIST '**ENV** + (CAR **ARGUMENT-REGISTERS**)))) + (GO ,(CONTINUATION\NAME KCFM))) + FNS))) + (C `(PROGN (SETQ **FUN** ,CONT) + ,@(IF (NOT (EQ VAL (CAR **ARGUMENT-REGISTERS**))) + `((SETQ ,(CAR **ARGUMENT-REGISTERS**) ,VAL))) + (RETURN NIL)) + FNS)))) + +;;; HANDLE CASE OF INVOKING A KNOWN NOCLOSE FUNCTION OR CONTINUATION. +;;; FOR AN EXPLICIT ((LAMBDA ... BODY) ...), BODY IS THE BODY. +;;; OTHERWISE, IT IS NIL, AND SOMEONE WILL DO AN APPROPRIATE GO LATER. + +(DEFINE LAMBDACATE + (LAMBDA (VARS TVARS DEP ARGS REM ENVADJ BODY) + (LABELS ((LOOP + (LAMBDA (V A REALVARS REALARGS EFFARGS) + ;;REALVARS IS COMPUTED PURELY FOR ERROR-CHECKING + (IF (NULL A) + (LET ((B `(PROGN ,@(PSETQ-TEMPS (NREVERSE REALARGS) DEP ENVADJ) + ,REM + ,@(DEPROGNIFY BODY))) + (RV (NREVERSE REALVARS))) + (IF (NOT (EQUAL RV TVARS)) + (ERROR '|TVARS screwup in LAMBDACATE| + `((VARS = ,VARS) + (TVARS = ,TVARS) + (REALVARS = ,RV)) + 'FAIL-ACT)) + (IF EFFARGS + `(PROGN ,@EFFARGS ,@(DEPROGNIFY B)) + B)) + (COND ((LET ((KFN (GET (CAR V) 'KNOWN-FUNCTION))) + (AND KFN + (EQ (EQCASE (TYPE (CNODE\CFORM KFN)) + (CLAMBDA + (CLAMBDA\FNP + (CNODE\CFORM KFN))) + (CONTINUATION + (CONTINUATION\FNP + (CNODE\CFORM KFN)))) + 'NOCLOSE))) + (LOOP (CDR V) (CDR A) REALVARS REALARGS EFFARGS)) + ((OR (GET (CAR V) 'READ-REFS) + (GET (CAR V) 'WRITE-REFS)) + (LOOP (CDR V) + (CDR A) + (CONS (CAR V) REALVARS) + (CONS (CAR A) REALARGS) + EFFARGS)) + (T (LOOP (CDR V) + (CDR A) + REALVARS + REALARGS + (CONS (CAR A) EFFARGS)))))))) + (LOOP VARS ARGS NIL NIL NIL)))) + +;;; GENERATE PARALLEL SETQ'ING OF REGISTERS TO ARGS. +;;; RETURNS A LIST OF THINGS; ONE WRITES ,@(PSETQIFY ...) WITHIN `. + +(DEFINE PSETQIFY + (LAMBDA (ARGS REGISTERS) + (IF (< (LENGTH ARGS) 5) + (PSETQIFY-METHOD-2 ARGS REGISTERS) + (PSETQIFY-METHOD-3 ARGS REGISTERS)))) + + +(DEFINE PSETQIFY-METHOD-2 + (LAMBDA (ARGS REGISTERS) + (LABELS ((PSETQ1 + (LAMBDA (A REGS QVARS SETQS USED) + (IF (NULL A) + (IF (NULL SETQS) + NIL + (IF (NULL (CDR SETQS)) + `((SETQ ,(CADAR SETQS) ,(CAR USED))) + ;;IMPORTANT: DO NOT NREVERSE THE SETQS! + ;;MAKES MACLISP COMPILER WIN BETTER. + `(((LAMBDA ,(NREVERSE QVARS) ,@SETQS) + ,@(NREVERSE USED))))) + (IF (EQ (CAR A) (CAR REGS)) ;AVOID USELESS SETQ'S + (PSETQ1 (CDR A) + (CDR REGS) + QVARS + SETQS + USED) + ((LAMBDA (QV) + (PSETQ1 (CDR A) + (CDR REGS) + (CONS QV QVARS) + (CONS `(SETQ ,(CAR REGS) ,QV) SETQS) + (CONS (CAR A) USED))) + (GENTEMP 'Q))))))) + (PSETQ1 ARGS REGISTERS NIL NIL NIL)))) + +(DEFINE PSETQIFY-METHOD-3 + (LAMBDA (ARGS REGISTERS) + (LABELS ((PSETQ1 + (LAMBDA (A REGS QVARS SETQS USED) + (IF (NULL A) + (IF (NULL SETQS) + NIL + (IF (NULL (CDR SETQS)) + `((SETQ ,(CADAR SETQS) ,(CADDR (CAR USED)))) + `((PROG () (DECLARE (SPECIAL ,@QVARS)) ,@USED ,@SETQS) ))) + (IF (EQ (CAR A) (CAR REGS)) ;AVOID USELESS SETQ'S + (PSETQ1 (CDR A) + (CDR REGS) + QVARS + SETQS + USED) + ((LAMBDA (QV) + (PSETQ1 (CDR A) + (CDR REGS) + (CONS QV QVARS) + (CONS `(SETQ ,(CAR REGS) ,QV) SETQS) + (CONS `(SETQ ,QV ,(CAR A)) USED))) + (CATENATE (CAR REGS) '|-TEMP|))))))) + (PSETQ1 ARGS REGISTERS NIL NIL NIL)))) + +(DEFINE PSETQ-ARGS + (LAMBDA (ARGS) + (PSETQ-ARGS-ENV ARGS '**ENV**))) + +(DEFINE PSETQ-ARGS-ENV + (LAMBDA (ARGS ENVADJ) + (IF (> (LENGTH ARGS) (+ **NUMBER-OF-ARG-REGS** 1)) + (PSETQIFY (LIST ENVADJ (CAR ARGS) (CONS 'LIST (CDR ARGS))) + **ENV+CONT+ARG-REGS**) + (PSETQIFY (CONS ENVADJ ARGS) **ENV+CONT+ARG-REGS**)))) + +(DEFINE PSETQ-TEMPS + (LAMBDA (ARGS DEP ENVADJ) + (DO ((A ARGS (CDR A)) + (J DEP (+ J 1)) + (R NIL (CONS (TEMPLOC J) R))) + ((NULL A) + (PSETQIFY (CONS ENVADJ ARGS) + (CONS '**ENV** (NREVERSE R))))))) + + +(DEFINE MAPANALYZE + (LAMBDA (FLIST RNL PROGNAME BLOCKFNS FNS C) + (LABELS ((LOOP + (LAMBDA (F Z FNS) + (IF (NULL F) + (C (NREVERSE Z) FNS) + (ANALYZE (CAR F) + RNL + PROGNAME + BLOCKFNS + FNS + (LAMBDA (STUFF FNS) + (LOOP (CDR F) + (CONS STUFF Z) + FNS))))))) + (LOOP FLIST NIL FNS)))) + +(DEFINE ANALYZE + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS FNS C) + (LET ((CFM (CNODE\CFORM CNODE))) + (EQCASE (TYPE CFM) + (TRIVIAL + (C (TRIVIALIZE (TRIVIAL\NODE CFM) RNL) FNS)) + (CVARIABLE + (C (LOOKUPICATE (CVARIABLE\VAR CFM) RNL) FNS)) + (CLAMBDA + (ANALYZE-CLAMBDA CNODE RNL PROGNAME BLOCKFNS FNS C CFM)) + (CONTINUATION + (ANALYZE-CONTINUATION CNODE RNL PROGNAME BLOCKFNS FNS C CFM)) + (CIF + (ANALYZE-CIF CNODE RNL PROGNAME BLOCKFNS FNS C CFM)) + (CLABELS + (ANALYZE-CLABELS CNODE RNL PROGNAME BLOCKFNS FNS C CFM)) + (CCOMBINATION + (ANALYZE-CCOMBINATION CNODE RNL PROGNAME BLOCKFNS FNS C CFM)) + (RETURN + (ANALYZE-RETURN CNODE RNL PROGNAME BLOCKFNS FNS C CFM)))))) + +(DEFINE ANALYZE-CLAMBDA + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS FNS C CFM) + (EQCASE (CLAMBDA\FNP CFM) + (NIL + (C `(CONS 'CBETA + (CONS ,PROGNAME + (CONS ',(CLAMBDA\NAME CFM) + ,(CONS-CLOSEREFS (CLAMBDA\CLOSEREFS CFM) + RNL)))) + (CONS (LIST PROGNAME CNODE NIL) FNS))) + (EZCLOSE + (C (CONS-CLOSEREFS (CLAMBDA\CLOSEREFS CFM) RNL) + (CONS (LIST PROGNAME CNODE NIL) FNS))) + (NOCLOSE + (C '|Shouldn't ever be seen - NOCLOSE CLAMBDA| + (CONS (LIST PROGNAME CNODE RNL) FNS)))))) + +(DEFINE ANALYZE-CONTINUATION + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS FNS C CFM) + (EQCASE (CONTINUATION\FNP CFM) + (NIL + (C `(CONS 'CBETA + (CONS ,PROGNAME + (CONS ',(CONTINUATION\NAME CFM) + ,(CONS-CLOSEREFS (CONTINUATION\CLOSEREFS CFM) + RNL)))) + (CONS (LIST PROGNAME CNODE NIL) FNS))) + (EZCLOSE + (C (CONS-CLOSEREFS (CONTINUATION\CLOSEREFS CFM) RNL) + (CONS (LIST PROGNAME CNODE NIL) FNS))) + (NOCLOSE + (C '|Shouldn't ever be seen - NOCLOSE CONTINUATION| + (CONS (LIST PROGNAME CNODE RNL) FNS)))))) + +(DEFINE ANALYZE-CIF + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS FNS C CFM) + (ANALYZE (CIF\PRED CFM) + RNL + PROGNAME + BLOCKFNS + FNS + (LAMBDA (PRED FNS) + (ANALYZE (CIF\CON CFM) + RNL + PROGNAME + BLOCKFNS + FNS + (LAMBDA (CON FNS) + (ANALYZE (CIF\ALT CFM) + RNL + PROGNAME + BLOCKFNS + FNS + (LAMBDA (ALT FNS) + (C (CONDICATE PRED CON ALT) + FNS))))))))) + +(DEFINE ANALYZE-CLABELS + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS FNS C CFM) + (ANALYZE (CLABELS\BODY CFM) + (ENVCARCDR (APPEND (CLABELS\FNENV CFM) + (CLABELS\CONSENV CFM)) + RNL) + PROGNAME + BLOCKFNS + FNS + (LAMBDA (LBOD FNS) + (PRODUCE-LABELS CNODE LBOD RNL PROGNAME BLOCKFNS FNS C))))) + +(DEFINE + ANALYZE-CCOMBINATION + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS FNS C CFM) + (LET ((FN (CNODE\CFORM (CAR (CCOMBINATION\ARGS CFM))))) + (IF (EQ (TYPE FN) 'CLAMBDA) + (ANALYZE (CLAMBDA\BODY FN) + (ENVCARCDR (CLAMBDA\ASETVARS FN) + (REGSLIST FN T (ENVCARCDR (CLAMBDA\CONSENV FN) RNL))) + PROGNAME + BLOCKFNS + FNS + (LAMBDA (BODY FNS) + (MAPANALYZE + (CDR (CCOMBINATION\ARGS CFM)) + RNL + PROGNAME + BLOCKFNS + FNS + (LAMBDA (ARGS FNS) + (C (LAMBDACATE (CLAMBDA\VARS FN) + (CLAMBDA\TVARS FN) + (CLAMBDA\DEP FN) + ARGS + (REMARK-ON (CAR (CCOMBINATION\ARGS CFM))) + '**ENV** + (SET-UP-ASETVARS BODY + (CLAMBDA\ASETVARS FN) + (REGSLIST FN NIL NIL))) + FNS))))) + (ERROR '|Non-trivial Function in ANALYZE-CCOMBINATION| CNODE 'FAIL-ACT))))) + +(DEFINE ANALYZE-RETURN + (LAMBDA (CNODE RNL PROGNAME BLOCKFNS FNS C CFM) + (LET ((FN (CNODE\CFORM (RETURN\CONT CFM)))) + (IF (EQ (TYPE FN) 'CONTINUATION) + (ANALYZE (CONTINUATION\BODY FN) + (IF (CONTINUATION\TVARS FN) + (CONS (CONS (CAR (CONTINUATION\TVARS FN)) + (TEMPLOC (CONTINUATION\DEP FN))) + (ENVCARCDR (CONTINUATION\CONSENV FN) RNL)) + (ENVCARCDR (CONTINUATION\CONSENV FN) RNL)) + PROGNAME + BLOCKFNS + FNS + (LAMBDA (BODY FNS) + (ANALYZE (RETURN\VAL CFM) + RNL + PROGNAME + BLOCKFNS + FNS + (LAMBDA (ARG FNS) + (C (LAMBDACATE + (LIST (CONTINUATION\VAR FN)) + (CONTINUATION\TVARS FN) + (CONTINUATION\DEP FN) + (LIST ARG) + (REMARK-ON (RETURN\CONT CFM)) + '**ENV** + BODY) + FNS))))) + (ERROR '|Non-trivial Function in ANALYZE-RETURN| CNODE 'FAIL-ACT))))) + +(DEFINE LOOKUPICATE + (LAMBDA (VAR RNL) + ((LAMBDA (SLOT) + (IF SLOT (CDR SLOT) + (IF (TRIVFN VAR) + `(GETL ',VAR '(EXPR SUBR LSUBR)) + VAR))) + (ASSQ VAR RNL)))) + +(DEFINE CONS-CLOSEREFS + (LAMBDA (CLOSEREFS RNL) + (DO ((CR (REVERSE CLOSEREFS) (CDR CR)) + (X '**ENV** `(CONS ,(LOOKUPICATE (CAR CR) RNL) ,X))) + ((NULL CR) X)))) + +(DEFINE OUTPUT-ASET + (LAMBDA (VARREF BODY) + (COND ((ATOM VARREF) + `(SETQ ,VARREF ,BODY)) + ((EQ (CAR VARREF) 'CAR) + `(CAR (RPLACA ,(CADR VARREF) ,BODY))) + ((EQ (CAR VARREF) 'CADR) + `(CAR (RPLACA (CDR ,(CADR VARREF)) ,BODY))) + ((EQ (CAR VARREF) 'CADDR) + `(CAR (RPLACA (CDDR ,(CADR VARREF)) ,BODY))) + ((EQ (CAR VARREF) 'CADDDR) + `(CAR (RPLACA (CDDDR ,(CADR VARREF)) ,BODY))) + (T (ERROR '|Unknown ASET discipline - OUTPUT-ASET| VARREF 'FAIL-ACT))))) + +;;; CONDICATE TURNS AN IF INTO A COND; IN SO DOING IT TRIES TO MAKE THE RESULT PRETTY. + +(DEFINE CONDICATE + (LAMBDA (PRED CON ALT) + (IF (OR (ATOM ALT) (NOT (EQ (CAR ALT) 'COND))) + `(COND (,PRED ,@(DEPROGNIFY CON)) + (T ,@(DEPROGNIFY ALT))) + `(COND (,PRED ,@(DEPROGNIFY CON)) + ,@(CDR ALT))))) + + +;;; DECARCDRATE MAKES CAR-CDR CHAINS PRETTIER. + +(DEFINE DECARCDRATE + (LAMBDA (X) + (COND ((ATOM X) X) + ((EQ (CAR X) 'CAR) + (IF (ATOM (CADR X)) + X + (LET ((Y (DECARCDRATE (CADR X)))) + (COND ((EQ (CAR Y) 'CAR) `(CAAR ,(CADR Y))) + ((EQ (CAR Y) 'CDR) `(CADR ,(CADR Y))) + ((EQ (CAR Y) 'CDDR) `(CADDR ,(CADR Y))) + ((EQ (CAR Y) 'CDDDR) `(CADDDR ,(CADR Y))) + (T `(CAR ,Y)))))) + ((EQ (CAR X) 'CDR) + (IF (ATOM (CADR X)) + X + (LET ((Y (DECARCDRATE (CADR X)))) + (COND ((EQ (CAR Y) 'CDR) `(CDDR ,(CADR Y))) + ((EQ (CAR Y) 'CDDR) `(CDDDR ,(CADR Y))) + ((EQ (CAR Y) 'CDDDR) `(CDDDDR ,(CADR Y))) + (T `(CDR ,Y)))))) + (T X)))) + +(DEFINE TRIVIALIZE + (LAMBDA (NODE RNL) + (LET ((FM (NODE\FORM NODE))) + (EQCASE (TYPE FM) + (CONSTANT `',(CONSTANT\VALUE FM)) + (VARIABLE (LOOKUPICATE (VARIABLE\VAR FM) RNL)) + (IF (CONDICATE (TRIVIALIZE (IF\PRED FM) RNL) + (TRIVIALIZE (IF\CON FM) RNL) + (TRIVIALIZE (IF\ALT FM) RNL))) + (ASET + (OUTPUT-ASET (LOOKUPICATE (ASET\VAR FM) RNL) + (TRIVIALIZE (ASET\BODY FM) RNL))) + (COMBINATION + (LET ((ARGS (COMBINATION\ARGS FM))) + (LET ((FN (NODE\FORM (CAR ARGS)))) + (IF (AND (EQ (TYPE FN) 'VARIABLE) + (VARIABLE\GLOBALP FN) + (TRIVFN (VARIABLE\VAR FN))) + (CONS (VARIABLE\VAR FN) + (AMAPCAR (LAMBDA (A) (TRIVIALIZE A RNL)) + (CDR ARGS))) + (IF (EQ (TYPE FN) 'LAMBDA) + (TRIV-LAMBDACATE + (LAMBDA\VARS FN) + (AMAPCAR (LAMBDA (A) (TRIVIALIZE A RNL)) + (CDR ARGS)) + (TRIVIALIZE (LAMBDA\BODY FN) RNL)) + (ERROR '|Strange Trivial Function - TRIVIALIZE| + NODE + 'FAIL-ACT)))))))))) + +(DEFINE TRIV-LAMBDACATE + (LAMBDA (VARS ARGS BODY) + (LABELS ((LOOP + (LAMBDA (V A REALVARS REALARGS EFFARGS) + (IF (NULL A) + (LET ((RV (NREVERSE REALVARS))) + (OR (NULL V) + (ERROR '|We blew it in TRIV-LAMBDACATE| V 'FAIL-ACT)) + (LET ((B (IF RV + `((LAMBDA ,RV + (COMMENT + (VARS = ,(MAP-USER-NAMES RV))) + ,@(DEPROGNIFY BODY)) + ,@(NREVERSE REALARGS)) + BODY))) + (IF EFFARGS + `(PROGN ,@EFFARGS ,@(DEPROGNIFY B)) + B))) + (IF (OR (GET (CAR V) 'READ-REFS) + (GET (CAR V) 'WRITE-REFS)) + (LOOP (CDR V) + (CDR A) + (CONS (CAR V) REALVARS) + (CONS (CAR A) REALARGS) + EFFARGS) + (LOOP (CDR V) + (CDR A) + REALVARS + REALARGS + (CONS (CAR A) EFFARGS))))))) + (LOOP VARS ARGS NIL NIL NIL)))) + +(DEFINE COMPILATE-ONE-FUNCTION ;COMPLICATE-ONE-FUNCTION? + (LAMBDA (CNODE USERNAME) + (LET ((PROGNAME (GEN-GLOBAL-NAME))) + (COMPILATE-LOOP USERNAME + PROGNAME + (LIST (LIST USERNAME CNODE)) + (LIST (LIST PROGNAME CNODE NIL)) + NIL + 0 + (LIST `(SETQ ,USERNAME + (LIST 'CBETA + ,PROGNAME + ',(CLAMBDA\NAME (CNODE\CFORM CNODE)))) + `(DEFPROP ,PROGNAME ,USERNAME USER-FUNCTION)))))) + +(DEFINE COMPILATE-LOOP + (LAMBDA (USERNAME PROGNAME BLOCKFNS FNS PROGBODY TMAX STUFF) + (IF (NULL FNS) + `(PROGN 'COMPILE + (COMMENT MODULE FOR FUNCTION ,USERNAME) + (DEFUN ,PROGNAME () + (PROG () + (DECLARE (SPECIAL ,PROGNAME ,@(USED-TEMPLOCS TMAX))) + (GO (PROG2 NIL + (CAR **ENV**) + (SETQ **ENV** (CDR **ENV**)))) + ,@(NREVERSE PROGBODY))) + (SETQ ,PROGNAME (GET ',PROGNAME 'SUBR)) + ,@STUFF) + (COMPILATE (CAR (CAR FNS)) + (CADR (CAR FNS)) + (CADDR (CAR FNS)) + BLOCKFNS + (CDR FNS) + (LAMBDA (CODE NEWFNS) + (LET ((CFM (CNODE\CFORM (CADR (CAR FNS))))) + (COMPILATE-LOOP + USERNAME + PROGNAME + BLOCKFNS + NEWFNS + (NCONC (REVERSE (DEPROGNIFY1 CODE T)) + (CONS (REMARK-ON (CADR (CAR FNS))) + (CONS (EQCASE (TYPE CFM) + (CLAMBDA + (CLAMBDA\NAME CFM)) + (CONTINUATION + (CONTINUATION\NAME CFM))) + PROGBODY))) + (MAX TMAX + (EQCASE (TYPE CFM) + (CLAMBDA + (CLAMBDA\MAXDEP CFM)) + (CONTINUATION + (CONTINUATION\MAXDEP CFM)))) + STUFF))))))) + +(DEFINE USED-TEMPLOCS + (LAMBDA (N) + (DO ((J (+ **NUMBER-OF-ARG-REGS** 1) (+ J 1)) + (X NIL (CONS (TEMPLOC J) X))) + ((> J N) (NREVERSE X))))) + +(DEFINE REMARK-ON + (LAMBDA (CNODE) + (LET ((CFM (CNODE\CFORM CNODE))) + (LABELS ((REMARK1 + (LAMBDA (DEP FNP VARS ENV) + `(COMMENT (DEPTH = ,DEP) + (FNP = ,FNP) + ,@(IF VARS `((VARS = ,(MAP-USER-NAMES VARS)))) + ,@(IF ENV `((ENV = ,(MAP-USER-NAMES ENV)))))))) + (EQCASE (TYPE CFM) + (CLAMBDA + (REMARK1 (CLAMBDA\DEP CFM) + (CLAMBDA\FNP CFM) + (IF (EQ (CLAMBDA\FNP CFM) 'NOCLOSE) + (CLAMBDA\TVARS CFM) + (CLAMBDA\VARS CFM)) + (APPEND (CLAMBDA\CLOSEREFS CFM) + (CLAMBDA\CONSENV CFM)))) + (CONTINUATION + (REMARK1 (CONTINUATION\DEP CFM) + (CONTINUATION\FNP CFM) + NIL ;NEVER INTERESTING ANYWAY + (APPEND (CONTINUATION\CLOSEREFS CFM) + (CONTINUATION\CONSENV CFM))))))))) + + +(DEFINE MAP-USER-NAMES + (LAMBDA (VARS) + (AMAPCAR (LAMBDA (X) (OR (GET X 'USER-NAME) X)) VARS))) + +(DEFINE COMFILE + (LAMBDA (FNAME) + (LET ((FN (DEFAULTF (MERGEF FNAME '(* >)))) + (RT (RUNTIME)) + (GCT (STATUS GCTIME))) + (LET ((IFILE (OPEN FN 'IN)) + (OFILE (OPEN (MERGEF '(_RABB_ OUTPUT) FN) 'OUT))) + (SET' *GLOBAL-GEN-PREFIX* + (CATENATE (CADAR (SYMEVAL 'DEFAULTF)) + '|=| + (CADR (SYMEVAL 'DEFAULTF)))) + (LET ((TN (NAMESTRING (TRUENAME IFILE)))) + (PRINT `(COMMENT THIS IS THE RABBIT LISP CODE FOR ,TN) OFILE) + (TIMESTAMP OFILE) + (TERPRI OFILE) + (TERPRI (SYMEVAL 'TYO)) + (PRINC '|;Beginning RABBIT compilation on | (SYMEVAL 'TYO)) + (PRINC TN (SYMEVAL 'TYO))) + (PRINT `(DECLARE (SPECIAL ,@**CONT+ARG-REGS** **ENV** **FUN** **NARGS**)) + OFILE) + (PRINT '(DECLARE (DEFUN DISPLACE (X Y) Y)) OFILE) + (ASET' *TESTING* NIL) + (ASET' *ERROR-COUNT* 0) + (ASET' *ERROR-LIST* NIL) + (TRANSDUCE IFILE + OFILE + (LIST NIL) + (CATENATE '|INIT-| (CADR (TRUENAME IFILE)))) + (TIMESTAMP OFILE) + (LET ((X (*QUO (- (RUNTIME) RT) 1.0E6)) + (Y (*QUO (- (STATUS GCTIME) GCT) 1.0E6))) + (LET ((MSG `(COMPILE TIME: ,X SECONDS + (GC TIME ,Y SECONDS) + (NET ,(-$ X Y) SECONDS) + ,@(IF (NOT (ZEROP *ERROR-COUNT*)) + `((,*ERROR-COUNT* ERRORS)))))) + (PRINT `(COMMENT ,MSG) OFILE) + (RENAMEF OFILE + (MERGEF (LIST (CADR FN) 'LISP) + FN)) + (CLOSE OFILE) + MSG)))))) + +(DEFINE TRANSDUCE + (LAMBDA (IFILE OFILE EOF INITNAME) + (LABELS ((LOOP + (LAMBDA (FORM RANDOM-FORMS) + (IF (EQ FORM EOF) + (DO ((X (GENTEMP INITNAME) (GENTEMP INITNAME)) + (Y NIL X) + (Z RANDOM-FORMS (CDR Z))) + ((NULL Z) + (IF RANDOM-FORMS + (PRINT `(,(LENGTH RANDOM-FORMS) + RANDOM FORMS IN FILE TO COMPILE) + (SYMEVAL 'TYO))) + (IF Y (PROCESS-FORM `(DECLARE (SPECIAL ,Y)) + OFILE + T)) + (PROCESS-FORM `(DEFINE ,INITNAME + (LAMBDA () ,(IF Y (LIST Y) NIL))) + OFILE + T)) + (IF Y (PROCESS-FORM `(DECLARE (SPECIAL ,Y)) + OFILE + NIL)) + (PROCESS-FORM `(DEFINE ,X + (LAMBDA () + (BLOCK ,(CAR Z) + ,(IF Y + (LIST Y) + NIL)))) + OFILE + NIL)) +; (PROCESS-FORM +; `(DEFINE ,INITNAME +; (LAMBDA () (BLOCK ,@RANDOM-FORMS NIL NIL))) +; OFILE) + (LET ((X (PROCESS-FORM FORM OFILE T))) + (LOOP (READIFY IFILE EOF) (NCONC X RANDOM-FORMS))))))) + (LOOP (READIFY IFILE EOF) NIL)))) + + +(DEFINE READIFY ;FUNNY MACLISP CONVENTION - READIFY'LL DO THE JOB! + (LAMBDA (IFILE EOF) + (IF (SYMEVAL 'READ) + (APPLY (SYMEVAL 'READ) IFILE EOF) + (READ IFILE EOF)))) + +(SET' *OPTIMIZE* T) + +(SET' *BUFFER-RANDOM-FORMS* T) + +(DEFINE PROCESS-FORM + (LAMBDA (FORM OFILE NOISYP) + (COND ((ATOM FORM) + (PRINT FORM OFILE) + NIL) + ((EQ (CAR FORM) 'DEFINE) + (PROCESS-DEFINE-FORM FORM OFILE NOISYP) + NIL) + ((AND (MEMQ (CAR FORM) '(BLOCK PROGN)) + (EQUAL (CADR FORM) ''COMPILE)) + (DO ((F (CDDR FORM) (CDR F)) + (Z NIL (NCONC Z (PROCESS-FORM (CAR F) OFILE NOISYP)))) + ((NULL F) Z))) + ((EQ (CAR FORM) 'PROCLAIM) + (AMAPC (LAMBDA (X) ((ENCLOSE `(LAMBDA (OFILE) ,X)) OFILE)) + (CDR FORM)) + NIL) + ((EQ (CAR FORM) 'DECLARE) + (PRINT FORM OFILE) + NIL) + ((EQ (CAR FORM) 'COMMENT) + NIL) + ((EQ (CAR FORM) 'DEFUN) + (PRINT FORM OFILE) + NIL) + ((AND (ATOM (CAR FORM)) + (EQ (GET (CAR FORM) 'AINT) 'AMACRO) + (NOT (EQ (GET (CAR FORM) 'AMACRO) 'AFSUBR))) + (IF (MEMQ (CAR FORM) '(DEFMAC SCHMAC MACRO)) + (EVAL FORM)) + (PROCESS-FORM (MACRO-EXPAND FORM) OFILE NOISYP)) + (T (COND (*BUFFER-RANDOM-FORMS* (LIST FORM)) + (T (PRINT FORM OFILE) NIL)))))) + +(DEFINE PROCESS-DEFINE-FORM + (LAMBDA (FORM OFILE NOISYP) + (COND ((ATOM (CADR FORM)) + (PROCESS-DEFINITION FORM + OFILE + NOISYP + (CADR FORM) + (IF (NULL (CDDDR FORM)) + (CADDR FORM) + `(LAMBDA ,(CADDR FORM) + (BLOCK . ,(CDDDR FORM)))))) + (T (PROCESS-DEFINITION FORM + OFILE + NOISYP + (CAADR FORM) + `(LAMBDA ,(CDADR FORM) + (BLOCK . ,(CDDR FORM)))))))) + +(DEFINE PROCESS-DEFINITION + (LAMBDA (FORM OFILE NOISYP NAME LAMBDA-EXP) + (COND ((NOT (EQ (TYPEP NAME) 'SYMBOL)) + (WARN |Function Name Not SYMBOL| NAME FORM)) + ((OR (NOT (EQ (CAR LAMBDA-EXP) 'LAMBDA)) + (AND (ATOM (CADR LAMBDA-EXP)) + (NOT (NULL (CADR LAMBDA-EXP))))) + (WARN |Malformed LAMBDA-expression| LAMBDA-EXP FORM)) + (T (PRINT (COMPILE NAME + LAMBDA-EXP + NIL + *OPTIMIZE*) + OFILE) + (CLEANUP) + (IF NOISYP + (PRINT (LIST NAME 'COMPILED) + (SYMEVAL 'TYO))))))) + +(DEFINE CLEANUP + (LAMBDA () + (BLOCK (REPLACE) + (GENFLUSH) + (MAPATOMS '(LAMBDA (X) + (REMPROP X 'READ-REFS) + (REMPROP X 'WRITE-REFS) + (REMPROP X 'NODE) + (REMPROP X 'BINDING) + (REMPROP X 'USER-NAME) + (REMPROP X 'KNOWN-FUNCTION) + (REMPROP X 'EASY-LABELS-FUNCTION)))))) + +;;; INVERSE OF ALPHATIZE. USED BY SX, E.G., FOR DEBUGGING. + +(DEFINE SEXPRFY + (LAMBDA (NODE USERP) + (LET ((FM (NODE\FORM NODE))) + (EQCASE (TYPE FM) + (CONSTANT `(QUOTE ,(CONSTANT\VALUE FM))) + (VARIABLE (IF (AND USERP (NOT (VARIABLE\GLOBALP FM))) + (GET (VARIABLE\VAR FM) 'USER-NAME) + (VARIABLE\VAR FM))) + (LAMBDA `(LAMBDA ,(IF USERP (LAMBDA\UVARS FM) (LAMBDA\VARS FM)) + ,(SEXPRFY (LAMBDA\BODY FM) USERP))) + (IF `(IF ,(SEXPRFY (IF\PRED FM) USERP) + ,(SEXPRFY (IF\CON FM) USERP) + ,(SEXPRFY (IF\ALT FM) USERP))) + (ASET `(ASET' ,(IF (AND USERP (NOT (ASET\GLOBALP FM))) + (GET (ASET\VAR FM) 'USER-NAME) + (ASET\VAR FM)) + ,(SEXPRFY (ASET\BODY FM) USERP))) + (CATCH `(CATCH ,(IF USERP + (GET (CATCH\VAR FM) 'USER-NAME) + (CATCH\VAR FM)) + ,(SEXPRFY (CATCH\BODY FM) USERP))) + (LABELS `(LABELS ,(AMAPCAR (LAMBDA (V D) `(,(IF USERP + (GET V 'USER-NAME) + V) + ,(SEXPRFY D USERP))) + (LABELS\FNVARS FM) + (LABELS\FNDEFS FM)) + ,(SEXPRFY (LABELS\BODY FM) USERP))) + (COMBINATION + (AMAPCAR (LAMBDA (A) (SEXPRFY A USERP)) + (COMBINATION\ARGS FM))))))) + +(DEFINE CSEXPRFY + (LAMBDA (CNODE) + (LET ((CFM (CNODE\CFORM CNODE))) + (EQCASE (TYPE CFM) + (TRIVIAL `(TRIVIAL ,(SEXPRFY (TRIVIAL\NODE CFM) NIL))) + (CVARIABLE (CVARIABLE\VAR CFM)) + (CLAMBDA `(CLAMBDA ,(CLAMBDA\VARS CFM) + ,(CSEXPRFY (CLAMBDA\BODY CFM)))) + (CONTINUATION + `(CONTINUATION (,(CONTINUATION\VAR CFM)) + ,(CSEXPRFY (CONTINUATION\BODY CFM)))) + (CIF `(CIF ,(CSEXPRFY (CIF\PRED CFM)) + ,(CSEXPRFY (CIF\CON CFM)) + ,(CSEXPRFY (CIF\ALT CFM)))) + (CASET `(CASET' ,(CSEXPRFY (CASET\CONT CFM)) + ,(CASET\VAR CFM) + ,(CSEXPRFY (CASET\BODY CFM)))) + (CLABELS `(CLABELS ,(AMAPCAR (LAMBDA (V D) `(,V + ,(CSEXPRFY D))) + (CLABELS\FNVARS CFM) + (CLABELS\FNDEFS CFM)) + ,(CSEXPRFY (CLABELS\BODY CFM)))) + (CCOMBINATION + (AMAPCAR CSEXPRFY (CCOMBINATION\ARGS CFM))) + (RETURN + `(RETURN ,(CSEXPRFY (RETURN\CONT CFM)) + ,(CSEXPRFY (RETURN\VAL CFM)))))))) + +(DEFINE CHECK-NUMBER-OF-ARGS + (LAMBDA (NAME NARGS DEFP) + (OR (GETL NAME '(*LEXPR LSUBR)) + (LET ((N (GET NAME 'NUMBER-OF-ARGS))) + (IF N + (IF (NOT (= N NARGS)) + (IF DEFP + (WARN |definition disagrees with earlier use on number of args| + NAME + NARGS + N) + (IF (GET NAME 'DEFINED) + (WARN |use disagrees with definition on number of args| + NAME + NARGS + N) + (WARN |two uses disagree before definition on number of args| + NAME + NARGS + N)))) + (PUTPROP NAME NARGS 'NUMBER-OF-ARGS)) + (IF DEFP (PUTPROP NAME 'T 'DEFINED)))))) + + +(DEFUN *EXPR FEXPR (X) + (MAPCAR '(LAMBDA (Y) (PUTPROP Y 'T '*EXPR)) X)) + +(DEFPROP *EXPR AFSUBR AMACRO) (DEFPROP *EXPR AMACRO AINT) + +(DEFUN *LEXPR FEXPR (X) + (MAPCAR '(LAMBDA (Y) (PUTPROP Y 'T '*LEXPR)) X)) + +(DEFPROP *LEXPR AFSUBR AMACRO) (DEFPROP *LEXPR AMACRO AINT) + + +(DEFINE DUMPIT + (LAMBDA () + (BLOCK (INIT-RABBIT) + (SUSPEND '|:PDUMP DSK:SCHEME;TS RABBIT|) + (TERPRI) + (PRINC '|File name: |) + (COMFILE (READLINE)) + (QUIT)))) + +(DEFINE STATS + (LAMBDA () + (AMAPC (LAMBDA (VAR) + (BLOCK (TERPRI) + (PRIN1 VAR) + (PRINC '| = |) + (PRIN1 (SYMEVAL VAR)))) + *STAT-VARS*))) + +(DEFINE RESET-STATS + (LAMBDA () (AMAPC (LAMBDA (VAR) (SET VAR 0)) *STAT-VARS*)))