├── README └── rabbit.lsp /README: -------------------------------------------------------------------------------- 1 | Said to be the source code for Guy Steele's RABBIT Scheme compiler. 2 | 3 | Link found on the History of Lisp - Software Preservation Group page 4 | here: http://www.softwarepreservation.org/projects/LISP/ 5 | 6 | Original URL: 7 | http://www-2.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/scheme/impl/rabbit/rabbit.lsp 8 | 9 | Also available here: 10 | ftp://ftp.cs.indiana.edu/pub/scheme-repository/imp/RABBIT.gz 11 | 12 | Disclaimer: I don't claim any ownership of this code, I'm simply 13 | making it available for posterity, and for its instructional 14 | value. The code was made available at the links given above without 15 | any copyright notice. Use at your own risk. 16 | -------------------------------------------------------------------------------- /rabbit.lsp: -------------------------------------------------------------------------------- 1 | ;;; RABBIT COMPILER -*-LISP-*- 2 | 3 | (DECLARE (FASLOAD (QUUX) SCHMAC)) 4 | (DECLARE (MACROS T) (NEWIO T)) 5 | (DECLARE (ALLOC '(LIST (300000 450000 .2) FIXNUM 50000 SYMBOL 24000))) 6 | (DECLARE (DEFUN DISPLACE (X Y) Y)) 7 | 8 | (DECLARE (SPECIAL EMPTY TRIVFN GENTEMP GENFLUSH GEN-GLOBAL-NAME PRINT-WARNING ADDPROP DELPROP SETPROP 9 | ADJOIN UNION INTERSECT REMOVE SETDIFF PAIRLIS COMPILE PASS1-ANALYZE TEST-COMPILE 10 | NODIFY ALPHATIZE ALPHA-ATOM ALPHA-LAMBDA ALPHA-IF ALPHA-ASET ALPHA-CATCH 11 | ALPHA-LABELS ALPHA-LABELS-DEFN ALPHA-BLOCK MACRO-EXPAND ALPHA-COMBINATION 12 | ENV-ANALYZE TRIV-ANALYZE TRIV-ANALYZE-FN-P EFFS-ANALYZE EFFS-UNION EFFS-ANALYZE-IF 13 | EFFS-ANALYZE-COMBINATION CHECK-COMBINATION-PEFFS ERASE-NODES META-EVALUATE 14 | META-IF-FUDGE META-COMBINATION-TRIVFN META-COMBINATION-LAMBDA SUBST-CANDIDATE 15 | REANALYZE1 EFFS-INTERSECT EFFECTLESS EFFECTLESS-EXCEPT-CONS PASSABLE 16 | META-SUBSTITUTE COPY-CODE COPY-NODES CNODIFY CONVERT MAKE-RETURN CONVERT-LAMBDA-FM 17 | CONVERT-IF CONVERT-ASET CONVERT-CATCH CONVERT-LABELS CONVERT-COMBINATION 18 | CENV-ANALYZE CENV-TRIV-ANALYZE CENV-CCOMBINATION-ANALYZE BIND-ANALYZE REFD-VARS 19 | BIND-ANALYZE-CLAMBDA BIND-ANALYZE-CONTINUATION BIND-ANALYZE-CIF BIND-ANALYZE-CASET 20 | BIND-ANALYZE-CLABELS BIND-ANALYZE-RETURN BIND-ANALYZE-CCOMBINATION 21 | BIND-CCOMBINATION-ANALYZE DEPTH-ANALYZE FILTER-CLOSEREFS CLOSE-ANALYZE COMPILATE 22 | DEPROGNIFY1 TEMPLOC ENVCARCDR REGSLIST SET-UP-ASETVARS COMP-BODY PRODUCE-IF 23 | PRODUCE-ASET PRODUCE-LABELS PRODUCE-LAMBDA-COMBINATION PRODUCE-TRIVFN-COMBINATION 24 | PRODUCE-TRIVFN-COMBINATION-CONTINUATION PRODUCE-TRIVFN-COMBINATION-CVARIABLE 25 | PRODUCE-COMBINATION PRODUCE-COMBINATION-VARIABLE ADJUST-KNOWNFN-CENV 26 | PRODUCE-CONTINUATION-RETURN PRODUCE-RETURN PRODUCE-RETURN-1 LAMBDACATE PSETQIFY 27 | PSETQIFY-METHOD-2 PSETQIFY-METHOD-3 PSETQ-ARGS PSETQ-ARGS-ENV PSETQ-TEMPS 28 | MAPANALYZE ANALYZE ANALYZE-CLAMBDA ANALYZE-CONTINUATION ANALYZE-CIF ANALYZE-CLABELS 29 | ANALYZE-CCOMBINATION ANALYZE-RETURN LOOKUPICATE CONS-CLOSEREFS OUTPUT-ASET 30 | CONDICATE DECARCDRATE TRIVIALIZE TRIV-LAMBDACATE COMPILATE-ONE-FUNCTION 31 | COMPILATE-LOOP USED-TEMPLOCS REMARK-ON MAP-USER-NAMES COMFILE TRANSDUCE 32 | PROCESS-FORM PROCESS-DEFINE-FORM PROCESS-DEFINITION CLEANUP SEXPRFY CSEXPRFY 33 | CHECK-NUMBER-OF-ARGS DUMPIT STATS RESET-STATS INIT-RABBIT)) 34 | 35 | (DECLARE (SPECIAL *EMPTY* *GENTEMPNUM* *GENTEMPLIST* *GLOBAL-GEN-PREFIX* *ERROR-COUNT* *ERROR-LIST* 36 | *TEST* *TESTING* *OPTIMIZE* *REANALYZE* *SUBSTITUTE* *FUDGE* *NEW-FUDGE* 37 | *SINGLE-SUBST* *LAMBDA-SUBST* *FLUSH-ARGS* *STAT-VARS* *DEAD-COUNT* *FUDGE-COUNT* 38 | *FOLD-COUNT* *FLUSH-COUNT* *CONVERT-COUNT* *SUBST-COUNT* *DEPROGNIFY-COUNT* 39 | *LAMBDA-BODY-SUBST* *LAMBDA-BODY-SUBST-TRY-COUNT* *LAMBDA-BODY-SUBST-SUCCESS-COUNT* 40 | *CHECK-PEFFS* **CONT+ARG-REGS** **ENV+CONT+ARG-REGS** **ARGUMENT-REGISTERS** 41 | **NUMBER-OF-ARG-REGS** *BUFFER-RANDOM-FORMS* *DISPLACE-SW*)) 42 | 43 | (PROCLAIM (*EXPR PRINT-SHORT) 44 | (SET' *BUFFER-RANDOM-FORMS* NIL) 45 | (ALLOC '(LIST (240000 340000 1000) FIXNUM (30000 40000 1000) 46 | SYMBOL (14000 24000 NIL) HUNK4 (20000 53000 NIL) 47 | HUNK8 (20000 50000 NIL) HUNK16 (20000 60000 NIL)))) 48 | 49 | (SET' *STAT-VARS* '(*DEAD-COUNT* *FUDGE-COUNT* *FOLD-COUNT* *FLUSH-COUNT* *CONVERT-COUNT* 50 | *SUBST-COUNT* *DEPROGNIFY-COUNT* *LAMBDA-BODY-SUBST-TRY-COUNT* 51 | *LAMBDA-BODY-SUBST-SUCCESS-COUNT*)) 52 | 53 | (ALLOC '(LIST (240000 340000 1000) FIXNUM (30000 40000 1000) 54 | SYMBOL (14000 24000 NIL) HUNK4 (20000 50000 NIL) 55 | HUNK8 (20000 50000 NIL) HUNK16 (20000 70000 NIL))) 56 | 57 | (APPLY 'GCTWA '(T)) ;GC USELESS ATOMS (CAN'T SAY (EVAL' (GCTWA T)) BECAUSE OF NCOMPLR) 58 | (REPLACE) ;UNDO ANY DISPLACED MACROS 59 | (SET' *DISPLACE-SW* NIL) ;DON'T LET MACROS SELF-DISPLACE 60 | (GRINDEF) ;LOAD THE GRINDER (PRETTY-PRINTER) 61 | 62 | (DECLARE (/@DEFINE DEFINE |SCHEME FUNCTION|)) ;DECLARATIONS FOR LISTING PROGRAM 63 | (DECLARE (/@DEFINE DEFMAC |MACLISP MACRO|)) 64 | (DECLARE (/@DEFINE SCHMAC |PDP-10 SCHEME MACRO|)) 65 | (DECLARE (/@DEFINE MACRO |SCHEME MACRO|)) 66 | 67 | (COND ((NOT (BOUNDP '*EMPTY*)) 68 | (SET' *EMPTY* (LIST '*EMPTY*)))) 69 | 70 | (DEFINE EMPTY 71 | (LAMBDA (X) (EQ X *EMPTY*))) 72 | 73 | 74 | (DEFINE TRIVFN 75 | (LAMBDA (SYM) 76 | (GETL SYM '(EXPR SUBR LSUBR *EXPR *LEXPR)))) 77 | 78 | 79 | (DEFMAC INCREMENT (X) `(ASET' ,X (+ ,X 1))) 80 | 81 | (DEFMAC CATENATE ARGS 82 | `(IMPLODE (APPEND ,@(MAPCAR '(LAMBDA (X) 83 | (COND ((OR (ATOM X) (NOT (EQ (CAR X) 'QUOTE))) 84 | `(EXPLODEN ,X)) 85 | (T `(QUOTE ,(EXPLODEN (CADR X)))))) 86 | ARGS)))) 87 | 88 | 89 | (COND ((NOT (BOUNDP '*GENTEMPNUM*)) 90 | (SET' *GENTEMPNUM* 0))) 91 | 92 | (COND ((NOT (BOUNDP '*GENTEMPLIST*)) 93 | (SET' *GENTEMPLIST* NIL))) 94 | 95 | (DEFINE GENTEMP 96 | (LAMBDA (X) 97 | (BLOCK (INCREMENT *GENTEMPNUM*) 98 | (LET ((SYM (CATENATE X '|-| *GENTEMPNUM*))) 99 | (ASET' *GENTEMPLIST* (CONS SYM *GENTEMPLIST*)) SYM)))) 100 | 101 | (DEFINE GENFLUSH 102 | (LAMBDA () 103 | (BLOCK (AMAPC REMOB *GENTEMPLIST*) 104 | (ASET' *GENTEMPLIST* NIL)))) 105 | 106 | (DEFINE GEN-GLOBAL-NAME 107 | (LAMBDA () (GENTEMP *GLOBAL-GEN-PREFIX*))) 108 | 109 | (SET' *GLOBAL-GEN-PREFIX* '|?|) 110 | 111 | (DEFMAC WARN (MSG . STUFF) 112 | `(PRINT-WARNING ',MSG (LIST ,@STUFF))) 113 | 114 | (DEFINE PRINT-WARNING 115 | (LAMBDA (MSG STUFF) 116 | (BLOCK (INCREMENT *ERROR-COUNT*) 117 | (ASET' *ERROR-LIST* (CONS (CONS MSG STUFF) *ERROR-LIST*)) 118 | (TYO 7 (SYMEVAL 'TYO)) ;BELL 119 | (TERPRI (SYMEVAL 'TYO)) 120 | (PRINC '|;Warning: | (SYMEVAL 'TYO)) 121 | (TYO 7 (SYMEVAL 'TYO)) ;BELL 122 | (PRINC MSG (SYMEVAL 'TYO)) 123 | (AMAPC PRINT-SHORT STUFF)))) 124 | 125 | (DEFUN PRINT-SHORT (X) 126 | ((LAMBDA (PRINLEVEL PRINLENGTH TERPRI) 127 | (TERPRI (SYMEVAL 'TYO)) 128 | (PRINC '|; | (SYMEVAL 'TYO)) 129 | (PRIN1 X (SYMEVAL 'TYO))) 130 | 3 8 T)) 131 | 132 | 133 | (SCHMAC ASK (MSG) 134 | `(BLOCK (TERPRI) (PRINC ',MSG) (TYO 40) (READ))) 135 | 136 | 137 | (DEFMAC SX (X) `(SPRINTER (SEXPRFY ,X NIL))) ;DEBUGGING AID 138 | (DEFMAC CSX (X) `(SPRINTER (CSEXPRFY ,X))) ;DEBUGGING AID 139 | 140 | 141 | (DEFMAC EQCASE (OBJ . CASES) 142 | `(COND ,@(MAPCAR '(LAMBDA (CASE) 143 | (OR (ATOM (CAR CASE)) 144 | (ERROR '|Losing EQCASE clause|)) 145 | `((EQ ,OBJ ',(CAR CASE)) ,@(CDR CASE))) 146 | CASES) 147 | (T (ERROR '|Losing EQCASE| ,OBJ 'FAIL-ACT)))) 148 | 149 | (DECLARE (/@DEFINE ACCESSFN |ACCESS MACRO|)) 150 | 151 | (DEFMAC ACCESSFN (NAME UVARS FETCH . PUT) 152 | ((LAMBDA (VARS CNAME) 153 | (DO ((A VARS (CDR A)) 154 | (B '*Z* `(CDR ,B)) 155 | (C NIL (CONS `(CAR ,B) C))) 156 | ((NULL A) 157 | `(PROGN 'COMPILE 158 | (DEFMAC ,NAME *Z* 159 | ((LAMBDA ,(NREVERSE (CDR (REVERSE VARS))) 160 | ,FETCH) 161 | ,@(REVERSE (CDR C)))) 162 | (DEFMAC ,CNAME *Z* 163 | ((LAMBDA ,VARS 164 | ,(COND (PUT (CAR PUT)) 165 | (T ``(CLOBBER ,,FETCH 166 | ,THE-NEW-VALUE)))) 167 | ,@(REVERSE C))))))) 168 | (COND (PUT UVARS) 169 | (T (APPEND UVARS '(THE-NEW-VALUE)))) 170 | (CATENATE '|CLOBBER-| NAME))) 171 | 172 | (DEFMAC CLOBBER (X Y) 173 | `(,(CATENATE '|CLOBBER-| (CAR X)) ,@(CDR X) ,Y)) 174 | 175 | (DECLARE (/@DEFINE HUNKFN |HUNK ACCESS MACRO|)) 176 | 177 | (DEFMAC HUNKFN (NAME SLOT) 178 | `(ACCESSFN ,NAME (THE-HUNK NEW-VALUE) 179 | `(CXR ,,SLOT ,THE-HUNK) 180 | `(RPLACX ,,SLOT ,THE-HUNK ,NEW-VALUE))) 181 | 182 | (DECLARE (/@DEFINE DEFTYPE |DATA TYPE|)) 183 | 184 | ;;; SLOT 0 IS ALWAYS THE PROPERTY LIST, AND SLOT 1 THE HUNK TYPE. 185 | 186 | (HUNKFN TYPE 1) 187 | 188 | (DEFMAC DEFTYPE (NAME SLOTS SUPP) 189 | `(PROGN 'COMPILE 190 | (DEFMAC ,(CATENATE '|CONS-| NAME) KWDS 191 | (PROGN (DO ((K KWDS (CDR K))) 192 | ((NULL K)) 193 | (OR ,(COND ((CDR SLOTS) `(MEMQ (CAAR K) ',SLOTS)) 194 | (T `(EQ (CAAR K) ',(CAR SLOTS)))) 195 | (ERROR ',(CATENATE '|Invalid Keyword Argument to CONS-| 196 | NAME) 197 | (CAR K) 198 | 'FAIL-ACT))) 199 | `(HUNK ',',NAME 200 | ,@(DO ((S ',SLOTS (CDR S)) 201 | (X NIL 202 | (CONS ((LAMBDA (KWD) 203 | (COND (KWD (CAR (LAST KWD))) 204 | (T '*EMPTY*))) 205 | (ASSQ (CAR S) KWDS)) 206 | X))) 207 | ((NULL S) (NREVERSE X))) 208 | NIL))) 209 | (DEFMAC ,(CATENATE '|ALTER-| NAME) (OBJ . KWDS) 210 | (PROGN (DO ((K KWDS (CDR K))) 211 | ((NULL K)) 212 | (OR ,(COND ((CDR SLOTS) `(MEMQ (CAAR K) ',SLOTS)) 213 | (T `(EQ (CAAR K) ',(CAR SLOTS)))) 214 | (ERROR ',(CATENATE '|Invalid Keyword Argument to ALTER-| 215 | NAME) 216 | (CAR K) 217 | 'FAIL-ACT))) 218 | (DO ((I (+ (LENGTH KWDS) 1) (- I 1)) 219 | (VARS NIL (CONS (GENSYM) VARS))) 220 | ((= I 0) 221 | `((LAMBDA ,VARS 222 | ,(BLOCKIFY 223 | (MAPCAR '(LAMBDA (K V) 224 | `(CLOBBER (,(CATENATE ',NAME 225 | '|\| 226 | (CAR K)) 227 | (,(CAR VARS))) 228 | (,V))) 229 | KWDS 230 | (CDR VARS)))) 231 | (LAMBDA () ,OBJ) 232 | ,@(MAPCAR '(LAMBDA (K) `(LAMBDA () ,(CAR (LAST K)))) 233 | KWDS)))))) 234 | ,@(DO ((S SLOTS (CDR S)) 235 | (N 2 (+ N 1)) 236 | (X NIL (CONS `(HUNKFN ,(CATENATE NAME '|\| (CAR S)) 237 | ,N) 238 | X))) 239 | ((NULL S) (NREVERSE X))) 240 | (DEFPROP ,NAME ,SLOTS COMPONENT-NAMES) 241 | (DEFPROP ,NAME ,SUPP SUPPRESSED-COMPONENT-NAMES) 242 | '(TYPE ,NAME DEFINED))) 243 | 244 | ;;; ADD TO A PROPERTY WHICH IS A LIST OF THINGS 245 | 246 | (DEFINE ADDPROP 247 | (LAMBDA (SYM VAL PROP) 248 | (LET ((L (GET SYM PROP))) 249 | (IF (NOT (MEMQ VAL L)) 250 | (PUTPROP SYM (CONS VAL L) PROP))))) 251 | 252 | ;;; INVERSE OF ADDPROP 253 | 254 | (DEFINE DELPROP 255 | (LAMBDA (SYM VAL PROP) 256 | (PUTPROP SYM (DELQ VAL (GET SYM PROP)) PROP))) 257 | 258 | ;;; LIKE PUTPROP, BUT INSIST ON NOT CHANGING A VALUE ALREADY THERE 259 | 260 | (DEFINE SETPROP 261 | (LAMBDA (SYM VAL PROP) 262 | (LET ((L (GETL SYM (LIST PROP)))) 263 | (IF (AND L (NOT (EQ VAL (CADR L)))) 264 | (ERROR '|Attempt to redefine a unique property| 265 | (LIST 'SETPROP SYM VAL PROP) 266 | 'FAIL-ACT) 267 | (PUTPROP SYM VAL PROP))))) 268 | 269 | ;;; OPERATIONS ON SETS, REPRESENTED AS LISTS 270 | 271 | (DEFINE ADJOIN 272 | (LAMBDA (X S) 273 | (IF (MEMQ X S) S (CONS X S)))) 274 | 275 | (DEFINE UNION 276 | (LAMBDA (X Y) 277 | (DO ((Z Y (CDR Z)) 278 | (V X (ADJOIN (CAR Z) V))) 279 | ((NULL Z) V)))) 280 | 281 | (DEFINE INTERSECT 282 | (LAMBDA (X Y) 283 | (IF (NULL X) 284 | NIL 285 | (IF (MEMQ (CAR X) Y) 286 | (CONS (CAR X) (INTERSECT (CDR X) Y)) 287 | (INTERSECT (CDR X) Y))))) 288 | 289 | (DEFINE REMOVE 290 | (LAMBDA (X S) 291 | (IF (NULL S) 292 | S 293 | (IF (EQ X (CAR S)) 294 | (CDR S) 295 | ((LAMBDA (Y) 296 | (IF (EQ Y (CDR S)) S 297 | (CONS (CAR S) Y))) 298 | (REMOVE X (CDR S))))))) 299 | 300 | (DEFINE SETDIFF 301 | (LAMBDA (X Y) 302 | (DO ((Z X (CDR Z)) 303 | (W NIL (IF (MEMQ (CAR Z) Y) 304 | W 305 | (CONS (CAR Z) W)))) 306 | ((NULL Z) W)))) 307 | 308 | (DEFINE PAIRLIS 309 | (LAMBDA (L1 L2 L) 310 | (DO ((V L1 (CDR V)) 311 | (U L2 (CDR U)) 312 | (E L (CONS (LIST (CAR V) (CAR U)) E))) 313 | ((NULL V) E)))) 314 | 315 | 316 | (DEFINE COMPILE 317 | (LAMBDA (NAME LAMBDA-EXP SEE-CRUD OPTIMIZE) 318 | (BLOCK (CHECK-NUMBER-OF-ARGS NAME 319 | (LENGTH (CADR LAMBDA-EXP)) 320 | T) 321 | (LET ((ALPHA-VERSION (ALPHATIZE LAMBDA-EXP NIL))) 322 | (IF (AND SEE-CRUD (ASK |See alpha-conversion?|)) 323 | (SX ALPHA-VERSION)) 324 | (LET ((OPT (IF (EQ OPTIMIZE 'MAYBE) 325 | (ASK |Optimize?|) 326 | OPTIMIZE))) 327 | (LET ((META-VERSION 328 | (IF OPT 329 | (META-EVALUATE ALPHA-VERSION) 330 | (PASS1-ANALYZE ALPHA-VERSION NIL NIL)))) 331 | (OR (AND (NULL (NODE\REFS META-VERSION)) 332 | (NULL (NODE\ASETS META-VERSION))) 333 | (ERROR '|ENV-ANALYZE lost - COMPILE| 334 | NAME 335 | 'FAIL-ACT)) 336 | (IF (AND SEE-CRUD OPT (ASK |See meta-evaluation?|)) 337 | (SX META-VERSION)) 338 | (LET ((CPS-VERSION (CONVERT META-VERSION NIL (NOT (NULL OPT))))) 339 | (IF (AND SEE-CRUD (ASK |See CPS-conversion?|)) 340 | (CSX CPS-VERSION)) 341 | (CENV-ANALYZE CPS-VERSION NIL NIL) 342 | (BIND-ANALYZE CPS-VERSION NIL NIL) 343 | (DEPTH-ANALYZE CPS-VERSION 0) 344 | (CLOSE-ANALYZE CPS-VERSION NIL) 345 | (COMPILATE-ONE-FUNCTION CPS-VERSION NAME)))))))) 346 | 347 | (DEFINE PASS1-ANALYZE 348 | (LAMBDA (NODE REDO OPT) 349 | (BLOCK (ENV-ANALYZE NODE REDO) 350 | (TRIV-ANALYZE NODE REDO) 351 | (IF OPT (EFFS-ANALYZE NODE REDO)) 352 | NODE))) 353 | 354 | 355 | (SCHMAC CL (FNNAME) `(TEST-COMPILE ',FNNAME)) 356 | 357 | (DEFINE TEST-COMPILE 358 | (LAMBDA (FNNAME) 359 | (LET ((FN (GET FNNAME 'SCHEME!FUNCTION))) 360 | (COND (FN (ASET' *TESTING* T) 361 | (ASET' *TEST* NIL) ;PURELY TO RELEASE FORMER GARBAGE 362 | (ASET' *ERROR-COUNT* 0) 363 | (ASET' *ERROR-LIST* NIL) 364 | (ASET' *TEST* (COMPILE FNNAME FN T 'MAYBE)) 365 | (SPRINTER *TEST*) 366 | `(,(IF (ZEROP *ERROR-COUNT*) 'NO *ERROR-COUNT*) ERRORS)) 367 | (T `(,FNNAME NOT DEFINED)))))) 368 | 369 | ;;; ALPHA-CONVERSION 370 | 371 | ;;; HERE WE RENAME ALL VARIABLES, AND CONVERT THE EXPRESSION TO AN EQUIVALENT TREE-LIKE FORM 372 | ;;; WITH EXTRA SLOTS TO BE FILLED IN LATER. AFTER THIS POINT, THE NEW NAMES ARE USED FOR 373 | ;;; VARIABLES, AND THE USER NAMES ARE USED ONLY FOR ERROR MESSAGES AND THE LIKE. THE TREE-LIKE 374 | ;;; FORM WILL BE USED AND AUGMENTED UNTIL IT IS CONVERTED TO CONTINUATION-PASSING STYLE. 375 | 376 | ;;; WE ALSO FIND ALL USER-NAMED LAMBDA-FORMS AND SET UP APPROPRIATE PROPERTIES. 377 | ;;; THE USER CAN NAME A LAMBDA-FORM BY WRITING (LAMBDA (X) BODY NAME). 378 | 379 | (DEFTYPE NODE (NAME SEXPR ENV REFS ASETS TRIVP EFFS AFFD PEFFS PAFFD METAP SUBSTP FORM) (SEXPR)) 380 | ;NAME: A GENSYM WHICH NAMES THE NODE'S VALUE 381 | ;SEXPR: THE S-EXPRESSION WHICH WAS ALPHATIZED TO MAKE THIS NODE 382 | ; (USED ONLY FOR WARNING MESSAGES AND DEBUGGING) 383 | ;ENV: THE ENVIRONMENT OF THE NODE (USED ONLY FOR DEBUGGING) 384 | ;REFS: ALL VARIABLES BOUND ABOVE AND REFERENCED BELOW OR BY THE NODE 385 | ;ASETS: ALL LOCAL VARIABLES SEEN IN AN ASET BELOW THIS NODE (A SUBSET OF REFS) 386 | ;TRIVP: NON-NIL IFF EVALUATION OF THIS NODE IS TRIVIAL 387 | ;EFFS: SET OF SIDE EFFECTS POSSIBLY OCCURRING AT THIS NODE OR BELOW 388 | ;AFFD: SET OF SIDE EFFECTS WHICH CAN POSSIBLY AFFECT THIS NODE OR BELOW 389 | ;PEFFS: ABSOLUTELY PROVABLE SET OF EFFS 390 | ;PAFFD: ABSOLUTELY PROVABLE SET OF AFFD 391 | ;METAP: NON-NIL IFF THIS NODE HAS BEEN EXAMINED BY THE META-EVALUATOR 392 | ;SUBSTP:FLAG INDICATING WHETHER META-SUBSTITUTE ACTUALLY MADE A SUBSTITUTION 393 | ;FORM: ONE OF THE BELOW TYPES 394 | 395 | (DEFTYPE CONSTANT (VALUE)) 396 | ;VALUE: THE S-EXPRESSION VALUE OF THE CONSTANT 397 | (DEFTYPE VARIABLE (VAR GLOBALP)) 398 | ;VAR: THE NEW UNIQUE NAME FOR THE VARIABLE, GENERATED BY ALPHATIZE. 399 | ; THE USER NAME AND OTHER INFORMATION IS ON ITS PROPERTY LIST. 400 | ;GLOBALP: NIL UNLESS THE VARIABLE IS GLOBAL (IN WHICH CASE VAR IS THE ACTUAL NAME) 401 | (DEFTYPE LAMBDA (UVARS VARS BODY)) 402 | ;UVARS: THE USER NAMES FOR THE BOUND VARIABLES (STRICTLY FOR DEBUGGING (SEE SEXPRFY)) 403 | ;VARS: A LIST OF THE GENERATED UNIQUE NAMES FOR THE BOUND VARIABLES 404 | ;BODY: THE NODE FOR THE BODY OF THE LAMBDA-EXPRESSION 405 | (DEFTYPE IF (PRED CON ALT)) 406 | ;PRED: THE NODE FOR THE PREDICATE 407 | ;CON: THE NODE FOR THE CONSEQUENT 408 | ;ALT: THE NODE FOR THE ALTERNATIVE 409 | (DEFTYPE ASET (VAR BODY GLOBALP)) 410 | ;VAR: THE GENERATED UNIQUE NAME FOR THE ASET VARIABLE 411 | ;BODY: THE NODE FOR THE BODY OF THE ASET 412 | ;GLOBALP: NIL UNLESS THE VARIABLE IS GLOBAL (IN WHICH CASE VAR IS THE ACTUAL NAME) 413 | (DEFTYPE CATCH (UVAR VAR BODY)) 414 | ;UVAR: THE USER NAME FOR THE BOUND VARIABLE (STRICTLY FOR DEBUGGING (SEE SEXPRFY)) 415 | ;VAR: THE GENERATED UNIQUE NAME FOR THE BOUND VARIABLE 416 | ;BODY: THE NODE FOR THE BODY OF THE CATCH 417 | (DEFTYPE LABELS (UFNVARS FNVARS FNDEFS BODY)) 418 | ;UFNVARS: THE USER NAMES FOR THE BOUND LABELS VARIABLES 419 | ;FNVARS: A LIST OF THE GENERATED UNIQUE NAMES FOR THE LABELS VARIABLES 420 | ;FNDEFS: A LIST OF THE NODES FOR THE LAMBDA-EXPRESSIONS 421 | ;BODY: THE NODE FOR THE BOY OF THE LABELS 422 | (DEFTYPE COMBINATION (ARGS WARNP)) 423 | ;ARGS: A LIST OF THE NODES FOR THE ARGUMENTS (THE FIRST IS THE FUNCTION) 424 | ;WARNP: NON-NIL IFF CHECK-COMBINATION-PEFFS HAS DETECTED A CONFLICT IN THIS COMBINATION 425 | 426 | (DEFINE NODIFY 427 | (LAMBDA (FORM SEXPR ENV) 428 | (LET ((N (CONS-NODE (NAME = (GENTEMP 'NODE)) 429 | (FORM = FORM) 430 | (SEXPR = SEXPR) 431 | (ENV = ENV) 432 | (METAP = NIL)))) 433 | (PUTPROP (NODE\NAME N) N 'NODE) 434 | N))) 435 | 436 | ;;; ON NODE NAMES THESE PROPERTIES ARE CREATED: 437 | ;;; NODE THE CORRESPONDING NODE 438 | 439 | (DEFINE ALPHATIZE 440 | (LAMBDA (SEXPR ENV) 441 | (COND ((ATOM SEXPR) 442 | (ALPHA-ATOM SEXPR ENV)) 443 | ((HUNKP SEXPR) 444 | (IF (EQ (TYPE SEXPR) 'NODE) 445 | SEXPR 446 | (ERROR '|Peculiar hunk - ALPHATIZE| SEXPR 'FAIL-ACT))) 447 | ((EQ (CAR SEXPR) 'QUOTE) 448 | (NODIFY (CONS-CONSTANT (VALUE = (CADR SEXPR))) SEXPR ENV)) 449 | ((EQ (CAR SEXPR) 'LAMBDA) 450 | (ALPHA-LAMBDA SEXPR ENV)) 451 | ((EQ (CAR SEXPR) 'IF) 452 | (ALPHA-IF SEXPR ENV)) 453 | ((EQ (CAR SEXPR) 'ASET) 454 | (ALPHA-ASET SEXPR ENV)) 455 | ((EQ (CAR SEXPR) 'CATCH) 456 | (ALPHA-CATCH SEXPR ENV)) 457 | ((EQ (CAR SEXPR) 'LABELS) 458 | (ALPHA-LABELS SEXPR ENV)) 459 | ((EQ (CAR SEXPR) 'BLOCK) 460 | (ALPHA-BLOCK SEXPR ENV)) 461 | ((AND (ATOM (CAR SEXPR)) 462 | (EQ (GET (CAR SEXPR) 'AINT) 'AMACRO)) 463 | (ALPHATIZE (MACRO-EXPAND SEXPR) ENV)) 464 | (T (ALPHA-COMBINATION SEXPR ENV))))) 465 | 466 | (DEFINE ALPHA-ATOM 467 | (LAMBDA (SEXPR ENV) 468 | (IF (OR (NUMBERP SEXPR) (NULL SEXPR) (EQ SEXPR 'T)) 469 | (NODIFY (CONS-CONSTANT (VALUE = SEXPR)) SEXPR ENV) 470 | (LET ((SLOT (ASSQ SEXPR ENV))) 471 | (NODIFY (CONS-VARIABLE (VAR = (IF SLOT (CADR SLOT) SEXPR)) 472 | (GLOBALP = (NULL SLOT))) 473 | SEXPR 474 | ENV))))) 475 | 476 | (DEFINE ALPHA-LAMBDA 477 | (LAMBDA (SEXPR ENV) 478 | (LET ((VARS (DO ((I (LENGTH (CADR SEXPR)) (- I 1)) 479 | (V NIL (CONS (GENTEMP 'VAR) V))) 480 | ((= I 0) (NREVERSE V))))) 481 | (IF (CDDDR SEXPR) 482 | (WARN |Malformed LAMBDA expression| SEXPR)) 483 | (NODIFY (CONS-LAMBDA (UVARS = (APPEND (CADR SEXPR) NIL)) 484 | ;;SEE META-COMBINATION-LAMBDA 485 | (VARS = VARS) 486 | (BODY = (ALPHATIZE (CADDR SEXPR) 487 | (PAIRLIS (CADR SEXPR) 488 | VARS 489 | ENV)))) 490 | SEXPR 491 | ENV)))) 492 | 493 | (DEFINE ALPHA-IF 494 | (LAMBDA (SEXPR ENV) 495 | (NODIFY (CONS-IF (PRED = (ALPHATIZE (CADR SEXPR) ENV)) 496 | (CON = (ALPHATIZE (CADDR SEXPR) ENV)) 497 | (ALT = (ALPHATIZE (CADDDR SEXPR) ENV))) 498 | SEXPR 499 | ENV))) 500 | 501 | (DEFINE ALPHA-ASET 502 | (LAMBDA (SEXPR ENV) 503 | (LET ((VAR (COND ((OR (ATOM (CADR SEXPR)) 504 | (NOT (EQ (CAADR SEXPR) 'QUOTE))) 505 | (ERROR '|Can't Compile Non-quoted ASET Variable| 506 | SEXPR 507 | 'FAIL-ACT)) 508 | (T (CADADR SEXPR))))) 509 | (LET ((SLOT (ASSQ VAR ENV))) 510 | (IF (AND (NULL SLOT) (TRIVFN VAR)) 511 | (ERROR '|Illegal to ASET a MacLISP primitive| 512 | SEXPR 513 | 'FAIL-ACT)) 514 | (NODIFY (CONS-ASET (VAR = (IF SLOT (CADR SLOT) VAR)) 515 | (GLOBALP = (NULL SLOT)) 516 | (BODY = (ALPHATIZE (CADDR SEXPR) ENV))) 517 | SEXPR 518 | ENV))))) 519 | 520 | (DEFINE ALPHA-CATCH 521 | (LAMBDA (SEXPR ENV) 522 | (LET ((VAR (GENTEMP 'CATCHVAR))) 523 | (NODIFY (CONS-CATCH (VAR = VAR) 524 | (UVAR = (CADR SEXPR)) 525 | (BODY = (ALPHATIZE (CADDR SEXPR) 526 | (CONS (LIST (CADR SEXPR) VAR) 527 | ENV)))) 528 | SEXPR 529 | ENV)))) 530 | 531 | (DEFINE ALPHA-LABELS 532 | (LAMBDA (SEXPR ENV) 533 | (LET ((UFNVARS (AMAPCAR (LAMBDA (X) 534 | (IF (ATOM (CAR X)) 535 | (CAR X) 536 | (CAAR X))) 537 | (CADR SEXPR)))) 538 | (LET ((FNVARS (DO ((I (LENGTH UFNVARS) (- I 1)) 539 | (V NIL (CONS (GENTEMP 'FNVAR) V))) 540 | ((= I 0) (NREVERSE V))))) 541 | (LET ((LENV (PAIRLIS UFNVARS FNVARS ENV))) 542 | (NODIFY (CONS-LABELS (UFNVARS = UFNVARS) 543 | (FNVARS = FNVARS) 544 | (FNDEFS = (AMAPCAR 545 | (LAMBDA (X) 546 | (ALPHA-LABELS-DEFN X LENV)) 547 | (CADR SEXPR))) 548 | (BODY = (ALPHATIZE (CADDR SEXPR) LENV))) 549 | SEXPR 550 | ENV)))))) 551 | 552 | (DEFINE ALPHA-LABELS-DEFN 553 | (LAMBDA (LDEF LENV) 554 | (ALPHATIZE (IF (ATOM (CAR LDEF)) 555 | (IF (CDDR LDEF) 556 | `(LAMBDA ,(CADR LDEF) ,(BLOCKIFY (CDDR LDEF))) 557 | (CADR LDEF)) 558 | `(LAMBDA ,(CDAR LDEF) ,(BLOCKIFY (CDR LDEF)))) 559 | LENV))) 560 | 561 | (DEFINE ALPHA-BLOCK 562 | (LAMBDA (SEXPR ENV) 563 | (COND ((NULL (CDR SEXPR)) 564 | (WARN |BLOCK with no forms| 565 | `(ENV = ,(AMAPCAR CAR ENV))) 566 | (ALPHATIZE NIL ENV)) 567 | (T (LABELS ((MUNG 568 | (LAMBDA (BODY) 569 | (IF (NULL (CDR BODY)) 570 | (CAR BODY) 571 | `((LAMBDA (A B) (B)) 572 | ,(CAR BODY) 573 | (LAMBDA () ,(MUNG (CDR BODY)))))))) 574 | (ALPHATIZE (MUNG (CDR SEXPR)) ENV)))))) 575 | 576 | (DEFINE MACRO-EXPAND 577 | (LAMBDA (SEXPR) 578 | (LET ((M (GETL (CAR SEXPR) '(MACRO AMACRO SMACRO)))) 579 | (IF (NULL M) 580 | (BLOCK (WARN |missing macro definition| SEXPR) 581 | `(ERROR '|Undefined Macro Form| ',SEXPR 'FAIL-ACT)) 582 | (EQCASE (CAR M) 583 | (MACRO (FUNCALL (CADR M) SEXPR)) 584 | (AMACRO (FUNCALL (CADR M) SEXPR)) 585 | (SMACRO ((SYMEVAL (CADR M)) SEXPR))))))) 586 | 587 | (DEFINE ALPHA-COMBINATION 588 | (LAMBDA (SEXPR ENV) 589 | (LET ((N (NODIFY (CONS-COMBINATION 590 | (WARNP = NIL) 591 | (ARGS = (AMAPCAR (LAMBDA (X) (ALPHATIZE X ENV)) 592 | SEXPR))) 593 | SEXPR 594 | ENV))) 595 | (LET ((M (NODE\FORM (CAR (COMBINATION\ARGS (NODE\FORM N)))))) 596 | (IF (AND (EQ (TYPE M) 'VARIABLE) 597 | (VARIABLE\GLOBALP M)) 598 | (CHECK-NUMBER-OF-ARGS 599 | (VARIABLE\VAR M) 600 | (LENGTH (CDR (COMBINATION\ARGS (NODE\FORM N)))) 601 | NIL)) 602 | N)))) 603 | 604 | ;;; ENVIRONMENT ANALYSIS. 605 | 606 | ;;; FOR NODES ENCOUNTERED WE FILL IN: 607 | ;;; REFS 608 | ;;; ASETS 609 | ;;; ON VARIABLE NAMES THESE PROPERTIES ARE CREATED: 610 | ;;; BINDING THE NODE WHERE THE VARIABLE IS BOUND 611 | ;;; USER-NAME THE USER'S NAME FOR THE VARIABLE (WHERE BOUND) 612 | ;;; READ-REFS VARIABLE NODES WHICH READ THE VARIABLE 613 | ;;; WRITE-REFS ASET NODES WHICH SET THE VARIABLE 614 | 615 | ;;; NORMALLY, ON RECURRING TO A LOWER NODE WE STOP IF THE INFORMATION 616 | ;;; IS ALREADY THERE. MAKING THE PARAMETER `REDOTHIS` BE `ALL` FORCES 617 | ;;; RE-COMPUTATION TO ALL LEVELS; MAKING IT `ONCE` FORCES 618 | ;;; RECOMPUTATION OF THIS NODE BUT NOT OF SUBNODES. 619 | 620 | (DEFINE ENV-ANALYZE 621 | (LAMBDA (NODE REDOTHIS) 622 | (IF (OR REDOTHIS (EMPTY (NODE\REFS NODE))) 623 | (LET ((FM (NODE\FORM NODE)) 624 | (REDO (IF (EQ REDOTHIS 'ALL) 'ALL NIL))) 625 | (EQCASE (TYPE FM) 626 | (CONSTANT 627 | (ALTER-NODE NODE 628 | (REFS := NIL) 629 | (ASETS := NIL))) 630 | (VARIABLE 631 | (ADDPROP (VARIABLE\VAR FM) NODE 'READ-REFS) 632 | (IF (VARIABLE\GLOBALP FM) 633 | (SETPROP (VARIABLE\VAR FM) (VARIABLE\VAR FM) 'USER-NAME)) 634 | (ALTER-NODE NODE 635 | (REFS := (AND (NOT (VARIABLE\GLOBALP FM)) 636 | (LIST (VARIABLE\VAR FM)))) 637 | (ASETS := NIL))) 638 | (LAMBDA 639 | (DO ((V (LAMBDA\VARS FM) (CDR V)) 640 | (UV (LAMBDA\UVARS FM) (CDR UV))) 641 | ((NULL V)) 642 | (SETPROP (CAR V) (CAR UV) 'USER-NAME) 643 | (SETPROP (CAR V) NODE 'BINDING)) 644 | (LET ((B (LAMBDA\BODY FM))) 645 | (ENV-ANALYZE B REDO) 646 | (ALTER-NODE NODE 647 | (REFS := (SETDIFF (NODE\REFS B) 648 | (LAMBDA\VARS FM))) 649 | (ASETS := (SETDIFF (NODE\ASETS B) 650 | (LAMBDA\VARS FM)))))) 651 | (IF 652 | (LET ((PRED (IF\PRED FM)) 653 | (CON (IF\CON FM)) 654 | (ALT (IF\ALT FM))) 655 | (ENV-ANALYZE PRED REDO) 656 | (ENV-ANALYZE CON REDO) 657 | (ENV-ANALYZE ALT REDO) 658 | (ALTER-NODE NODE 659 | (REFS := (UNION (NODE\REFS PRED) 660 | (UNION (NODE\REFS CON) 661 | (NODE\REFS ALT)))) 662 | (ASETS := (UNION (NODE\ASETS PRED) 663 | (UNION (NODE\ASETS CON) 664 | (NODE\ASETS ALT))))))) 665 | (ASET 666 | (LET ((B (ASET\BODY FM)) 667 | (V (ASET\VAR FM))) 668 | (ENV-ANALYZE B REDO) 669 | (ADDPROP V NODE 'WRITE-REFS) 670 | (IF (ASET\GLOBALP FM) 671 | (ALTER-NODE NODE 672 | (REFS := (NODE\REFS B)) 673 | (ASETS := (NODE\ASETS B))) 674 | (ALTER-NODE NODE 675 | (REFS := (ADJOIN V (NODE\REFS B))) 676 | (ASETS := (ADJOIN V (NODE\ASETS B))))))) 677 | (CATCH 678 | (LET ((B (CATCH\BODY FM)) 679 | (V (CATCH\VAR FM))) 680 | (SETPROP V (CATCH\UVAR FM) 'USER-NAME) 681 | (SETPROP V NODE 'BINDING) 682 | (ENV-ANALYZE B REDO) 683 | (ALTER-NODE NODE 684 | (REFS := (REMOVE V (NODE\REFS B))) 685 | (ASETS := (REMOVE V (NODE\ASETS B)))))) 686 | (LABELS 687 | (DO ((V (LABELS\FNVARS FM) (CDR V)) 688 | (UV (LABELS\UFNVARS FM) (CDR UV)) 689 | (D (LABELS\FNDEFS FM) (CDR D)) 690 | (R NIL (UNION R (NODE\REFS (CAR D)))) 691 | (A NIL (UNION A (NODE\ASETS (CAR D))))) 692 | ((NULL V) 693 | (LET ((B (LABELS\BODY FM))) 694 | (ENV-ANALYZE B REDO) 695 | (ALTER-NODE NODE 696 | (REFS := (SETDIFF 697 | (UNION R (NODE\REFS B)) 698 | (LABELS\FNVARS FM))) 699 | (ASETS := (SETDIFF 700 | (UNION A (NODE\ASETS B)) 701 | (LABELS\FNVARS FM)))))) 702 | (SETPROP (CAR V) (CAR UV) 'USER-NAME) 703 | (SETPROP (CAR V) NODE 'BINDING) 704 | (ENV-ANALYZE (CAR D) REDO))) 705 | (COMBINATION 706 | (LET ((ARGS (COMBINATION\ARGS FM))) 707 | (AMAPC (LAMBDA (X) (ENV-ANALYZE X REDO)) ARGS) 708 | (DO ((A ARGS (CDR A)) 709 | (R NIL (UNION R (NODE\REFS (CAR A)))) 710 | (S NIL (UNION S (NODE\ASETS (CAR A))))) 711 | ((NULL A) 712 | (ALTER-NODE NODE 713 | (REFS := R) 714 | (ASETS := S))))))))))) 715 | 716 | ;;; TRIVIALITY ANALYSIS 717 | 718 | ;;; FOR NODES ENCOUNTERED WE FILL IN: 719 | ;;; TRIVP 720 | 721 | ;;; A COMBINATION IS TRIVIAL IFF ALL ARGUMENTS ARE TRIVIAL, AND 722 | ;;; THE FUNCTION CAN BE PROVED TO BE TRIVIAL. WE ASSUME CLOSURES 723 | ;;; TO BE NON-TRIVIAL IN THIS CONTEXT, SO THAT THE CONVERT FUNCTION 724 | ;;; WILL BE FORCED TO EXAMINE THEM. 725 | 726 | (DEFINE TRIV-ANALYZE 727 | (LAMBDA (NODE REDOTHIS) 728 | (IF (OR REDOTHIS (EMPTY (NODE\TRIVP NODE))) 729 | (LET ((FM (NODE\FORM NODE)) 730 | (REDO (IF (EQ REDOTHIS 'ALL) 'ALL NIL))) 731 | (EQCASE (TYPE FM) 732 | (CONSTANT 733 | (ALTER-NODE NODE (TRIVP := T))) 734 | (VARIABLE 735 | (ALTER-NODE NODE (TRIVP := T))) 736 | (LAMBDA 737 | (TRIV-ANALYZE (LAMBDA\BODY FM) REDO) 738 | (ALTER-NODE NODE (TRIVP := NIL))) 739 | (IF 740 | (TRIV-ANALYZE (IF\PRED FM) REDO) 741 | (TRIV-ANALYZE (IF\CON FM) REDO) 742 | (TRIV-ANALYZE (IF\ALT FM) REDO) 743 | (ALTER-NODE NODE 744 | (TRIVP := (AND (NODE\TRIVP (IF\PRED FM)) 745 | (NODE\TRIVP (IF\CON FM)) 746 | (NODE\TRIVP (IF\ALT FM)))))) 747 | (ASET 748 | (TRIV-ANALYZE (ASET\BODY FM) REDO) 749 | (ALTER-NODE NODE (TRIVP := (NODE\TRIVP (ASET\BODY FM))))) 750 | (CATCH 751 | (TRIV-ANALYZE (CATCH\BODY FM) REDO) 752 | (ALTER-NODE NODE (TRIVP := NIL))) 753 | (LABELS 754 | (AMAPC (LAMBDA (F) (TRIV-ANALYZE F REDO)) 755 | (LABELS\FNDEFS FM)) 756 | (TRIV-ANALYZE (LABELS\BODY FM) REDO) 757 | (ALTER-NODE NODE (TRIVP := NIL))) 758 | (COMBINATION 759 | (LET ((ARGS (COMBINATION\ARGS FM))) 760 | (TRIV-ANALYZE (CAR ARGS) REDO) 761 | (DO ((A (CDR ARGS) (CDR A)) 762 | (SW T (AND SW (NODE\TRIVP (CAR A))))) 763 | ((NULL A) 764 | (ALTER-NODE NODE 765 | (TRIVP := (AND SW 766 | (TRIV-ANALYZE-FN-P 767 | (CAR ARGS)))))) 768 | (TRIV-ANALYZE (CAR A) REDO))))))))) 769 | 770 | (DEFINE TRIV-ANALYZE-FN-P 771 | (LAMBDA (FN) 772 | (OR (AND (EQ (TYPE (NODE\FORM FN)) 'VARIABLE) 773 | (TRIVFN (VARIABLE\VAR (NODE\FORM FN)))) 774 | (AND (EQ (TYPE (NODE\FORM FN)) 'LAMBDA) 775 | (NODE\TRIVP (LAMBDA\BODY (NODE\FORM FN))))))) 776 | 777 | ;;; SIDE-EFFECTS ANALYSIS 778 | ;;; FOR NODES ENCOUNTERED WE FILL IN: EFFS, AFFD, PEFFS, PAFFD 779 | ;;; A SET OF SIDE EFFECTS MAY BE EITHER 'NONE OR 'ANY, OR A SET. 780 | 781 | (DEFINE EFFS-ANALYZE 782 | (LAMBDA (NODE REDOTHIS) 783 | (IF (OR REDOTHIS (EMPTY (NODE\EFFS NODE))) 784 | (LET ((FM (NODE\FORM NODE)) 785 | (REDO (IF (EQ REDOTHIS 'ALL) 'ALL NIL))) 786 | (EQCASE (TYPE FM) 787 | (CONSTANT 788 | (ALTER-NODE NODE 789 | (EFFS := 'NONE) 790 | (AFFD := 'NONE) 791 | (PEFFS := 'NONE) 792 | (PAFFD := 'NONE))) 793 | (VARIABLE 794 | (LET ((A (COND ((VARIABLE\GLOBALP FM) '(SETQ)) 795 | ((GET (VARIABLE\VAR FM) 'WRITE-REFS) '(ASET)) 796 | (T 'NONE)))) 797 | (ALTER-NODE NODE 798 | (EFFS := 'NONE) 799 | (AFFD := A) 800 | (PEFFS := 'NONE) 801 | (PAFFD := A)))) 802 | (LAMBDA 803 | (EFFS-ANALYZE (LAMBDA\BODY FM) REDO) 804 | (ALTER-NODE NODE 805 | (EFFS := '(CONS)) 806 | (AFFD := NIL) 807 | (PEFFS := '(CONS)) 808 | (PAFFD := NIL))) 809 | (IF (EFFS-ANALYZE-IF NODE FM REDO)) 810 | (ASET 811 | (EFFS-ANALYZE (ASET\BODY FM) REDO) 812 | (LET ((ASETEFFS (IF (ASET\GLOBALP FM) 813 | '(SETQ) 814 | '(ASET)))) 815 | (ALTER-NODE NODE 816 | (EFFS := (EFFS-UNION ASETEFFS 817 | (NODE\EFFS (ASET\BODY FM)))) 818 | (AFFD := (NODE\AFFD (ASET\BODY FM))) 819 | (PEFFS := (EFFS-UNION ASETEFFS 820 | (NODE\PEFFS (ASET\BODY FM)))) 821 | (PAFFD := (NODE\PAFFD (ASET\BODY FM)))))) 822 | (CATCH 823 | (EFFS-ANALYZE (CATCH\BODY FM) REDO) 824 | (ALTER-NODE NODE 825 | (EFFS := (NODE\EFFS (CATCH\BODY FM))) 826 | (AFFD := (NODE\AFFD (CATCH\BODY FM))) 827 | (PEFFS := (NODE\PEFFS (CATCH\BODY FM))) 828 | (PAFFD := (NODE\PAFFD (CATCH\BODY FM))))) 829 | (LABELS 830 | (AMAPC (LAMBDA (F) (EFFS-ANALYZE F REDO)) 831 | (LABELS\FNDEFS FM)) 832 | (EFFS-ANALYZE (LABELS\BODY FM) REDO) 833 | (ALTER-NODE NODE 834 | (EFFS := (EFFS-UNION '(CONS) 835 | (NODE\EFFS (LABELS\BODY FM)))) 836 | (AFFD := (NODE\AFFD (LABELS\BODY FM))) 837 | (PEFFS := (EFFS-UNION '(CONS) 838 | (NODE\PEFFS (LABELS\BODY FM)))) 839 | (PAFFD := (NODE\PAFFD (LABELS\BODY FM))))) 840 | (COMBINATION 841 | (EFFS-ANALYZE-COMBINATION NODE FM REDO))))))) 842 | 843 | (DEFINE EFFS-UNION 844 | (LAMBDA (A B) 845 | (COND ((EQ A 'NONE) B) 846 | ((EQ B 'NONE) A) 847 | ((EQ A 'ANY) 'ANY) 848 | ((EQ B 'ANY) 'ANY) 849 | (T (UNION A B))))) 850 | 851 | (DEFINE EFFS-ANALYZE-IF 852 | (LAMBDA (NODE FM REDO) 853 | (BLOCK (EFFS-ANALYZE (IF\PRED FM) REDO) 854 | (EFFS-ANALYZE (IF\CON FM) REDO) 855 | (EFFS-ANALYZE (IF\ALT FM) REDO) 856 | (ALTER-NODE NODE 857 | (EFFS := (EFFS-UNION (NODE\EFFS (IF\PRED FM)) 858 | (EFFS-UNION (NODE\EFFS (IF\CON FM)) 859 | (NODE\EFFS (IF\ALT FM))))) 860 | (AFFD := (EFFS-UNION (NODE\AFFD (IF\PRED FM)) 861 | (EFFS-UNION (NODE\AFFD (IF\CON FM)) 862 | (NODE\AFFD (IF\ALT FM))))) 863 | (PEFFS := (EFFS-UNION (NODE\PEFFS (IF\PRED FM)) 864 | (EFFS-UNION (NODE\PEFFS (IF\CON FM)) 865 | (NODE\PEFFS (IF\ALT FM))))) 866 | (PAFFD := (EFFS-UNION (NODE\PAFFD (IF\PRED FM)) 867 | (EFFS-UNION (NODE\PAFFD (IF\CON FM)) 868 | (NODE\PAFFD (IF\ALT FM))))))))) 869 | 870 | (SET' *CHECK-PEFFS* NIL) 871 | 872 | (DEFINE EFFS-ANALYZE-COMBINATION 873 | (LAMBDA (NODE FM REDO) 874 | (LET ((ARGS (COMBINATION\ARGS FM))) 875 | (EFFS-ANALYZE (CAR ARGS) REDO) 876 | (DO ((A (CDR ARGS) (CDR A)) 877 | (EF 'NONE (EFFS-UNION EF (NODE\EFFS (CAR A)))) 878 | (AF 'NONE (EFFS-UNION AF (NODE\AFFD (CAR A)))) 879 | (PEF 'NONE (EFFS-UNION PEF (NODE\PEFFS (CAR A)))) 880 | (PAF 'NONE (EFFS-UNION PAF (NODE\PAFFD (CAR A))))) 881 | ((NULL A) 882 | (IF *CHECK-PEFFS* (CHECK-COMBINATION-PEFFS FM)) 883 | (COND ((EQ (TYPE (NODE\FORM (CAR ARGS))) 'VARIABLE) 884 | (LET ((V (VARIABLE\VAR (NODE\FORM (CAR ARGS))))) 885 | (LET ((VE (GET V 'FN-SIDE-EFFECTS)) 886 | (VA (GET V 'FN-SIDE-AFFECTED))) 887 | (ALTER-NODE NODE 888 | (EFFS := (IF VE (EFFS-UNION EF VE) 'ANY)) 889 | (AFFD := (IF VA (EFFS-UNION AF VA) 'ANY)) 890 | (PEFFS := (EFFS-UNION PEF VE)) 891 | (PAFFD := (EFFS-UNION PAF VA)))))) 892 | ((EQ (TYPE (NODE\FORM (CAR ARGS))) 'LAMBDA) 893 | (LET ((B (LAMBDA\BODY (NODE\FORM (CAR ARGS))))) 894 | (ALTER-NODE NODE 895 | (EFFS := (EFFS-UNION EF (NODE\EFFS B))) 896 | (AFFD := (EFFS-UNION AF (NODE\AFFD B))) 897 | (PEFFS := (EFFS-UNION PEF (NODE\PEFFS B))) 898 | (PAFFD := (EFFS-UNION PAF (NODE\PAFFD B)))))) 899 | (T (ALTER-NODE NODE 900 | (EFFS := 'ANY) 901 | (AFFD := 'ANY) 902 | (PEFFS := (EFFS-UNION PEF 903 | (NODE\PEFFS (CAR ARGS)))) 904 | (PAFFD := (EFFS-UNION PAF 905 | (NODE\PAFFD (CAR ARGS)))))))) 906 | (EFFS-ANALYZE (CAR A) REDO))))) 907 | 908 | (DEFINE CHECK-COMBINATION-PEFFS 909 | (LAMBDA (FM) 910 | (IF (NOT (COMBINATION\WARNP FM)) 911 | (DO ((A (COMBINATION\ARGS FM) (CDR A))) 912 | ((NULL A)) 913 | (DO ((B (CDR A) (CDR B))) 914 | ((NULL B)) 915 | (IF (NOT (EFFECTLESS (EFFS-INTERSECT (NODE\PEFFS (CAR A)) 916 | (NODE\PAFFD (CAR B))))) 917 | (BLOCK (WARN |co-argument may affect later one| 918 | (NODE\SEXPR (CAR A)) 919 | `(EFFECTS = ,(NODE\PEFFS (CAR A))) 920 | (NODE\SEXPR (CAR B)) 921 | `(AFFECTED BY ,(NODE\PAFFD (CAR B)))) 922 | (ALTER-COMBINATION FM (WARNP := T)))) 923 | (IF (NOT (EFFECTLESS (EFFS-INTERSECT (NODE\PEFFS (CAR B)) 924 | (NODE\PAFFD (CAR A))))) 925 | (BLOCK (WARN |co-argument may affect earlier one| 926 | (NODE\SEXPR (CAR B)) 927 | `(EFFECTS = ,(NODE\PEFFS (CAR B))) 928 | (NODE\SEXPR (CAR A)) 929 | `(AFFECTED BY ,(NODE\PAFFD (CAR A)))) 930 | (ALTER-COMBINATION FM (WARNP := T)))) 931 | (IF (NOT (EFFECTLESS-EXCEPT-CONS (EFFS-INTERSECT (NODE\PEFFS (CAR A)) 932 | (NODE\PEFFS (CAR B))))) 933 | (BLOCK (WARN |co-arguments may have interfering effects| 934 | (NODE\SEXPR (CAR A)) 935 | `(EFFECTS = ,(NODE\PEFFS (CAR A))) 936 | (NODE\SEXPR (CAR B)) 937 | `(EFFECTS = ,(NODE\PEFFS (CAR B)))) 938 | (ALTER-COMBINATION FM (WARNP := T))))))))) 939 | 940 | (DEFMAC EFFDEF (FN EFFS AFFD . FOLD) 941 | `(PROGN (DEFPROP ,FN ,EFFS FN-SIDE-EFFECTS) 942 | (DEFPROP ,FN ,AFFD FN-SIDE-AFFECTED) 943 | ,(AND FOLD `(DEFPROP ,FN T OKAY-TO-FOLD)))) 944 | 945 | (DECLARE (/@DEFINE EFFDEF |SIDE EFFECTS|)) 946 | 947 | (PROGN 'COMPILE 948 | (EFFDEF + NONE NONE) 949 | (EFFDEF - NONE NONE) 950 | (EFFDEF * NONE NONE) 951 | (EFFDEF // NONE NONE) 952 | (EFFDEF = NONE NONE) 953 | (EFFDEF < NONE NONE) 954 | (EFFDEF > NONE NONE) 955 | (EFFDEF CAR NONE (RPLACA)) 956 | (EFFDEF CDR NONE (RPLACD)) 957 | (EFFDEF CAAR NONE (RPLACA)) 958 | (EFFDEF CADR NONE (RPLACA RPLACD)) 959 | (EFFDEF CDAR NONE (RPLACA RPLACD)) 960 | (EFFDEF CDDR NONE (RPLACD)) 961 | (EFFDEF CAAAR NONE (RPLACA)) 962 | (EFFDEF CAADR NONE (RPLACA RPLACD)) 963 | (EFFDEF CADAR NONE (RPLACA RPLACD)) 964 | (EFFDEF CADDR NONE (RPLACA RPLACD)) 965 | (EFFDEF CDAAR NONE (RPLACA RPLACD)) 966 | (EFFDEF CDADR NONE (RPLACA RPLACD)) 967 | (EFFDEF CDDAR NONE (RPLACA RPLACD)) 968 | (EFFDEF CDDDR NONE (RPLACD)) 969 | (EFFDEF CAAAAR NONE (RPLACA)) 970 | (EFFDEF CAAADR NONE (RPLACA RPLACD)) 971 | (EFFDEF CAADAR NONE (RPLACA RPLACD)) 972 | (EFFDEF CAADDR NONE (RPLACA RPLACD)) 973 | (EFFDEF CADAAR NONE (RPLACA RPLACD)) 974 | (EFFDEF CADADR NONE (RPLACA RPLACD)) 975 | (EFFDEF CADDAR NONE (RPLACA RPLACD)) 976 | (EFFDEF CADDDR NONE (RPLACA RPLACD)) 977 | (EFFDEF CDAAAR NONE (RPLACA RPLACD)) 978 | (EFFDEF CDAADR NONE (RPLACA RPLACD)) 979 | (EFFDEF CDADAR NONE (RPLACA RPLACD)) 980 | (EFFDEF CDADDR NONE (RPLACA RPLACD)) 981 | (EFFDEF CDDAAR NONE (RPLACA RPLACD)) 982 | (EFFDEF CDDADR NONE (RPLACA RPLACD)) 983 | (EFFDEF CDDDAR NONE (RPLACA RPLACD)) 984 | (EFFDEF CDDDDR NONE (RPLACD)) 985 | (EFFDEF CXR NONE (RPLACA RPLACD)) 986 | (EFFDEF RPLACA (RPLACA) NONE) 987 | (EFFDEF RPLACD (RPLACA) NONE) 988 | (EFFDEF RPLACX (RPLACA RPLACD) NONE) 989 | (EFFDEF EQ NONE NONE) 990 | (EFFDEF ATOM NONE NONE) 991 | (EFFDEF NUMBERP NONE NONE) 992 | (EFFDEF TYPEP NONE NONE) 993 | (EFFDEF SYMBOLP NONE NONE) 994 | (EFFDEF HUNKP NONE NONE) 995 | (EFFDEF FIXP NONE NONE) 996 | (EFFDEF FLOATP NONE NONE) 997 | (EFFDEF BIGP NONE NONE) 998 | (EFFDEF NOT NONE NONE) 999 | (EFFDEF NULL NONE NONE) 1000 | (EFFDEF CONS (CONS) NONE) 1001 | (EFFDEF LIST (CONS) NONE) 1002 | (EFFDEF APPEND (CONS) (RPLACD)) 1003 | (EFFDEF MEMQ NONE (RPLACA RPLACD) T) 1004 | (EFFDEF ASSQ NONE (RPLACA RPLACD) T) 1005 | (EFFDEF PRINT (FILE) (FILE RPLACA RPLACD)) 1006 | (EFFDEF PRIN1 (FILE) (FILE RPLACA RPLACD)) 1007 | (EFFDEF PRINC (FILE) (FILE RPLACA RPLACD)) 1008 | (EFFDEF TERPRI (FILE) (FILE)) 1009 | (EFFDEF TYO (FILE) (FILE)) 1010 | (EFFDEF READ ANY (FILE)) 1011 | (EFFDEF TYI ANY (FILE)) 1012 | 'SIDE-EFFECTS-PROPERTIES) 1013 | 1014 | ;;; THIS ROUTINE IS USED TO UNDO ANY PASS 1 ANALYSIS ON A NODE. 1015 | 1016 | (DEFMAC ERASE-NODE (NODE) `(ERASE-NODES ,NODE NIL)) 1017 | (DEFMAC ERASE-ALL-NODES (NODE) `(ERASE-NODES ,NODE T)) 1018 | 1019 | (DEFINE ERASE-NODES 1020 | (LAMBDA (NODE ALLP) 1021 | (LET ((FM (NODE\FORM NODE))) 1022 | (OR (EQ (TYPE NODE) 'NODE) 1023 | (ERROR '|Cannot erase a non-node| NODE 'FAIL-ACT)) 1024 | (EQCASE (TYPE FM) 1025 | (CONSTANT) 1026 | (VARIABLE 1027 | (DELPROP (VARIABLE\VAR FM) NODE 'READ-REFS)) 1028 | (LAMBDA 1029 | (IF ALLP (ERASE-ALL-NODES (LAMBDA\BODY FM))) 1030 | (IF (NOT *TESTING*) 1031 | (AMAPC (LAMBDA (V) (REMPROP V 'BINDING)) (LAMBDA\VARS FM)))) 1032 | (IF (COND (ALLP (ERASE-ALL-NODES (IF\PRED FM)) 1033 | (ERASE-ALL-NODES (IF\CON FM)) 1034 | (ERASE-ALL-NODES (IF\ALT FM))))) 1035 | (ASET 1036 | (IF ALLP (ERASE-ALL-NODES (ASET\BODY FM))) 1037 | (DELPROP (ASET\VAR FM) NODE 'WRITE-REFS)) 1038 | (CATCH 1039 | (IF ALLP (ERASE-ALL-NODES (CATCH\BODY FM))) 1040 | (IF (NOT *TESTING*) 1041 | (REMPROP (CATCH\VAR FM) 'BINDING))) 1042 | (LABELS 1043 | (COND (ALLP (AMAPC (LAMBDA (D) (ERASE-ALL-NODES D)) 1044 | (LABELS\FNDEFS FM)) 1045 | (ERASE-ALL-NODES (LABELS\BODY FM)))) 1046 | (IF (NOT *TESTING*) 1047 | (AMAPC (LAMBDA (V) (REMPROP V 'BINDING)) (LABELS\FNVARS FM)))) 1048 | (COMBINATION 1049 | (IF ALLP (AMAPC (LAMBDA (A) (ERASE-ALL-NODES A)) 1050 | (COMBINATION\ARGS FM))))) 1051 | (IF (NOT *TESTING*) 1052 | (REMPROP (NODE\NAME NODE) 'NODE))))) 1053 | 1054 | ;;; THE VALUE OF META-EVALUATE IS THE (POSSIBLY NEW) NODE RESULTING FROM THE GIVEN ONE. 1055 | 1056 | (SET' *FUDGE* T) ;SWITCH TO CONTROL META-IF-FUDGE 1057 | (SET' *DEAD-COUNT* 0) ;COUNT OF DEAD-CODE ELIMINATIONS 1058 | 1059 | (DEFINE META-EVALUATE 1060 | (LAMBDA (NODE) 1061 | (IF (NODE\METAP NODE) 1062 | NODE 1063 | (LET ((FM (NODE\FORM NODE))) 1064 | (EQCASE (TYPE FM) 1065 | (CONSTANT 1066 | (REANALYZE1 NODE) 1067 | (ALTER-NODE NODE (METAP := T))) 1068 | (VARIABLE 1069 | (REANALYZE1 NODE) 1070 | (ALTER-NODE NODE (METAP := T))) 1071 | (LAMBDA 1072 | (ALTER-LAMBDA FM (BODY := (META-EVALUATE (LAMBDA\BODY FM)))) 1073 | (REANALYZE1 NODE) 1074 | (ALTER-NODE NODE (METAP := T))) 1075 | (IF 1076 | (ALTER-IF FM 1077 | (PRED := (META-EVALUATE (IF\PRED FM))) 1078 | (CON := (META-EVALUATE (IF\CON FM))) 1079 | (ALT := (META-EVALUATE (IF\ALT FM)))) 1080 | (IF (AND *FUDGE* (EQ (TYPE (NODE\FORM (IF\PRED FM))) 'IF)) 1081 | (META-IF-FUDGE NODE) 1082 | (IF (EQ (TYPE (NODE\FORM (IF\PRED FM))) 'CONSTANT) 1083 | (LET ((CON (IF\CON FM)) 1084 | (ALT (IF\ALT FM)) 1085 | (VAL (CONSTANT\VALUE (NODE\FORM (IF\PRED FM))))) 1086 | (ERASE-NODE NODE) 1087 | (ERASE-ALL-NODES (IF\PRED FM)) 1088 | (INCREMENT *DEAD-COUNT*) 1089 | (IF VAL 1090 | (BLOCK (ERASE-ALL-NODES ALT) CON) 1091 | (BLOCK (ERASE-ALL-NODES CON) ALT))) 1092 | (BLOCK (REANALYZE1 NODE) 1093 | (ALTER-NODE NODE (METAP := T)))))) 1094 | (ASET 1095 | (ALTER-ASET FM (BODY := (META-EVALUATE (ASET\BODY FM)))) 1096 | (REANALYZE1 NODE) 1097 | (ALTER-NODE NODE (METAP := T))) 1098 | (CATCH 1099 | (ALTER-CATCH FM (BODY := (META-EVALUATE (CATCH\BODY FM)))) 1100 | (REANALYZE1 NODE) 1101 | (ALTER-NODE NODE (METAP := T))) 1102 | (LABELS 1103 | (DO ((D (LABELS\FNDEFS FM) (CDR D))) 1104 | ((NULL D)) 1105 | (RPLACA D (META-EVALUATE (CAR D)))) 1106 | (ALTER-LABELS FM (BODY := (META-EVALUATE (LABELS\BODY FM)))) 1107 | (REANALYZE1 NODE) 1108 | (ALTER-NODE NODE (METAP := T))) 1109 | (COMBINATION 1110 | (LET ((FN (NODE\FORM (CAR (COMBINATION\ARGS FM))))) 1111 | (COND ((AND (EQ (TYPE FN) 'VARIABLE) 1112 | (TRIVFN (VARIABLE\VAR FN))) 1113 | (META-COMBINATION-TRIVFN NODE)) 1114 | ((EQ (TYPE FN) 'LAMBDA) 1115 | (META-COMBINATION-LAMBDA NODE)) 1116 | (T (DO ((A (COMBINATION\ARGS FM) (CDR A))) 1117 | ((NULL A)) 1118 | (RPLACA A (META-EVALUATE (CAR A)))) 1119 | (REANALYZE1 NODE) 1120 | (ALTER-NODE NODE (METAP := T))))))))))) 1121 | 1122 | ;;; TRANSFORM (IF (IF A B C) D E) INTO: 1123 | ;;; ((LAMBDA (D1 E1) 1124 | ;;; (IF A (IF B (D1) (E1)) (IF C (D1) (E1)))) 1125 | ;;; (LAMBDA () D) 1126 | ;;; (LAMBDA () E)) 1127 | 1128 | (SET' *FUDGE-COUNT* 0) ;COUNT OF IF-FUDGES 1129 | 1130 | (DEFINE META-IF-FUDGE 1131 | (LAMBDA (NODE) 1132 | (LET ((FM (NODE\FORM NODE))) 1133 | (LET ((PFM (NODE\FORM (IF\PRED FM)))) 1134 | (LET ((N (ALPHATIZE (LET ((CONVAR (GENTEMP 'META-CON)) 1135 | (ALTVAR (GENTEMP 'META-ALT))) 1136 | `((LAMBDA (,CONVAR ,ALTVAR) 1137 | (IF ,(IF\PRED PFM) 1138 | (IF ,(IF\CON PFM) 1139 | (,CONVAR) 1140 | (,ALTVAR)) 1141 | (IF ,(IF\ALT PFM) 1142 | (,CONVAR) 1143 | (,ALTVAR)))) 1144 | (LAMBDA () ,(IF\CON FM)) 1145 | (LAMBDA () ,(IF\ALT FM)))) 1146 | (NODE\ENV NODE)))) ;DOESN'T MATTER 1147 | (ERASE-NODE NODE) 1148 | (ERASE-NODE (IF\PRED FM)) 1149 | (INCREMENT *FUDGE-COUNT*) 1150 | (META-EVALUATE N)))))) 1151 | 1152 | ;;; REDUCE A COMBINATION WITH A SIDE-EFFECT-LESS TRIVIAL 1153 | ;;; FUNCTION AND CONSTANT ARGUMENTS TO A CONSTANT. 1154 | 1155 | (SET' *FOLD-COUNT* 0) ;COUNT OF CONSTANT FOLDINGS 1156 | 1157 | (DEFINE META-COMBINATION-TRIVFN 1158 | (LAMBDA (NODE) 1159 | (LET ((FM (NODE\FORM NODE))) 1160 | (LET ((ARGS (COMBINATION\ARGS FM))) 1161 | (RPLACA ARGS (META-EVALUATE (CAR ARGS))) 1162 | (DO ((A (CDR ARGS) (CDR A)) 1163 | (CONSTP (LET ((FNNAME (VARIABLE\VAR (NODE\FORM (CAR ARGS))))) 1164 | (OR (AND (EQ (GET FNNAME 1165 | 'FN-SIDE-EFFECTS) 1166 | 'NONE) 1167 | (EQ (GET FNNAME 1168 | 'FN-SIDE-AFFECTED) 1169 | 'NONE)) 1170 | (GET FNNAME 'OKAY-TO-FOLD))) 1171 | (AND CONSTP (EQ (TYPE (NODE\FORM (CAR A))) 'CONSTANT)))) 1172 | ((NULL A) 1173 | (COND (CONSTP 1174 | (LET ((VAL (APPLY (VARIABLE\VAR (NODE\FORM (CAR ARGS))) 1175 | (AMAPCAR (LAMBDA (X) 1176 | (CONSTANT\VALUE 1177 | (NODE\FORM X))) 1178 | (CDR ARGS))))) 1179 | (ERASE-ALL-NODES NODE) 1180 | (INCREMENT *FOLD-COUNT*) 1181 | (META-EVALUATE (ALPHATIZE `(QUOTE ,VAL) NIL)))) 1182 | (T (REANALYZE1 NODE) 1183 | (ALTER-NODE NODE (METAP := T))))) 1184 | (RPLACA A (META-EVALUATE (CAR A)))))))) 1185 | 1186 | (SET' *FLUSH-ARGS* T) ;SWITCH TO CONTROL VARIABLE ELIMINATION 1187 | (SET' *FLUSH-COUNT* 0) ;COUNT OF VARIABLES ELIMINATED 1188 | (SET' *CONVERT-COUNT* 0) ;COUNT OF FULL BETA-CONVERSIONS 1189 | 1190 | (DEFINE 1191 | META-COMBINATION-LAMBDA 1192 | (LAMBDA (NODE) 1193 | (LET ((FM (NODE\FORM NODE))) 1194 | (LET ((ARGS (COMBINATION\ARGS FM))) 1195 | (DO ((A (CDR ARGS) (CDR A))) 1196 | ((NULL A)) 1197 | (RPLACA A (META-EVALUATE (CAR A))) 1198 | (ALTER-NODE (CAR A) (SUBSTP := NIL))) 1199 | (LET ((FN (NODE\FORM (CAR ARGS)))) 1200 | (DO ((V (LAMBDA\VARS FN) (CDR V)) 1201 | (A (CDR ARGS) (CDR A)) 1202 | (B (META-EVALUATE (LAMBDA\BODY FN)) 1203 | (IF (SUBST-CANDIDATE (CAR A) (CAR V) B) 1204 | (META-SUBSTITUTE (CAR A) (CAR V) B) 1205 | B))) 1206 | ((NULL V) 1207 | (ALTER-LAMBDA FN (BODY := (META-EVALUATE B))) 1208 | (DO ((V (LAMBDA\VARS FN) (CDR V)) 1209 | (A (CDR ARGS) (CDR A))) 1210 | ((NULL A)) 1211 | (IF (AND *FLUSH-ARGS* 1212 | (NULL (GET (CAR V) 'READ-REFS)) 1213 | (NULL (GET (CAR V) 'WRITE-REFS)) 1214 | (OR (EFFECTLESS-EXCEPT-CONS (NODE\EFFS (CAR A))) 1215 | (NODE\SUBSTP (CAR A)))) 1216 | (BLOCK (IF (OR (MEMQ V (NODE\REFS (LAMBDA\BODY FN))) 1217 | (MEMQ V (NODE\ASETS (LAMBDA\BODY FN)))) 1218 | (ERROR '|Reanalysis lost - META-COMBINATION-LAMBDA| 1219 | NODE 1220 | 'FAIL-ACT)) 1221 | (DELQ (CAR A) ARGS) 1222 | (ERASE-ALL-NODES (CAR A)) 1223 | (INCREMENT *FLUSH-COUNT*) 1224 | (ALTER-LAMBDA FN 1225 | (VARS := (DELQ (CAR V) (LAMBDA\VARS FN))) 1226 | (UVARS := (DELQ (GET (CAR V) 'USER-NAME) 1227 | (LAMBDA\UVARS FN))))))) 1228 | (COND ((NULL (LAMBDA\VARS FN)) 1229 | (OR (NULL (CDR ARGS)) 1230 | (ERROR '|Too many args in META-COMBINATION-LAMBDA| 1231 | NODE 1232 | 'FAIL-ACT)) 1233 | (LET ((BOD (LAMBDA\BODY FN))) 1234 | (ERASE-NODE (CAR ARGS)) 1235 | (ERASE-NODE NODE) 1236 | (INCREMENT *CONVERT-COUNT*) 1237 | BOD)) 1238 | (T (REANALYZE1 (CAR ARGS)) 1239 | (ALTER-NODE (CAR ARGS) (METAP := T)) 1240 | (REANALYZE1 NODE) 1241 | (ALTER-NODE NODE (METAP := T))))))))))) 1242 | 1243 | (SET' *SUBSTITUTE* T) ;SWITCH TO CONTROL SUBSTITUTION 1244 | (SET' *SINGLE-SUBST* T) ;SWITCH TO CONTROL SUBSTITUTION OF EXPRESSIONS WITH SIDE EFFECTS 1245 | (SET' *LAMBDA-SUBST* T) ;SWITCH TO CONTROL SUBSTITUTION OF LAMBDA-EXPRESSIONS 1246 | 1247 | (DEFINE SUBST-CANDIDATE 1248 | (LAMBDA (ARG VAR BOD) 1249 | (AND *SUBSTITUTE* 1250 | (NOT (GET VAR 'WRITE-REFS)) ;BE PARANOID FOR NOW 1251 | (OR (AND *SINGLE-SUBST* 1252 | (NULL (CDR (GET VAR 'READ-REFS)))) 1253 | (MEMQ (TYPE (NODE\FORM ARG)) '(CONSTANT VARIABLE)) 1254 | (AND *LAMBDA-SUBST* 1255 | (EQ (TYPE (NODE\FORM ARG)) 'LAMBDA) 1256 | (OR (NULL (CDR (GET VAR 'READ-REFS))) 1257 | (LET ((B (NODE\FORM (LAMBDA\BODY (NODE\FORM ARG))))) 1258 | (OR (MEMQ (TYPE B) '(CONSTANT VARIABLE)) 1259 | (AND (EQ (TYPE B) 'COMBINATION) 1260 | (NOT (> (LENGTH (CDR (COMBINATION\ARGS B))) 1261 | (LENGTH (LAMBDA\VARS (NODE\FORM ARG))))) 1262 | (DO ((A (COMBINATION\ARGS B) (CDR A)) 1263 | (P T (AND P (MEMQ (TYPE (NODE\FORM (CAR A))) 1264 | '(CONSTANT VARIABLE))))) 1265 | ((NULL A) P))))))))))) 1266 | 1267 | (DEFINE REANALYZE1 1268 | (LAMBDA (NODE) 1269 | (PASS1-ANALYZE NODE *REANALYZE* T))) 1270 | 1271 | (SET' *REANALYZE* 'ONCE) 1272 | 1273 | 1274 | 1275 | ;;; HERE WE DETERMINE, FOR EACH VARIABLE NODE WHOSE VAR IS THE ONE 1276 | ;;; GIVEN, WHETHER IT IS POSSIBLE TO SUBSTITUTE IN FOR IT; THIS IS 1277 | ;;; DETERMINED ON THE BASIS OF SIDE EFFECTS. THIS IS DONE BY 1278 | ;;; WALKING THE PROGRAM, STOPPING WHEN A SIDE-EFFECT BLOCKS IT. 1279 | ;;; A SUBSTITUTION IS MADE IFF IS VARIABLE NODE IS REACHED IN THE WALK. 1280 | 1281 | ;;; THERE IS A BUG IN THIS THEORY TO THE EFFECT THAT A CATCH 1282 | ;;; WHICH RETURNS MULTIPLY CAN CAUSE AN EXPRESSION EXTERNAL 1283 | ;;; TO THE CATCH TO BE EVALUATED TWICE. THIS IS A DYNAMIC PROBLEM 1284 | ;;; WHICH CANNOT BE RESOLVED AT COMPILE TIME, AND SO WE SHALL 1285 | ;;; IGNORE IT FOR NOW. 1286 | 1287 | ;;; WE ALSO RESET THE METAP FLAG ON ALL NODES WHICH HAVE A 1288 | ;;; SUBSTITUTION AT OR BELOW THEM, SO THAT THE META-EVALUATOR WILL 1289 | ;;; RE-PENETRATE TO SUBSTITUTION POINTS, WHICH MAY ADMIT FURTHER 1290 | ;;; OPTIMIZATIONS. 1291 | 1292 | 1293 | (DEFINE EFFS-INTERSECT 1294 | (LAMBDA (A B) 1295 | (COND ((EQ A 'ANY) B) 1296 | ((EQ B 'ANY) A) 1297 | ((EQ A 'NONE) A) 1298 | ((EQ B 'NONE) B) 1299 | (T (INTERSECT A B))))) 1300 | 1301 | (DEFINE EFFECTLESS 1302 | (LAMBDA (X) (OR (NULL X) (EQ X 'NONE)))) 1303 | 1304 | (DEFINE EFFECTLESS-EXCEPT-CONS 1305 | (LAMBDA (X) (OR (EFFECTLESS X) (EQUAL X '(CONS))))) 1306 | 1307 | (DEFINE PASSABLE 1308 | (LAMBDA (NODE EFFS AFFD) 1309 | (BLOCK (IF (EMPTY (NODE\EFFS NODE)) 1310 | (ERROR '|Pass 1 Analysis Missing - PASSABLE| 1311 | NODE 1312 | 'FAIL-ACT)) 1313 | (AND (EFFECTLESS (EFFS-INTERSECT EFFS (NODE\AFFD NODE))) 1314 | (EFFECTLESS (EFFS-INTERSECT AFFD (NODE\EFFS NODE))) 1315 | (EFFECTLESS-EXCEPT-CONS (EFFS-INTERSECT EFFS (NODE\EFFS NODE))))))) 1316 | 1317 | (SET' *SUBST-COUNT* 0) ;COUNT OF SUBSTITUTIONS 1318 | (SET' *LAMBDA-BODY-SUBST* T) ;SWITCH TO CONTROL SUBSTITUTION IN LAMBDA BODIES 1319 | (SET' *LAMBDA-BODY-SUBST-TRY-COUNT* 0) ;COUNT THEREOF - TRIES 1320 | (SET' *LAMBDA-BODY-SUBST-SUCCESS-COUNT* 0) ;COUNT THEREOF - SUCCESSES 1321 | 1322 | 1323 | (DEFINE 1324 | META-SUBSTITUTE 1325 | (LAMBDA 1326 | (ARG VAR BOD) 1327 | (LET ((EFFS (NODE\EFFS ARG)) 1328 | (AFFD (NODE\AFFD ARG))) 1329 | (IF (EMPTY EFFS) 1330 | (ERROR '|Pass 1 Analysis Screwed Up - META-SUBSTITUTE| ARG 'FAIL-ACT)) 1331 | (LABELS 1332 | ((SUBSTITUTE 1333 | (LAMBDA (NODE) 1334 | (IF (OR (EMPTY (NODE\REFS NODE)) 1335 | (NOT (MEMQ VAR (NODE\REFS NODE)))) ;EFFICIENCY HACK 1336 | NODE 1337 | (LET ((FM (NODE\FORM NODE))) 1338 | (EQCASE (TYPE FM) 1339 | (CONSTANT NODE) 1340 | (VARIABLE 1341 | (IF (EQ (VARIABLE\VAR FM) VAR) 1342 | (BLOCK (ERASE-ALL-NODES NODE) 1343 | (INCREMENT *SUBST-COUNT*) 1344 | (ALTER-NODE ARG (SUBSTP := T)) 1345 | (COPY-CODE ARG)) 1346 | NODE)) 1347 | (LAMBDA 1348 | (IF (AND (EFFECTLESS-EXCEPT-CONS EFFS) (EFFECTLESS AFFD)) 1349 | (ALTER-LAMBDA FM (BODY := (SUBSTITUTE (LAMBDA\BODY FM))))) 1350 | (IF (NODE\METAP NODE) 1351 | (ALTER-NODE NODE (METAP := (NODE\METAP (LAMBDA\BODY FM))))) 1352 | NODE) 1353 | (IF 1354 | (ALTER-IF FM (PRED := (SUBSTITUTE (IF\PRED FM)))) 1355 | (IF (PASSABLE (IF\PRED FM) EFFS AFFD) 1356 | (ALTER-IF FM 1357 | (CON := (SUBSTITUTE (IF\CON FM))) 1358 | (ALT := (SUBSTITUTE (IF\ALT FM))))) 1359 | (IF (NODE\METAP NODE) 1360 | (ALTER-NODE NODE 1361 | (METAP := (AND (NODE\METAP (IF\PRED FM)) 1362 | (NODE\METAP (IF\CON FM)) 1363 | (NODE\METAP (IF\ALT FM)))))) 1364 | NODE) 1365 | (ASET 1366 | (ALTER-ASET FM (BODY := (SUBSTITUTE (ASET\BODY FM)))) 1367 | (IF (NODE\METAP NODE) 1368 | (ALTER-NODE NODE (METAP := (NODE\METAP (ASET\BODY FM))))) 1369 | NODE) 1370 | (CATCH 1371 | (ALTER-CATCH FM (BODY := (SUBSTITUTE (CATCH\BODY FM)))) 1372 | (IF (NODE\METAP NODE) 1373 | (ALTER-NODE NODE (METAP := (NODE\METAP (CATCH\BODY FM))))) 1374 | NODE) 1375 | (LABELS 1376 | (ALTER-LABELS FM (BODY := (SUBSTITUTE (LABELS\BODY FM)))) 1377 | (DO ((D (LABELS\FNDEFS FM) (CDR D)) 1378 | (MP (NODE\METAP (LABELS\BODY FM)) 1379 | (AND MP (NODE\METAP (CAR D))))) 1380 | ((NULL D) 1381 | (IF (NODE\METAP NODE) 1382 | (ALTER-NODE NODE (METAP := MP)))) 1383 | (RPLACA D (SUBSTITUTE (CAR D)))) 1384 | NODE) 1385 | (COMBINATION 1386 | (LET ((ARGS (COMBINATION\ARGS FM))) 1387 | (DO ((A ARGS (CDR A)) 1388 | (X T (AND X (PASSABLE (CAR A) EFFS AFFD)))) 1389 | ((NULL A) 1390 | (IF X (DO ((A (CDR ARGS) (CDR A))) 1391 | ((NULL A)) 1392 | (RPLACA A (SUBSTITUTE (CAR A))))) 1393 | (IF (AND *LAMBDA-BODY-SUBST* 1394 | (EQ (TYPE (NODE\FORM (CAR ARGS))) 'LAMBDA)) 1395 | (LET ((FN (NODE\FORM (CAR ARGS)))) 1396 | (INCREMENT *LAMBDA-BODY-SUBST-TRY-COUNT*) 1397 | (COND (X 1398 | (INCREMENT 1399 | *LAMBDA-BODY-SUBST-SUCCESS-COUNT*) 1400 | (ALTER-LAMBDA 1401 | FN 1402 | (BODY := (SUBSTITUTE 1403 | (LAMBDA\BODY FN)))))) 1404 | (IF (NODE\METAP (CAR ARGS)) 1405 | (ALTER-NODE 1406 | (CAR ARGS) 1407 | (METAP := (NODE\METAP 1408 | (LAMBDA\BODY FN)))))) 1409 | (IF X (RPLACA ARGS (SUBSTITUTE (CAR ARGS))))))) 1410 | (DO ((A ARGS (CDR A)) 1411 | (MP T (AND MP (NODE\METAP (CAR A))))) 1412 | ((NULL A) 1413 | (IF (NODE\METAP NODE) 1414 | (ALTER-NODE NODE (METAP := MP)))))) 1415 | NODE))))))) 1416 | (SUBSTITUTE BOD))))) 1417 | 1418 | (DEFINE COPY-CODE 1419 | (LAMBDA (NODE) 1420 | (REANALYZE1 (COPY-NODES NODE (NODE\ENV NODE) NIL)))) 1421 | 1422 | (DEFINE 1423 | COPY-NODES 1424 | (LAMBDA (NODE ENV RNL) 1425 | (NODIFY 1426 | (LET ((FM (NODE\FORM NODE))) 1427 | (EQCASE (TYPE FM) 1428 | (CONSTANT 1429 | (CONS-CONSTANT (VALUE = (CONSTANT\VALUE FM)))) 1430 | (VARIABLE 1431 | (CONS-VARIABLE (VAR = (LET ((SLOT (ASSQ (VARIABLE\VAR FM) RNL))) 1432 | (IF SLOT (CADR SLOT) (VARIABLE\VAR FM)))) 1433 | (GLOBALP = (VARIABLE\GLOBALP FM)))) 1434 | (LAMBDA 1435 | (LET ((VARS (AMAPCAR GENTEMP (LAMBDA\VARS FM)))) 1436 | (CONS-LAMBDA (UVARS = (APPEND (LAMBDA\UVARS FM) NIL)) 1437 | (VARS = VARS) 1438 | (BODY = (COPY-NODES 1439 | (LAMBDA\BODY FM) 1440 | (PAIRLIS (LAMBDA\UVARS FM) VARS ENV) 1441 | (PAIRLIS (LAMBDA\VARS FM) VARS RNL)))))) 1442 | (IF (CONS-IF (PRED = (COPY-NODES (IF\PRED FM) ENV RNL)) 1443 | (CON = (COPY-NODES (IF\CON FM) ENV RNL)) 1444 | (ALT = (COPY-NODES (IF\ALT FM) ENV RNL)))) 1445 | (ASET 1446 | (CONS-ASET (VAR = (LET ((SLOT (ASSQ (ASET\VAR FM) RNL))) 1447 | (IF SLOT (CADR SLOT) (ASET\VAR FM)))) 1448 | (GLOBALP = (ASET\GLOBALP FM)) 1449 | (BODY = (COPY-NODES (ASET\BODY FM) ENV RNL)))) 1450 | (CATCH 1451 | (LET ((VAR (GENTEMP (CATCH\VAR FM))) 1452 | (UVAR (CATCH\UVAR FM))) 1453 | (CONS-CATCH (UVAR = (CATCH\UVAR FM)) 1454 | (VAR = VAR) 1455 | (BODY = (COPY-NODES 1456 | (CATCH\BODY FM) 1457 | (CONS (LIST UVAR VAR) ENV) 1458 | (CONS (LIST (CATCH\VAR FM) VAR) RNL)))))) 1459 | (LABELS 1460 | (LET ((FNVARS (AMAPCAR GENTEMP (LABELS\FNVARS FM)))) 1461 | (LET ((LENV (PAIRLIS (LABELS\UFNVARS FM) FNVARS ENV)) 1462 | (LRNL (PAIRLIS (LABELS\FNVARS FM) FNVARS RNL))) 1463 | (CONS-LABELS (UFNVARS = (LABELS\UFNVARS FM)) 1464 | (FNVARS = FNVARS) 1465 | (FNDEFS = (AMAPCAR 1466 | (LAMBDA (N) (COPY-NODES N LENV LRNL)) 1467 | (LABELS\FNDEFS FM))) 1468 | (BODY = (COPY-NODES (LABELS\BODY FM) 1469 | LENV 1470 | LRNL)))))) 1471 | (COMBINATION 1472 | (CONS-COMBINATION (ARGS = (AMAPCAR (LAMBDA (N) (COPY-NODES N ENV RNL)) 1473 | (COMBINATION\ARGS FM))) 1474 | (WARNP = (COMBINATION\WARNP FM)))))) 1475 | (NODE\SEXPR NODE) 1476 | ENV))) 1477 | 1478 | ;;; CONVERSION TO CONTINUATION-PASSING STYLE 1479 | 1480 | ;;; THIS INVOLVES MAKING A COMPLETE COPY OF THE PROGRAM IN TERMS 1481 | ;;; OF THE FOLLOWING NEW DATA STRUCTURES: 1482 | 1483 | (DEFTYPE CNODE (ENV REFS CLOVARS CFORM)) 1484 | ;ENV ENVIRONMENT (A LIST OF VARIABLES, NOT A MAPPING; DEBUGGING ONLY) 1485 | ;REFS VARIABLES BOUND ABOVE AND REFERENCED BELOW THIS CNODE 1486 | ;CLOVARS VARIABLES REFERRED TO AT OR BELOW THIS CNODE BY CLOSURES 1487 | ; (SHOULD BE A SUBSET OF REFS) 1488 | ;CFORM ONE OF THE BELOW TYPES 1489 | (DEFTYPE TRIVIAL (NODE)) 1490 | ;NODE A PASS-1 NODE TREE 1491 | (DEFTYPE CVARIABLE (VAR)) 1492 | ;VAR GENERATED VARIABLE NAME 1493 | (DEFTYPE CLAMBDA (VARS BODY FNP TVARS NAME DEP MAXDEP CONSENV CLOSEREFS ASETVARS)) 1494 | ;FNP NON-NIL => NEEDN'T MAKE A FULL CLOSURE OF THIS 1495 | ; CLAMBDA. MAY BE 'NOCLOSE OR 'EZCLOSE (THE FORMER 1496 | ; MEANING NO CLOSURE IS NECESSARY AT ALL, THE LATTER 1497 | ; THAT THE CLOSURE IS MERELY THE ENVIRONMENT). 1498 | ;TVARS THE VARIABLES WHICH ARE PASSED THROUGH TEMP LOCATIONS 1499 | ; ON ENTRY. NON-NIL ONLY IF FNP='NOCLOSE; THEN IS 1500 | ; NORMALLY THE LAMBDA VARS, BUT MAY BE DECREASED 1501 | ; TO ACCOUNT FOR ARGS WHICH ARE THEMSELVES KNOWN NOCLOSE'S, 1502 | ; OR WHOSE CORRESPONDING PARAMETERS ARE NEVER REFERENCED. 1503 | ; THE TEMP VARS INVOLVED START IN NUMBER AT DEP. 1504 | ;NAME THE PROG TAG USED TO LABEL THE FINAL OUTPUT CODE FOR THE CLAMBDA 1505 | ;DEP DEPTH OF TEMPORARY REGISTER USAGE WHEN THE CLAMBDA IS INVOKED 1506 | ;MAXDEP MAXIMUM DEPTH OF REGISTER USAGE WITHIN CLAMBDA BODY 1507 | ;CONSENV THE `CONSED ENVIRONMENT` WHEN THE CLAMBDA IS EVALUATED 1508 | ;CLOSEREFS VARIABLES REFERENCED BY THE CLAMBDA WHICH ARE NOT IN 1509 | ; THE CONSED ENVIRONMENT AT EVALUATION TIME, AND SO MUST BE 1510 | ; ADDED TO CONSENV AT THAT POINT TO MAKE THE CLOSURE 1511 | ;ASETVARS THE ELEMENTS OF VARS WHICH ARE EVER SEEN IN A CASET 1512 | (DEFTYPE CONTINUATION (VAR BODY FNP TVARS NAME DEP MAXDEP CONSENV CLOSEREFS)) 1513 | ;COMPONENTS ARE AS FOR CLAMBDA 1514 | (DEFTYPE CIF (PRED CON ALT)) 1515 | (DEFTYPE CASET (CONT VAR BODY)) 1516 | (DEFTYPE CLABELS (FNVARS FNDEFS FNENV EASY CONSENV BODY)) 1517 | ;FNENV A LIST OF VARIABLES TO CONS ONTO THE ENVIRONMENT BEFORE 1518 | ; CREATING THE CLOSURES AND EXECUTING THE BODY 1519 | ;EASY NON-NIL IFF NO LABELED FUNCTION IS REFERRED TO 1520 | ; AS A VARIABLE. CAN BE 'NOCLOSE OR 'EZCLOSE 1521 | ; (REFLECTING THE STATUS OF ALL THE LABELLED FUNCTIONS) 1522 | ;CONSENV AS FOR CLAMBDA 1523 | (DEFTYPE CCOMBINATION (ARGS)) 1524 | ;ARGS LIST OF CNODES REPRESENTING ARGUMENTS 1525 | (DEFTYPE RETURN (CONT VAL)) 1526 | ;CONT CNODE FOR CONTINUATION 1527 | ;VAL CNODE FOR VALUE 1528 | 1529 | (DEFINE CNODIFY 1530 | (LAMBDA (CFORM) 1531 | (CONS-CNODE (CFORM = CFORM)))) 1532 | 1533 | (DEFINE CONVERT 1534 | (LAMBDA (NODE CONT MP) 1535 | (LET ((FM (NODE\FORM NODE))) 1536 | (IF (EMPTY (NODE\TRIVP NODE)) 1537 | (ERROR '|Pass 1 analysis missing| NODE 'FAIL-ACT)) 1538 | (OR (EQ (NODE\METAP NODE) MP) 1539 | (ERROR '|Meta-evaluation Screwed Up METAP| NODE 'FAIL-ACT)) 1540 | (EQCASE (TYPE FM) 1541 | (CONSTANT 1542 | (OR (NODE\TRIVP NODE) 1543 | (ERROR '|Non-trivial Constant| NODE 'FAIL-ACT)) 1544 | (MAKE-RETURN (CONS-TRIVIAL (NODE = NODE)) CONT)) 1545 | (VARIABLE 1546 | (OR (NODE\TRIVP NODE) 1547 | (ERROR '|Non-trivial Variable| 'FAIL-ACT)) 1548 | (MAKE-RETURN (CONS-TRIVIAL (NODE = NODE)) CONT)) 1549 | (LAMBDA (MAKE-RETURN (CONVERT-LAMBDA-FM NODE NIL MP) CONT)) 1550 | (IF (OR CONT (ERROR '|Null Continuation to IF| NODE 'FAIL-ACT)) 1551 | (CONVERT-IF NODE FM CONT MP)) 1552 | (ASET (OR CONT (ERROR '|Null Continuation to ASET| NODE 'FAIL-ACT)) 1553 | (CONVERT-ASET NODE FM CONT MP)) 1554 | (CATCH (OR CONT (ERROR '|Null Continuation to CATCH| NODE 'FAIL-ACT)) 1555 | (CONVERT-CATCH NODE FM CONT MP)) 1556 | (LABELS (OR CONT (ERROR '|Null Continuation to LABELS| NODE 'FAIL-ACT)) 1557 | (CONVERT-LABELS NODE FM CONT MP)) 1558 | (COMBINATION (OR CONT (ERROR '|Null Continuation to Combination| 1559 | NODE 1560 | 'FAIL-ACT)) 1561 | (CONVERT-COMBINATION NODE FM CONT MP)))))) 1562 | 1563 | (DEFINE MAKE-RETURN 1564 | (LAMBDA (CFORM CONT) 1565 | (LET ((CN (CNODIFY CFORM))) 1566 | (IF CONT 1567 | (CNODIFY (CONS-RETURN (CONT = CONT) (VAL = CN))) 1568 | CN)))) 1569 | 1570 | (DEFINE CONVERT-LAMBDA-FM 1571 | (LAMBDA (NODE CNAME MP) 1572 | (LET ((CV (GENTEMP 'CONT)) 1573 | (FM (NODE\FORM NODE))) 1574 | (CONS-CLAMBDA (VARS = (CONS CV (LAMBDA\VARS FM))) 1575 | (BODY = (CONVERT (LAMBDA\BODY FM) 1576 | (CNODIFY 1577 | (CONS-CVARIABLE (VAR = (OR CNAME CV)))) 1578 | MP)))))) 1579 | 1580 | ;;; ISSUES FOR CONVERTING IF: 1581 | ;;; (1) IF WHOLE IF IS TRIVIAL, MAY JUST CREATE A CTRIVIAL. 1582 | ;;; (2) IF CONTINUATION IS NON-CVARIABLE, MUST BIND A VARIABLE TO IT. 1583 | ;;; (3) IF PREDICATE IS TRIVIAL, MAY JUST STICK IT IN SIMPLE CIF. 1584 | 1585 | (DEFINE CONVERT-IF 1586 | (LAMBDA (NODE FM CONT MP) 1587 | (IF (NODE\TRIVP NODE) 1588 | (MAKE-RETURN (CONS-TRIVIAL (NODE = NODE)) CONT) 1589 | (LET ((CVAR (IF (EQ (TYPE (CNODE\CFORM CONT)) 'CVARIABLE) 1590 | NIL 1591 | (GENTEMP 'CONT))) 1592 | (PVAR (IF (NODE\TRIVP (IF\PRED FM)) 1593 | NIL 1594 | (NODE\NAME (IF\PRED FM))))) 1595 | (LET ((ICONT (IF CVAR 1596 | (CNODIFY (CONS-CVARIABLE (VAR = CVAR))) 1597 | CONT)) 1598 | (IPRED (IF PVAR 1599 | (CNODIFY (CONS-CVARIABLE (VAR = PVAR))) 1600 | (CNODIFY (CONS-TRIVIAL (NODE = (IF\PRED FM))))))) 1601 | (LET ((CIF (CNODIFY 1602 | (CONS-CIF 1603 | (PRED = IPRED) 1604 | (CON = (CONVERT (IF\CON FM) ICONT MP)) 1605 | (ALT = (CONVERT (IF\ALT FM) 1606 | (CNODIFY 1607 | (CONS-CVARIABLE 1608 | (VAR = (CVARIABLE\VAR 1609 | (CNODE\CFORM ICONT))))) 1610 | MP)))))) 1611 | (LET ((FOO (IF PVAR 1612 | (CONVERT (IF\PRED FM) 1613 | (CNODIFY (CONS-CONTINUATION (VAR = PVAR) 1614 | (BODY = CIF))) 1615 | MP) 1616 | CIF))) 1617 | (IF CVAR 1618 | (CNODIFY 1619 | (CONS-CCOMBINATION 1620 | (ARGS = (LIST (CNODIFY 1621 | (CONS-CLAMBDA 1622 | (VARS = (LIST CVAR)) 1623 | (BODY = FOO))) 1624 | CONT)))) 1625 | FOO)))))))) 1626 | 1627 | (DEFINE CONVERT-ASET 1628 | (LAMBDA (NODE FM CONT MP) 1629 | (IF (NODE\TRIVP NODE) 1630 | (MAKE-RETURN (CONS-TRIVIAL (NODE = NODE)) CONT) 1631 | (CONVERT (ASET\BODY FM) 1632 | (LET ((NM (NODE\NAME (ASET\BODY FM)))) 1633 | (CNODIFY 1634 | (CONS-CONTINUATION 1635 | (VAR = NM) 1636 | (BODY = (CNODIFY 1637 | (CONS-CASET 1638 | (CONT = CONT) 1639 | (VAR = (ASET\VAR FM)) 1640 | (BODY = (CNODIFY (CONS-CVARIABLE 1641 | (VAR = NM)))))))))) 1642 | MP)))) 1643 | 1644 | ;;; ISSUES FOR CONVERTING CATCH: 1645 | ;;; (1) MUST BIND THE CATCH VARIABLE TO A FUNNY FUNCTION WHICH IGNORES ITS CONTINUATION: 1646 | ;;; (2) IF CONTINUATION IS NON-CVARIABLE, MUST BIND A VARIABLE TO IT. 1647 | 1648 | (DEFINE 1649 | CONVERT-CATCH 1650 | (LAMBDA (NODE FM CONT MP) 1651 | (LET ((CVAR (IF (EQ (TYPE (CNODE\CFORM CONT)) 'CVARIABLE) 1652 | NIL 1653 | (GENTEMP 'CONT)))) 1654 | (LET ((ICONT (IF CVAR 1655 | (CNODIFY (CONS-CVARIABLE (VAR = CVAR))) 1656 | CONT))) 1657 | (LET ((CP (CNODIFY 1658 | (CONS-CCOMBINATION 1659 | (ARGS = (LIST (CNODIFY 1660 | (CONS-CLAMBDA 1661 | (VARS = (LIST (CATCH\VAR FM))) 1662 | (BODY = (CONVERT (CATCH\BODY FM) ICONT MP)))) 1663 | (CNODIFY 1664 | (CONS-CLAMBDA 1665 | (VARS = '(*IGNORE* V)) 1666 | (BODY = (MAKE-RETURN 1667 | (CONS-CVARIABLE (VAR = 'V)) 1668 | (CNODIFY 1669 | (CONS-CVARIABLE 1670 | (VAR = (CVARIABLE\VAR 1671 | (CNODE\CFORM ICONT))))))))))))))) 1672 | (IF CVAR (CNODIFY 1673 | (CONS-CCOMBINATION 1674 | (ARGS = (LIST (CNODIFY 1675 | (CONS-CLAMBDA (VARS = (LIST CVAR)) 1676 | (BODY = CP))) 1677 | CONT)))) 1678 | CP)))))) 1679 | 1680 | ;;; ISSUES FOR CONVERTING LABELS: 1681 | ;;; (1) MUST CONVERT ALL THE NAMED LAMBDA-EXPRESSIONS, USING A NULL CONTINUATION. 1682 | ;;; (2) TO MAKE THINGS EASIER LATER, WE FORBID ASET ON A LABELS VARIABLE. 1683 | 1684 | (DEFINE CONVERT-LABELS 1685 | (LAMBDA (NODE FM CONT MP) 1686 | (DO ((F (LABELS\FNDEFS FM) (CDR F)) 1687 | (V (LABELS\FNVARS FM) (CDR V)) 1688 | (CF NIL (CONS (CONVERT (CAR F) NIL MP) CF))) 1689 | ((NULL F) 1690 | (CNODIFY (CONS-CLABELS (FNVARS = (LABELS\FNVARS FM)) 1691 | (FNDEFS = (NREVERSE CF)) 1692 | (BODY = (CONVERT (LABELS\BODY FM) CONT MP))))) 1693 | (AND (GET (CAR V) 'WRITE-REFS) 1694 | (ERROR '|Are you crazy, using ASET on a LABELS variable?| 1695 | (CAR V) 1696 | 'FAIL-ACT))))) 1697 | 1698 | ;;; ISSUES FOR CONVERTING COMBINATIONS: 1699 | ;;; (1) TRIVIAL ARGUMENT EVALUATIONS ARE DELAYED AND ARE NOT BOUND TO THE VARIABLE OF 1700 | ;;; A CONTINUATION. WE ASSUME THEREBY THAT THE COMPILER IS PERMITTED TO EVALUATE 1701 | ;;; OPERANDS IN ANY ORDER. 1702 | ;;; (2) ALL NON-DELAYABLE COMPUTATIONS ARE ASSIGNED NAMES AND STRUNG OUT WITH CONTINUATIONS. 1703 | ;;; (3) IF CONT IS A CVARIABLE AND THE COMBINATION IS ((LAMBDA ...) ...) THEN WHEN CONVERTING 1704 | ;;; THE LAMBDA-EXPRESSION WE ARRANGE FOR ITS BODY TO REFER TO THE CVARIABLE CONT RATHER 1705 | ;;; THAN TO ITS OWN CONTINUATION. THIS CROCK EFFECTIVELY PERFORMS THE OPTIMIZATION OF 1706 | ;;; SUBSTITUTING ONE VARIABLE FOR ANOTHER, ONLY ON CONTINUATION VARIABLES (WHICH COULDN'T 1707 | ;;; BE CAUGHT BY META-EVALUATE). 1708 | 1709 | (DEFINE 1710 | CONVERT-COMBINATION 1711 | (LAMBDA (NODE FM CONT MP) 1712 | (IF (NODE\TRIVP NODE) 1713 | (MAKE-RETURN (CONS-TRIVIAL (NODE = NODE)) CONT) 1714 | (DO ((A (COMBINATION\ARGS FM) (CDR A)) 1715 | (DELAY-FLAGS NIL 1716 | (CONS (OR (NODE\TRIVP (CAR A)) 1717 | (EQ (TYPE (NODE\FORM (CAR A))) 'LAMBDA)) 1718 | DELAY-FLAGS))) 1719 | ((NULL A) 1720 | (DO ((A (REVERSE (COMBINATION\ARGS FM)) (CDR A)) 1721 | (D DELAY-FLAGS (CDR D)) 1722 | (F (CNODIFY 1723 | (CONS-CCOMBINATION 1724 | (ARGS = (DO ((A (REVERSE (COMBINATION\ARGS FM)) (CDR A)) 1725 | (D DELAY-FLAGS (CDR D)) 1726 | (Z NIL (CONS (IF (CAR D) 1727 | (IF (EQ (TYPE (NODE\FORM (CAR A))) 1728 | 'LAMBDA) 1729 | (CNODIFY 1730 | (CONVERT-LAMBDA-FM 1731 | (CAR A) 1732 | (AND (NULL (CDR A)) 1733 | (EQ (TYPE 1734 | (CNODE\CFORM CONT)) 1735 | 'CVARIABLE) 1736 | (CVARIABLE\VAR 1737 | (CNODE\CFORM CONT))) 1738 | MP)) 1739 | (CNODIFY 1740 | (CONS-TRIVIAL 1741 | (NODE = (CAR A))))) 1742 | (CNODIFY 1743 | (CONS-CVARIABLE 1744 | (VAR = (NODE\NAME (CAR A)))))) 1745 | Z))) 1746 | ((NULL A) (CONS (CAR Z) (CONS CONT (CDR Z)))))))) 1747 | (IF (CAR D) F 1748 | (CONVERT (CAR A) 1749 | (CNODIFY (CONS-CONTINUATION 1750 | (VAR = (NODE\NAME (CAR A))) 1751 | (BODY = F))) 1752 | MP)))) 1753 | ((NULL A) F))))))) 1754 | 1755 | ;;; ENVIRONMENT ANALYSIS FOR CPS VERSION 1756 | 1757 | ;;; WE WISH TO DETERMINE THE ENVIRONMENT AT EACH CNODE, 1758 | ;;; AND DETERMINE WHAT VARIABLES ARE BOUND ABOVE AND 1759 | ;;; REFERRED TO BELOW EACH CNODE. 1760 | 1761 | ;;; FOR EACH CNODE WE FILL IN THESE SLOTS: 1762 | ;;; ENV THE ENVIRONMENT SEEN AT THAT CNODE (A LIST OF VARS) 1763 | ;;; REFS VARIABLES BOUND ABOVE AND REFERRED TO BELOW THAT CNODE 1764 | ;;; FOR EACH VARIABLE REFERRED TO IN NON-FUNCTION POSITION 1765 | ;;; BY A CVARIABLE OR CTRIVIAL CNODE WE GIVE A NON-NIL VALUE TO THE PROPERTY: 1766 | ;;; VARIABLE-REFP 1767 | 1768 | ;;; FNP IS NON-NIL IFF CNODE OCCURS IN FUNCTIONAL POSITION 1769 | 1770 | (DEFINE 1771 | CENV-ANALYZE 1772 | (LAMBDA (CNODE ENV FNP) 1773 | (LET ((CFM (CNODE\CFORM CNODE))) 1774 | (ALTER-CNODE CNODE (ENV := ENV)) 1775 | (EQCASE (TYPE CFM) 1776 | (TRIVIAL 1777 | (CENV-TRIV-ANALYZE (TRIVIAL\NODE CFM) FNP) 1778 | (ALTER-CNODE CNODE 1779 | (REFS := (NODE\REFS (TRIVIAL\NODE CFM))))) 1780 | (CVARIABLE 1781 | (LET ((V (CVARIABLE\VAR CFM))) 1782 | (ADDPROP V CNODE 'READ-REFS) 1783 | (OR FNP (PUTPROP V T 'VARIABLE-REFP)) 1784 | (ALTER-CNODE CNODE 1785 | (REFS := (AND (MEMQ V ENV) 1786 | (LIST (CVARIABLE\VAR CFM))))))) 1787 | (CLAMBDA 1788 | (LET ((B (CLAMBDA\BODY CFM))) 1789 | (CENV-ANALYZE B (APPEND (CLAMBDA\VARS CFM) ENV) NIL) 1790 | (LET ((REFS (SETDIFF (CNODE\REFS B) (CLAMBDA\VARS CFM)))) 1791 | (ALTER-CNODE CNODE (REFS := REFS))))) 1792 | (CONTINUATION 1793 | (LET ((B (CONTINUATION\BODY CFM))) 1794 | (CENV-ANALYZE B (CONS (CONTINUATION\VAR CFM) ENV) NIL) 1795 | (LET ((REFS (REMOVE (CONTINUATION\VAR CFM) (CNODE\REFS B)))) 1796 | (ALTER-CNODE CNODE (REFS := REFS))))) 1797 | (CIF 1798 | (LET ((PRED (CIF\PRED CFM)) 1799 | (CON (CIF\CON CFM)) 1800 | (ALT (CIF\ALT CFM))) 1801 | (CENV-ANALYZE PRED ENV NIL) 1802 | (CENV-ANALYZE CON ENV NIL) 1803 | (CENV-ANALYZE ALT ENV NIL) 1804 | (ALTER-CNODE CNODE 1805 | (REFS := (UNION (CNODE\REFS PRED) 1806 | (UNION (CNODE\REFS CON) 1807 | (CNODE\REFS ALT))))))) 1808 | (CASET 1809 | (LET ((V (CASET\VAR CFM)) 1810 | (CN (CASET\CONT CFM)) 1811 | (B (CASET\BODY CFM))) 1812 | (PUTPROP (CASET\VAR CFM) T 'VARIABLE-REFP) 1813 | (CENV-ANALYZE CN ENV T) 1814 | (CENV-ANALYZE B ENV NIL) 1815 | (ALTER-CNODE CNODE 1816 | (REFS := (LET ((R (UNION (CNODE\REFS CN) 1817 | (CNODE\REFS B)))) 1818 | (IF (MEMQ V ENV) (ADJOIN V R) R)))))) 1819 | (CLABELS 1820 | (LET ((LENV (APPEND (CLABELS\FNVARS CFM) ENV))) 1821 | (DO ((F (CLABELS\FNDEFS CFM) (CDR F)) 1822 | (R NIL (UNION R (CNODE\REFS (CAR F))))) 1823 | ((NULL F) 1824 | (LET ((B (CLABELS\BODY CFM))) 1825 | (CENV-ANALYZE B LENV NIL) 1826 | (ALTER-CNODE CNODE 1827 | (REFS := (SETDIFF (UNION R (CNODE\REFS B)) 1828 | (CLABELS\FNVARS CFM)))))) 1829 | (CENV-ANALYZE (CAR F) LENV NIL)))) 1830 | (CCOMBINATION 1831 | (LET ((ARGS (CCOMBINATION\ARGS CFM))) 1832 | (CENV-ANALYZE (CAR ARGS) ENV T) 1833 | (COND ((AND (EQ (TYPE (CNODE\CFORM (CAR ARGS))) 'TRIVIAL) 1834 | (EQ (TYPE (NODE\FORM (TRIVIAL\NODE 1835 | (CNODE\CFORM (CAR ARGS))))) 1836 | 'VARIABLE) 1837 | (TRIVFN (VARIABLE\VAR 1838 | (NODE\FORM 1839 | (TRIVIAL\NODE 1840 | (CNODE\CFORM 1841 | (CAR ARGS))))))) 1842 | (CENV-ANALYZE (CADR ARGS) ENV T) 1843 | (CENV-CCOMBINATION-ANALYZE CNODE 1844 | ENV 1845 | (CDDR ARGS) 1846 | (UNION (CNODE\REFS (CAR ARGS)) 1847 | (CNODE\REFS (CADR ARGS))))) 1848 | (T (CENV-CCOMBINATION-ANALYZE CNODE 1849 | ENV 1850 | (CDR ARGS) 1851 | (CNODE\REFS (CAR ARGS))))))) 1852 | (RETURN 1853 | (LET ((C (RETURN\CONT CFM)) 1854 | (V (RETURN\VAL CFM))) 1855 | (CENV-ANALYZE C ENV T) 1856 | (CENV-ANALYZE V ENV NIL) 1857 | (ALTER-CNODE CNODE 1858 | (REFS := (UNION (CNODE\REFS C) (CNODE\REFS V)))))))))) 1859 | 1860 | ;;; THIS FUNCTION MUST GO THROUGH AND LOCATE VARIABLES APPEARING IN NON-FUNCTION POSITION. 1861 | 1862 | (DEFINE CENV-TRIV-ANALYZE 1863 | (LAMBDA (NODE FNP) 1864 | (LET ((FM (NODE\FORM NODE))) 1865 | (EQCASE (TYPE FM) 1866 | (CONSTANT NIL) 1867 | (VARIABLE 1868 | (OR FNP (PUTPROP (VARIABLE\VAR FM) T 'VARIABLE-REFP))) 1869 | (LAMBDA 1870 | (OR FNP 1871 | (ERROR '|Trivial closure - CENV-TRIV-ANALYZE| NODE 'FAIL-ACT)) 1872 | (CENV-TRIV-ANALYZE (LAMBDA\BODY FM) NIL)) 1873 | (IF 1874 | (CENV-TRIV-ANALYZE (IF\PRED FM) NIL) 1875 | (CENV-TRIV-ANALYZE (IF\CON FM) NIL) 1876 | (CENV-TRIV-ANALYZE (IF\ALT FM) NIL)) 1877 | (ASET 1878 | (PUTPROP (ASET\VAR FM) T 'VARIABLE-REFP) 1879 | (CENV-TRIV-ANALYZE (ASET\BODY FM) NIL)) 1880 | (COMBINATION 1881 | (DO ((A (COMBINATION\ARGS FM) (CDR A)) 1882 | (F T NIL)) 1883 | ((NULL A)) 1884 | (CENV-TRIV-ANALYZE (CAR A) F))))))) 1885 | 1886 | (DEFINE CENV-CCOMBINATION-ANALYZE 1887 | (LAMBDA (CNODE ENV ARGS FREFS) 1888 | (DO ((A ARGS (CDR A)) 1889 | (R FREFS (UNION R (CNODE\REFS (CAR A))))) 1890 | ((NULL A) 1891 | (ALTER-CNODE CNODE (REFS := R))) 1892 | (CENV-ANALYZE (CAR A) ENV NIL)))) 1893 | 1894 | ;;; BINDING ANALYSIS. 1895 | 1896 | ;;; FOR EACH CNODE WE FILL IN: 1897 | ;;; CLOVARS THE SET OF VARIABLES REFERRED TO BY CLOSURES 1898 | ;;; AT OR BELOW THIS NODE (SHOULD ALWAYS BE A 1899 | ;;; SUBSET OF REFS) 1900 | ;;; FOR EACH CLAMBDA AND CONTINUATION WE FILL IN: 1901 | ;;; FNP NON-NIL IFF REFERENCED ONLY AS A FUNCTION. 1902 | ;;; WILL BE 'EZCLOSE IF REFERRED TO BY A CLOSURE, 1903 | ;;; AND OTHERWISE 'NOCLOSE. 1904 | ;;; TVARS VARIABLES PASSED THROUGH TEMP LOCATIONS WHEN CALLING 1905 | ;;; THIS FUNCTION 1906 | ;;; NAME THE NAME OF THE FUNCTION (USED FOR THE PROG TAG) 1907 | ;;; FOR EACH CLABELS WE FILL IN: 1908 | ;;; EASY REFLECTS FNP STATUS OF ALL THE LABELLED FUNCTIONS 1909 | ;;; FOR EACH VARIABLE WHICH ALWAYS DENOTES A CERTAIN FUNCTION WE 1910 | ;;; PUT THE PROPERTIES: 1911 | ;;; KNOWN-FUNCTION IFF THE VARIABLE IS NEVER ASET 1912 | ;;; THE VALUE OF THE KNOWN-FUNCTION PROPERTY IS THE CNODE FOR 1913 | ;;; THE FUNCTION DEFINITION. 1914 | ;;; FOR EACH LABELS VARIABLE IN A LABELS OF THE 'EZCLOSE VARIETY 1915 | ;;; WE PUT THE PROPERTY: 1916 | ;;; LABELS-FUNCTION 1917 | ;;; TO INDICATE THAT ITS `EASY` CLOSURE MUST BE CDR'D TO GET THE 1918 | ;;; CORRECT ENVIRONMENT (SEE PRODUCE-LABELS). 1919 | 1920 | ;;; NAME, IF NON-NIL, IS A SUGGESTED NAME FOR THE FUNCTION 1921 | 1922 | (DEFINE BIND-ANALYZE 1923 | (LAMBDA (CNODE FNP NAME) 1924 | (LET ((CFM (CNODE\CFORM CNODE))) 1925 | (EQCASE (TYPE CFM) 1926 | (TRIVIAL 1927 | (ALTER-CNODE CNODE (CLOVARS := NIL))) 1928 | (CVARIABLE 1929 | (ALTER-CNODE CNODE (CLOVARS := NIL))) 1930 | (CLAMBDA 1931 | (BIND-ANALYZE-CLAMBDA CNODE FNP NAME CFM)) 1932 | (CONTINUATION 1933 | (BIND-ANALYZE-CONTINUATION CNODE FNP NAME CFM)) 1934 | (CIF 1935 | (BIND-ANALYZE-CIF CNODE CFM)) 1936 | (CASET 1937 | (BIND-ANALYZE-CASET CNODE CFM)) 1938 | (CLABELS 1939 | (BIND-ANALYZE-CLABELS CNODE CFM)) 1940 | (CCOMBINATION 1941 | (BIND-ANALYZE-CCOMBINATION CNODE CFM)) 1942 | (RETURN 1943 | (BIND-ANALYZE-RETURN CNODE CFM)))))) 1944 | 1945 | (DEFINE REFD-VARS 1946 | (LAMBDA (VARS) 1947 | (DO ((V VARS (CDR V)) 1948 | (W NIL (IF (OR (GET (CAR V) 'READ-REFS) 1949 | (GET (CAR V) 'WRITE-REFS)) 1950 | (CONS (CAR V) W) 1951 | W))) 1952 | ((NULL V) (NREVERSE W))))) 1953 | 1954 | (DEFINE BIND-ANALYZE-CLAMBDA 1955 | (LAMBDA (CNODE FNP NAME CFM) 1956 | (BLOCK (BIND-ANALYZE (CLAMBDA\BODY CFM) NIL NIL) 1957 | (ALTER-CNODE CNODE 1958 | (CLOVARS := (IF (EQ FNP 'NOCLOSE) 1959 | (CNODE\CLOVARS (CLAMBDA\BODY CFM)) 1960 | (CNODE\REFS CNODE)))) 1961 | (ALTER-CLAMBDA CFM 1962 | (FNP := FNP) 1963 | (TVARS := (IF (EQ FNP 'NOCLOSE) 1964 | (REFD-VARS (CLAMBDA\VARS CFM)) 1965 | NIL)) 1966 | (NAME := (OR NAME (GENTEMP 'F))))))) 1967 | 1968 | (DEFINE BIND-ANALYZE-CONTINUATION 1969 | (LAMBDA (CNODE FNP NAME CFM) 1970 | (BLOCK (BIND-ANALYZE (CONTINUATION\BODY CFM) NIL NIL) 1971 | (ALTER-CNODE CNODE 1972 | (CLOVARS := (IF (EQ FNP 'NOCLOSE) 1973 | (CNODE\CLOVARS (CONTINUATION\BODY CFM)) 1974 | (CNODE\REFS CNODE)))) 1975 | (ALTER-CONTINUATION CFM 1976 | (FNP := FNP) 1977 | (TVARS := (IF (EQ FNP 'NOCLOSE) 1978 | (REFD-VARS (LIST (CONTINUATION\VAR CFM))) 1979 | NIL)) 1980 | (NAME := (OR NAME (GENTEMP 'C))))))) 1981 | 1982 | (DEFINE BIND-ANALYZE-CIF 1983 | (LAMBDA (CNODE CFM) 1984 | (BLOCK (BIND-ANALYZE (CIF\PRED CFM) NIL NIL) 1985 | (BIND-ANALYZE (CIF\CON CFM) NIL NIL) 1986 | (BIND-ANALYZE (CIF\ALT CFM) NIL NIL) 1987 | (ALTER-CNODE CNODE 1988 | (CLOVARS := (UNION (CNODE\CLOVARS (CIF\PRED CFM)) 1989 | (UNION (CNODE\CLOVARS (CIF\CON CFM)) 1990 | (CNODE\CLOVARS (CIF\ALT CFM))))))))) 1991 | 1992 | (DEFINE BIND-ANALYZE-CASET 1993 | (LAMBDA (CNODE CFM) 1994 | (LET ((CN (CASET\CONT CFM)) 1995 | (VAL (CASET\BODY CFM))) 1996 | (BIND-ANALYZE CN 'NOCLOSE NIL) 1997 | (COND ((AND (EQ (TYPE (CNODE\CFORM CN)) 'CONTINUATION) 1998 | (EQ (TYPE (CNODE\CFORM VAL)) 'CLAMBDA)) 1999 | (LET ((VAR (CONTINUATION\VAR (CNODE\CFORM CN)))) 2000 | (PUTPROP VAR VAL 'KNOWN-FUNCTION) 2001 | (BIND-ANALYZE VAL 2002 | (AND (NOT (GET VAR 'VARIABLE-REFP)) 2003 | (IF (MEMQ VAR 2004 | (CNODE\CLOVARS 2005 | (CONTINUATION\BODY 2006 | (CNODE\CFORM CN)))) 2007 | 'EZCLOSE 2008 | (BLOCK (ALTER-CONTINUATION (CNODE\CFORM CN) 2009 | (TVARS := NIL)) 2010 | 'NOCLOSE))) 2011 | NIL))) 2012 | (T (BIND-ANALYZE VAL NIL NIL))) 2013 | (ALTER-CNODE CNODE 2014 | (CLOVARS := (UNION (CNODE\CLOVARS CN) 2015 | (CNODE\CLOVARS VAL))))))) 2016 | 2017 | (DEFINE BIND-ANALYZE-CLABELS 2018 | (LAMBDA (CNODE CFM) 2019 | (BLOCK (BIND-ANALYZE (CLABELS\BODY CFM) NIL NIL) 2020 | (DO ((V (CLABELS\FNVARS CFM) (CDR V)) 2021 | (D (CLABELS\FNDEFS CFM) (CDR D)) 2022 | (EZ 'NOCLOSE (AND (NULL (GET (CAR V) 'VARIABLE-REFP)) EZ))) 2023 | ((NULL V) 2024 | (ALTER-CLABELS CFM (EASY := EZ)) 2025 | (DO ((V (CLABELS\FNVARS CFM) (CDR V)) 2026 | (D (CLABELS\FNDEFS CFM) (CDR D)) 2027 | (CV (CNODE\CLOVARS (CLABELS\BODY CFM)) 2028 | (UNION CV (CNODE\CLOVARS (CAR D))))) 2029 | ((NULL D) 2030 | (ALTER-CNODE CNODE (CLOVARS := CV)) 2031 | (COND ((AND EZ (INTERSECT CV (LABELS\FNVARS CFM))) 2032 | (DO ((D (CLABELS\FNDEFS CFM) (CDR D)) 2033 | (CV (CNODE\CLOVARS (CLABELS\BODY CFM)) 2034 | (UNION CV (CNODE\CLOVARS (CAR D))))) 2035 | ((NULL D) 2036 | (ALTER-CNODE CNODE (CLOVARS := CV))) 2037 | (ALTER-CLAMBDA (CNODE\CFORM (CAR D)) 2038 | (FNP := 'EZCLOSE) 2039 | (TVARS := NIL)) 2040 | (ALTER-CNODE (CAR D) 2041 | (CLOVARS := (CNODE\REFS (CAR D))))) 2042 | (AMAPC (LAMBDA (V) (PUTPROP V T 'LABELS-FUNCTION)) 2043 | (CLABELS\FNVARS CFM)) 2044 | (ALTER-CLABELS CFM (EASY := 'EZCLOSE))))) 2045 | (BIND-ANALYZE (CAR D) EZ (CAR V)))) 2046 | (PUTPROP (CAR V) (CAR D) 'KNOWN-FUNCTION))))) 2047 | 2048 | (DEFINE BIND-ANALYZE-RETURN 2049 | (LAMBDA (CNODE CFM) 2050 | (LET ((CN (RETURN\CONT CFM)) 2051 | (VAL (RETURN\VAL CFM))) 2052 | (BIND-ANALYZE CN 'NOCLOSE NIL) 2053 | (COND ((AND (EQ (TYPE (CNODE\CFORM CN)) 'CONTINUATION) 2054 | (EQ (TYPE (CNODE\CFORM VAL)) 'CLAMBDA)) 2055 | (LET ((VAR (CONTINUATION\VAR (CNODE\CFORM CN)))) 2056 | (PUTPROP VAR VAL 'KNOWN-FUNCTION) 2057 | (BIND-ANALYZE VAL 2058 | (AND (NOT (GET VAR 'VARIABLE-REFP)) 2059 | (IF (MEMQ VAR 2060 | (CNODE\CLOVARS 2061 | (CONTINUATION\BODY 2062 | (CNODE\CFORM CN)))) 2063 | 'EZCLOSE 2064 | (BLOCK (ALTER-CONTINUATION (CNODE\CFORM CN) 2065 | (TVARS := NIL)) 2066 | 'NOCLOSE))) 2067 | NIL))) 2068 | (T (BIND-ANALYZE VAL NIL NIL))) 2069 | (ALTER-CNODE CNODE 2070 | (CLOVARS := (UNION (CNODE\CLOVARS CN) 2071 | (CNODE\CLOVARS VAL))))))) 2072 | 2073 | (DEFINE BIND-ANALYZE-CCOMBINATION 2074 | (LAMBDA (CNODE CFM) 2075 | (LET ((ARGS (CCOMBINATION\ARGS CFM))) 2076 | (BIND-ANALYZE (CAR ARGS) 'NOCLOSE NIL) 2077 | (LET ((FN (CNODE\CFORM (CAR ARGS)))) 2078 | (COND ((AND (EQ (TYPE FN) 'TRIVIAL) 2079 | (EQ (TYPE (NODE\FORM (TRIVIAL\NODE FN))) 2080 | 'VARIABLE) 2081 | (TRIVFN (VARIABLE\VAR (NODE\FORM (TRIVIAL\NODE FN))))) 2082 | (BIND-ANALYZE (CADR ARGS) 'NOCLOSE NIL) 2083 | (BIND-CCOMBINATION-ANALYZE CNODE 2084 | (CDDR ARGS) 2085 | NIL 2086 | (CNODE\CLOVARS (CADR ARGS)))) 2087 | ((EQ (TYPE FN) 'CLAMBDA) 2088 | (BIND-CCOMBINATION-ANALYZE CNODE 2089 | (CDR ARGS) 2090 | (CLAMBDA\VARS FN) 2091 | (CNODE\CLOVARS (CAR ARGS))) 2092 | (AMAPC (LAMBDA (V) 2093 | (IF (LET ((KFN (GET V 'KNOWN-FUNCTION))) 2094 | (AND KFN 2095 | (EQ (EQCASE (TYPE (CNODE\CFORM KFN)) 2096 | (CLAMBDA 2097 | (CLAMBDA\FNP 2098 | (CNODE\CFORM KFN))) 2099 | (CONTINUATION 2100 | (CONTINUATION\FNP 2101 | (CNODE\CFORM KFN)))) 2102 | 'NOCLOSE))) 2103 | (ALTER-CLAMBDA 2104 | FN 2105 | (TVARS := (DELQ V (CLAMBDA\TVARS FN)))))) 2106 | (CLAMBDA\TVARS FN))) 2107 | (T (BIND-CCOMBINATION-ANALYZE CNODE 2108 | (CDR ARGS) 2109 | NIL 2110 | (CNODE\CLOVARS (CAR ARGS))))))))) 2111 | 2112 | ;;; VARS MAY BE NIL - WE DEPEND ON (CDR NIL)=NIL. 2113 | 2114 | (DEFINE BIND-CCOMBINATION-ANALYZE 2115 | (LAMBDA (CNODE ARGS VARS FCV) 2116 | (DO ((A ARGS (CDR A)) 2117 | (V VARS (CDR V)) 2118 | (CV FCV (UNION CV (CNODE\CLOVARS (CAR A))))) 2119 | ((NULL A) 2120 | (ALTER-CNODE CNODE (CLOVARS := CV))) 2121 | (COND ((AND VARS 2122 | (MEMQ (TYPE (CNODE\CFORM (CAR A))) '(CLAMBDA CONTINUATION)) 2123 | (NOT (GET (CAR V) 'WRITE-REFS))) 2124 | (PUTPROP (CAR V) (CAR A) 'KNOWN-FUNCTION) 2125 | (BIND-ANALYZE (CAR A) 2126 | (AND (NOT (GET (CAR V) 'VARIABLE-REFP)) 2127 | (IF (MEMQ (CAR V) FCV) 2128 | 'EZCLOSE 2129 | 'NOCLOSE)) 2130 | NIL)) 2131 | (T (BIND-ANALYZE (CAR A) NIL NIL)))))) 2132 | 2133 | ;;; DEPTH ANALYSIS FOR CPS VERSION. 2134 | 2135 | ;;; FOR EACH CLAMBDA AND CONTINUATION WE FILL IN: 2136 | ;;; DEP DEPTH OF TEMP VAR USAGE AT THIS POINT 2137 | ;;; MAXDEP MAX DEPTH BELOW THIS POINT 2138 | 2139 | ;;; VALUE OF DEPTH-ANALYZE IS THE MAX DEPTH 2140 | 2141 | (DEFINE DEPTH-ANALYZE 2142 | (LAMBDA (CNODE DEP) 2143 | (LET ((CFM (CNODE\CFORM CNODE))) 2144 | (EQCASE (TYPE CFM) 2145 | (TRIVIAL DEP) 2146 | (CVARIABLE DEP) 2147 | (CLAMBDA 2148 | (LET ((MD (DEPTH-ANALYZE (CLAMBDA\BODY CFM) 2149 | (IF (EQ (CLAMBDA\FNP CFM) 'NOCLOSE) 2150 | (+ DEP (LENGTH (CLAMBDA\TVARS CFM))) 2151 | (MIN (LENGTH (CLAMBDA\VARS CFM)) 2152 | (+ 1 **NUMBER-OF-ARG-REGS**)))))) 2153 | (ALTER-CLAMBDA 2154 | CFM 2155 | (DEP := (IF (EQ (CLAMBDA\FNP CFM) 'NOCLOSE) DEP 0)) 2156 | (MAXDEP := MD)) 2157 | MD)) 2158 | (CONTINUATION 2159 | (LET ((MD (DEPTH-ANALYZE 2160 | (CONTINUATION\BODY CFM) 2161 | (IF (EQ (CONTINUATION\FNP CFM) 'NOCLOSE) 2162 | (+ DEP (LENGTH (CONTINUATION\TVARS CFM))) 2163 | 2)))) 2164 | (ALTER-CONTINUATION 2165 | CFM 2166 | (DEP := (IF (EQ (CONTINUATION\FNP CFM) 'NOCLOSE) DEP 0)) 2167 | (MAXDEP := MD)) 2168 | MD)) 2169 | (CIF 2170 | (MAX (DEPTH-ANALYZE (CIF\PRED CFM) DEP) 2171 | (DEPTH-ANALYZE (CIF\CON CFM) DEP) 2172 | (DEPTH-ANALYZE (CIF\ALT CFM) DEP))) 2173 | (CASET 2174 | (MAX (DEPTH-ANALYZE (CASET\CONT CFM) DEP) 2175 | (DEPTH-ANALYZE (CASET\BODY CFM) DEP))) 2176 | (CLABELS 2177 | (LET ((DP (IF (EQ (CLABELS\EASY CFM) 'NOCLOSE) 2178 | DEP 2179 | (+ DEP (LENGTH (CLABELS\FNVARS CFM)))))) 2180 | (DO ((D (CLABELS\FNDEFS CFM) (CDR D)) 2181 | (MD (DEPTH-ANALYZE (CLABELS\BODY CFM) DP) 2182 | (MAX MD (DEPTH-ANALYZE (CAR D) DP)))) 2183 | ((NULL D) MD)))) 2184 | (CCOMBINATION 2185 | (DO ((A (CCOMBINATION\ARGS CFM) (CDR A)) 2186 | (MD 0 (MAX MD (DEPTH-ANALYZE (CAR A) DEP)))) 2187 | ((NULL A) MD))) 2188 | (RETURN 2189 | (MAX (DEPTH-ANALYZE (RETURN\CONT CFM) DEP) 2190 | (DEPTH-ANALYZE (RETURN\VAL CFM) DEP))))))) 2191 | 2192 | ;;; CLOSURE ANALYSIS FOR CPS VERSION 2193 | 2194 | ;;; FOR EACH CLAMBDA, CONTINUATION, AND CLABELS WE FILL IN: 2195 | ;;; CONSENV THE CONSED ENVIRONMENT OF THE CLAMBDA, 2196 | ;;; CONTINUATION, OR CLABELS (BEFORE ANY 2197 | ;;; CLOSEREFS HAVE BEEN CONSED ON) 2198 | ;;; FOR EACH CLAMBDA AND CONTINUATION WE FILL IN: 2199 | ;;; CLOSEREFS A LIST OF VARIABLES REFERENCED BY THE CLAMBDA 2200 | ;;; OR CONTINUATION WHICH ARE NOT IN THE CONSED 2201 | ;;; ENVIRONMENT AT THE POINT OF THE CLAMBDA OR 2202 | ;;; CONTINUATION AND SO MUST BE CONSED ONTO THE 2203 | ;;; ENVIRONMENT AT CLOSURE TIME; HOWEVER, THESE 2204 | ;;; NEED NOT BE CONSED ON IF THE CLAMBDA OR 2205 | ;;; CONTINUATION IS IN FUNCTION POSITION OF 2206 | ;;; A FATHER WHICH IS A CCOMBINATION OR RETURN 2207 | ;;; FOR THE CLAMBDA'S IN THE FNDEFS OF A CLABELS, THESE MAY BE 2208 | ;;; SLIGHTLY ARTIFICIAL FOR THE SAKE OF OPTIMIZATION (SEE BELOW). 2209 | ;;; FOR EACH CLAMBDA WE FILL IN: 2210 | ;;; ASETVARS A LIST OF THE VARIABLES BOUND IN THE CLAMBDA 2211 | ;;; WHICH ARE EVER ASET AND SO MUST BE CONSED 2212 | ;;; ONTO THE ENVIRONMENT IMMEDIATELY IF ANY 2213 | ;;; CLOSURES OCCUR IN THE BODY 2214 | ;;; FOR EACH CLABELS WE FILL IN: 2215 | ;;; FNENV VARIABLES TO BE CONSED ONTO THE CURRENT CONSENV 2216 | ;;; BEFORE CLOSING THE LABELS FUNCTIONS 2217 | 2218 | ;;; CENV IS THE CONSED ENVIRONMENT (A LIST OF VARIABLES) 2219 | 2220 | (DEFINE FILTER-CLOSEREFS 2221 | (LAMBDA (REFS CENV) 2222 | (DO ((X REFS (CDR X)) 2223 | (Y NIL 2224 | (IF (OR (MEMQ (CAR X) CENV) 2225 | (LET ((KFN (GET (CAR X) 'KNOWN-FUNCTION))) 2226 | (AND KFN 2227 | (EQ (EQCASE (TYPE (CNODE\CFORM KFN)) 2228 | (CLAMBDA 2229 | (CLAMBDA\FNP (CNODE\CFORM KFN))) 2230 | (CONTINUATION 2231 | (CONTINUATION\FNP (CNODE\CFORM KFN)))) 2232 | 'NOCLOSE)))) 2233 | Y 2234 | (CONS (CAR X) Y)))) 2235 | ((NULL X) (NREVERSE Y))))) 2236 | 2237 | (DEFINE CLOSE-ANALYZE 2238 | (LAMBDA (CNODE CENV) 2239 | (LET ((CFM (CNODE\CFORM CNODE))) 2240 | (EQCASE (TYPE CFM) 2241 | (TRIVIAL NIL) 2242 | (CVARIABLE NIL) 2243 | (CLAMBDA 2244 | (LET ((CR (AND (NOT (EQ (CLAMBDA\FNP CFM) 'NOCLOSE)) 2245 | (FILTER-CLOSEREFS (CNODE\REFS CNODE) CENV))) 2246 | (AV (DO ((V (CLAMBDA\VARS (CNODE\CFORM CNODE)) (CDR V)) 2247 | (A NIL (IF (AND (GET (CAR V) 'WRITE-REFS) 2248 | (MEMQ (CAR V) 2249 | (CNODE\CLOVARS 2250 | (CLAMBDA\BODY CFM)))) 2251 | (CONS (CAR V) A) 2252 | A))) 2253 | ((NULL V) A)))) 2254 | (ALTER-CLAMBDA CFM 2255 | (CONSENV := CENV) 2256 | (CLOSEREFS := CR) 2257 | (ASETVARS := AV)) 2258 | (CLOSE-ANALYZE (CLAMBDA\BODY CFM) 2259 | (APPEND AV CR CENV)))) 2260 | (CONTINUATION 2261 | (AND (GET (CONTINUATION\VAR CFM) 'WRITE-REFS) 2262 | (ERROR '|How could an ASET refer to a continuation variable?| 2263 | CNODE 2264 | 'FAIL-ACT)) 2265 | (LET ((CR (AND (NOT (EQ (CONTINUATION\FNP CFM) 'NOCLOSE)) 2266 | (FILTER-CLOSEREFS (CNODE\REFS CNODE) CENV)))) 2267 | (ALTER-CONTINUATION CFM 2268 | (CONSENV := CENV) 2269 | (CLOSEREFS := CR)) 2270 | (CLOSE-ANALYZE (CONTINUATION\BODY CFM) 2271 | (APPEND CR CENV)))) 2272 | (CIF 2273 | (CLOSE-ANALYZE (CIF\PRED CFM) CENV) 2274 | (CLOSE-ANALYZE (CIF\CON CFM) CENV) 2275 | (CLOSE-ANALYZE (CIF\ALT CFM) CENV)) 2276 | (CASET 2277 | (CLOSE-ANALYZE (CASET\CONT CFM) CENV) 2278 | (CLOSE-ANALYZE (CASET\BODY CFM) CENV)) 2279 | (CLABELS 2280 | ((LAMBDA (CENV) 2281 | (BLOCK (AMAPC (LAMBDA (D) (CLOSE-ANALYZE D CENV)) 2282 | (CLABELS\FNDEFS CFM)) 2283 | (CLOSE-ANALYZE (CLABELS\BODY CFM) CENV))) 2284 | (COND ((CLABELS\EASY CFM) 2285 | (DO ((D (CLABELS\FNDEFS CFM) (CDR D)) 2286 | (R NIL (UNION R (CNODE\REFS (CAR D))))) 2287 | ((NULL D) 2288 | (LET ((E (FILTER-CLOSEREFS R CENV))) 2289 | (ALTER-CLABELS CFM 2290 | (FNENV := E) 2291 | (CONSENV := CENV)) 2292 | (APPEND E CENV))))) 2293 | (T (ALTER-CLABELS CFM 2294 | (FNENV := NIL) 2295 | (CONSENV := CENV)) 2296 | CENV)))) 2297 | (CCOMBINATION 2298 | (AMAPC (LAMBDA (A) (CLOSE-ANALYZE A CENV)) 2299 | (CCOMBINATION\ARGS CFM))) 2300 | (RETURN 2301 | (CLOSE-ANALYZE (RETURN\CONT CFM) CENV) 2302 | (CLOSE-ANALYZE (RETURN\VAL CFM) CENV)))))) 2303 | 2304 | ;;; CODE GENERATION ROUTINES 2305 | 2306 | ;;; PROGNAME: NAME OF A VARIABLE WHICH AT RUN TIME WILL HAVE 2307 | ;;; AS VALUE THE SUBR POINTER FOR THE PROG 2308 | ;;; FN: THE FUNCTION TO COMPILE (A CLAMBDA OR CONTINUATION CNODE) 2309 | ;;; EXTERNALP: NON-NIL IF THE FUNCTION IS EXTERNAL 2310 | ;;; RNL: INITIAL RENAME LIST (NON-NIL ONLY FOR NOCLOSE FNS). 2311 | ;;; ENTRIES ARE: (VAR . CODE) 2312 | ;;; BLOCKFNS: AN ALIST OF FUNCTIONS IN THIS BLOCK. 2313 | ;;; ENTRIES ARE: (USERNAME CNODE) 2314 | ;;; FNS: A LIST OF TUPLES FOR FUNCTIONS YET TO BE COMPILED; 2315 | ;;; EACH TUPLE IS (PROGNAME FN RNL) 2316 | ;;; C: A CONTINUATION, TAKING: 2317 | ;;; CODE: THE PIECE OF MACLISP CODE FOR THE FUNCTION 2318 | ;;; FNS: AN AUGMENTED FNS LIST 2319 | 2320 | (DEFINE COMPILATE 2321 | (LAMBDA (PROGNAME FN RNL BLOCKFNS FNS C) 2322 | (LET ((CFM (CNODE\CFORM FN))) 2323 | (EQCASE (TYPE CFM) 2324 | (CLAMBDA 2325 | (LET ((CENV (APPEND (CLAMBDA\ASETVARS CFM) 2326 | (CLAMBDA\CLOSEREFS CFM) 2327 | (CLAMBDA\CONSENV CFM)))) 2328 | (COMP-BODY (CLAMBDA\BODY CFM) 2329 | (REGSLIST CFM T (ENVCARCDR CENV RNL)) 2330 | PROGNAME 2331 | BLOCKFNS 2332 | CENV 2333 | FNS 2334 | (LAMBDA (CODE FNS) 2335 | (C (SET-UP-ASETVARS CODE 2336 | (CLAMBDA\ASETVARS CFM) 2337 | (REGSLIST CFM NIL NIL)) 2338 | FNS))))) 2339 | (CONTINUATION 2340 | (LET ((CENV (APPEND (CONTINUATION\CLOSEREFS CFM) 2341 | (CONTINUATION\CONSENV CFM)))) 2342 | (COMP-BODY (CONTINUATION\BODY CFM) 2343 | (IF (EQ (CONTINUATION\FNP CFM) 'NOCLOSE) 2344 | (IF (NULL (CONTINUATION\TVARS CFM)) 2345 | (ENVCARCDR CENV RNL) 2346 | (CONS (CONS (CONTINUATION\VAR CFM) 2347 | (TEMPLOC (CONTINUATION\DEP CFM))) 2348 | (ENVCARCDR CENV RNL))) 2349 | (CONS (CONS (CONTINUATION\VAR CFM) 2350 | (CAR **ARGUMENT-REGISTERS**)) 2351 | (ENVCARCDR CENV RNL))) 2352 | PROGNAME 2353 | BLOCKFNS 2354 | CENV 2355 | FNS 2356 | C))))))) 2357 | 2358 | ;;; DEPROGNIFY IS USED ONLY TO MAKE THE OUTPUT PRETTY BY ELIMINATING 2359 | ;;; UNNECESSARY OCCURRENCES OF `PROGN`. 2360 | 2361 | (DEFMAC DEPROGNIFY (FORM) `(DEPROGNIFY1 ,FORM NIL)) 2362 | 2363 | (SET' *DEPROGNIFY-COUNT* 0) 2364 | 2365 | (DEFINE DEPROGNIFY1 2366 | (LAMBDA (FORM ATOMFLUSHP) 2367 | (IF (OR (ATOM FORM) (NOT (EQ (CAR FORM) 'PROGN))) 2368 | (LIST FORM) 2369 | (DO ((X (CDR FORM) (CDR X)) 2370 | (Z NIL (COND ((NULL (CDR X)) (CONS (CAR X) Z)) 2371 | ((NULL (CAR X)) 2372 | (INCREMENT *DEPROGNIFY-COUNT*) 2373 | Z) 2374 | ((ATOM (CAR X)) 2375 | (COND (ATOMFLUSHP 2376 | (INCREMENT *DEPROGNIFY-COUNT*) 2377 | Z) 2378 | (T (CONS (CAR X) Z)))) 2379 | ((EQ (CAAR X) 'QUOTE) 2380 | (INCREMENT *DEPROGNIFY-COUNT*) 2381 | Z) 2382 | (T (CONS (CAR X) Z))))) 2383 | ((NULL X) (NREVERSE Z)))))) 2384 | 2385 | (DEFINE TEMPLOC 2386 | (LAMBDA (N) 2387 | (LABELS ((LOOP 2388 | (LAMBDA (REGS J) 2389 | (IF (NULL REGS) 2390 | (IMPLODE (APPEND '(-) (EXPLODEN N) '(-))) 2391 | (IF (= J 0) 2392 | (CAR REGS) 2393 | (LOOP (CDR REGS) (- J 1))))))) 2394 | (LOOP **CONT+ARG-REGS** N)))) 2395 | 2396 | (DEFINE ENVCARCDR 2397 | (LAMBDA (VARS RNL) 2398 | (DO ((X '**ENV** `(CDR ,X)) 2399 | (V VARS (CDR V)) 2400 | (R RNL (CONS (CONS (CAR V) (DECARCDRATE `(CAR ,X))) R))) 2401 | ((NULL V) R)))) 2402 | 2403 | ;;; AVP NON-NIL MEANS THAT ASETVARS ARE TO BE EXCLUDED FROM THE CONSED LIST. 2404 | 2405 | (DEFINE REGSLIST 2406 | (LAMBDA (CLAM AVP RNL) 2407 | (LET ((AV (AND AVP (CLAMBDA\ASETVARS CLAM)))) 2408 | (IF (EQ (CLAMBDA\FNP CLAM) 'NOCLOSE) 2409 | (DO ((J (CLAMBDA\DEP CLAM) (+ J 1)) 2410 | (TV (CLAMBDA\TVARS CLAM) (CDR TV)) 2411 | (R RNL 2412 | (IF (MEMQ (CAR TV) AV) 2413 | R 2414 | (CONS (CONS (CAR TV) (TEMPLOC J)) R)))) 2415 | ((NULL TV) R)) 2416 | (LET ((VARS (CLAMBDA\VARS CLAM))) 2417 | (IF (> (LENGTH (CDR VARS)) **NUMBER-OF-ARG-REGS**) 2418 | (DO ((X (CAR **ARGUMENT-REGISTERS**) `(CDR ,X)) 2419 | (V (CDR VARS) (CDR V)) 2420 | (R (CONS (CONS (CAR VARS) '**CONT**) RNL) 2421 | (IF (MEMQ (CAR V) AV) 2422 | R 2423 | (CONS (CONS (CAR V) (DECARCDRATE `(CAR ,X))) R)))) 2424 | ((NULL V) R)) 2425 | (DO ((V VARS (CDR V)) 2426 | (X **CONT+ARG-REGS** (CDR X)) 2427 | (R RNL 2428 | (IF (MEMQ (CAR V) AV) 2429 | R 2430 | (CONS (CONS (CAR V) (CAR X)) R)))) 2431 | ((NULL V) R)))))))) 2432 | 2433 | (DEFINE SET-UP-ASETVARS 2434 | (LAMBDA (CODE AV RNL) 2435 | (IF (NULL AV) 2436 | CODE 2437 | `(PROGN (SETQ **ENV** 2438 | ,(DO ((A (REVERSE AV) (CDR A)) 2439 | (E '**ENV** `(CONS ,(LOOKUPICATE (CAR A) RNL) ,E))) 2440 | ((NULL A) E))) 2441 | ,@(DEPROGNIFY CODE))))) 2442 | 2443 | ;;; RNL IS THE `RENAME LIST`: AN ALIST DESCRIBING HOW TO REFER TO THE VARIABLES IN THE 2444 | ;;; ENVIRONMENT. CENV IS THE CONSED ENVIRONMENT SEEN BY THE BODY. 2445 | 2446 | (DEFINE 2447 | COMP-BODY 2448 | (LAMBDA (BODY RNL PROGNAME BLOCKFNS CENV FNS C) 2449 | (LET ((CFM (CNODE\CFORM BODY))) 2450 | (EQCASE (TYPE CFM) 2451 | (CIF 2452 | (PRODUCE-IF BODY RNL PROGNAME BLOCKFNS CENV FNS C)) 2453 | (CASET 2454 | (PRODUCE-ASET BODY RNL PROGNAME BLOCKFNS CENV FNS C)) 2455 | (CLABELS 2456 | (OR (EQUAL CENV (CLABELS\CONSENV CFM)) 2457 | (ERROR '|Environment disagreement| BODY 'FAIL-ACT)) 2458 | (LET ((LCENV (APPEND (CLABELS\FNENV CFM) CENV))) 2459 | (COMP-BODY 2460 | (CLABELS\BODY CFM) 2461 | (ENVCARCDR LCENV RNL) 2462 | PROGNAME 2463 | BLOCKFNS 2464 | LCENV 2465 | FNS 2466 | (LAMBDA (LBOD FNS) 2467 | (PRODUCE-LABELS BODY LBOD RNL PROGNAME BLOCKFNS FNS C))))) 2468 | (CCOMBINATION 2469 | (LET ((FN (CNODE\CFORM (CAR (CCOMBINATION\ARGS CFM))))) 2470 | (COND ((EQ (TYPE FN) 'CLAMBDA) 2471 | (PRODUCE-LAMBDA-COMBINATION BODY RNL PROGNAME BLOCKFNS CENV FNS C)) 2472 | ((AND (EQ (TYPE FN) 'TRIVIAL) 2473 | (EQ (TYPE (NODE\FORM (TRIVIAL\NODE FN))) 'VARIABLE) 2474 | (TRIVFN (VARIABLE\VAR (NODE\FORM (TRIVIAL\NODE FN))))) 2475 | (PRODUCE-TRIVFN-COMBINATION BODY RNL PROGNAME BLOCKFNS CENV FNS C)) 2476 | (T (PRODUCE-COMBINATION BODY RNL PROGNAME BLOCKFNS CENV FNS C))))) 2477 | (RETURN 2478 | (LET ((FN (CNODE\CFORM (RETURN\CONT CFM)))) 2479 | (IF (EQ (TYPE FN) 'CONTINUATION) 2480 | (PRODUCE-CONTINUATION-RETURN BODY RNL PROGNAME BLOCKFNS CENV FNS C) 2481 | (PRODUCE-RETURN BODY RNL PROGNAME BLOCKFNS CENV FNS C)))))))) 2482 | 2483 | (DEFINE PRODUCE-IF 2484 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C) 2485 | (LET ((CFM (CNODE\CFORM CNODE))) 2486 | (ANALYZE (CIF\PRED CFM) 2487 | RNL 2488 | PROGNAME 2489 | BLOCKFNS 2490 | FNS 2491 | (LAMBDA (PRED FNS) 2492 | (COMP-BODY (CIF\CON CFM) 2493 | RNL 2494 | PROGNAME 2495 | BLOCKFNS 2496 | CENV 2497 | FNS 2498 | (LAMBDA (CON FNS) 2499 | (COMP-BODY (CIF\ALT CFM) 2500 | RNL 2501 | PROGNAME 2502 | BLOCKFNS 2503 | CENV 2504 | FNS 2505 | (LAMBDA (ALT FNS) 2506 | (C (CONDICATE PRED 2507 | CON 2508 | ALT) 2509 | FNS)))))))))) 2510 | 2511 | (DEFINE 2512 | PRODUCE-ASET 2513 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C) 2514 | (LET ((CFM (CNODE\CFORM CNODE))) 2515 | (ANALYZE (CASET\BODY CFM) 2516 | RNL 2517 | PROGNAME 2518 | BLOCKFNS 2519 | FNS 2520 | (LAMBDA (BODY FNS) 2521 | (LET ((CONTCFM (CNODE\CFORM (CASET\CONT CFM)))) 2522 | (IF (EQ (TYPE CONTCFM) 'CONTINUATION) 2523 | (COMP-BODY (CONTINUATION\BODY CONTCFM) 2524 | (IF (CONTINUATION\TVARS CONTCFM) 2525 | (CONS (CONS (CAR (CONTINUATION\TVARS CONTCFM)) 2526 | (TEMPLOC (CONTINUATION\DEP 2527 | CONTCFM))) 2528 | (ENVCARCDR CENV RNL)) 2529 | (ENVCARCDR CENV RNL)) 2530 | PROGNAME 2531 | BLOCKFNS 2532 | CENV 2533 | FNS 2534 | (LAMBDA (CODE FNS) 2535 | (C (LAMBDACATE 2536 | (LIST (CONTINUATION\VAR CONTCFM)) 2537 | (CONTINUATION\TVARS CONTCFM) 2538 | (CONTINUATION\DEP CONTCFM) 2539 | (LIST (OUTPUT-ASET 2540 | (LOOKUPICATE (CASET\VAR CFM) 2541 | RNL) 2542 | BODY)) 2543 | (REMARK-ON (CASET\CONT CFM)) 2544 | '**ENV** 2545 | CODE) 2546 | FNS))) 2547 | (ANALYZE 2548 | (CASET\CONT CFM) 2549 | RNL 2550 | PROGNAME 2551 | BLOCKFNS 2552 | FNS 2553 | (LAMBDA (CONT FNS) 2554 | (C `(PROGN (SETQ **FUN** ,CONT) 2555 | (SETQ ,(CAR **ARGUMENT-REGISTERS**) 2556 | ,(OUTPUT-ASET 2557 | (LOOKUPICATE (CASET\VAR CFM) 2558 | RNL) 2559 | BODY)) 2560 | (RETURN NIL)) 2561 | FNS)))))))))) 2562 | 2563 | (DEFINE 2564 | PRODUCE-LABELS 2565 | (LAMBDA (CNODE LBOD RNL PROGNAME BLOCKFNS FNS C) 2566 | (LET ((CFM (CNODE\CFORM CNODE))) 2567 | (LET ((VARS (CLABELS\FNVARS CFM)) 2568 | (DEFS (CLABELS\FNDEFS CFM)) 2569 | (FNENV (CLABELS\FNENV CFM))) 2570 | (LET ((FNENV-FIX (IF FNENV `((SETQ **ENV** ,(CONS-CLOSEREFS FNENV RNL)))))) 2571 | (EQCASE (CLABELS\EASY CFM) 2572 | (NIL 2573 | (DO ((V VARS (CDR V)) 2574 | (D DEFS (CDR D)) 2575 | (FNS FNS (CONS (LIST PROGNAME (CAR D) NIL) FNS)) 2576 | (RP NIL (CONS `(RPLACD (CDDR ,(CAR V)) 2577 | ,(CONS-CLOSEREFS 2578 | (CLAMBDA\CLOSEREFS 2579 | (CNODE\CFORM (CAR D))) 2580 | RNL)) 2581 | RP)) 2582 | (CB NIL (CONS `(LIST 'CBETA ,PROGNAME ',(CAR V)) CB))) 2583 | ((NULL V) 2584 | (C `((LAMBDA ,VARS 2585 | ,@FNENV-FIX 2586 | ,@RP 2587 | ,@(DEPROGNIFY LBOD)) 2588 | ,@(NREVERSE CB)) 2589 | FNS)))) 2590 | (EZCLOSE 2591 | (DO ((V VARS (CDR V)) 2592 | (D DEFS (CDR D)) 2593 | (FNS FNS (CONS (LIST PROGNAME (CAR D) NIL) FNS)) 2594 | (RP NIL (CONS `(RPLACD ,(CAR V) 2595 | ,(CONS-CLOSEREFS 2596 | (CLAMBDA\CLOSEREFS 2597 | (CNODE\CFORM (CAR D))) 2598 | RNL)) 2599 | RP)) 2600 | (CB NIL (CONS `(LIST ',(CAR V)) CB))) 2601 | ((NULL V) 2602 | (C `((LAMBDA ,VARS 2603 | ,@FNENV-FIX 2604 | ,@RP 2605 | ,@(DEPROGNIFY LBOD)) 2606 | ,@(NREVERSE CB)) 2607 | FNS)))) 2608 | (NOCLOSE 2609 | (C `(PROGN ,@FNENV-FIX ,@(DEPROGNIFY LBOD)) 2610 | (DO ((V VARS (CDR V)) 2611 | (D DEFS (CDR D)) 2612 | (FNS FNS (CONS (LIST PROGNAME (CAR D) RNL) FNS))) 2613 | ((NULL V) FNS)))))))))) 2614 | 2615 | (DEFINE 2616 | PRODUCE-LAMBDA-COMBINATION 2617 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C) 2618 | (LET ((CFM (CNODE\CFORM CNODE))) 2619 | (LET ((FN (CNODE\CFORM (CAR (CCOMBINATION\ARGS CFM))))) 2620 | (AND (CLAMBDA\CLOSEREFS FN) 2621 | (ERROR '|Functional LAMBDA has CLOSEREFS| CNODE 'FAIL-ACT)) 2622 | (OR (EQUAL CENV (CLAMBDA\CONSENV FN)) 2623 | (ERROR '|Environment disagreement| CNODE 'FAIL-ACT)) 2624 | (OR (EQ (CLAMBDA\FNP FN) 'NOCLOSE) 2625 | (ERROR '|Non-NOCLOSE LAMBDA in function position| CNODE 'FAIL-ACT)) 2626 | (COMP-BODY 2627 | (CLAMBDA\BODY FN) 2628 | (ENVCARCDR (CLAMBDA\ASETVARS FN) 2629 | (REGSLIST FN T (ENVCARCDR CENV RNL))) 2630 | PROGNAME 2631 | BLOCKFNS 2632 | (APPEND (CLAMBDA\ASETVARS FN) CENV) 2633 | FNS 2634 | (LAMBDA (BODY FNS) 2635 | (MAPANALYZE (CDR (CCOMBINATION\ARGS CFM)) 2636 | RNL 2637 | PROGNAME 2638 | BLOCKFNS 2639 | FNS 2640 | (LAMBDA (ARGS FNS) 2641 | (C (LAMBDACATE (CLAMBDA\VARS FN) 2642 | (CLAMBDA\TVARS FN) 2643 | (CLAMBDA\DEP FN) 2644 | ARGS 2645 | (REMARK-ON 2646 | (CAR (CCOMBINATION\ARGS CFM))) 2647 | '**ENV** 2648 | (SET-UP-ASETVARS 2649 | BODY 2650 | (CLAMBDA\ASETVARS FN) 2651 | (REGSLIST FN NIL NIL))) 2652 | FNS))))))))) 2653 | 2654 | (DEFINE PRODUCE-TRIVFN-COMBINATION 2655 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C) 2656 | (LET ((CFM (CNODE\CFORM CNODE))) 2657 | (LET ((FN (CNODE\CFORM (CAR (CCOMBINATION\ARGS CFM)))) 2658 | (CONT (CNODE\CFORM (CADR (CCOMBINATION\ARGS CFM))))) 2659 | (MAPANALYZE (CDDR (CCOMBINATION\ARGS CFM)) 2660 | RNL 2661 | PROGNAME 2662 | BLOCKFNS 2663 | FNS 2664 | (LAMBDA (ARGS FNS) 2665 | (EQCASE (TYPE CONT) 2666 | (CONTINUATION 2667 | (PRODUCE-TRIVFN-COMBINATION-CONTINUATION 2668 | CNODE RNL PROGNAME BLOCKFNS CENV 2669 | FNS C CFM FN CONT ARGS)) 2670 | (CVARIABLE 2671 | (PRODUCE-TRIVFN-COMBINATION-CVARIABLE 2672 | CNODE RNL PROGNAME BLOCKFNS CENV 2673 | FNS C CFM FN CONT ARGS))))))))) 2674 | 2675 | (DEFINE PRODUCE-TRIVFN-COMBINATION-CONTINUATION 2676 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C CFM FN CONT ARGS) 2677 | (BLOCK (AND (CONTINUATION\CLOSEREFS CONT) 2678 | (ERROR '|CONTINUATION for TRIVFN has CLOSEREFS| CNODE 'FAIL-ACT)) 2679 | (OR (EQ (CONTINUATION\FNP CONT) 'NOCLOSE) 2680 | (ERROR '|Non-NOCLOSE CONTINUATION for TRIVFN| CNODE 'FAIL-ACT)) 2681 | (COMP-BODY (CONTINUATION\BODY CONT) 2682 | (IF (CONTINUATION\TVARS CONT) 2683 | (CONS (CONS (CAR (CONTINUATION\TVARS CONT)) 2684 | (TEMPLOC (CONTINUATION\DEP CONT))) 2685 | (ENVCARCDR CENV RNL)) 2686 | (ENVCARCDR CENV RNL)) 2687 | PROGNAME 2688 | BLOCKFNS 2689 | CENV 2690 | FNS 2691 | (LAMBDA (BODY FNS) 2692 | (C (LAMBDACATE 2693 | (LIST (CONTINUATION\VAR CONT)) 2694 | (CONTINUATION\TVARS CONT) 2695 | (CONTINUATION\DEP CONT) 2696 | (LIST `(,(VARIABLE\VAR (NODE\FORM (TRIVIAL\NODE FN))) 2697 | ,@ARGS)) 2698 | (REMARK-ON (CADR (CCOMBINATION\ARGS CFM))) 2699 | '**ENV** 2700 | BODY) 2701 | FNS)))))) 2702 | 2703 | (DEFINE PRODUCE-TRIVFN-COMBINATION-CVARIABLE 2704 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C CFM FN CONT ARGS) 2705 | (ANALYZE 2706 | (CADR (CCOMBINATION\ARGS CFM)) 2707 | RNL 2708 | PROGNAME 2709 | BLOCKFNS 2710 | FNS 2711 | (LAMBDA (CONTF FNS) 2712 | (LET ((KF (GET (CVARIABLE\VAR CONT) 'KNOWN-FUNCTION)) 2713 | (VAL `(,(VARIABLE\VAR (NODE\FORM (TRIVIAL\NODE FN))) ,@ARGS))) 2714 | (IF KF 2715 | (LET ((KCFM (CNODE\CFORM KF))) 2716 | (LET ((ENVADJ 2717 | (ADJUST-KNOWNFN-CENV CENV 2718 | (CVARIABLE\VAR CONT) 2719 | CONTF 2720 | (CONTINUATION\FNP KCFM) 2721 | (APPEND 2722 | (CONTINUATION\CLOSEREFS KCFM) 2723 | (CONTINUATION\CONSENV KCFM))))) 2724 | (C `(PROGN 2725 | ,@(IF (EQ (CONTINUATION\FNP KCFM) 2726 | 'NOCLOSE) 2727 | (DEPROGNIFY 2728 | (LAMBDACATE (LIST (CONTINUATION\VAR KCFM)) 2729 | (CONTINUATION\TVARS KCFM) 2730 | (CONTINUATION\DEP KCFM) 2731 | (LIST VAL) 2732 | (REMARK-ON KF) 2733 | ENVADJ 2734 | NIL)) 2735 | (PSETQIFY (LIST ENVADJ VAL) 2736 | (LIST '**ENV** 2737 | (CAR **ARGUMENT-REGISTERS**)))) 2738 | (GO ,(CONTINUATION\NAME KCFM))) 2739 | FNS))) 2740 | (C `(PROGN (SETQ **FUN** ,CONTF) 2741 | (SETQ ,(CAR **ARGUMENT-REGISTERS**) ,VAL) 2742 | (RETURN NIL)) 2743 | FNS))))))) 2744 | 2745 | (DEFINE PRODUCE-COMBINATION 2746 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C) 2747 | (MAPANALYZE (CCOMBINATION\ARGS (CNODE\CFORM CNODE)) 2748 | RNL 2749 | PROGNAME 2750 | BLOCKFNS 2751 | FNS 2752 | (LAMBDA (FORM FNS) 2753 | (C (LET ((F (CNODE\CFORM (CAR (CCOMBINATION\ARGS 2754 | (CNODE\CFORM CNODE)))))) 2755 | (IF (AND (EQ (TYPE F) 'TRIVIAL) 2756 | (EQ (TYPE (NODE\FORM (TRIVIAL\NODE F))) 2757 | 'VARIABLE)) 2758 | (LET ((V (VARIABLE\VAR 2759 | (NODE\FORM (TRIVIAL\NODE F))))) 2760 | (PRODUCE-COMBINATION-VARIABLE 2761 | CNODE RNL PROGNAME BLOCKFNS CENV 2762 | FNS C FORM V (GET V 'KNOWN-FUNCTION))) 2763 | `(PROGN (SETQ **FUN** ,(CAR FORM)) 2764 | ,@(PSETQ-ARGS (CDR FORM)) 2765 | (SETQ **NARGS** ',(LENGTH (CDDR FORM))) 2766 | (RETURN NIL)))) 2767 | FNS))))) 2768 | 2769 | (DEFINE PRODUCE-COMBINATION-VARIABLE 2770 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C FORM V KFN) 2771 | (IF KFN 2772 | (LET ((ENVADJ 2773 | (ADJUST-KNOWNFN-CENV CENV 2774 | V 2775 | (CAR FORM) 2776 | (CLAMBDA\FNP (CNODE\CFORM KFN)) 2777 | (APPEND (CLAMBDA\CLOSEREFS (CNODE\CFORM KFN)) 2778 | (CLAMBDA\CONSENV (CNODE\CFORM KFN)))))) 2779 | (OR (EQ (TYPE (CNODE\CFORM KFN)) 'CLAMBDA) 2780 | (ERROR '|Known function not CLAMBDA| CNODE 'FAIL-ACT)) 2781 | `(PROGN ,@(IF (EQ (CLAMBDA\FNP (CNODE\CFORM KFN)) 'NOCLOSE) 2782 | (DEPROGNIFY 2783 | (LAMBDACATE (CLAMBDA\VARS (CNODE\CFORM KFN)) 2784 | (CLAMBDA\TVARS (CNODE\CFORM KFN)) 2785 | (CLAMBDA\DEP (CNODE\CFORM KFN)) 2786 | (CDR FORM) 2787 | (REMARK-ON KFN) 2788 | ENVADJ 2789 | NIL)) 2790 | (PSETQ-ARGS-ENV (CDR FORM) ENVADJ)) 2791 | (GO ,(CLAMBDA\NAME (CNODE\CFORM KFN))))) 2792 | (IF (ASSQ V BLOCKFNS) 2793 | `(PROGN ,@(PSETQ-ARGS (CDR FORM)) 2794 | ,@(IF (NOT (EQUAL (CLAMBDA\CONSENV 2795 | (CNODE\CFORM 2796 | (CADR (ASSQ V BLOCKFNS)))) 2797 | CENV)) 2798 | `((SETQ **ENV** (CDDDR ,(CAR FORM))))) 2799 | (GO ,(CLAMBDA\NAME (CNODE\CFORM (CADR (ASSQ V BLOCKFNS)))))) 2800 | `(PROGN (SETQ **FUN** ,(CAR FORM)) 2801 | ,@(PSETQ-ARGS (CDR FORM)) 2802 | (SETQ **NARGS** ',(LENGTH (CDDR FORM))) 2803 | (RETURN NIL)))))) 2804 | 2805 | (DEFINE ADJUST-KNOWNFN-CENV 2806 | (LAMBDA (CENV VAR VARREF FNP LCENV) 2807 | (COND ((EQUAL LCENV CENV) '**ENV**) 2808 | ((NULL LCENV) 'NIL) 2809 | (T (EQCASE FNP 2810 | (NOCLOSE 2811 | (DO ((X CENV (CDR X)) 2812 | (Y '**ENV** `(CDR ,Y)) 2813 | (I (- (LENGTH CENV) (LENGTH LCENV)) (- I 1))) 2814 | ((< I 1) 2815 | (IF (EQUAL X LCENV) 2816 | (DECARCDRATE Y) 2817 | (ERROR '|Cannot recover environment for known function| 2818 | VAR 2819 | 'FAIL-ACT))))) 2820 | (EZCLOSE 2821 | (IF (GET VAR 'LABELS-FUNCTION) 2822 | `(CDR ,VARREF) 2823 | VARREF)) 2824 | (NIL `(CDDDR ,VARREF))))))) 2825 | 2826 | (DEFINE PRODUCE-CONTINUATION-RETURN 2827 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C) 2828 | (LET ((CFM (CNODE\CFORM CNODE))) 2829 | (LET ((FN (CNODE\CFORM (RETURN\CONT CFM)))) 2830 | (AND (CONTINUATION\CLOSEREFS FN) 2831 | (ERROR '|Functional CONTINUATION has CLOSEREFS| CNODE 'FAIL-ACT)) 2832 | (OR (EQUAL CENV (CONTINUATION\CONSENV FN)) 2833 | (ERROR '|Environment disagreement| CNODE 'FAIL-ACT)) 2834 | (OR (EQ (CONTINUATION\FNP FN) 'NOCLOSE) 2835 | (ERROR '|Non-NOCLOSE CONTINUATION in function position| 2836 | CNODE 2837 | 'FAIL-ACT)) 2838 | (COMP-BODY (CONTINUATION\BODY FN) 2839 | (IF (CONTINUATION\TVARS FN) 2840 | (CONS (CONS (CAR (CONTINUATION\TVARS FN)) 2841 | (TEMPLOC (CONTINUATION\DEP FN))) 2842 | (ENVCARCDR CENV RNL)) 2843 | (ENVCARCDR CENV RNL)) 2844 | PROGNAME 2845 | BLOCKFNS 2846 | CENV 2847 | FNS 2848 | (LAMBDA (BODY FNS) 2849 | (ANALYZE (RETURN\VAL CFM) 2850 | RNL 2851 | PROGNAME 2852 | BLOCKFNS 2853 | FNS 2854 | (LAMBDA (VAL FNS) 2855 | (C (LAMBDACATE 2856 | (LIST (CONTINUATION\VAR FN)) 2857 | (CONTINUATION\TVARS FN) 2858 | (CONTINUATION\DEP FN) 2859 | (LIST VAL) 2860 | (REMARK-ON (RETURN\CONT CFM)) 2861 | '**ENV** 2862 | BODY) 2863 | FNS))))))))) 2864 | 2865 | (DEFINE PRODUCE-RETURN 2866 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C) 2867 | (LET ((CFM (CNODE\CFORM CNODE))) 2868 | (ANALYZE (RETURN\VAL CFM) 2869 | RNL 2870 | PROGNAME 2871 | BLOCKFNS 2872 | FNS 2873 | (LAMBDA (VAL FNS) 2874 | (ANALYZE (RETURN\CONT CFM) 2875 | RNL 2876 | PROGNAME 2877 | BLOCKFNS 2878 | FNS 2879 | (LAMBDA (CONT FNS) 2880 | (PRODUCE-RETURN-1 2881 | CNODE RNL PROGNAME BLOCKFNS 2882 | CENV FNS C CFM VAL CONT)))))))) 2883 | 2884 | (DEFINE PRODUCE-RETURN-1 2885 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS CENV FNS C CFM VAL CONT) 2886 | (IF (AND (EQ (TYPE (CNODE\CFORM (RETURN\CONT CFM))) 'CVARIABLE) 2887 | (GET (CVARIABLE\VAR (CNODE\CFORM (RETURN\CONT CFM))) 2888 | 'KNOWN-FUNCTION)) 2889 | (LET ((KCFM (CNODE\CFORM 2890 | (GET (CVARIABLE\VAR 2891 | (CNODE\CFORM (RETURN\CONT CFM))) 2892 | 'KNOWN-FUNCTION)))) 2893 | (OR (EQ (TYPE KCFM) 'CONTINUATION) 2894 | (ERROR '|Known function not CONTINUATION| CNODE 'FAIL-ACT)) 2895 | (LET ((ENVADJ 2896 | (ADJUST-KNOWNFN-CENV CENV 2897 | (CVARIABLE\VAR (CNODE\CFORM (RETURN\CONT CFM))) 2898 | CONT 2899 | (CONTINUATION\FNP KCFM) 2900 | (APPEND 2901 | (CONTINUATION\CLOSEREFS KCFM) 2902 | (CONTINUATION\CONSENV KCFM))))) 2903 | (C `(PROGN ,@(IF (EQ (CONTINUATION\FNP KCFM) 'NOCLOSE) 2904 | (DEPROGNIFY 2905 | (LAMBDACATE (LIST (CONTINUATION\VAR KCFM)) 2906 | (CONTINUATION\TVARS KCFM) 2907 | (CONTINUATION\DEP KCFM) 2908 | (LIST VAL) 2909 | (REMARK-ON 2910 | (GET (CVARIABLE\VAR 2911 | (CNODE\CFORM (RETURN\CONT CFM))) 2912 | 'KNOWN-FUNCTION)) 2913 | ENVADJ 2914 | NIL)) 2915 | (PSETQIFY (LIST ENVADJ VAL) 2916 | (LIST '**ENV** 2917 | (CAR **ARGUMENT-REGISTERS**)))) 2918 | (GO ,(CONTINUATION\NAME KCFM))) 2919 | FNS))) 2920 | (C `(PROGN (SETQ **FUN** ,CONT) 2921 | ,@(IF (NOT (EQ VAL (CAR **ARGUMENT-REGISTERS**))) 2922 | `((SETQ ,(CAR **ARGUMENT-REGISTERS**) ,VAL))) 2923 | (RETURN NIL)) 2924 | FNS)))) 2925 | 2926 | ;;; HANDLE CASE OF INVOKING A KNOWN NOCLOSE FUNCTION OR CONTINUATION. 2927 | ;;; FOR AN EXPLICIT ((LAMBDA ... BODY) ...), BODY IS THE BODY. 2928 | ;;; OTHERWISE, IT IS NIL, AND SOMEONE WILL DO AN APPROPRIATE GO LATER. 2929 | 2930 | (DEFINE LAMBDACATE 2931 | (LAMBDA (VARS TVARS DEP ARGS REM ENVADJ BODY) 2932 | (LABELS ((LOOP 2933 | (LAMBDA (V A REALVARS REALARGS EFFARGS) 2934 | ;;REALVARS IS COMPUTED PURELY FOR ERROR-CHECKING 2935 | (IF (NULL A) 2936 | (LET ((B `(PROGN ,@(PSETQ-TEMPS (NREVERSE REALARGS) DEP ENVADJ) 2937 | ,REM 2938 | ,@(DEPROGNIFY BODY))) 2939 | (RV (NREVERSE REALVARS))) 2940 | (IF (NOT (EQUAL RV TVARS)) 2941 | (ERROR '|TVARS screwup in LAMBDACATE| 2942 | `((VARS = ,VARS) 2943 | (TVARS = ,TVARS) 2944 | (REALVARS = ,RV)) 2945 | 'FAIL-ACT)) 2946 | (IF EFFARGS 2947 | `(PROGN ,@EFFARGS ,@(DEPROGNIFY B)) 2948 | B)) 2949 | (COND ((LET ((KFN (GET (CAR V) 'KNOWN-FUNCTION))) 2950 | (AND KFN 2951 | (EQ (EQCASE (TYPE (CNODE\CFORM KFN)) 2952 | (CLAMBDA 2953 | (CLAMBDA\FNP 2954 | (CNODE\CFORM KFN))) 2955 | (CONTINUATION 2956 | (CONTINUATION\FNP 2957 | (CNODE\CFORM KFN)))) 2958 | 'NOCLOSE))) 2959 | (LOOP (CDR V) (CDR A) REALVARS REALARGS EFFARGS)) 2960 | ((OR (GET (CAR V) 'READ-REFS) 2961 | (GET (CAR V) 'WRITE-REFS)) 2962 | (LOOP (CDR V) 2963 | (CDR A) 2964 | (CONS (CAR V) REALVARS) 2965 | (CONS (CAR A) REALARGS) 2966 | EFFARGS)) 2967 | (T (LOOP (CDR V) 2968 | (CDR A) 2969 | REALVARS 2970 | REALARGS 2971 | (CONS (CAR A) EFFARGS)))))))) 2972 | (LOOP VARS ARGS NIL NIL NIL)))) 2973 | 2974 | ;;; GENERATE PARALLEL SETQ'ING OF REGISTERS TO ARGS. 2975 | ;;; RETURNS A LIST OF THINGS; ONE WRITES ,@(PSETQIFY ...) WITHIN `. 2976 | 2977 | (DEFINE PSETQIFY 2978 | (LAMBDA (ARGS REGISTERS) 2979 | (IF (< (LENGTH ARGS) 5) 2980 | (PSETQIFY-METHOD-2 ARGS REGISTERS) 2981 | (PSETQIFY-METHOD-3 ARGS REGISTERS)))) 2982 | 2983 | 2984 | (DEFINE PSETQIFY-METHOD-2 2985 | (LAMBDA (ARGS REGISTERS) 2986 | (LABELS ((PSETQ1 2987 | (LAMBDA (A REGS QVARS SETQS USED) 2988 | (IF (NULL A) 2989 | (IF (NULL SETQS) 2990 | NIL 2991 | (IF (NULL (CDR SETQS)) 2992 | `((SETQ ,(CADAR SETQS) ,(CAR USED))) 2993 | ;;IMPORTANT: DO NOT NREVERSE THE SETQS! 2994 | ;;MAKES MACLISP COMPILER WIN BETTER. 2995 | `(((LAMBDA ,(NREVERSE QVARS) ,@SETQS) 2996 | ,@(NREVERSE USED))))) 2997 | (IF (EQ (CAR A) (CAR REGS)) ;AVOID USELESS SETQ'S 2998 | (PSETQ1 (CDR A) 2999 | (CDR REGS) 3000 | QVARS 3001 | SETQS 3002 | USED) 3003 | ((LAMBDA (QV) 3004 | (PSETQ1 (CDR A) 3005 | (CDR REGS) 3006 | (CONS QV QVARS) 3007 | (CONS `(SETQ ,(CAR REGS) ,QV) SETQS) 3008 | (CONS (CAR A) USED))) 3009 | (GENTEMP 'Q))))))) 3010 | (PSETQ1 ARGS REGISTERS NIL NIL NIL)))) 3011 | 3012 | (DEFINE PSETQIFY-METHOD-3 3013 | (LAMBDA (ARGS REGISTERS) 3014 | (LABELS ((PSETQ1 3015 | (LAMBDA (A REGS QVARS SETQS USED) 3016 | (IF (NULL A) 3017 | (IF (NULL SETQS) 3018 | NIL 3019 | (IF (NULL (CDR SETQS)) 3020 | `((SETQ ,(CADAR SETQS) ,(CADDR (CAR USED)))) 3021 | `((PROG () (DECLARE (SPECIAL ,@QVARS)) ,@USED ,@SETQS) ))) 3022 | (IF (EQ (CAR A) (CAR REGS)) ;AVOID USELESS SETQ'S 3023 | (PSETQ1 (CDR A) 3024 | (CDR REGS) 3025 | QVARS 3026 | SETQS 3027 | USED) 3028 | ((LAMBDA (QV) 3029 | (PSETQ1 (CDR A) 3030 | (CDR REGS) 3031 | (CONS QV QVARS) 3032 | (CONS `(SETQ ,(CAR REGS) ,QV) SETQS) 3033 | (CONS `(SETQ ,QV ,(CAR A)) USED))) 3034 | (CATENATE (CAR REGS) '|-TEMP|))))))) 3035 | (PSETQ1 ARGS REGISTERS NIL NIL NIL)))) 3036 | 3037 | (DEFINE PSETQ-ARGS 3038 | (LAMBDA (ARGS) 3039 | (PSETQ-ARGS-ENV ARGS '**ENV**))) 3040 | 3041 | (DEFINE PSETQ-ARGS-ENV 3042 | (LAMBDA (ARGS ENVADJ) 3043 | (IF (> (LENGTH ARGS) (+ **NUMBER-OF-ARG-REGS** 1)) 3044 | (PSETQIFY (LIST ENVADJ (CAR ARGS) (CONS 'LIST (CDR ARGS))) 3045 | **ENV+CONT+ARG-REGS**) 3046 | (PSETQIFY (CONS ENVADJ ARGS) **ENV+CONT+ARG-REGS**)))) 3047 | 3048 | (DEFINE PSETQ-TEMPS 3049 | (LAMBDA (ARGS DEP ENVADJ) 3050 | (DO ((A ARGS (CDR A)) 3051 | (J DEP (+ J 1)) 3052 | (R NIL (CONS (TEMPLOC J) R))) 3053 | ((NULL A) 3054 | (PSETQIFY (CONS ENVADJ ARGS) 3055 | (CONS '**ENV** (NREVERSE R))))))) 3056 | 3057 | 3058 | (DEFINE MAPANALYZE 3059 | (LAMBDA (FLIST RNL PROGNAME BLOCKFNS FNS C) 3060 | (LABELS ((LOOP 3061 | (LAMBDA (F Z FNS) 3062 | (IF (NULL F) 3063 | (C (NREVERSE Z) FNS) 3064 | (ANALYZE (CAR F) 3065 | RNL 3066 | PROGNAME 3067 | BLOCKFNS 3068 | FNS 3069 | (LAMBDA (STUFF FNS) 3070 | (LOOP (CDR F) 3071 | (CONS STUFF Z) 3072 | FNS))))))) 3073 | (LOOP FLIST NIL FNS)))) 3074 | 3075 | (DEFINE ANALYZE 3076 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS FNS C) 3077 | (LET ((CFM (CNODE\CFORM CNODE))) 3078 | (EQCASE (TYPE CFM) 3079 | (TRIVIAL 3080 | (C (TRIVIALIZE (TRIVIAL\NODE CFM) RNL) FNS)) 3081 | (CVARIABLE 3082 | (C (LOOKUPICATE (CVARIABLE\VAR CFM) RNL) FNS)) 3083 | (CLAMBDA 3084 | (ANALYZE-CLAMBDA CNODE RNL PROGNAME BLOCKFNS FNS C CFM)) 3085 | (CONTINUATION 3086 | (ANALYZE-CONTINUATION CNODE RNL PROGNAME BLOCKFNS FNS C CFM)) 3087 | (CIF 3088 | (ANALYZE-CIF CNODE RNL PROGNAME BLOCKFNS FNS C CFM)) 3089 | (CLABELS 3090 | (ANALYZE-CLABELS CNODE RNL PROGNAME BLOCKFNS FNS C CFM)) 3091 | (CCOMBINATION 3092 | (ANALYZE-CCOMBINATION CNODE RNL PROGNAME BLOCKFNS FNS C CFM)) 3093 | (RETURN 3094 | (ANALYZE-RETURN CNODE RNL PROGNAME BLOCKFNS FNS C CFM)))))) 3095 | 3096 | (DEFINE ANALYZE-CLAMBDA 3097 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS FNS C CFM) 3098 | (EQCASE (CLAMBDA\FNP CFM) 3099 | (NIL 3100 | (C `(CONS 'CBETA 3101 | (CONS ,PROGNAME 3102 | (CONS ',(CLAMBDA\NAME CFM) 3103 | ,(CONS-CLOSEREFS (CLAMBDA\CLOSEREFS CFM) 3104 | RNL)))) 3105 | (CONS (LIST PROGNAME CNODE NIL) FNS))) 3106 | (EZCLOSE 3107 | (C (CONS-CLOSEREFS (CLAMBDA\CLOSEREFS CFM) RNL) 3108 | (CONS (LIST PROGNAME CNODE NIL) FNS))) 3109 | (NOCLOSE 3110 | (C '|Shouldn't ever be seen - NOCLOSE CLAMBDA| 3111 | (CONS (LIST PROGNAME CNODE RNL) FNS)))))) 3112 | 3113 | (DEFINE ANALYZE-CONTINUATION 3114 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS FNS C CFM) 3115 | (EQCASE (CONTINUATION\FNP CFM) 3116 | (NIL 3117 | (C `(CONS 'CBETA 3118 | (CONS ,PROGNAME 3119 | (CONS ',(CONTINUATION\NAME CFM) 3120 | ,(CONS-CLOSEREFS (CONTINUATION\CLOSEREFS CFM) 3121 | RNL)))) 3122 | (CONS (LIST PROGNAME CNODE NIL) FNS))) 3123 | (EZCLOSE 3124 | (C (CONS-CLOSEREFS (CONTINUATION\CLOSEREFS CFM) RNL) 3125 | (CONS (LIST PROGNAME CNODE NIL) FNS))) 3126 | (NOCLOSE 3127 | (C '|Shouldn't ever be seen - NOCLOSE CONTINUATION| 3128 | (CONS (LIST PROGNAME CNODE RNL) FNS)))))) 3129 | 3130 | (DEFINE ANALYZE-CIF 3131 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS FNS C CFM) 3132 | (ANALYZE (CIF\PRED CFM) 3133 | RNL 3134 | PROGNAME 3135 | BLOCKFNS 3136 | FNS 3137 | (LAMBDA (PRED FNS) 3138 | (ANALYZE (CIF\CON CFM) 3139 | RNL 3140 | PROGNAME 3141 | BLOCKFNS 3142 | FNS 3143 | (LAMBDA (CON FNS) 3144 | (ANALYZE (CIF\ALT CFM) 3145 | RNL 3146 | PROGNAME 3147 | BLOCKFNS 3148 | FNS 3149 | (LAMBDA (ALT FNS) 3150 | (C (CONDICATE PRED CON ALT) 3151 | FNS))))))))) 3152 | 3153 | (DEFINE ANALYZE-CLABELS 3154 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS FNS C CFM) 3155 | (ANALYZE (CLABELS\BODY CFM) 3156 | (ENVCARCDR (APPEND (CLABELS\FNENV CFM) 3157 | (CLABELS\CONSENV CFM)) 3158 | RNL) 3159 | PROGNAME 3160 | BLOCKFNS 3161 | FNS 3162 | (LAMBDA (LBOD FNS) 3163 | (PRODUCE-LABELS CNODE LBOD RNL PROGNAME BLOCKFNS FNS C))))) 3164 | 3165 | (DEFINE 3166 | ANALYZE-CCOMBINATION 3167 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS FNS C CFM) 3168 | (LET ((FN (CNODE\CFORM (CAR (CCOMBINATION\ARGS CFM))))) 3169 | (IF (EQ (TYPE FN) 'CLAMBDA) 3170 | (ANALYZE (CLAMBDA\BODY FN) 3171 | (ENVCARCDR (CLAMBDA\ASETVARS FN) 3172 | (REGSLIST FN T (ENVCARCDR (CLAMBDA\CONSENV FN) RNL))) 3173 | PROGNAME 3174 | BLOCKFNS 3175 | FNS 3176 | (LAMBDA (BODY FNS) 3177 | (MAPANALYZE 3178 | (CDR (CCOMBINATION\ARGS CFM)) 3179 | RNL 3180 | PROGNAME 3181 | BLOCKFNS 3182 | FNS 3183 | (LAMBDA (ARGS FNS) 3184 | (C (LAMBDACATE (CLAMBDA\VARS FN) 3185 | (CLAMBDA\TVARS FN) 3186 | (CLAMBDA\DEP FN) 3187 | ARGS 3188 | (REMARK-ON (CAR (CCOMBINATION\ARGS CFM))) 3189 | '**ENV** 3190 | (SET-UP-ASETVARS BODY 3191 | (CLAMBDA\ASETVARS FN) 3192 | (REGSLIST FN NIL NIL))) 3193 | FNS))))) 3194 | (ERROR '|Non-trivial Function in ANALYZE-CCOMBINATION| CNODE 'FAIL-ACT))))) 3195 | 3196 | (DEFINE ANALYZE-RETURN 3197 | (LAMBDA (CNODE RNL PROGNAME BLOCKFNS FNS C CFM) 3198 | (LET ((FN (CNODE\CFORM (RETURN\CONT CFM)))) 3199 | (IF (EQ (TYPE FN) 'CONTINUATION) 3200 | (ANALYZE (CONTINUATION\BODY FN) 3201 | (IF (CONTINUATION\TVARS FN) 3202 | (CONS (CONS (CAR (CONTINUATION\TVARS FN)) 3203 | (TEMPLOC (CONTINUATION\DEP FN))) 3204 | (ENVCARCDR (CONTINUATION\CONSENV FN) RNL)) 3205 | (ENVCARCDR (CONTINUATION\CONSENV FN) RNL)) 3206 | PROGNAME 3207 | BLOCKFNS 3208 | FNS 3209 | (LAMBDA (BODY FNS) 3210 | (ANALYZE (RETURN\VAL CFM) 3211 | RNL 3212 | PROGNAME 3213 | BLOCKFNS 3214 | FNS 3215 | (LAMBDA (ARG FNS) 3216 | (C (LAMBDACATE 3217 | (LIST (CONTINUATION\VAR FN)) 3218 | (CONTINUATION\TVARS FN) 3219 | (CONTINUATION\DEP FN) 3220 | (LIST ARG) 3221 | (REMARK-ON (RETURN\CONT CFM)) 3222 | '**ENV** 3223 | BODY) 3224 | FNS))))) 3225 | (ERROR '|Non-trivial Function in ANALYZE-RETURN| CNODE 'FAIL-ACT))))) 3226 | 3227 | (DEFINE LOOKUPICATE 3228 | (LAMBDA (VAR RNL) 3229 | ((LAMBDA (SLOT) 3230 | (IF SLOT (CDR SLOT) 3231 | (IF (TRIVFN VAR) 3232 | `(GETL ',VAR '(EXPR SUBR LSUBR)) 3233 | VAR))) 3234 | (ASSQ VAR RNL)))) 3235 | 3236 | (DEFINE CONS-CLOSEREFS 3237 | (LAMBDA (CLOSEREFS RNL) 3238 | (DO ((CR (REVERSE CLOSEREFS) (CDR CR)) 3239 | (X '**ENV** `(CONS ,(LOOKUPICATE (CAR CR) RNL) ,X))) 3240 | ((NULL CR) X)))) 3241 | 3242 | (DEFINE OUTPUT-ASET 3243 | (LAMBDA (VARREF BODY) 3244 | (COND ((ATOM VARREF) 3245 | `(SETQ ,VARREF ,BODY)) 3246 | ((EQ (CAR VARREF) 'CAR) 3247 | `(CAR (RPLACA ,(CADR VARREF) ,BODY))) 3248 | ((EQ (CAR VARREF) 'CADR) 3249 | `(CAR (RPLACA (CDR ,(CADR VARREF)) ,BODY))) 3250 | ((EQ (CAR VARREF) 'CADDR) 3251 | `(CAR (RPLACA (CDDR ,(CADR VARREF)) ,BODY))) 3252 | ((EQ (CAR VARREF) 'CADDDR) 3253 | `(CAR (RPLACA (CDDDR ,(CADR VARREF)) ,BODY))) 3254 | (T (ERROR '|Unknown ASET discipline - OUTPUT-ASET| VARREF 'FAIL-ACT))))) 3255 | 3256 | ;;; CONDICATE TURNS AN IF INTO A COND; IN SO DOING IT TRIES TO MAKE THE RESULT PRETTY. 3257 | 3258 | (DEFINE CONDICATE 3259 | (LAMBDA (PRED CON ALT) 3260 | (IF (OR (ATOM ALT) (NOT (EQ (CAR ALT) 'COND))) 3261 | `(COND (,PRED ,@(DEPROGNIFY CON)) 3262 | (T ,@(DEPROGNIFY ALT))) 3263 | `(COND (,PRED ,@(DEPROGNIFY CON)) 3264 | ,@(CDR ALT))))) 3265 | 3266 | 3267 | ;;; DECARCDRATE MAKES CAR-CDR CHAINS PRETTIER. 3268 | 3269 | (DEFINE DECARCDRATE 3270 | (LAMBDA (X) 3271 | (COND ((ATOM X) X) 3272 | ((EQ (CAR X) 'CAR) 3273 | (IF (ATOM (CADR X)) 3274 | X 3275 | (LET ((Y (DECARCDRATE (CADR X)))) 3276 | (COND ((EQ (CAR Y) 'CAR) `(CAAR ,(CADR Y))) 3277 | ((EQ (CAR Y) 'CDR) `(CADR ,(CADR Y))) 3278 | ((EQ (CAR Y) 'CDDR) `(CADDR ,(CADR Y))) 3279 | ((EQ (CAR Y) 'CDDDR) `(CADDDR ,(CADR Y))) 3280 | (T `(CAR ,Y)))))) 3281 | ((EQ (CAR X) 'CDR) 3282 | (IF (ATOM (CADR X)) 3283 | X 3284 | (LET ((Y (DECARCDRATE (CADR X)))) 3285 | (COND ((EQ (CAR Y) 'CDR) `(CDDR ,(CADR Y))) 3286 | ((EQ (CAR Y) 'CDDR) `(CDDDR ,(CADR Y))) 3287 | ((EQ (CAR Y) 'CDDDR) `(CDDDDR ,(CADR Y))) 3288 | (T `(CDR ,Y)))))) 3289 | (T X)))) 3290 | 3291 | (DEFINE TRIVIALIZE 3292 | (LAMBDA (NODE RNL) 3293 | (LET ((FM (NODE\FORM NODE))) 3294 | (EQCASE (TYPE FM) 3295 | (CONSTANT `',(CONSTANT\VALUE FM)) 3296 | (VARIABLE (LOOKUPICATE (VARIABLE\VAR FM) RNL)) 3297 | (IF (CONDICATE (TRIVIALIZE (IF\PRED FM) RNL) 3298 | (TRIVIALIZE (IF\CON FM) RNL) 3299 | (TRIVIALIZE (IF\ALT FM) RNL))) 3300 | (ASET 3301 | (OUTPUT-ASET (LOOKUPICATE (ASET\VAR FM) RNL) 3302 | (TRIVIALIZE (ASET\BODY FM) RNL))) 3303 | (COMBINATION 3304 | (LET ((ARGS (COMBINATION\ARGS FM))) 3305 | (LET ((FN (NODE\FORM (CAR ARGS)))) 3306 | (IF (AND (EQ (TYPE FN) 'VARIABLE) 3307 | (VARIABLE\GLOBALP FN) 3308 | (TRIVFN (VARIABLE\VAR FN))) 3309 | (CONS (VARIABLE\VAR FN) 3310 | (AMAPCAR (LAMBDA (A) (TRIVIALIZE A RNL)) 3311 | (CDR ARGS))) 3312 | (IF (EQ (TYPE FN) 'LAMBDA) 3313 | (TRIV-LAMBDACATE 3314 | (LAMBDA\VARS FN) 3315 | (AMAPCAR (LAMBDA (A) (TRIVIALIZE A RNL)) 3316 | (CDR ARGS)) 3317 | (TRIVIALIZE (LAMBDA\BODY FN) RNL)) 3318 | (ERROR '|Strange Trivial Function - TRIVIALIZE| 3319 | NODE 3320 | 'FAIL-ACT)))))))))) 3321 | 3322 | (DEFINE TRIV-LAMBDACATE 3323 | (LAMBDA (VARS ARGS BODY) 3324 | (LABELS ((LOOP 3325 | (LAMBDA (V A REALVARS REALARGS EFFARGS) 3326 | (IF (NULL A) 3327 | (LET ((RV (NREVERSE REALVARS))) 3328 | (OR (NULL V) 3329 | (ERROR '|We blew it in TRIV-LAMBDACATE| V 'FAIL-ACT)) 3330 | (LET ((B (IF RV 3331 | `((LAMBDA ,RV 3332 | (COMMENT 3333 | (VARS = ,(MAP-USER-NAMES RV))) 3334 | ,@(DEPROGNIFY BODY)) 3335 | ,@(NREVERSE REALARGS)) 3336 | BODY))) 3337 | (IF EFFARGS 3338 | `(PROGN ,@EFFARGS ,@(DEPROGNIFY B)) 3339 | B))) 3340 | (IF (OR (GET (CAR V) 'READ-REFS) 3341 | (GET (CAR V) 'WRITE-REFS)) 3342 | (LOOP (CDR V) 3343 | (CDR A) 3344 | (CONS (CAR V) REALVARS) 3345 | (CONS (CAR A) REALARGS) 3346 | EFFARGS) 3347 | (LOOP (CDR V) 3348 | (CDR A) 3349 | REALVARS 3350 | REALARGS 3351 | (CONS (CAR A) EFFARGS))))))) 3352 | (LOOP VARS ARGS NIL NIL NIL)))) 3353 | 3354 | (DEFINE COMPILATE-ONE-FUNCTION ;COMPLICATE-ONE-FUNCTION? 3355 | (LAMBDA (CNODE USERNAME) 3356 | (LET ((PROGNAME (GEN-GLOBAL-NAME))) 3357 | (COMPILATE-LOOP USERNAME 3358 | PROGNAME 3359 | (LIST (LIST USERNAME CNODE)) 3360 | (LIST (LIST PROGNAME CNODE NIL)) 3361 | NIL 3362 | 0 3363 | (LIST `(SETQ ,USERNAME 3364 | (LIST 'CBETA 3365 | ,PROGNAME 3366 | ',(CLAMBDA\NAME (CNODE\CFORM CNODE)))) 3367 | `(DEFPROP ,PROGNAME ,USERNAME USER-FUNCTION)))))) 3368 | 3369 | (DEFINE COMPILATE-LOOP 3370 | (LAMBDA (USERNAME PROGNAME BLOCKFNS FNS PROGBODY TMAX STUFF) 3371 | (IF (NULL FNS) 3372 | `(PROGN 'COMPILE 3373 | (COMMENT MODULE FOR FUNCTION ,USERNAME) 3374 | (DEFUN ,PROGNAME () 3375 | (PROG () 3376 | (DECLARE (SPECIAL ,PROGNAME ,@(USED-TEMPLOCS TMAX))) 3377 | (GO (PROG2 NIL 3378 | (CAR **ENV**) 3379 | (SETQ **ENV** (CDR **ENV**)))) 3380 | ,@(NREVERSE PROGBODY))) 3381 | (SETQ ,PROGNAME (GET ',PROGNAME 'SUBR)) 3382 | ,@STUFF) 3383 | (COMPILATE (CAR (CAR FNS)) 3384 | (CADR (CAR FNS)) 3385 | (CADDR (CAR FNS)) 3386 | BLOCKFNS 3387 | (CDR FNS) 3388 | (LAMBDA (CODE NEWFNS) 3389 | (LET ((CFM (CNODE\CFORM (CADR (CAR FNS))))) 3390 | (COMPILATE-LOOP 3391 | USERNAME 3392 | PROGNAME 3393 | BLOCKFNS 3394 | NEWFNS 3395 | (NCONC (REVERSE (DEPROGNIFY1 CODE T)) 3396 | (CONS (REMARK-ON (CADR (CAR FNS))) 3397 | (CONS (EQCASE (TYPE CFM) 3398 | (CLAMBDA 3399 | (CLAMBDA\NAME CFM)) 3400 | (CONTINUATION 3401 | (CONTINUATION\NAME CFM))) 3402 | PROGBODY))) 3403 | (MAX TMAX 3404 | (EQCASE (TYPE CFM) 3405 | (CLAMBDA 3406 | (CLAMBDA\MAXDEP CFM)) 3407 | (CONTINUATION 3408 | (CONTINUATION\MAXDEP CFM)))) 3409 | STUFF))))))) 3410 | 3411 | (DEFINE USED-TEMPLOCS 3412 | (LAMBDA (N) 3413 | (DO ((J (+ **NUMBER-OF-ARG-REGS** 1) (+ J 1)) 3414 | (X NIL (CONS (TEMPLOC J) X))) 3415 | ((> J N) (NREVERSE X))))) 3416 | 3417 | (DEFINE REMARK-ON 3418 | (LAMBDA (CNODE) 3419 | (LET ((CFM (CNODE\CFORM CNODE))) 3420 | (LABELS ((REMARK1 3421 | (LAMBDA (DEP FNP VARS ENV) 3422 | `(COMMENT (DEPTH = ,DEP) 3423 | (FNP = ,FNP) 3424 | ,@(IF VARS `((VARS = ,(MAP-USER-NAMES VARS)))) 3425 | ,@(IF ENV `((ENV = ,(MAP-USER-NAMES ENV)))))))) 3426 | (EQCASE (TYPE CFM) 3427 | (CLAMBDA 3428 | (REMARK1 (CLAMBDA\DEP CFM) 3429 | (CLAMBDA\FNP CFM) 3430 | (IF (EQ (CLAMBDA\FNP CFM) 'NOCLOSE) 3431 | (CLAMBDA\TVARS CFM) 3432 | (CLAMBDA\VARS CFM)) 3433 | (APPEND (CLAMBDA\CLOSEREFS CFM) 3434 | (CLAMBDA\CONSENV CFM)))) 3435 | (CONTINUATION 3436 | (REMARK1 (CONTINUATION\DEP CFM) 3437 | (CONTINUATION\FNP CFM) 3438 | NIL ;NEVER INTERESTING ANYWAY 3439 | (APPEND (CONTINUATION\CLOSEREFS CFM) 3440 | (CONTINUATION\CONSENV CFM))))))))) 3441 | 3442 | 3443 | (DEFINE MAP-USER-NAMES 3444 | (LAMBDA (VARS) 3445 | (AMAPCAR (LAMBDA (X) (OR (GET X 'USER-NAME) X)) VARS))) 3446 | 3447 | (DEFINE COMFILE 3448 | (LAMBDA (FNAME) 3449 | (LET ((FN (DEFAULTF (MERGEF FNAME '(* >)))) 3450 | (RT (RUNTIME)) 3451 | (GCT (STATUS GCTIME))) 3452 | (LET ((IFILE (OPEN FN 'IN)) 3453 | (OFILE (OPEN (MERGEF '(_RABB_ OUTPUT) FN) 'OUT))) 3454 | (SET' *GLOBAL-GEN-PREFIX* 3455 | (CATENATE (CADAR (SYMEVAL 'DEFAULTF)) 3456 | '|=| 3457 | (CADR (SYMEVAL 'DEFAULTF)))) 3458 | (LET ((TN (NAMESTRING (TRUENAME IFILE)))) 3459 | (PRINT `(COMMENT THIS IS THE RABBIT LISP CODE FOR ,TN) OFILE) 3460 | (TIMESTAMP OFILE) 3461 | (TERPRI OFILE) 3462 | (TERPRI (SYMEVAL 'TYO)) 3463 | (PRINC '|;Beginning RABBIT compilation on | (SYMEVAL 'TYO)) 3464 | (PRINC TN (SYMEVAL 'TYO))) 3465 | (PRINT `(DECLARE (SPECIAL ,@**CONT+ARG-REGS** **ENV** **FUN** **NARGS**)) 3466 | OFILE) 3467 | (PRINT '(DECLARE (DEFUN DISPLACE (X Y) Y)) OFILE) 3468 | (ASET' *TESTING* NIL) 3469 | (ASET' *ERROR-COUNT* 0) 3470 | (ASET' *ERROR-LIST* NIL) 3471 | (TRANSDUCE IFILE 3472 | OFILE 3473 | (LIST NIL) 3474 | (CATENATE '|INIT-| (CADR (TRUENAME IFILE)))) 3475 | (TIMESTAMP OFILE) 3476 | (LET ((X (*QUO (- (RUNTIME) RT) 1.0E6)) 3477 | (Y (*QUO (- (STATUS GCTIME) GCT) 1.0E6))) 3478 | (LET ((MSG `(COMPILE TIME: ,X SECONDS 3479 | (GC TIME ,Y SECONDS) 3480 | (NET ,(-$ X Y) SECONDS) 3481 | ,@(IF (NOT (ZEROP *ERROR-COUNT*)) 3482 | `((,*ERROR-COUNT* ERRORS)))))) 3483 | (PRINT `(COMMENT ,MSG) OFILE) 3484 | (RENAMEF OFILE 3485 | (MERGEF (LIST (CADR FN) 'LISP) 3486 | FN)) 3487 | (CLOSE OFILE) 3488 | MSG)))))) 3489 | 3490 | (DEFINE TRANSDUCE 3491 | (LAMBDA (IFILE OFILE EOF INITNAME) 3492 | (LABELS ((LOOP 3493 | (LAMBDA (FORM RANDOM-FORMS) 3494 | (IF (EQ FORM EOF) 3495 | (DO ((X (GENTEMP INITNAME) (GENTEMP INITNAME)) 3496 | (Y NIL X) 3497 | (Z RANDOM-FORMS (CDR Z))) 3498 | ((NULL Z) 3499 | (IF RANDOM-FORMS 3500 | (PRINT `(,(LENGTH RANDOM-FORMS) 3501 | RANDOM FORMS IN FILE TO COMPILE) 3502 | (SYMEVAL 'TYO))) 3503 | (IF Y (PROCESS-FORM `(DECLARE (SPECIAL ,Y)) 3504 | OFILE 3505 | T)) 3506 | (PROCESS-FORM `(DEFINE ,INITNAME 3507 | (LAMBDA () ,(IF Y (LIST Y) NIL))) 3508 | OFILE 3509 | T)) 3510 | (IF Y (PROCESS-FORM `(DECLARE (SPECIAL ,Y)) 3511 | OFILE 3512 | NIL)) 3513 | (PROCESS-FORM `(DEFINE ,X 3514 | (LAMBDA () 3515 | (BLOCK ,(CAR Z) 3516 | ,(IF Y 3517 | (LIST Y) 3518 | NIL)))) 3519 | OFILE 3520 | NIL)) 3521 | ; (PROCESS-FORM 3522 | ; `(DEFINE ,INITNAME 3523 | ; (LAMBDA () (BLOCK ,@RANDOM-FORMS NIL NIL))) 3524 | ; OFILE) 3525 | (LET ((X (PROCESS-FORM FORM OFILE T))) 3526 | (LOOP (READIFY IFILE EOF) (NCONC X RANDOM-FORMS))))))) 3527 | (LOOP (READIFY IFILE EOF) NIL)))) 3528 | 3529 | 3530 | (DEFINE READIFY ;FUNNY MACLISP CONVENTION - READIFY'LL DO THE JOB! 3531 | (LAMBDA (IFILE EOF) 3532 | (IF (SYMEVAL 'READ) 3533 | (APPLY (SYMEVAL 'READ) IFILE EOF) 3534 | (READ IFILE EOF)))) 3535 | 3536 | (SET' *OPTIMIZE* T) 3537 | 3538 | (SET' *BUFFER-RANDOM-FORMS* T) 3539 | 3540 | (DEFINE PROCESS-FORM 3541 | (LAMBDA (FORM OFILE NOISYP) 3542 | (COND ((ATOM FORM) 3543 | (PRINT FORM OFILE) 3544 | NIL) 3545 | ((EQ (CAR FORM) 'DEFINE) 3546 | (PROCESS-DEFINE-FORM FORM OFILE NOISYP) 3547 | NIL) 3548 | ((AND (MEMQ (CAR FORM) '(BLOCK PROGN)) 3549 | (EQUAL (CADR FORM) ''COMPILE)) 3550 | (DO ((F (CDDR FORM) (CDR F)) 3551 | (Z NIL (NCONC Z (PROCESS-FORM (CAR F) OFILE NOISYP)))) 3552 | ((NULL F) Z))) 3553 | ((EQ (CAR FORM) 'PROCLAIM) 3554 | (AMAPC (LAMBDA (X) ((ENCLOSE `(LAMBDA (OFILE) ,X)) OFILE)) 3555 | (CDR FORM)) 3556 | NIL) 3557 | ((EQ (CAR FORM) 'DECLARE) 3558 | (PRINT FORM OFILE) 3559 | NIL) 3560 | ((EQ (CAR FORM) 'COMMENT) 3561 | NIL) 3562 | ((EQ (CAR FORM) 'DEFUN) 3563 | (PRINT FORM OFILE) 3564 | NIL) 3565 | ((AND (ATOM (CAR FORM)) 3566 | (EQ (GET (CAR FORM) 'AINT) 'AMACRO) 3567 | (NOT (EQ (GET (CAR FORM) 'AMACRO) 'AFSUBR))) 3568 | (IF (MEMQ (CAR FORM) '(DEFMAC SCHMAC MACRO)) 3569 | (EVAL FORM)) 3570 | (PROCESS-FORM (MACRO-EXPAND FORM) OFILE NOISYP)) 3571 | (T (COND (*BUFFER-RANDOM-FORMS* (LIST FORM)) 3572 | (T (PRINT FORM OFILE) NIL)))))) 3573 | 3574 | (DEFINE PROCESS-DEFINE-FORM 3575 | (LAMBDA (FORM OFILE NOISYP) 3576 | (COND ((ATOM (CADR FORM)) 3577 | (PROCESS-DEFINITION FORM 3578 | OFILE 3579 | NOISYP 3580 | (CADR FORM) 3581 | (IF (NULL (CDDDR FORM)) 3582 | (CADDR FORM) 3583 | `(LAMBDA ,(CADDR FORM) 3584 | (BLOCK . ,(CDDDR FORM)))))) 3585 | (T (PROCESS-DEFINITION FORM 3586 | OFILE 3587 | NOISYP 3588 | (CAADR FORM) 3589 | `(LAMBDA ,(CDADR FORM) 3590 | (BLOCK . ,(CDDR FORM)))))))) 3591 | 3592 | (DEFINE PROCESS-DEFINITION 3593 | (LAMBDA (FORM OFILE NOISYP NAME LAMBDA-EXP) 3594 | (COND ((NOT (EQ (TYPEP NAME) 'SYMBOL)) 3595 | (WARN |Function Name Not SYMBOL| NAME FORM)) 3596 | ((OR (NOT (EQ (CAR LAMBDA-EXP) 'LAMBDA)) 3597 | (AND (ATOM (CADR LAMBDA-EXP)) 3598 | (NOT (NULL (CADR LAMBDA-EXP))))) 3599 | (WARN |Malformed LAMBDA-expression| LAMBDA-EXP FORM)) 3600 | (T (PRINT (COMPILE NAME 3601 | LAMBDA-EXP 3602 | NIL 3603 | *OPTIMIZE*) 3604 | OFILE) 3605 | (CLEANUP) 3606 | (IF NOISYP 3607 | (PRINT (LIST NAME 'COMPILED) 3608 | (SYMEVAL 'TYO))))))) 3609 | 3610 | (DEFINE CLEANUP 3611 | (LAMBDA () 3612 | (BLOCK (REPLACE) 3613 | (GENFLUSH) 3614 | (MAPATOMS '(LAMBDA (X) 3615 | (REMPROP X 'READ-REFS) 3616 | (REMPROP X 'WRITE-REFS) 3617 | (REMPROP X 'NODE) 3618 | (REMPROP X 'BINDING) 3619 | (REMPROP X 'USER-NAME) 3620 | (REMPROP X 'KNOWN-FUNCTION) 3621 | (REMPROP X 'EASY-LABELS-FUNCTION)))))) 3622 | 3623 | ;;; INVERSE OF ALPHATIZE. USED BY SX, E.G., FOR DEBUGGING. 3624 | 3625 | (DEFINE SEXPRFY 3626 | (LAMBDA (NODE USERP) 3627 | (LET ((FM (NODE\FORM NODE))) 3628 | (EQCASE (TYPE FM) 3629 | (CONSTANT `(QUOTE ,(CONSTANT\VALUE FM))) 3630 | (VARIABLE (IF (AND USERP (NOT (VARIABLE\GLOBALP FM))) 3631 | (GET (VARIABLE\VAR FM) 'USER-NAME) 3632 | (VARIABLE\VAR FM))) 3633 | (LAMBDA `(LAMBDA ,(IF USERP (LAMBDA\UVARS FM) (LAMBDA\VARS FM)) 3634 | ,(SEXPRFY (LAMBDA\BODY FM) USERP))) 3635 | (IF `(IF ,(SEXPRFY (IF\PRED FM) USERP) 3636 | ,(SEXPRFY (IF\CON FM) USERP) 3637 | ,(SEXPRFY (IF\ALT FM) USERP))) 3638 | (ASET `(ASET' ,(IF (AND USERP (NOT (ASET\GLOBALP FM))) 3639 | (GET (ASET\VAR FM) 'USER-NAME) 3640 | (ASET\VAR FM)) 3641 | ,(SEXPRFY (ASET\BODY FM) USERP))) 3642 | (CATCH `(CATCH ,(IF USERP 3643 | (GET (CATCH\VAR FM) 'USER-NAME) 3644 | (CATCH\VAR FM)) 3645 | ,(SEXPRFY (CATCH\BODY FM) USERP))) 3646 | (LABELS `(LABELS ,(AMAPCAR (LAMBDA (V D) `(,(IF USERP 3647 | (GET V 'USER-NAME) 3648 | V) 3649 | ,(SEXPRFY D USERP))) 3650 | (LABELS\FNVARS FM) 3651 | (LABELS\FNDEFS FM)) 3652 | ,(SEXPRFY (LABELS\BODY FM) USERP))) 3653 | (COMBINATION 3654 | (AMAPCAR (LAMBDA (A) (SEXPRFY A USERP)) 3655 | (COMBINATION\ARGS FM))))))) 3656 | 3657 | (DEFINE CSEXPRFY 3658 | (LAMBDA (CNODE) 3659 | (LET ((CFM (CNODE\CFORM CNODE))) 3660 | (EQCASE (TYPE CFM) 3661 | (TRIVIAL `(TRIVIAL ,(SEXPRFY (TRIVIAL\NODE CFM) NIL))) 3662 | (CVARIABLE (CVARIABLE\VAR CFM)) 3663 | (CLAMBDA `(CLAMBDA ,(CLAMBDA\VARS CFM) 3664 | ,(CSEXPRFY (CLAMBDA\BODY CFM)))) 3665 | (CONTINUATION 3666 | `(CONTINUATION (,(CONTINUATION\VAR CFM)) 3667 | ,(CSEXPRFY (CONTINUATION\BODY CFM)))) 3668 | (CIF `(CIF ,(CSEXPRFY (CIF\PRED CFM)) 3669 | ,(CSEXPRFY (CIF\CON CFM)) 3670 | ,(CSEXPRFY (CIF\ALT CFM)))) 3671 | (CASET `(CASET' ,(CSEXPRFY (CASET\CONT CFM)) 3672 | ,(CASET\VAR CFM) 3673 | ,(CSEXPRFY (CASET\BODY CFM)))) 3674 | (CLABELS `(CLABELS ,(AMAPCAR (LAMBDA (V D) `(,V 3675 | ,(CSEXPRFY D))) 3676 | (CLABELS\FNVARS CFM) 3677 | (CLABELS\FNDEFS CFM)) 3678 | ,(CSEXPRFY (CLABELS\BODY CFM)))) 3679 | (CCOMBINATION 3680 | (AMAPCAR CSEXPRFY (CCOMBINATION\ARGS CFM))) 3681 | (RETURN 3682 | `(RETURN ,(CSEXPRFY (RETURN\CONT CFM)) 3683 | ,(CSEXPRFY (RETURN\VAL CFM)))))))) 3684 | 3685 | (DEFINE CHECK-NUMBER-OF-ARGS 3686 | (LAMBDA (NAME NARGS DEFP) 3687 | (OR (GETL NAME '(*LEXPR LSUBR)) 3688 | (LET ((N (GET NAME 'NUMBER-OF-ARGS))) 3689 | (IF N 3690 | (IF (NOT (= N NARGS)) 3691 | (IF DEFP 3692 | (WARN |definition disagrees with earlier use on number of args| 3693 | NAME 3694 | NARGS 3695 | N) 3696 | (IF (GET NAME 'DEFINED) 3697 | (WARN |use disagrees with definition on number of args| 3698 | NAME 3699 | NARGS 3700 | N) 3701 | (WARN |two uses disagree before definition on number of args| 3702 | NAME 3703 | NARGS 3704 | N)))) 3705 | (PUTPROP NAME NARGS 'NUMBER-OF-ARGS)) 3706 | (IF DEFP (PUTPROP NAME 'T 'DEFINED)))))) 3707 | 3708 | 3709 | (DEFUN *EXPR FEXPR (X) 3710 | (MAPCAR '(LAMBDA (Y) (PUTPROP Y 'T '*EXPR)) X)) 3711 | 3712 | (DEFPROP *EXPR AFSUBR AMACRO) (DEFPROP *EXPR AMACRO AINT) 3713 | 3714 | (DEFUN *LEXPR FEXPR (X) 3715 | (MAPCAR '(LAMBDA (Y) (PUTPROP Y 'T '*LEXPR)) X)) 3716 | 3717 | (DEFPROP *LEXPR AFSUBR AMACRO) (DEFPROP *LEXPR AMACRO AINT) 3718 | 3719 | 3720 | (DEFINE DUMPIT 3721 | (LAMBDA () 3722 | (BLOCK (INIT-RABBIT) 3723 | (SUSPEND '|:PDUMP DSK:SCHEME;TS RABBIT|) 3724 | (TERPRI) 3725 | (PRINC '|File name: |) 3726 | (COMFILE (READLINE)) 3727 | (QUIT)))) 3728 | 3729 | (DEFINE STATS 3730 | (LAMBDA () 3731 | (AMAPC (LAMBDA (VAR) 3732 | (BLOCK (TERPRI) 3733 | (PRIN1 VAR) 3734 | (PRINC '| = |) 3735 | (PRIN1 (SYMEVAL VAR)))) 3736 | *STAT-VARS*))) 3737 | 3738 | (DEFINE RESET-STATS 3739 | (LAMBDA () (AMAPC (LAMBDA (VAR) (SET VAR 0)) *STAT-VARS*))) 3740 | --------------------------------------------------------------------------------