Artifact fca8972bb78c01f400c01100c9c34a9a04635a8f49903b72ae1266d1d25cb799:
- File
r30/complr.red
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 49353) [annotate] [blame] [check-ins using] [more...]
COMMENT ************************************************************** ********************************************************************** THE STANDARD LISP COMPILER ********************************************************************** *********************************************************************; COMMENT machine dependent parts are in a separate file; COMMENT these include the macros described below and, in addition, an auxiliary function !&MKFUNC which is required to pass functional arguments (input as FUNCTION <func>) to the loader. In most cases, !&MKFUNC may be defined as MKQUOTE; COMMENT global flags used in this compiler: !*MODULE indicates block compilation (a future extension of this compiler) !*MSG indicates whether certain messages should be printed !*NOLINKE if ON inhibits use of !*LINKE c-macro !*ORD if ON forces left-to-right argument evaluation !*PLAP if ON causes LAP output to be printed !*R2I if ON causes recursion removal where possible; GLOBAL '(!*MODULE !*MSG !*NOLINKE !*ORD !*PLAP !*R2I); COMMENT global variables used: ERFG!* used by REDUCE to control error recovery MAXNARGS maximum number of arguments permitted; GLOBAL '(ERFG!* MAXNARGS); MAXNARGS := 15; %Standard LISP limit; COMMENT fluid variables used: ALSTS alist of fluid parameters CODELIST code being built CONDTAIL simulated stack of position in the tail of a COND DFPRINT!* name of special definition process (or NIL) EXIT label for !*EXIT jump FLAGG used in !&COMTST, and in !&FIXREST FREELST list of free variables with bindings GOLIST storage map for jump labels IREGS initial register contents IREGS1 temporary placeholder for IREGS for branch compilation JMPLIST list of locations in CODELIST of transfers LBLIST list of label words LLNGTH cell whose CAR is length of frame NAME name of function being currently compiled NARG number of arguments in function REGS known current contents of registers as an alist with elements of form (<reg> . <contents>) REGS1 temporary placeholder for REGS during branch compilation SLST association list for stores which have not yet been used STLST list of active stores in function STOMAP storage map for variables SWITCH boolean expression value flag - keeps track of NULLs; FLUID '(ALSTS CODELIST CONDTAIL DFPRINT!* EXIT FLAGG FREELST GOLIST IREGS IREGS1 JMPLIST LBLIST LLNGTH NAME NARG REGS REGS1 SLST STLST STOMAP SWITCH); COMMENT c-macros used in this compiler; COMMENT The following c-macros must NOT change regs 1-MAXNARGS: !*ALLOC n allocate new stack frame of n words !*DEALLOC n deallocate above frame !*ENTRY name type nargs entry point to function name of type type with nargs args !*EXIT exit to previously saved return address !*STORE reg floc store contents of reg (or NIL) in floc !*JUMP adr unconditional jump !*JUMPC adr exp type jump to adr if exp is of type type !*JUMPNC adr exp type jump to adr if exp is not of type type !*JUMPNIL adr jump on register 1 eq to NIL !*JUMPT adr jump on register 1 not eq to NIL !*JUMPE adr exp jump on register 1 eq to exp !*JUMPN adr exp jump on register 1 not eq to exp !*LBL adr define label !*LAMBIND regs alst bind free lambda vars in alst currently in regs !*PROGBIND alst bind free prog vars in alst !*FREERSTR alst unbind free variables in alst COMMENT the following c-macro must only change specific register being loaded: !*LOAD reg exp load exp into reg; COMMENT the following c-macros do not protect regs 1-MAXNARGS: !*LINK fn type nargs link to fn of type type with nargs args !*LINKE fn type nargs n link to fn of type type with nargs args and exit removing frame of n words !*CODE list this macro allows for the inclusion of a list of c-macro expressions (or even explicit assembly language) in a function definition; FLAG('(!*ALLOC !*DEALLOC !*ENTRY !*EXIT !*STORE !*JUMP !*JUMPC !*JUMPNC !*JUMPNIL !*JUMPT !*JUMPE !*JUMPN !*LBL !*LAMBIND !*PROGBIND !*FREERSTR !*LOAD !*LINK !*LINKE !*CODE), 'MC); COMMENT general functions used in this compiler; SYMBOLIC PROCEDURE ATSOC(U,V); IF NULL V THEN NIL ELSE IF U EQ CAAR V THEN CAR V ELSE ATSOC(U,CDR V); SYMBOLIC PROCEDURE EQCAR(U,V); NOT ATOM U AND CAR U EQ V; SYMBOLIC PROCEDURE LPRI U; IF ATOM U THEN LPRI LIST U ELSE FOR EACH X IN U DO <<PRIN2 X; PRIN2 " ">>; SYMBOLIC PROCEDURE LPRIE U; <<LPRI ("*****" . IF ATOM U THEN LIST U ELSE U); ERFG!* := T; TERPRI()>>; SYMBOLIC PROCEDURE LPRIM U; IF !*MSG THEN <<TERPRI(); LPRI ("***" . IF ATOM U THEN LIST U ELSE U); TERPRI()>>; SYMBOLIC PROCEDURE MKQUOTE U; LIST('QUOTE,U); SYMBOLIC PROCEDURE REVERSIP U; BEGIN SCALAR X,Y; WHILE U DO <<X := CDR U; Y := RPLACD(U,Y); U := X>>; RETURN Y END; SYMBOLIC PROCEDURE RPLACW(A,B); RPLACA(RPLACD(A,CDR B),CAR B); COMMENT the following two functions are used by the CONS open coding. They should be defined in the interpreter if possible. They should only be compiled without a COMPFN for CONS; SYMBOLIC PROCEDURE NCONS U; U . NIL; SYMBOLIC PROCEDURE XCONS(U,V); V . U; COMMENT Top level compiling functions; SYMBOLIC PROCEDURE COMPILE X; BEGIN SCALAR EXP; FOR EACH Y IN X DO IF NULL (EXP := GETD Y) THEN LPRIM LIST(Y,'UNDEFINED) ELSE COMPD(Y,CAR EXP,CDR EXP); RETURN X END; SYMBOLIC PROCEDURE COMPD(NAME,TYPE,EXP); BEGIN IF NOT FLAGP(TYPE,'COMPILE) THEN <<LPRIM LIST("UNCOMPILABLE FUNCTION",NAME,"OF TYPE", TYPE); RETURN NIL>>; IF NOT ATOM EXP THEN IF !*MODULE THEN MODCMP(NAME,TYPE,EXP) ELSE IF DFPRINT!* THEN APPLY(DFPRINT!*, LIST IF TYPE EQ 'EXPR THEN 'DE . (NAME . CDR EXP) ELSE IF TYPE EQ 'FEXPR THEN 'DF . (NAME . CDR EXP) ELSE IF TYPE EQ 'MACRO THEN 'DM . (NAME . CDR EXP) ELSE LIST('PUTD,MKQUOTE NAME, MKQUOTE TYPE, MKQUOTE EXP)) ELSE BEGIN SCALAR X; IF FLAGP(TYPE,'COMPILE) THEN PUT(NAME,'CFNTYPE,LIST TYPE); X := LIST('!*ENTRY,NAME,TYPE,LENGTH CADR EXP) . !&COMPROC(EXP, IF FLAGP(TYPE,'COMPILE) THEN NAME); IF !*PLAP THEN FOR EACH Y IN X DO PRINT Y; LAP X; %this is the entry point to the assembler. LAP %must remove any preexisting function definition; IF (X := GET(NAME,'CFNTYPE)) AND EQCAR(GETD NAME,CAR X) THEN REMPROP(NAME,'CFNTYPE) END; RETURN NAME END; FLAG('(EXPR FEXPR MACRO),'COMPILE); SYMBOLIC PROCEDURE !&COMPROC(EXP,NAME); %compiles a function body, returning the generated LAP; BEGIN SCALAR CODELIST,FLAGG,IREGS,IREGS1,JMPLIST,LBLIST, LLNGTH,REGS,REGS1,ALSTS,EXIT,SLST,STLST,STOMAP, CONDTAIL,FREELST, SWITCH; INTEGER NARG; LLNGTH := LIST 1; NARG := 0; EXIT := !&GENLBL(); STOMAP := '((NIL 1)); CODELIST := LIST ('!*ALLOC . LLNGTH); EXP := !&PASS1 EXP; IF LENGTH CADR EXP>MAXNARGS THEN LPRIE LIST("TOO MANY ARGS FOR COMPILER IN",NAME); FOR EACH Z IN CADR EXP DO <<!&FRAME Z; NARG := NARG + 1; IF NOT NONLOCAL Z THEN IREGS := NCONC(IREGS, LIST LIST(NARG,Z)); REGS := NCONC(REGS,LIST LIST(NARG,Z))>>; IF NULL REGS THEN REGS := LIST (1 . NIL); ALSTS := !&FREEBIND(CADR EXP,T); !&PASS2 CADDR EXP; !&FREERST(ALSTS,0); !&PASS3(); RPLACA(LLNGTH,1 - CAR LLNGTH); RETURN CODELIST END; SYMBOLIC PROCEDURE NONLOCAL X; IF FLUIDP X THEN 'FLUID ELSE IF GLOBALP X THEN 'GLOBAL ELSE NIL; COMMENT Pass 1 of the compiler; SYMBOLIC PROCEDURE !&PASS1 EXP; !&PA1(EXP,NIL); SYMBOLIC PROCEDURE !&PA1(U,VBLS); BEGIN SCALAR X; RETURN IF ATOM U THEN IF CONSTANTP U OR U MEMQ '(NIL T) THEN MKQUOTE U ELSE IF U MEMQ VBLS THEN U ELSE IF NONLOCAL U THEN U ELSE <<MKNONLOCAL U; U>> ELSE IF NOT ATOM CAR U THEN !&PA1(CAR U,VBLS) . !&PALIS(CDR U,VBLS) ELSE IF X := GET(CAR U,'PA1FN) THEN APPLY(X,LIST(U,VBLS)) ELSE IF (X := GETD CAR U) AND CAR X EQ 'MACRO AND NOT GET(CAR U,'COMPFN) THEN !&PA1(APPLY(CDR X,LIST U),VBLS) ELSE IF X := GET(CAR U,'CMACRO) THEN !&PA1(SUBLIS(PAIR(CADR X,CDR U),CADDR X),VBLS) ELSE IF !&CFNTYPE CAR U EQ 'FEXPR AND NOT GET(CAR U,'COMPFN) THEN LIST(CAR U,MKQUOTE CDR U) ELSE IF CAR U MEMQ VBLS OR FLUIDP CAR U THEN LIST('APPLY,CAR U,!&PALIST(CDR U,VBLS)) ELSE CAR U . !&PALIS(CDR U,VBLS) END; SYMBOLIC PROCEDURE !&PAIDEN(U,VBLS); U; PUT('GO,'PA1FN,'!&PAIDEN); PUT('QUOTE,'PA1FN,'!&PAIDEN); PUT('CODE,'PA1FN,'!&PAIDEN); SYMBOLIC PROCEDURE !&PACOND(U,VBLS); 'COND . FOR EACH Z IN CDR U COLLECT LIST(!&PA1(CAR Z,VBLS), !&PA1(!&MKPROGN CDR Z,VBLS)); PUT('COND,'PA1FN,'!&PACOND); SYMBOLIC PROCEDURE !&PAFUNC(U,VBLS); IF ATOM CADR U THEN !&MKFUNC CADR U ELSE !&MKFUNC COMPD(!&MKNAM NAME,'EXPR,CADR U); PUT('FUNCTION,'PA1FN,'!&PAFUNC); SYMBOLIC PROCEDURE !&PALAMB(U,VBLS); 'LAMBDA . LIST(CADR U,!&PA1(!&MKPROGN CDDR U,APPEND(CADR U,VBLS))); PUT('LAMBDA,'PA1FN,'!&PALAMB); SYMBOLIC PROCEDURE !&PALIST(U,VBLS); 'LIST . !&PALIS(U,VBLS); SYMBOLIC PROCEDURE !&PAPROG(U,VBLS); 'PROG . (CADR U . !&PAPROG1(CDDR U,APPEND(CADR U,VBLS))); SYMBOLIC PROCEDURE !&PAPROG1(U,VBLS); FOR EACH X IN U COLLECT IF ATOM X THEN X ELSE !&PA1(X,VBLS); PUT('PROG,'PA1FN,'!&PAPROG); SYMBOLIC PROCEDURE !&PALIS(U,VBLS); FOR EACH X IN U COLLECT !&PA1(X,VBLS); SYMBOLIC PROCEDURE MKNONLOCAL U; <<LPRIM LIST(U,"declared fluid"); FLUID LIST U; LIST('FLUID,U)>>; SYMBOLIC PROCEDURE !&MKNAM U; %generates unique name for auxiliary function in U; INTERN COMPRESS APPEND(EXPLODE U,EXPLODE GENSYM()); SYMBOLIC PROCEDURE !&MKPROGN U; IF NULL U OR CDR U THEN 'PROGN . U ELSE CAR U; COMMENT CMACRO definitions for some functions; COMMENT We do not expand CAAAAR and similar functions, since fewer instructions are generated without open coding; DEFLIST('((CAAR (LAMBDA (U) (CAR (CAR U)))) (CADR (LAMBDA (U) (CAR (CDR U)))) (CDAR (LAMBDA (U) (CDR (CAR U)))) (CDDR (LAMBDA (U) (CDR (CDR U)))) (CAAAR (LAMBDA (U) (CAR (CAR (CAR U))))) (CAADR (LAMBDA (U) (CAR (CAR (CDR U))))) (CADAR (LAMBDA (U) (CAR (CDR (CAR U))))) (CADDR (LAMBDA (U) (CAR (CDR (CDR U))))) (CDAAR (LAMBDA (U) (CDR (CAR (CAR U))))) (CDADR (LAMBDA (U) (CDR (CAR (CDR U))))) (CDDAR (LAMBDA (U) (CDR (CDR (CAR U))))) (CDDDR (LAMBDA (U) (CDR (CDR (CDR U))))) (NOT (LAMBDA (U) (NULL U)))),'CMACRO); COMMENT Pass 2 of the compiler; SYMBOLIC PROCEDURE !&PASS2 EXP; !&COMVAL(EXP,0); SYMBOLIC PROCEDURE !&COMVAL(EXP,STATUS); %computes code for value of EXP; IF !&ANYREG(EXP,NIL) THEN IF STATUS>1 THEN NIL ELSE !&LREG1(EXP,STATUS) ELSE !&COMVAL1(EXP,STOMAP,STATUS); SYMBOLIC PROCEDURE !&COMVAL1(EXP,STOMAP,STATUS); BEGIN SCALAR X; IF ATOM EXP THEN IF STATUS<2 THEN !&LREG1(EXP,STATUS) ELSE NIL ELSE IF NOT ATOM CAR EXP THEN IF CAAR EXP EQ 'LAMBDA THEN !&COMPLY(CAR EXP,CDR EXP,STATUS) ELSE LPRIE LIST("INVALID FUNCTION",CAR EXP) ELSE IF X := GET(CAR EXP,'COMPFN) THEN APPLY(X,LIST(EXP,STATUS)) ELSE IF !*R2I AND CAR EXP EQ NAME AND STATUS=0 AND NULL FREELST THEN !&COMREC(EXP,STATUS) ELSE IF CAR EXP EQ 'LAMBDA THEN LPRIE LIST("INVALID USE OF LAMBDA IN FUNCTION",NAME) ELSE IF CAR EXP EQ '!*CODE THEN !&ATTACH EXP ELSE !&CALL(CAR EXP,CDR EXP,STATUS); RETURN NIL END; SYMBOLIC PROCEDURE !&ANYREG(U,V); %determines if U can be loaded in any register; %!*ORD = T means force correct order, unless safe; IF EQCAR(U,'QUOTE) THEN T ELSE (ATOM U OR IDP CAR U AND GET(CAR U,'ANYREG) AND !&ANYREG(CADR U,NIL)) AND (NULL !*ORD OR !&ANYREGL V); SYMBOLIC PROCEDURE !&ANYREGL U; NULL U OR !&ANYREG(CAR U,NIL) AND !&ANYREGL CDR U; SYMBOLIC PROCEDURE !&CALL(FN,ARGS,STATUS); !&CALL1(FN,!&COMLIS ARGS,STATUS); SYMBOLIC PROCEDURE !&CALL1(FN,ARGS,STATUS); %ARGS is reversed list of compiled arguments of FN; BEGIN INTEGER ARGNO; ARGNO := LENGTH ARGS; !&LOADARGS(ARGS,STATUS); !&ATTACH LIST('!*LINK,FN,!&CFNTYPE FN,ARGNO); IF FLAGP(FN,'ONEREG) THEN REGS := (1 . NIL) . CDR REGS ELSE IF FLAGP(FN,'TWOREG) THEN REGS := (1 . NIL) . DELASC(2,CDR REGS) ELSE REGS := LIST (1 . NIL) END; SYMBOLIC PROCEDURE DELASC(U,V); IF NULL V THEN NIL ELSE IF U=CAAR V THEN CDR V ELSE CAR V . DELASC(U,CDR V); SYMBOLIC PROCEDURE !&COMLIS EXP; %returns reversed list of compiled arguments; BEGIN SCALAR ACUSED,Y; WHILE EXP DO <<IF !&ANYREG(CAR EXP,CDR EXP) THEN Y := CAR EXP . Y ELSE <<IF ACUSED THEN !&STORE1(); !&COMVAL1(CAR EXP,STOMAP,1); ACUSED := GENSYM(); REGS := (1 . (ACUSED . CDAR REGS)) . CDR REGS; Y := ACUSED . Y>>; EXP := CDR EXP>>; RETURN Y END; SYMBOLIC PROCEDURE !&STORE1; %Marks contents of register 1 for storage; BEGIN SCALAR X; X := CADAR REGS; IF NULL X OR EQCAR(X,'QUOTE) THEN RETURN NIL ELSE IF NOT ATSOC(X,STOMAP) THEN !&FRAME X; !&STORE0(X,1) END; SYMBOLIC PROCEDURE !&COMPLY(FN,ARGS,STATUS); BEGIN SCALAR ALSTS,VARS; INTEGER I; VARS := CADR FN; !&LOADARGS(!&COMLIS ARGS,1); ARGS := !&REMVARL VARS; % The stores that were protected; I := 1; FOR EACH V IN VARS DO <<!&FRAME V; REGS := !&REPASC(I,V,REGS); I := I + 1>>; ALSTS := !&FREEBIND(VARS,T); %Old fluid values saved; I := 1; FOR EACH V IN VARS DO <<IF NOT NONLOCAL V THEN !&STORE0(V,I); I := I + 1>>; !&COMVAL(CADDR FN,STATUS); !&FREERST(ALSTS,STATUS); !&RSTVARL(VARS,ARGS) END; SYMBOLIC PROCEDURE !&COMREC(EXP,STATUS); BEGIN SCALAR X,Z; !&LOADARGS(!&COMLIS CDR EXP,STATUS); Z := CODELIST; IF NULL CDR Z THEN LPRIE LIST("CIRCULAR DEFINITION FOR",CAR EXP); WHILE CDDR Z DO Z := CDR Z; IF CAAR Z EQ '!*LBL THEN X := CDAR Z ELSE <<X := !&GENLBL(); RPLACD(Z,LIST('!*LBL . X,CADR Z))>>; !&ATTJMP X END; SYMBOLIC PROCEDURE !&LOADARGS(ARGS,STATUS); BEGIN INTEGER N; N := LENGTH ARGS; IF N>MAXNARGS THEN LPRIE LIST("TOO MANY ARGUMENTS IN",NAME); IF STATUS>0 THEN !&CLRREGS(); WHILE ARGS DO <<!&LREG(N,CAR ARGS,CDR ARGS,STATUS); N := N - 1; ARGS := CDR ARGS>> END; SYMBOLIC PROCEDURE !&LOCATE X; BEGIN SCALAR Y,VTYPE; IF EQCAR(X,'QUOTE) THEN RETURN LIST X ELSE IF Y := !&RASSOC(X,REGS) THEN RETURN LIST CAR Y ELSE IF NOT ATOM X THEN RETURN LIST (CAR X . !&LOCATE CADR X) ELSE IF VTYPE := NONLOCAL X THEN RETURN LIST LIST(VTYPE,X); WHILE Y := ATSOC(X,SLST) DO SLST := DELETE(Y,SLST); RETURN IF Y := ATSOC(X,STOMAP) THEN CDR Y ELSE LIST MKNONLOCAL X END; SYMBOLIC PROCEDURE !&LREG(REG,U,V,STATUS); BEGIN SCALAR X,Y; IF (X := ASSOC(REG,REGS)) AND U MEMBER CDR X THEN RETURN NIL ELSE IF (Y := ASSOC(REG,IREGS)) AND (STATUS>0 OR !&MEMLIS(CADR Y,V)) THEN <<!&STORE0(CADR Y,REG); IREGS := DELETE(Y,IREGS)>>; !&ATTACH ('!*LOAD . (REG . !&LOCATE U)); REGS := !&REPASC(REG,U,REGS) END; SYMBOLIC PROCEDURE !&LREG1(X,STATUS); !&LREG(1,X,NIL,STATUS); COMMENT Functions for handling non-local variables; SYMBOLIC PROCEDURE !&FREEBIND(VARS,LAMBP); %bind FLUID variables in lambda or prog lists; %LAMBP is true for LAMBDA, false for PROG; BEGIN SCALAR FALST,FREGS,X,Y; INTEGER I; I := 1; FOR EACH X IN VARS DO <<IF FLUIDP X THEN <<FALST := (X . !&GETFFRM X) . FALST; FREGS := I . FREGS>> ELSE IF GLOBALP X THEN LPRIE LIST("CANNOT BIND GLOBAL ", X); I := I + 1>>; IF NULL FALST THEN RETURN NIL; IF LAMBP THEN !&ATTACH LIST('!*LAMBIND,FREGS,FALST) ELSE !&ATTACH LIST('!*PROGBIND,FALST); RETURN FALST END; SYMBOLIC PROCEDURE !&FREERST(ALSTS,STATUS); %restores FLUID variables; IF ALSTS THEN !&ATTACH LIST('!*FREERSTR,ALSTS); SYMBOLIC PROCEDURE !&ATTACH U; CODELIST := U . CODELIST; SYMBOLIC PROCEDURE !&STORE0(U,REG); %marks expression U in register REG for storage; BEGIN SCALAR X; X := '!*STORE . (REG . !&GETFRM U); STLST := X . STLST; !&ATTACH X; IF ATOM U THEN <<!&CLRSTR U; SLST := (U . CODELIST) . SLST>> END; SYMBOLIC PROCEDURE !&CLRSTR VAR; %removes unneeded stores; BEGIN SCALAR X; IF CONDTAIL THEN RETURN NIL; X := ATSOC(VAR,SLST); IF NULL X THEN RETURN NIL; STLST := !&DELEQ(CADR X,STLST); SLST := !&DELEQ(X,SLST); RPLACA(CADR X,'!*NOOP) END; COMMENT Functions for general tests; SYMBOLIC PROCEDURE !&COMTST(EXP,LABL); %compiles boolean expression EXP. %If EXP has the same value as SWITCH then branch to LABL, %otherwise fall through; %REGS/IREGS are active registers for fall through, %REGS1/IREGS1 for branch; BEGIN SCALAR X; WHILE EQCAR(EXP,'NULL) DO <<SWITCH := NOT SWITCH; EXP := CADR EXP>>; IF NOT ATOM EXP AND ATOM CAR EXP AND (X := GET(CAR EXP,'COMTST)) THEN APPLY(X,LIST(EXP,LABL)) ELSE <<IF EXP='(QUOTE T) THEN IF SWITCH THEN !&ATTJMP LABL ELSE FLAGG := T ELSE <<!&COMVAL(EXP,1); !&ATTACH LIST(IF SWITCH THEN '!*JUMPT ELSE '!*JUMPNIL,CAR LABL); !&ADDJMP CODELIST>>; REGS1 := REGS; IREGS1 := IREGS>>; IF EQCAR(CAR CODELIST,'!*JUMPT) THEN REGS := (1 . ('(QUOTE NIL) . CDAR REGS)) . CDR REGS ELSE IF EQCAR(CAR CODELIST,'!*JUMPNIL) THEN REGS1 := (1 . ('(QUOTE NIL) . CDAR REGS1)) . CDR REGS1 END; COMMENT Specific function open coding; SYMBOLIC PROCEDURE !&COMANDOR(EXP,STATUS); BEGIN SCALAR FN,LABL,IREGSL,REGSL; FN := CAR EXP EQ 'AND; LABL := !&GENLBL(); IF STATUS>1 THEN BEGIN SCALAR REGS1; !&TSTANDOR(EXP,LABL); REGS := !&RMERGE2(REGS,REGS1) END ELSE BEGIN IF STATUS>0 THEN !&CLRREGS(); EXP := CDR EXP; WHILE EXP DO <<!&COMVAL(CAR EXP,IF CDR EXP THEN 1 ELSE STATUS); %to allow for recursion on last entry; IREGSL := IREGS . IREGSL; REGSL := REGS . REGSL; IF CDR EXP THEN <<!&ATTACH LIST(IF FN THEN '!*JUMPNIL ELSE '!*JUMPT,CAR LABL); !&ADDJMP CODELIST>>; EXP := CDR EXP>>; IREGS := !&RMERGE IREGSL; REGS := !&RMERGE REGSL END; !&ATTLBL LABL END; SYMBOLIC PROCEDURE !&TSTANDOR(EXP,LABL); BEGIN SCALAR FLG,FLG1,FN,LAB2,REGSL,REGS1L,TAILP; %FLG is initial switch condition; %FN is appropriate AND/OR case; %FLG1 determines appropriate switching state; FLG := SWITCH; SWITCH := NIL; FN := CAR EXP EQ 'AND; FLG1 := FLG EQ FN; EXP := CDR EXP; LAB2 := !&GENLBL(); !&CLRREGS(); WHILE EXP DO <<SWITCH := NIL; IF NULL CDR EXP AND FLG1 THEN <<IF FN THEN SWITCH := T; !&COMTST(CAR EXP,LABL); REGSL := REGS . REGSL; REGS1L := REGS1 . REGS1L>> ELSE <<IF NOT FN THEN SWITCH := T; IF FLG1 THEN <<!&COMTST(CAR EXP,LAB2); REGSL := REGS1 . REGSL; REGS1L := REGS . REGS1L>> ELSE <<!&COMTST(CAR EXP,LABL); REGSL := REGS . REGSL; REGS1L := REGS1 . REGS1L>>>>; IF NULL TAILP THEN <<CONDTAIL := NIL . CONDTAIL; TAILP := T>>; EXP := CDR EXP>>; !&ATTLBL LAB2; REGS := IF NOT FLG1 THEN CAR REGSL ELSE !&RMERGE REGSL; REGS1 := IF FLG1 THEN CAR REGS1L ELSE !&RMERGE REGS1L; IF TAILP THEN CONDTAIL := CDR CONDTAIL; SWITCH := FLG END; PUT('AND,'COMPFN,'!&COMANDOR); PUT('OR,'COMPFN,'!&COMANDOR); PUT('AND,'COMTST,'!&TSTANDOR); PUT('OR,'COMTST,'!&TSTANDOR); SYMBOLIC PROCEDURE !&COMCOND(EXP,STATUS); %compiles conditional expressions; %registers REGS and IREGS are set for dropping through, %REGS1 and IREGS1 are set for a branch; BEGIN SCALAR IREGS1,REGS1,FLAGG,SWITCH,LAB1,LAB2,REGSL,IREGSL,TAILP; EXP := CDR EXP; LAB1 := !&GENLBL(); IF STATUS>0 THEN !&CLRREGS(); FOR EACH X IN EXP DO <<LAB2 := !&GENLBL(); SWITCH := NIL; IF CDR X THEN !&COMTST(CAR X,LAB2) %update CONDTAIL; ELSE <<!&COMVAL(CAR X,1); !&ATTACH LIST('!*JUMPNIL,CAR LAB2); !&ADDJMP CODELIST; IREGS1 := IREGS; REGS1 := (1 . '(QUOTE NIL) . CDAR REGS) . CDR REGS>>; IF NULL TAILP THEN <<CONDTAIL := NIL . CONDTAIL; TAILP := T>>; !&COMVAL(CADR X,STATUS); % Branch code; %test if need jump to LAB1; IF NOT !&TRANSFERP CAR CODELIST THEN <<!&ATTJMP LAB1; IREGSL := IREGS . IREGSL; REGSL := REGS . REGSL>>; REGS := REGS1; %restore register status for next iteration; IREGS := IREGS1; IREGS1 := NIL; %we do not need to set REGS1 to NIL since all !&COMTSTs %are required to set it; !&ATTLBL LAB2>>; IF NULL FLAGG AND STATUS<2 THEN <<!&LREG1('(QUOTE NIL),STATUS); IREGS := !&RMERGE1(IREGS,IREGSL); REGS := !&RMERGE1(REGS,REGSL)>> ELSE IF REGSL THEN <<IREGS := !&RMERGE1(IREGS,IREGSL); REGS := !&RMERGE1(REGS,REGSL)>>; !&ATTLBL LAB1; IF TAILP THEN CONDTAIL := CDR CONDTAIL END; SYMBOLIC PROCEDURE !&RMERGE U; IF NULL U THEN NIL ELSE !&RMERGE1(CAR U,CDR U); SYMBOLIC PROCEDURE !&RMERGE1(U,V); IF NULL V THEN U ELSE !&RMERGE1(!&RMERGE2(U,CAR V),CDR V); SYMBOLIC PROCEDURE !&RMERGE2(U,V); IF NULL U OR NULL V THEN NIL ELSE (LAMBDA X; IF X THEN (CAAR U . XN(CDAR U,CDR X)) . !&RMERGE2(CDR U,DELETE(X,V)) ELSE !&RMERGE2(CDR U,V)) ASSOC(CAAR U,V); FLAG('(!*JUMP !*LINKE ERROR),'TRANSFER); PUT('COND,'COMPFN,'!&COMCOND); SYMBOLIC PROCEDURE !&COMCONS(EXP,STATUS); IF NULL (EXP := CDR EXP) OR NULL CDR EXP OR CDDR EXP THEN LPRIE "MISMATCH OF ARGUMENTS" ELSE IF CADR EXP='(QUOTE NIL) THEN !&CALL('NCONS,LIST CAR EXP,STATUS) ELSE IF EQCAR(!&RASSOC(CADR EXP,REGS),1) AND !&ANYREG(CAR EXP,NIL) THEN !&CALL1('XCONS,!&COMLIS REVERSE EXP,STATUS) ELSE IF !&ANYREG(CADR EXP,NIL) THEN !&CALL('CONS,EXP,STATUS) ELSE !&CALL1('XCONS,REVERSIP !&COMLIS EXP,STATUS); PUT('CONS,'COMPFN,'!&COMCONS); SYMBOLIC PROCEDURE !&COMGO(EXP,STATUS); <<!&CLRREGS(); IF STATUS>2 THEN <<!&ATTJMP !&GETLBL CADR EXP; SLST := NIL>> ELSE LPRIE LIST(EXP,"INVALID")>>; PUT('GO,'COMPFN,'!&COMGO); SYMBOLIC PROCEDURE !&COMLIST(EXP,STATUS); %we only support explicit functions up to 5 arguments here; BEGIN SCALAR M,N,FN; EXP := CDR EXP; M := MIN(MAXNARGS,5); N := LENGTH EXP; IF N=0 THEN !&LREG1('(QUOTE NIL),STATUS) ELSE IF N>M THEN !&COMVAL(!&COMLIST1 EXP,STATUS) ELSE !&CALL(IF N=1 THEN 'NCONS ELSE IF N=2 THEN 'LIST2 ELSE IF N=3 THEN 'LIST3 ELSE IF N=4 THEN 'LIST4 ELSE 'LIST5,EXP,STATUS) END; SYMBOLIC PROCEDURE LIST2(U,V); U . (V . NIL); SYMBOLIC PROCEDURE LIST3(U,V,W); U . (V . (W . NIL)); SYMBOLIC PROCEDURE LIST4(U,V,W,X); U . (V . (W . (X . NIL))); SYMBOLIC PROCEDURE LIST5(U,V,W,X,Y); U . (V . (W . (X . (Y . NIL)))); SYMBOLIC PROCEDURE !&COMLIST1 EXP; IF NULL EXP THEN '(QUOTE NIL) ELSE LIST('CONS,CAR EXP,'LIST . CDR EXP); PUT('LIST,'COMPFN,'!&COMLIST); SYMBOLIC PROCEDURE !&PAMAP(U,VARS); IF EQCAR(CADDR U,'FUNCTION) THEN (LAMBDA X; LIST(CAR U, !&PA1(CADR U,VARS), MKQUOTE (IF ATOM X THEN X ELSE !&PA1(X,VARS)))) CADR CADDR U ELSE CAR U . !&PALIS(CDR U,VARS); PUT('MAP,'PA1FN,'!&PAMAP); PUT('MAPC,'PA1FN,'!&PAMAP); PUT('MAPCAN,'PA1FN,'!&PAMAP); PUT('MAPCAR,'PA1FN,'!&PAMAP); PUT('MAPCON,'PA1FN,'!&PAMAP); PUT('MAPLIST,'PA1FN,'!&PAMAP); SYMBOLIC PROCEDURE !&COMMAP(EXP,STATUS); BEGIN SCALAR BODY,FN,LAB1,LAB2,LAB3,TMP,MTYPE,RESULT,SLST1,VAR,X; BODY := CADR EXP; FN := CADDR EXP; LAB1 := !&GENLBL(); LAB2 := !&GENLBL(); MTYPE := IF CAR EXP MEMQ '(MAPCAR MAPLIST) THEN 'CONS ELSE IF CAR EXP MEMQ '(MAPCAN MAPCON) THEN <<LAB3 := !&GENLBL(); 'NCONC>> ELSE NIL; !&CLRREGS(); IF MTYPE THEN <<!&FRAME (RESULT := GENSYM()); IF NULL LAB3 THEN !&STORE0(RESULT,NIL)>>; !&FRAME (VAR := GENSYM()); !&COMVAL(BODY,1); REGS := LIST LIST(1,VAR); IF LAB3 THEN <<!&STORE0(VAR,1); !&FRAME (TMP := GENSYM()); !&COMVAL('(NCONS 'NIL),1); !&STORE0(RESULT,1); !&STORE0(TMP,1); !&LREG1(VAR,1)>>; !&ATTJMP LAB2; !&ATTLBL LAB1; !&STORE0(VAR,1); X := IF CAR EXP MEMQ '(MAP MAPCON MAPLIST) THEN VAR ELSE LIST('CAR,VAR); IF EQCAR(FN,'QUOTE) THEN FN := CADR FN; SLST1 := SLST; %to allow for store in function body; !&COMVAL(LIST(FN,X),IF MTYPE THEN 1 ELSE 3); IF MTYPE THEN <<IF LAB3 THEN <<!&ATTACH LIST('!*JUMPNIL,CAR LAB3); !&ADDJMP CODELIST; !&ATTACH '(!*LOAD 2 1); !&LREG1(TMP,1); !&STORE0(TMP,2); !&ATTACH '(!*LINK NCONC EXPR 2); !&ATTLBL LAB3>> ELSE <<!&LREG(2,RESULT,NIL,1); !&ATTACH '(!*LINK CONS EXPR 2); !&STORE0(RESULT,1)>>; REGS := LIST (1 . NIL)>>; SLST := XN(SLST,SLST1); !&COMVAL(LIST('CDR,VAR),1); !&ATTLBL LAB2; !&ATTACH LIST('!*JUMPT,CAR LAB1); !&ADDJMP CODELIST; IF MTYPE THEN !&COMVAL(LIST(IF LAB3 THEN 'CDR ELSE 'REVERSIP,RESULT),1) ELSE REGS := LIST LIST(1,MKQUOTE NIL) END; SYMBOLIC PROCEDURE XN(U,V); IF NULL U THEN NIL ELSE IF CAR U MEMBER V THEN CAR U . XN(CDR U,DELETE(CAR U,V)) ELSE XN(CDR U,V); PUT('MAP,'COMPFN,'!&COMMAP); PUT('MAPC,'COMPFN,'!&COMMAP); PUT('MAPCAN,'COMPFN,'!&COMMAP); PUT('MAPCAR,'COMPFN,'!&COMMAP); PUT('MAPCON,'COMPFN,'!&COMMAP); PUT('MAPLIST,'COMPFN,'!&COMMAP); SYMBOLIC PROCEDURE !&COMPROG(EXP,STATUS); %compiles program blocks; BEGIN SCALAR ALSTS,GOLIST,PG,PROGLIS,EXIT; INTEGER I; PROGLIS := CADR EXP; EXP := CDDR EXP; EXIT := !&GENLBL(); PG := !&REMVARL PROGLIS; %protect prog variables; FOR EACH X IN PROGLIS DO !&FRAME X; ALSTS := !&FREEBIND(PROGLIS,NIL); FOR EACH X IN PROGLIS DO IF NOT NONLOCAL X THEN !&STORE0(X,NIL); FOR EACH X IN EXP DO IF ATOM X THEN GOLIST := (X . !&GENLBL()) . GOLIST; WHILE EXP DO <<IF ATOM CAR EXP THEN <<!&CLRREGS(); !&ATTLBL !&GETLBL CAR EXP; REGS := LIST (1 . NIL)>> ELSE !&COMVAL(CAR EXP,IF STATUS>2 THEN 4 ELSE 3); IF NULL CDR EXP AND STATUS<2 AND (ATOM CAR EXP OR NOT CAAR EXP MEMQ '(GO RETURN)) THEN EXP := LIST '(RETURN (QUOTE NIL)) ELSE EXP := CDR EXP>>; !&ATTLBL EXIT; IF CDR !&FINDLBL EXIT THEN REGS := LIST (1 . NIL); !&FREERST(ALSTS,STATUS); !&RSTVARL(PROGLIS,PG) END; PUT('PROG,'COMPFN,'!&COMPROG); SYMBOLIC PROCEDURE !&REMVARL VARS; FOR EACH X IN VARS COLLECT !&REMVAR X; SYMBOLIC PROCEDURE !&REMVAR X; %removes references to variable X from IREGS and REGS %and protects SLST; <<!&REMSTORES X; !&PROTECT X>>; SYMBOLIC PROCEDURE !&REMSTORES X; BEGIN FOR EACH Y IN IREGS DO IF X EQ CADR Y THEN <<!&STORE0(CADR Y,CAR Y); IREGS := DELETE(Y,IREGS)>>; FOR EACH Y IN REGS DO WHILE X MEMBER CDR Y DO RPLACD(Y,!&DELEQ(X,CDR Y)) END; SYMBOLIC PROCEDURE !&PROTECT U; BEGIN SCALAR X; IF X := ATSOC(U,SLST) THEN SLST := !&DELEQ(X,SLST); RETURN X END; SYMBOLIC PROCEDURE !&RSTVARL(VARS,LST); FOR EACH X IN VARS DO <<!&REMSTORES X; !&CLRSTR X; !&UNPROTECT CAR LST; LST := CDR LST>>; SYMBOLIC PROCEDURE !&UNPROTECT VAL; %restores VAL to SLST; IF VAL THEN SLST := VAL . SLST; SYMBOLIC PROCEDURE !&COMPROGN(EXP,STATUS); BEGIN EXP := CDR EXP; IF NULL EXP THEN RETURN NIL; WHILE CDR EXP DO <<!&COMVAL(CAR EXP,IF STATUS<2 THEN 2 ELSE STATUS); EXP := CDR EXP>>; !&COMVAL(CAR EXP,STATUS) END; PUT('PROG2,'COMPFN,'!&COMPROGN); PUT('PROGN,'COMPFN,'!&COMPROGN); SYMBOLIC PROCEDURE !&COMRETURN(EXP,STATUS); <<IF STATUS<4 OR NOT !&ANYREG(CADR EXP,NIL) THEN !&LREG1(CAR !&COMLIS LIST CADR EXP,STATUS); !&ATTJMP EXIT>>; PUT('RETURN,'COMPFN,'!&COMRETURN); SYMBOLIC PROCEDURE !&COMSETQ(EXP,STATUS); BEGIN SCALAR X; EXP := CDR EXP; IF STATUS>1 AND (NULL CADR EXP OR CADR EXP='(QUOTE NIL)) THEN !&STORE2(CAR EXP,NIL) ELSE <<!&COMVAL(CADR EXP,1); !&STORE2(CAR EXP,1); IF X := !&RASSOC(CAR EXP,IREGS) THEN IREGS := DELETE(X,IREGS); REGS := (1 . (CAR EXP . CDAR REGS)) . CDR REGS>> END; SYMBOLIC PROCEDURE !&REMSETVAR(U,V); %removes references to SETQ variable U from regs list V; IF NULL V THEN NIL ELSE (CAAR V . !&REMS1(U,CDAR V)) . !&REMSETVAR(U,CDR V); SYMBOLIC PROCEDURE !&REMS1(U,V); %removes references to SETQ variable U from list V; IF NULL V THEN NIL ELSE IF SMEMQ(U,CAR V) THEN !&REMS1(U,CDR V) ELSE CAR V . !&REMS1(U,CDR V); SYMBOLIC PROCEDURE SMEMQ(U,V); %true if atom U is a member of V at any level (excluding %quoted expressions); IF ATOM V THEN U EQ V ELSE IF CAR V EQ 'QUOTE THEN NIL ELSE SMEMQ(U,CAR V) OR SMEMQ(U,CDR V); SYMBOLIC PROCEDURE !&STORE2(U,V); BEGIN SCALAR VTYPE; REGS := !&REMSETVAR(U,REGS); IF VTYPE := NONLOCAL U THEN !&ATTACH LIST('!*STORE,V,LIST(VTYPE,U)) ELSE IF NOT ATSOC(U,STOMAP) THEN !&ATTACH LIST('!*STORE,V,MKNONLOCAL U) ELSE !&STORE0(U,V) END; PUT('SETQ,'COMPFN,'!&COMSETQ); COMMENT Specific test open coding; SYMBOLIC PROCEDURE !&COMEQ(EXP,LABL); BEGIN SCALAR U,V,W; U := CADR EXP; V := CADDR EXP; IF U MEMBER CDAR REGS THEN W := !&COMEQ1(V,U) ELSE IF V MEMBER CDAR REGS THEN W := !&COMEQ1(U,V) ELSE IF !&ANYREG(V,NIL) THEN <<!&COMVAL(U,1); W := !&LOCATE V>> ELSE IF !&ANYREG(U,LIST V) THEN <<!&COMVAL(V,1); W := !&LOCATE U>> ELSE <<U := !&COMLIS CDR EXP; W := !&LOCATE CADR U>>; !&ATTACH ((IF SWITCH THEN '!*JUMPE ELSE '!*JUMPN) . (CAR LABL . W)); IREGS1 := IREGS; REGS1 := REGS; !&ADDJMP CODELIST END; SYMBOLIC PROCEDURE !&COMEQ1(U,V); IF !&ANYREG(U,LIST V) THEN !&LOCATE U ELSE <<!&COMVAL(U,1); !&LOCATE V>>; PUT('EQ,'COMTST,'!&COMEQ); SYMBOLIC PROCEDURE !&TESTFN(EXP,LABL); %generates c-macros !*JUMPC and !*JUMPNC; BEGIN SCALAR X; IF NOT (X := !&RASSOC(CADR EXP,REGS)) THEN !&COMVAL(CADR EXP,1); !&CLRREGS(); !&ATTACH LIST(IF SWITCH THEN '!*JUMPC ELSE '!*JUMPNC, CAR LABL, IF X THEN CAR X ELSE 1,CAR EXP); REGS1 := REGS; !&ADDJMP CODELIST END; COMMENT Support functions; SYMBOLIC PROCEDURE !&MEMLIS(U,V); V AND (!&MEMB(U,CAR V) OR !&MEMLIS(U,CDR V)); SYMBOLIC PROCEDURE !&MEMB(U,V); IF ATOM V THEN U EQ V ELSE !&MEMB(U,CADR V); SYMBOLIC PROCEDURE !&RASSOC(U,V); IF NULL V THEN NIL ELSE IF U MEMBER CDAR V THEN CAR V ELSE !&RASSOC(U,CDR V); SYMBOLIC PROCEDURE !&REPASC(REG,U,V); IF NULL V THEN LIST LIST(REG,U) ELSE IF REG=CAAR V THEN LIST(REG,U) . CDR V ELSE CAR V . !&REPASC(REG,U,CDR V); SYMBOLIC PROCEDURE !&CLRREGS; %store deferred values in IREGS; WHILE IREGS DO <<!&STORE0(CADAR IREGS,CAAR IREGS); IREGS := CDR IREGS>>; SYMBOLIC PROCEDURE !&CFNTYPE FN; BEGIN SCALAR X; RETURN IF NOT ATOM FN THEN 'EXPR ELSE IF X := GET(FN,'CFNTYPE) THEN CAR X ELSE IF X := GETD FN THEN CAR X ELSE 'EXPR END; SYMBOLIC PROCEDURE !&GENLBL; BEGIN SCALAR L; L := GENSYM(); LBLIST := LIST L . LBLIST; RETURN LIST L END; SYMBOLIC PROCEDURE !&GETLBL LABL; BEGIN SCALAR X; X := ATSOC(LABL,GOLIST); IF NULL X THEN LPRIE LIST(LABL," - MISSING LABEL -"); RETURN CDR X END; SYMBOLIC PROCEDURE !&FINDLBL LBLST; ASSOC(CAR LBLST,LBLIST); SYMBOLIC PROCEDURE !&RECHAIN(OLBL,NLBL); % Fix OLBL to now point at NLBL; BEGIN SCALAR X,Y,USES; X := !&FINDLBL OLBL; Y := !&FINDLBL NLBL; RPLACA(OLBL,CAR NLBL); % FIX L VAR; USES := CDR X; % OLD USES; RPLACD(X,NIL); RPLACD(Y,APPEND(USES,CDR Y)); FOR EACH X IN USES DO RPLACA(CDR X,CAR NLBL) END; SYMBOLIC PROCEDURE !&MOVEUP U; IF CAADR U EQ '!*JUMP THEN <<JMPLIST := !&DELEQ(CDR U,JMPLIST); RPLACW(U,CDR U); JMPLIST := U . JMPLIST>> ELSE RPLACW(U,CDR U); SYMBOLIC PROCEDURE !&ATTLBL LBL; IF CAAR CODELIST EQ '!*LBL THEN !&RECHAIN(LBL,CDAR CODELIST) ELSE !&ATTACH ('!*LBL . LBL); SYMBOLIC PROCEDURE !&ATTJMP LBL; BEGIN IF CAAR CODELIST EQ '!*LBL THEN <<!&RECHAIN(CDAR CODELIST,LBL); CODELIST := CDR CODELIST>>; IF !&TRANSFERP CAR CODELIST THEN RETURN NIL; !&ATTACH ('!*JUMP . LBL); !&ADDJMP CODELIST END; SYMBOLIC PROCEDURE !&TRANSFERP X; FLAGP(IF CAR X EQ '!*LINK THEN CADR X ELSE CAR X,'TRANSFER); SYMBOLIC PROCEDURE !&ADDJMP CLIST; BEGIN SCALAR X; X := !&FINDLBL CDAR CLIST; RPLACD(X,CAR CLIST . CDR X); JMPLIST := CLIST . JMPLIST END; SYMBOLIC PROCEDURE !&REMJMP CLIST; BEGIN SCALAR X; X := !&FINDLBL CDAR CLIST; RPLACD(X,!&DELEQ(CAR CLIST,CDR X)); JMPLIST := !&DELEQ(CLIST,JMPLIST); !&MOVEUP CLIST END; SYMBOLIC PROCEDURE !&DELEQ(U,V); IF NULL V THEN NIL ELSE IF U EQ CAR V THEN CDR V ELSE CAR V . !&DELEQ(U,CDR V); SYMBOLIC PROCEDURE !&FRAME U; %allocates space for U in frame; BEGIN SCALAR Z; STOMAP := LIST(U,Z := CADAR STOMAP - 1) . STOMAP; IF Z<CAR LLNGTH THEN RPLACA(LLNGTH,Z) END; SYMBOLIC PROCEDURE !&GETFRM U; (LAMBDA X; IF X THEN CDR X ELSE LPRIE LIST("COMPILER ERROR: LOST VAR",U)) ATSOC(U,STOMAP); SYMBOLIC PROCEDURE !&GETFFRM U; BEGIN SCALAR X; X := !&GETFRM U; FREELST := X . FREELST; RETURN X END; COMMENT Pass 3 of the compiler (post code generation fixups); SYMBOLIC PROCEDURE !&PASS3; BEGIN SCALAR FLAGG; %remove spurious stores; FOR EACH J IN SLST DO <<STLST := !&DELEQ(CADR J,STLST); RPLACA(CADR J,'!*NOOP)>>; !&FIXCHAINS(); !&FIXLINKS(); !&FIXFRM(); !&ATTLBL EXIT; IF FLAGG THEN <<IF NOT !*NOLINKE AND CAAR CODELIST EQ '!*LBL AND CAADR CODELIST EQ '!*LINKE THEN RPLACA(CDR CODELIST, LIST('!*LINK,CADADR CODELIST, CADR CDADR CODELIST, CADDR CDADR CODELIST)); %removes unnecessary !*LINKE; !&ATTACH ('!*DEALLOC . LLNGTH); !&ATTACH LIST '!*EXIT>>; !&PEEPHOLEOPT(); !&FIXREST() END; SYMBOLIC PROCEDURE !&FIXCHAINS; BEGIN SCALAR EJMPS,EJMPS1,P,Q; %find any common chains of code; IF NOT CAR CODELIST='!*LBL . EXIT THEN !&ATTLBL EXIT; CODELIST := CDR CODELIST; IF NOT CAR CODELIST='!*JUMP . EXIT THEN !&ATTJMP EXIT; EJMPS := REVERSE JMPLIST; WHILE EJMPS DO BEGIN P := CAR EJMPS; EJMPS := CDR EJMPS; IF CAAR P EQ '!*JUMP THEN <<EJMPS1 := EJMPS; WHILE EJMPS1 DO IF CAR P=CAAR EJMPS1 AND CADR P=CADAR EJMPS1 THEN <<!&REMJMP P; !&FIXCHN(P,CDAR EJMPS1); EJMPS1 := NIL>> ELSE EJMPS1 := CDR EJMPS1>> END END; SYMBOLIC PROCEDURE !&FIXLINKS; %replace !*LINK by !*LINKE where appropriate; BEGIN SCALAR EJMPS,P,Q; EJMPS := JMPLIST; IF NOT !*NOLINKE THEN WHILE EJMPS DO BEGIN P := CAR EJMPS; Q := CDR P; EJMPS := CDR EJMPS; IF NOT CADAR P EQ CAR EXIT THEN RETURN NIL ELSE IF NOT CAAR P EQ '!*JUMP OR NOT CAAR Q EQ '!*LINK THEN RETURN FLAGG := T; RPLACW(CAR Q, '!*LINKE . (CADAR Q . (CADDAR Q . (CADR CDDAR Q . LLNGTH)))); !&REMJMP P END ELSE FLAGG := T END; SYMBOLIC PROCEDURE !&FINDBLK(U,LBL); IF NULL CDR U THEN NIL ELSE IF CAADR U EQ '!*LBL AND !&TRANSFERP CADDR U THEN U ELSE IF GET(CAADR U,'NEGJMP) AND CADADR U EQ LBL THEN U ELSE !&FINDBLK(CDR U,LBL); PUT('!*NOOP,'OPTFN,'!&MOVEUP); PUT('!*LBL,'OPTFN,'!&LBLOPT); SYMBOLIC PROCEDURE !&LBLOPT U; BEGIN SCALAR Z; IF CADAR U EQ CADADR U THEN RETURN !&REMJMP CDR U ELSE IF CAADR U EQ '!*JUMP AND (Z := GET(CAADDR U,'NEGJMP)) AND CADAR U EQ CADR CADDR U THEN RETURN <<Z := Z . (CADADR U . CDDR CADDR U); !&REMJMP CDR U; !&REMJMP CDR U; RPLACD(U,Z . (CADR U . CDDR U)); !&ADDJMP CDR U; T>> ELSE RETURN NIL END; SYMBOLIC PROCEDURE !&PEEPHOLEOPT; %'peep-hole' optimization for various cases; BEGIN SCALAR X,Z; Z := CODELIST; WHILE Z DO IF NOT (X := GET(CAAR Z,'OPTFN)) OR NOT APPLY(X,LIST Z) THEN Z := CDR Z END; SYMBOLIC PROCEDURE !&FIXREST; %checks for various cases involving unique (and unused) labels %and sequences like (JUMPx lab) M1 ... Mn ... (LAB lab) M1 ... Mn %where Mi do not affect reg 1; BEGIN SCALAR LABS,TLABS,X,Y,Z; WHILE CODELIST DO <<IF CAAR CODELIST EQ '!*LBL THEN <<!&LBLOPT CODELIST; IF CDR (Z := !&FINDLBL CDAR CODELIST) THEN <<Y := CAR CODELIST . Y; IF NULL CDDR Z AND !&TRANSFERP CADR Z AND CAADR Y EQ '!*LOAD AND !&NOLOADP(CDADR Y, CDR ATSOC(CADR Z, JMPLIST)) THEN <<IF NOT !&NOLOADP(CDADR Y, CDR CODELIST) THEN RPLACW(CDR CODELIST, CADR Y . CADR CODELIST . CDDR CODELIST); RPLACW(CDR Y,CDDR Y)>> ELSE <<IF NULL CDDR Z AND CAADR CODELIST EQ '!*JUMP AND GET(CAADR Z,'NEGJMP) THEN LABS := (CADR Z . Y) . LABS; IF !&TRANSFERP CADR CODELIST THEN TLABS := (CADAR Y . Y) . TLABS>>>>>> ELSE IF GET(CAAR CODELIST,'NEGJMP) AND (Z := ATSOC(CAR CODELIST,LABS)) THEN <<X := CAR CODELIST; CODELIST := CDR CODELIST; Z := CDDR Z; WHILE CAR Y=CAR Z AND (CAAR Y EQ '!*STORE OR CAAR Y EQ '!*LOAD AND NOT CADAR Y=1) DO <<CODELIST := CAR Y . CODELIST; RPLACW(Z,CADR Z . CDDR Z); Y := CDR Y>>; CODELIST := X . CODELIST; Y := X . Y>> ELSE IF CAAR CODELIST EQ '!*JUMP AND (Z := ATSOC(CADAR CODELIST,TLABS)) AND (X := !&FINDBLK(CDR CODELIST, IF CAAR Y EQ '!*LBL THEN CADAR Y ELSE NIL)) THEN BEGIN SCALAR W; IF NOT CAADR X EQ '!*LBL THEN <<IF NOT CAAR X EQ '!*LBL THEN X := CDR RPLACD(X, ('!*LBL . !&GENLBL()) . CDR X); W := GET(CAADR X,'NEGJMP) . (CADAR X . CDDADR X); !&REMJMP CDR X; RPLACD(X,W . (CADR X . CDDR X)); !&ADDJMP CDR X>> ELSE X := CDR X; W := NIL; REPEAT <<W := CAR Y . W; Y := CDR Y>> UNTIL Y EQ CDR Z; RPLACD(X,NCONC(W,CDR X)); !&REMJMP CODELIST; TLABS := NIL; %since code chains have changed; CODELIST := NIL . (CAR Y . CODELIST); Y := CDR Y END ELSE Y := CAR CODELIST . Y; CODELIST := CDR CODELIST>>; CODELIST := Y END; SYMBOLIC PROCEDURE !&NOLOADP(ARGS,INSTRS); %determines if a LOAD is not necessary in instruction stream; ATOM CADR ARGS AND (CAAR INSTRS EQ '!*LOAD AND CDAR INSTRS=ARGS OR CAAR INSTRS EQ '!*STORE AND (CDAR INSTRS=ARGS OR NOT CADDAR INSTRS=CADR ARGS AND !&NOLOADP(ARGS,CDR INSTRS))); SYMBOLIC PROCEDURE !&FIXCHN(U,V); BEGIN SCALAR X; WHILE CAR U=CAR V DO <<!&MOVEUP U; V := CDR V>>; X := !&GENLBL(); IF CAAR V EQ '!*LBL THEN !&RECHAIN(X,CDAR V) ELSE RPLACW(V,('!*LBL . X) . (CAR V . CDR V)); IF CAAR U EQ '!*LBL THEN <<!&RECHAIN(CDAR U,X); !&MOVEUP U>>; IF CAAR U EQ '!*JUMP THEN RETURN NIL; RPLACW(U,('!*JUMP . X) . (CAR U . CDR U)); !&ADDJMP U END; SYMBOLIC PROCEDURE !&FIXFRM; BEGIN SCALAR HOLES,LST,X,Y,Z; INTEGER N; IF NULL STLST AND NULL FREELST THEN RETURN RPLACA(LLNGTH,1); N := 0; WHILE NOT N<CAR LLNGTH DO <<Y := NIL; FOR EACH LST IN STLST DO IF N=CADDR LST THEN Y := CDDR LST . Y; FOR EACH LST IN FREELST DO IF N=CAR LST THEN Y := LST . Y; IF NULL Y THEN HOLES := N . HOLES ELSE Z := (N . Y) . Z; N := N - 1>>; Y := Z; IF CAAR Z>CAR LLNGTH THEN RPLACA(LLNGTH,CAAR Z); WHILE HOLES DO <<WHILE HOLES AND CAR HOLES<CAR LLNGTH DO HOLES := CDR HOLES; IF HOLES THEN <<HOLES := REVERSIP HOLES; FOR EACH X IN CDAR Z DO RPLACA(X,CAR HOLES); RPLACA(LLNGTH, IF NULL CDR Z OR CAR HOLES<CAADR Z THEN CAR HOLES ELSE CAADR Z); HOLES := REVERSIP CDR HOLES; Z := CDR Z>>>>; %now see if we can map frame to registers; N := IF NARG<3 THEN 3 ELSE NARG + 1; IF FREELST OR NULL !®P CODELIST OR CAR LLNGTH<N - MAXNARGS THEN RETURN NIL; FOR EACH X IN STLST DO RPLACW(X, LIST('!*LOAD, N - CADDR X, IF NULL CADR X THEN '(QUOTE NIL) ELSE CADR X)); WHILE Y DO <<FOR EACH X IN CDAR Y DO NOT CAR X>0 AND RPLACA(X,N - CAR X); %first test makes sure replacement only occurs once; Y := CDR Y>>; RPLACA(LLNGTH,1) END; SYMBOLIC PROCEDURE !®P U; %there is no test for !*LAMBIND/!*PROGBIND %since FREELST tested explicitly in !&FIXFRM; IF NULL CDR U THEN T ELSE IF CAAR U MEMQ '(!*LOAD !*STORE) AND NUMBERP CADAR U AND CADAR U>2 THEN NIL ELSE IF FLAGP(CAADR U,'UNKNOWNUSE) AND NOT (IDP CADADR U AND (FLAGP(CADADR U,'ONEREG) OR FLAGP(CADADR U,'TWOREG)) OR CAR U='!*JUMP . EXIT) THEN NIL ELSE !®P CDR U; FLAG('(!*CODE !*LINK !*LINKE),'UNKNOWNUSE); SYMBOLIC PROCEDURE !*CODE U; EVAL U; PUT('!*JUMPN,'NEGJMP,'!*JUMPE); PUT('!*JUMPE,'NEGJMP,'!*JUMPN); PUT('!*JUMPNIL,'NEGJMP,'!*JUMPT); PUT('!*JUMPT,'NEGJMP,'!*JUMPNIL); PUT('!*JUMPC,'NEGJMP,'!*JUMPNC); PUT('!*JUMPNC,'NEGJMP,'!*JUMPC); COMMENT Some arithmetic optimizations to reduce the amount of code generated; SYMBOLIC PROCEDURE !&PAPLUS2(U,VARS); IF CADDR U=1 THEN LIST('ADD1,!&PA1(CADR U,VARS)) ELSE IF CADR U=1 THEN LIST('ADD1,!&PA1(CADDR U,VARS)) ELSE 'PLUS2 . !&PALIS(CDR U,VARS); PUT('PLUS2,'PA1FN,'!&PAPLUS2); SYMBOLIC PROCEDURE !&PADIFF(U,VARS); IF CADDR U=1 THEN LIST('SUB1,!&PA1(CADR U,VARS)) ELSE 'DIFFERENCE . !&PALIS(CDR U,VARS); PUT('DIFFERENCE,'PA1FN,'!&PADIFF); SYMBOLIC PROCEDURE !&PALESSP(U,VARS); IF CADDR U=0 THEN LIST('MINUSP,!&PA1(CADR U,VARS)) ELSE 'LESSP . !&PALIS(CDR U,VARS); PUT('LESSP,'PA1FN,'!&PALESSP); COMMENT removing unnecessary calls to MINUS; SYMBOLIC PROCEDURE !&PAMINUS(U,VARS); IF EQCAR(U := !&PA1(CADR U,VARS),'QUOTE) AND NUMBERP CADR U THEN MKQUOTE ( - CADR U) ELSE LIST('MINUS,U); PUT('MINUS,'PA1FN,'!&PAMINUS); END;