DEFINE (( (LENGTH (LAMBDA (M) (PROG (N) (SETQ N 0) A (COND ((NULL M) (RETURN N))) (SETQ N (ADD1 N)) (SETQ M (CDR M)) (GO A)))) (REVERSE (LAMBDA (X) (PROG (Y) A (COND ((NULL X) (RETURN Y))) (SETQ Y (CONS (CAR X) Y)) (SETQ X (CDR X)) (GO A)))) (MEMBER (LAMBDA (U V) (COND ((NULL V) NIL) ((EQUAL (CAR V) U) T) (T (MEMBER U (CDR V)))))) ;; top level compilation ;; leave value in AC and return where it was stored (COMVAL (LAMBDA (EXP STOMAP NAME) (PROG NIL (COND ;; load atom directly ((OR (ATOM EXP) (MEMBER (CAR EXP) (QUOTE (QUOTE SPECIAL)))) (LAC EXP)) ;; store in variable ((EQ (CAR EXP) (QUOTE SETQ)) (PROG NIL (COMVAL (CADDR EXP) STOMAP NAME) (ATTACH (LIST (CONS (QUOTE STO) (LOCATE (CADR EXP))))))) ((EQ (CAR EXP) (QUOTE COND)) (COMCOND (CDR EXP) T)) ((EQ (CAR EXP) (QUOTE PROG)) (COMPROG (CDDR EXP) (CADR EXP) NAME)) ((EQ (CAR EXP) (QUOTE OR)) (COMBOOL F F (CDR EXP) NIL)) ((EQ (CAR EXP) (QUOTE AND)) (COMBOOL T F (CDR EXP) NIL)) ((ATOM (CAR EXP)) (CALL (CAR EXP) (COMLIS (CDR EXP)))) (T (PROG NIL (COMPLY (CAR EXP) (CDR EXP)) (COMVAL (CADDAR EXP) STOMAP NAME)))) (SETQ AC NAME) (RETURN NAME)))) ;; compile argument list and store in parameters ;; FN is a lambda (COMPLY (LAMBDA (FN ARGS) (MAP (PAIR (CADR FN) ARGS) (FUNCTION (LAMBDA (J) (PROG NIL (COMVAL (CDAR J) STOMAP (GENSYM)) (STORE (CAAR J) T))))))) ;; compile list arguments and return list of locations ;; store everything non-trivial but the last value in PDL (COMLIS (LAMBDA (EXP) (PROG (X) (RETURN (MAPLIST EXP (FUNCTION (LAMBDA (J) (COND ((OR (EQ (CAAR J) (QUOTE QUOTE)) (ATOM (CAR J))) (CAR J)) (X (PROG2 (STORE AC T) (COMVAL (CAR J) STOMAP (GENSYM)))) (T (PROG2 (SETQ X T) (COMVAL (CAR J) STOMAP (GENSYM)))))))))))) ;; load AC with X (LAC (LAMBDA (X) (COND ((EQUAL AC X) NIL) (T (ATTACH (LIST (CONS (QUOTE CLA) (LOCATE X)))))))) ;; push AC on PDL as value for X ;; Y generate STO instruction (STORE (LAMBDA (X Y) (PROG NIL (COND ((OR (NULL X) (EQ (CAR X) (QUOTE QUOTE))) (RETURN NIL))) ;; remember what was stored (SETQ STOMAP (CONS (CONS X (LIST (LIST (ADD1 (CAADAR STOMAP)) (QUOTE *N)) 1)) STOMAP)) ;; generate STO (COND (Y (ATTACH (LIST (CONS (QUOTE STO) (LOCATE X)))))) ;; expand needed PDL length (SETQ LENGTH (MAX LENGTH (CAADAR STOMAP)))))) ;; turn EXP into LAP assembly listing ;; EXP is a lambda (PHASE2 (LAMBDA (EXP NAME) (PROG (AC LISTING STOMAP LENGTH) ;; TODO: what's this? (COND (((LAMBDA (J) (AND (EQ (CAADR EXP) (CADAR J)) (EQ (CAAR J) (QUOTE NULL)) (EQUAL (CADR J) (QUOTE (QUOTE NIL))))) (CADAR (CDDR EXP))) (PROG2 (ATTACH (QUOTE ((TZE 1 4)))) (SETQ EXP (LIST (CAR EXP) (CADR EXP) (CONS (QUOTE COND) (CDDAR (CDDR EXP)))))))) ;; generate prologue (ATTACH (LIST (LIST (QUOTE TNX) (LIST (QUOTE E) NAME) 1 (QUOTE *MN)) (APPEND (QUOTE (TSX *MOVE 1)) ((LAMBDA (J) (LIST (COND ((LESSP J 3) C) (T (DIFFERENCE (TIMES J 2) 4))))) (LENGTH (CADR EXP)))))) ;; init PDL (SETQ LENGTH 0) (SETQ STOMAP (QUOTE ((NIL (0 *N) 1)))) (MAP (CADR EXP) (FUNCTION (LAMBDA (J) (STORE (CAR J) F)))) ;; AC holds name of thing it currently stores (NIL -> temporary) (SETQ AC NIL) (COMVAL (CADDR EXP) STOMAP NIL) ;; add return for non-PROG (COND ((NOT (MEMBER (CAADDR EXP) (QUOTE (COND PROG)))) (ATTACH (QUOTE ((TXI *RETURN 1 *MN)))))) (SETQ EXP (REVERSE LISTING)) (RETURN (LIST EXP (LIST (CONS (QUOTE *MN) (PLUS LENGTH 2)) (CONS (QUOTE *N) (DIFFERENCE -2 LENGTH)))))))) (COMPROG (LAMBDA (EXP PROGLIS RETN) (PROG (GOLIST HOLD NAME SETS S) (SETQ HOLD EXP) A (COND ((NULL HOLD) (GO B)) ((ATOM (CAR HOLD)) (SETQ GOLIST (CONS (CONS (CAR HOLD) (GENSYM)) GOLIST))) ((NOT SETS) (COND ((EQ (CAAR HOLD) (QUOTE SPECBIND)) (SETQ S (CADADR HOLD))) (T (SETQ SETS T))))) (SETQ HOLD (CDR HOLD)) (GO A) B (SETQ HOLD PROGLIS) C (COND ((NULL HOLD) (GO G))) (STORE (CAR HOLD) NIL) (COND ((NOT (EQ (CAR HOLD) S)) (ATTACH (LIST (CONS (QUOTE STZ) (LOCATE (CAR HOLD))))))) (SETQ HOLD (CDR HOLD)) (GO C) G (SETQ HOLD EXP) D (SETQ AC NIL) (SETQ NAME (GENSYM)) (COND ((NULL HOLD) (GO E)) ((ATOM (CAR HOLD)) (ATTACH (LIST (CDR (SASSOC (CAR HOLD) GOLIST NIL))))) ((EQ (CAAR HOLD) (QUOTE GO)) (ATTACH (LIST (LIST (QUOTE TRA) (CDR (SASSOC (CADAR HOLD) GOLIST (FUNCTION (LAMBDA NIL (ERROR (QUOTE GO)))))))))) ((EQ (CAAR HOLD) (QUOTE COND)) (COMCOND (CDAR HOLD) F)) (T (COMVAL (CAR HOLD) STOMAP NAME))) (SETQ HOLD (CDR HOLD)) (GO D) E (COND (RETN (ATTACH (LIST RETN))))))) (COMPACT (LAMBDA (EXP NAME) (COND ((EQ (CAR EXP) (QUOTE NULL)) (PROG2 (SETQ SWITCH (NOT SWITCH)) (COMPACT (CADR EXP) NAME))) ((EQUAL EXP (QUOTE (QUOTE *T*))) (COND (SWITCH (ATTACH (LIST (LIST (QUOTE TRA) NAME)))) (T (SETQ FLAG F)))) ((EQ (CAR EXP) (QUOTE OR)) (COMBOOL F T (CDR EXP) SWITCH)) ((EQ (CAR EXP) (QUOTE AND)) (COMBOOL T T (CDR EXP) SWITCH)) (T (PROG2 (COND ((EQ (CAR EXP) (QUOTE EQ)) (CEQ EXP STOMAP)) (T (COMVAL EXP STOMAP (GENSYM)))) (ATTACH (LIST (LIST (COND (SWITCH (QUOTE TNZ)) (T (QUOTE TZE))) NAME)))))))) (COMBOOL (LAMBDA (FN MODE EXP A) (PROG (GEN SWITCH) (SETQ GEN (GENSYM)) A (SETQ SWITCH NIL) (COND ((NULL EXP) (GO C)) ((AND MODE (NULL (CDR EXP)) (EQ A FN)) (GO B))) (COMPACT (COND (FN (CAR EXP)) (T (LIST (QUOTE NULL) (CAR EXP)))) (COND ((AND MODE (NOT A)) (COND (FN NAME) (T GEN))) (T (COND ((NOT MODE) GEN) (FN GEN) (T NAME))))) (SETQ AC (COND ((EQ (CAAR LISTING) (QUOTE TNZ)) (QUOTE (QUOTE NIL))) (T (QUOTE (QUOTE *T* ))))) (SETQ EXP (CDR EXP)) (GO A) B (COMPACT (COND (FN (LIST (QUOTE NULL) (CAR EXP))) (T (CAR EXP))) NAME) C (COND ((NOT MODE) (ATTACH (LIST (QUOTE (TRA (* 2))) (LIST (QUOTE CLA) (LIST (QUOTE QUOTE) FN)))))) (ATTACH (LIST GEN)) (COND ((NOT MODE) (ATTACH (LIST (LIST (QUOTE CLA) (LIST (QUOTE QUOTE) (NOT FN)))))))))) (COMCOND (LAMBDA (EXP MODE) (PROG (FLAG SWITCH GEN) (SETQ FLAG T) A (COND ((NULL EXP) (GO B))) (SETQ GEN (GENSYM)) (SETQ SWITCH NIL) (COND ((AND (NOT MODE) (EQ (CAADAR EXP) (QUOTE GO))) (GO C))) (COMPACT (CAAR EXP) GEN) (SETQ AC (COND (SWITCH (QUOTE (QUOTE NIL))) (T NIL))) (COMVAL (CADAR EXP) STOMAP NAME) (COND ((OR (AND NAME (NULL (CDR EXP))) (MEMBER (CAADAR EXP) (QUOTE (RETURN GO)))) (GO L))) (ATTACH (LIST (COND (NAME (LIST (QUOTE TRA) NAME)) (T (QUOTE (TXI *RETURN 1 *MN)))))) L (ATTACH (LIST GEN)) D (SETQ EXP (CDR EXP)) (SETQ AC (COND (SWITCH (QUOTE NIL)) (T (QUOTE (QUOTE NIL))))) (GO A) B (COND (NAME (ATTACH (LIST NAME)))) (RETURN NIL) C (COMPACT (LIST (QUOTE NULL) (CAAR EXP)) (CDR (SASSOC (CADR (CADAR EXP)) GOLIST (FUNCTION (LAMBDA (V) (ERROR (QUOTE GO))))))) (GO D)))) (CEQ (LAMBDA (EXP STOMAP) (PROG (A) (SETQ A (COMLIS (CDR EXP))) (COND ((EQUAL (CAR A) AC) (ATTACH (LIST (CONS (QUOTE SUB) (LOCATE (CADR A)))))) (T (PROG2 (LAC (CADR A)) (ATTACH (LIST (CONS (QUOTE SUB) (LOCATE (CAR A)))))))) (SETQ SWITCH (NOT SWITCH))))) (CALL (LAMBDA (FN ARGS) (PROG (HOLD ITEM NUM) (COND ((MEMBER FN (QUOTE (SPECBIND SPECSTR LIST RETURN GO))) (GO E)) ((NULL ARGS) (GO D)) ((NULL (CDR ARGS)) (GO C))) (SETQ HOLD (REVERSE (CDDR ARGS))) (SETQ NUM (LENGTH ARGS)) (COND ((GREATERP NUM 20) (ERROR (QUOTE ARGS)))) A (COND ((NULL HOLD) (GO B))) (SETQ ITEM (CAR HOLD)) (COND ((EQUAL ITEM (QUOTE (QUOTE NIL))) (ATTACH (LIST (LIST (QUOTE STZ) (LIST (QUOTE $ALIST) NUM))))) ((EQUAL ITEM AC) (ATTACH (LIST (LIST (QUOTE STO) (LIST (QUOTE $ALIST) NUM))))) (T (ATTACH (LIST (LIST (QUOTE STQ) (LIST (QUOTE $ALIST) NUM)) (CONS (QUOTE LDQ) (LOCATE ITEM)))))) (SETQ HOLD (CDR HOLD)) (SETQ NUM (SUB1 NUM)) (GO A) B (COND ((EQUAL AC (CADR ARGS)) (COND ((EQUAL AC (CAR ARGS)) (ATTACH (QUOTE ((LDQ ($ALIST 2)) (STO ($ALIST 2)))))) (T (ATTACH (QUOTE ((XCA))))))) (T (ATTACH (LIST (CONS (QUOTE LDQ) (LOCATE (CADR ARGS))))))) C (LAC (CAR ARGS)) D (ATTACH (LIST (LIST (QUOTE STR) (LIST (QUOTE E) FN) 7 (LENGTH ARGS)))) (RETURN NIL) E (COND ((EQ FN (QUOTE GO)) (ERROR (QUOTE GO))) ((EQ FN (QUOTE RETURN)) (PROG NIL (LAC (CAR ARGS)) (ATTACH (LIST (COND (RETN (LIST (QUOTE TRA) RETN)) (T (QUOTE (TXI *RETURN 1 *MN)))))))) ((EQ FN (QUOTE LIST)) (PROG (X) (COND ((NULL ARGS) (RETURN (ATTACH (QUOTE ((CLA (QUOTE NIL)))))))) (COND (AC (LOCATE AC))) (ATTACH (QUOTE ((TSX *LIST 4)))) (ATTACH (LIST (CONS (TIMES (LENGTH ARGS) 1Q6) (LOCATE (CAR ARGS))))) (SETQ X (CDR ARGS)) A (COND ((NULL X) (RETURN NIL))) (ATTACH (LIST (CONS 0 (LOCATE (CAR X))))) (SETQ X (CDR X)) (GO A))) ((MEMBER FN (QUOTE (SPECBIND SPECRSTR))) (PROG NIL (ATTACH (LIST (LIST (QUOTE TSX) FN 4))) (MAPLIST (CADAR ARGS) (FUNCTION (LAMBDA (J) (ATTACH (LIST (LIST (COND ((CDR J) 0) (T (QUOTE STR))) (CAR (LOCATE (CAR J))) 1 (LIST (QUOTE SPECIAL) (CAR J)))))))))))))) ;; Prepend A to listing with some optimization (listing is reversed later) (ATTACH (LAMBDA (A) (COND ((AND (EQUAL (CAR A) (QUOTE (TXI *RETURN 1 *MN))) (MEMBER (CAAR LISTING) (QUOTE (TXI TRA)))) NIL) (T (SETQ LISTING (APPEND A LISTING)))))) ;; find address of variable (LOCATE (LAMBDA (X) (COND ((OR (EQ (CAR X) (QUOTE QUOTE)) (EQ (CAR X) (QUOTE SPECIAL)) (EQ X (QUOTE $ALIST))) (LIST X)) (T (CDR (SASSOC X STOMAP (FUNCTION (LAMBDA NIL (COND ((EQ X AC) (PROG NIL (STORE AC T) (RETURN (SASSOC X STOMAP (FUNCTION NIL))))) (T (ERROR (LIST X (QUOTE UNDECLARED))))))))))))) ;; delete items in L from M (DELETEL (LAMBDA (L M) (MAPCON M (FUNCTION (LAMBDA (J) (COND ((MEMBER (CAR J) L) NIL) (T (LIST (CAR J))))))))) ;; pass one of compiler. rewrite tail recursion and process lambda/label ;; NAME function symbol ;; FN lambda expression (PASSONE (LAMBDA (NAME FN) (PALAM (PROGITER NAME FN) NIL))) ;; map PAFORM over L (PA1 (LAMBDA (L) (MAPLIST L (FUNCTION (LAMBDA (J) (PAFORM (CAR J) B)))))) ;; add wrapper around lambda if it has SPECIAL/COMMON vars ;; and process lambda body ;; GENSYM for return value (PA4 (LAMBDA (COMS SPECS G) (COND ((AND (NULL COMS) (NULL SPECS)) (LIST (QUOTE LAMBDA) (CADR FN) (PAFORM (CADDR FN) (APPEND (CADR FN) B)))) (T (LIST (QUOTE LAMBDA) (CADR FN) (CONC (LIST (QUOTE PROG) (LIST G)) (PA11 COMS (QUOTE COMBIND)) (PA9 SPECS (QUOTE SPECBIND)) (LIST (LIST (QUOTE SETQ) G (PAFORM (CADDR FN) (APPEND (CADR FN) B)))) (PA9 SPECS (QUOTE SPECRSTR)) (PA14 COMS) (PA12 G))))))) (PA3 (LAMBDA (L) (COND ((NULL (CDR L)) (LIST (LIST (QUOTE (QUOTE *T*)) (PAFORM (CAR L) B)))) (T (CONS (LIST (LIST (QUOTE EQ) G (PAFORM (CAAR L) B)) (PAFORM (CADAR L) B)) (PA3 (CDR L))))))) ;; filter vars by property (SPECIAL/COMMON) (PA5 (LAMBDA (VARS PROP) (COND ((NULL VARS) NIL) ((GET (CAR VARS) PROP) (CONS (CAR VARS) (PA5 (CDR VARS) PROP))) (T (PA5 (CDR VARS) PROP))))) ;; Only used with COMBIND ;; ((kind (QUOTE (vars)) (LIST vars))) (PA6 (LAMBDA (KIND VAR) (LIST (LIST KIND (LIST (QUOTE QUOTE) VAR) (CONS (QUOTE LIST) VAR))))) ;; process PROG body (PA7 (LAMBDA (L B) (COND ((NULL L) (QUOTE ((RETURN (QUOTE NIL))))) ((AND (NULL (CDR L)) (EQ (CAAR L) (QUOTE GO))) L) ((ATOM (CAR L)) (CONS (CAR L) (PA7 (CDR L) B))) (T (CONS (PAFORM (CAR L) B) (PA7 (CDR L) B)))))) ;; generate COMBINDs for COMMON vars if there are any (PA11 (LAMBDA (VARS FUNC) (COND (VARS (PA6 FUNC VARS)) (T NIL)))) ;; generate COMRSTR for COMMON vars if there are any ;; ((COMRSTR (QUOTE (length vars)))) (PA14 (LAMBDA (COMS) (COND (COMS (LIST (LIST (QUOTE COMRSTR) (LIST (QUOTE QUOTE) (LENGTH COMS))))) (T NIL)))) ;; generate ((RETURN g)) (PA12 (LAMBDA (G) (LIST (LIST (QUOTE RETURN) G)))) ;; Compile list of functions (COMPILE (LAMBDA (L) (MAPLIST L (FUNCTION (LAMBDA (J) (COM1 (CAR J) (GET (CAR J) (QUOTE EXPR)) (GET (CAR J) (QUOTE FEXPR)))))))) ;; Compile one function ;; N function name ;; A its EXPR ;; B its FEXPR (COM1 (LAMBDA (N A B) (PROG2 (COND (A (COM2 (QUOTE SUBR) (LENGTH (CADR A)) A N)) (B (COM2 (QUOTE FSUBR) (LENGTH (CADR B)) B N)) (T (PRINT (LIST N (QUOTE UNDEFINED))))) N))) ;; TYPE SUBR or FSUBR ;; LENGTH number of arguments ;; EXP lambda expression (COM2 (LAMBDA (TYPE LENGTH EXP NAME) (PROG (LISTING) ;; the first two passes (SETQ LISTING (PHASE2 (PASSONE NAME EXP) NAME)) ;; print assembly listing (TERPRI) (TERPRI) (TERPRI) (PRINT (LIST NAME TYPE LENGTH)) (MAP (CAR LISTING) (FUNCTION (LAMBDA (J) (PRINT (CAR J))))) (TERPRI) ;; assemble it (LAP (CONS (LIST NAME TYPE LENGTH) (CAR LISTING)) (CADR LISTING)) ;; remove old expressions (REMPROP NAME (QUOTE EXPR)) (REMPROP NAME (QUOTE FEXPR)) (RETURN NAME)))) (COMMON (LAMBDA (L) (FLAG L (QUOTE COMMON)))) (UNCOMMON (LAMBDA (L) (REMFLAG L (QUOTE COMMON)))) ;; put (NIL) prop on SPECIAL slot (SPECIAL (LAMBDA (X) (MAPLIST X (FUNCTION (LAMBDA (J) (DEFLIST (LIST (LIST (CAR J) (LIST NIL))) (QUOTE SPECIAL))))))) (UNSPECIAL (LAMBDA (L) (MAP L (FUNCTION (LAMBDA (J) (REMPROP (CAR J) (QUOTE SPECIAL))))))) ;; rewrite recursion to iteration if there's a tail recursion in a cond (PROGITER (LAMBDA (NAME EXP) (COND ((AND (EQ (CAADDR EXP) (QUOTE COND)) (PI1 (CDADDR EXP))) ;; G1 tail recursion label ((LAMBDA (G1 G2 VS GS) (LIST (QUOTE LAMBDA) VS (CONS (QUOTE PROG) (CONS GS (CONS G1 (PI3 (CDADDR EXP) NIL (CONS G2 (PAIRMAP VS GS (FUNCTION PI2) (LIST (LIST (QUOTE GO) G1)))))))))) (GENSYM) (GENSYM) (CADR EXP) (MAPLIST (CADR EXP) (FUNCTION GENSYM)))) (T EXP)))) ;; check if there's a recursion in a cond clause ;; L cond clause list (PI1 (LAMBDA (L) (COND ((NULL L) F) ((EQ (CAADAR L) NAME) T) (T (PI1 (CDR L)))))) ;; return (SETQ j k) (PI2 (LAMBDA (J K) (LIST (QUOTE SETQ) J K))) ;; replace tail recursive calls in a COND with GOs ;; L cond clause list ;; C new clause list ;; S tail call sequence (PI3 (LAMBDA (L C S) (COND ((NULL L) (CONS (CONS (QUOTE COND) C) S)) ;; recursive call. replace with (GO G3) and append call sequence at G3 ((EQ (CAADAR L) NAME) ((LAMBDA (G3) (PI3 (CDR L) (NCONC C (LIST (LIST (CAAR L) (LIST (QUOTE GO) G3)))) (CONS G3 (PAIRMAP GS (CDADAR L) (FUNCTION PI2) (CONS (LIST (QUOTE GO) G2) S))))) (GENSYM))) ;; don't have to touch this, but prepend a return because we're in a PROG now (T (PI3 (CDR L) (NCONC C (LIST (LIST (CAAR L) (LIST (QUOTE RETURN) (CADAR L))))) S))))) ;; process lambda/label ;; B environment (PALAM (LAMBDA (FN B) (COND ((ATOM FN) FN) ((EQ (CAR FN) (QUOTE LAMBDA)) (PA4 (PA5 (CADR FN) (QUOTE COMMON)) (PA5 (CADR FN) (QUOTE SPECIAL)) (GENSYM))) ;; lambda inside a label ((EQ (CAR FN) (QUOTE LABEL)) (COMP (CADR FN) (CADDR FN))) (T (ERROR (CONS FN (QUOTE (NOT FUNCTION)))))))) ;; process lambda body. similar to eval (PAFORM (LAMBDA (FORM B) (COND ((ATOM FORM) (COND ;; self evaluating ((OR (NUMBERP FORM) (MEMBER FORM (QUOTE (NIL *T*)))) (LIST (QUOTE QUOTE) FORM)) ;; known constants ((EQ FORM (QUOTE T)) (QUOTE (QUOTE *T*))) ((EQ FORM (QUOTE F)) (QUOTE (QUOTE NIL))) ;; (EVAL (QUOTE form) $ALIST) ((GET FORM (QUOTE COMMON)) (LIST (QUOTE EVAL) (LIST (QUOTE QUOTE) FORM) (QUOTE $ALIST))) ;; (SPECIAL form) ((GET FORM (QUOTE SPECIAL)) (LIST (QUOTE SPECIAL) FORM)) ;; ordinary variable ((MEMBER FORM B) FORM) (T (PROG NIL (PRINT (CONS FORM (QUOTE (UNDECLARED)))) (RETURN (LIST (QUOTE EVAL) (LIST (QUOTE QUOTE) FORM) (QUOTE $ALIST))))))) ((ATOM (CAR FORM)) (COND ;; special forms ((OR (GET (CAR FORM) (QUOTE FSUBR)) (GET (CAR FORM) (QUOTE FEXPR))) (COND ;; boolean ((MEMBER (CAR FORM) (QUOTE (AND OR))) (CONS (CAR FORM) (PA1 (CDR FORM)))) ;; arithmetic, logic ((MEMBER (CAR FORM) (QUOTE (MAX MIN PLUS TIMES LOGOR LOGAND LOGXOR))) (LIST (CAR FORM) (CONS (QUOTE LIST) (PA1 (CDR FORM))) (QUOTE $ALIST))) (T (SELECT (CAR FORM) ((QUOTE COND) (CONS (QUOTE COND) (MAPLIST (CDR FORM) (FUNCTION (LAMBDA (J) (LIST (PAFORM (CAAR J) B) (PAFORM (CADAR J) B))))))) ((QUOTE LIST) (CONS (QUOTE LIST) (PA1 (CDR FORM)))) ((QUOTE QUOTE) FORM) ((QUOTE PROG) (PA8 (PA5 (CADR FORM) (QUOTE COMMON)) (PA5 (CADR FORM) (QUOTE SPECIAL)) (GENSYM))) ;; (FUNC (QUOTE compfun) $ALIST) ((QUOTE FUNCTION) (LIST (QUOTE FUNC) (LIST (QUOTE QUOTE) (COMP (GENSYM) (CADR FORM))) (QUOTE $ALIST))) ((QUOTE SETQ) (COND ((GET (CADR FORM) (QUOTE COMMON)) (LIST (QUOTE SETQ) (LIST (QUOTE QUOTE) (CADR FORM)) (PAFORM (CADDR FORM) B))) (T (LIST (QUOTE SETQ) (PAFORM (CADR FORM) B) (PAFORM (CADDR FORM) B))))) ((QUOTE GO) FORM) ((QUOTE CSETQ) (LIST (QUOTE CSET) (LIST (QUOTE QUOTE) (CADR FORM)) (PAFORM (CADDR FORM) B))) ((QUOTE SELECT) ((LAMBDA (G) (LIST (LIST (QUOTE LAMBDA) (LIST G) (CONS (QUOTE COND) (PA3 (CDDR FORM)))) (PAFORM (CADR FORM) B))) (GENSYM))) ((QUOTE CONC) (PA2 (CDR FORM))) ;; (func (quote (args)) $ALIST) (LIST (CAR FORM) (LIST (QUOTE QUOTE) (CDR FORM)) (QUOTE $ALIST)))))) ;; replace NOT by NULL ((EQ (CAR FORM) (QUOTE NOT)) (LIST (QUOTE NULL) (PAFORM (CADR FORM) B))) ;; replace SET by SETQ (TODO: is this weird) ((EQ (CAR FORM) (QUOTE SET)) (LIST (QUOTE SETQ) (PAFORM (CADR FORM) B) (PAFORM (CADDR FORM) B))) ;; recur PAFORM over arguments (T (CONS (CAR FORM) (PA1 (CDR FORM)))))) ((OR (EQ (CAAR FORM) (QUOTE LAMBDA)) (EQ (CAAR FORM) (QUOTE LABEL))) (CONS (PALAM (CAR FORM) B) (PA1 (CDR FORM)))) ;; (APPLY func (args) $ALIST) (T (LIST (QUOTE APPLY) (PAFORM (CAR FORM) B) (CONS (QUOTE LIST) (PA1 (CDR FORM))) (QUOTE $ALIST)))))) ;; prepend SETQs to GO of tail call ;; L param list ;; M arg list ;; FARG generates (SETQ param arg) ;; Z ((GO tail)) (PAIRMAP (LAMBDA (L M FARG Z) (PROG (A B) (COND ((NULL L) (RETURN Z))) ; no args (SETQ A (SETQ B (CONS (FARG (CAR L) (CAR M)) Z))) ; first arg A (SETQ L (CDR L)) (SETQ M (CDR M)) (COND ((NULL L) (RETURN A))) (SETQ B (CDR (RPLACD B (CONS (FARG (CAR L) (CAR M)) Z)))) ; put before GO (GO A)))) ;; process PROG (PA8 (LAMBDA (COMS SPECS G) (COND ((AND (NULL COMS) (NULL SPECS)) (CONS (QUOTE PROG) (CONS (CADR FORM) (PA7 (CDDR FORM) (APPEND (CADR FORM) B))))) (T (CONC (LIST (QUOTE PROG) (CONS G (APPEND COMS SPECS))) (PA11 COMS (QUOTE COMBIND)) (PA9 SPECS (QUOTE SPECBIND)) (LIST (LIST (QUOTE SETQ) G (CONS (QUOTE PROG) (CONS (DELETEL (APPEND COMS SPECS) (CADR FORM)) (PA7 (CDDR FORM) (APPEND (CADR FORM) B)))))) (PA9 SPECS (QUOTE SPECRSTR)) (PA14 COMS) (PA12 G)))))) ;; compile expression E with name N (COMP (LAMBDA (N E) (COND ((ATOM E) E) (T (COM2 (QUOTE SUBR) (LENGTH (CADR E)) E N))))) ;; generate SPECBIND/SPECRSTR for SPECIAL vars if there are any ;; ((kind (QUOTE (vars)))) (PA9 (LAMBDA (V K) (COND (V (LIST (LIST K (LIST (QUOTE QUOTE) V)))) (T NIL)))) ;; turn CONC into chain of APPEND (PA2 (LAMBDA (L) (COND ((NULL L) (QUOTE (QUOTE NIL))) (T (LIST (QUOTE APPEND) (PAFORM (CAR L) B) (PA2 (CDR L))))))) ))