%********************************************************************* 00000100 %********************************************************************* 00000200 % THE STANDARD LISP COMPILER 00000300 %********************************************************************; 00000400 %********************************************************************; 00000500 00000600 00000700 COMMENT machine dependent parts are in a separate file; 00000800 00000900 COMMENT these include the macros described below and, in addition, 00001000 an auxiliary function !&MKFUNC which is required to pass 00001100 functional arguments (input as FUNCTION ) to the 00001200 loader. In most cases, !&MKFUNC may be defined as MKQUOTE; 00001300 00001400 00001500 COMMENT general functions used in this compiler; 00001600 00001700 SYMBOLIC PROCEDURE ATSOC(U,V); 00001800 IF NULL V THEN NIL 00001900 ELSE IF U EQ CAAR V THEN CAR V 00002000 ELSE ATSOC(U,CDR V); 00002100 00002200 SYMBOLIC PROCEDURE EQCAR(U,V); 00002300 NOT ATOM U AND CAR U EQ V; 00002400 00002500 GLOBAL '(ERFG!*); 00002600 00002700 SYMBOLIC PROCEDURE LPRI U; 00002800 IF ATOM U THEN LPRI LIST U 00002900 ELSE FOR EACH X IN U DO <>; 00003000 00003100 SYMBOLIC PROCEDURE LPRIE U; 00003200 <>; 00003500 00003600 SYMBOLIC PROCEDURE LPRIM U; 00003700 <>; 00004000 00004100 SYMBOLIC PROCEDURE MKQUOTE U; 00004200 LIST('QUOTE,U); 00004300 00004400 SYMBOLIC PROCEDURE REVERSIP U; 00004500 BEGIN SCALAR X,Y; 00004600 WHILE U DO <>; 00004700 RETURN Y 00004800 END; 00004900 00005000 SYMBOLIC PROCEDURE RPLACW(A,B); 00005100 RPLACA(RPLACD(A,CDR B),CAR B); 00005200 00005300 COMMENT the following two functions are used by the CONS open 00005400 coding. They should be defined in the interpreter if 00005500 possible. They should only be compiled without a COMPFN 00005600 for CONS; 00005700 00005800 SYMBOLIC PROCEDURE NCONS U; U . NIL; 00005900 00006000 SYMBOLIC PROCEDURE XCONS(U,V); V . U; 00006100 00006200 00006300 COMMENT Registers used: 00006400 1-MAXNARGS used for args of link. result returned in reg 1; 00006500 00006600 COMMENT Macros used in this compiler; 00006700 00006800 COMMENT The following macros must NOT change regs 1-MAXNARGS: 00006900 00007000 !*ALLOC nw allocate new stack frame of nw words 00007100 !*DEALLOC nw deallocate above frame 00007200 !*ENTRY name type noargs entry point to function name of type type 00007300 with noargs args 00007400 !*FREERSTR alst unbind free variables in alst 00007500 !*JUMP adr unconditional jump 00007600 !*JUMPNIL adr jump on register 1 NIL 00007700 !*JUMPT adr jump on register 1 not NIL 00007800 !*JUMPE adr exp jump on register 1 equal to exp 00007900 !*JUMPN adr exp jump on register 1 not equal to exp 00008000 !*LBL adr define label 00008100 !*LAMBIND regs alst bind free lambda vars in alst currently in regs 00008200 !*PROGBIND alst bind free prog vars in alst 00008300 !*EXIT exit to previously saved return address 00008400 !*STORE reg floc store contents of reg (or NIL) in floc 00008500 00008600 COMMENT the following macro must only change specific register being 00008700 loaded: 00008800 00008900 !*LOAD reg exp load exp into reg; 00009000 00009100 COMMENT the following macros do not protect regs 1-MAXNARGS: 00009200 00009300 !*LINK fn nargs link to fn with nargs args 00009400 !*LINKE fn nargs nw link to fn with nargs args and exit 00009500 removing frame of nw words; 00009600 00009700 00009800 COMMENT variable types are: 00009900 00010000 LOCAL allocated on stack and known only locally 00010100 GLOBAL accessed via cell (GLOBAL name) known to 00010200 loader at load time 00010300 FLUID accessed via cell (FLUID name) 00010400 known to loader. This cell is rebound by LAMBIND/ 00010500 PROGBIND if variable used in lambda/prog list 00010600 and restored by FREERSTR; 00010700 00010800 00010900 COMMENT global flags used in this compiler: 00011000 00011100 !*MODULE indicates block compilation (a future extension of 00011200 this compiler) 00011300 !*NOLINKE if ON inhibits use of !*LINKE macro 00011400 !*ORD if ON forces left-to-right argument evaluation 00011500 !*PLAP if ON causes LAP output to be printed 00011600 !*R2I if ON causes recursion removal where possible 00011700 !*SAVEDEF if ON causes old (uncompiled) definition to remain 00011800 and saves compiled macros with indicator COMPEXP; 00011900 00012000 GLOBAL '(!*MODULE !*NOLINKE !*ORD !*PLAP !*R2I !*SAVEDEF); 00012100 00012200 COMMENT global variables used: 00012300 00012400 DFPRINT!* name of special definition process (or NIL) 00012500 ERFG!* used by REDUCE to control error recovery 00012600 MAXNARGS number of arguments in true registers; 00012700 00012800 GLOBAL '(DFPRINT!* MAXNARGS); 00012900 00013000 MAXNARGS := 15; %Standard LISP limit; 00013100 00013200 00013300 COMMENT fluid variables used: 00013400 00013500 ALSTS alist of fluid parameters 00013600 FLAGG used in COMTST, and in FIXUP2 00013700 FREELST list of free variables with bindings 00013800 GOLIST storage map for jump labels 00013900 IREGS initial register contents 00014000 CODELIST code being built 00014100 CONDTAIL simulated stack of position in the tail of a COND 00014200 LLNGTH cell whose CAR is length of frame 00014300 NAME name of function being currently compiled 00014400 FNAME!& name of function being currently compiled, set by COMPILE 00014500 NARG number of arguments in function 00014600 REGS known current contents of registers as an alist with elements 00014700 of form ( . ) 00014800 EXIT label for *EXIT jump 00014900 LBLIST list of label words 00015000 JMPLIST list of locations in CODELIST of transfers 00015100 SLST association list for stores which have not yet been used 00015200 STLST list of active stores in function 00015300 STOMAP storage map for variables 00015400 SWITCH boolean expression value flag - keeps track of NULLs; 00015500 00015600 FLUID '(ALSTS FLAGG NAME FNAME!& GOLIST IREGS CODELIST CONDTAIL 00015700 LLNGTH NARG REGS EXIT LBLIST JMPLIST SLST STLST STOMAP 00015800 SWITCH REGS1 IREGS1 FREELST); 00015900 00016000 00016100 SYMBOLIC PROCEDURE COMPILE X; 00016200 BEGIN SCALAR EXP,FNAME!&; 00016300 WHILE X DO 00016400 <> 00016900 END; 00017000 00017100 SYMBOLIC PROCEDURE COMPD(NAME,TYPE,EXP); 00017200 BEGIN SCALAR CTYPE; 00017300 IF TYPE EQ 'EXPR THEN CTYPE := 'SUBR 00017400 ELSE IF TYPE EQ 'FEXPR THEN CTYPE := 'FSUBR 00017500 ELSE IF FLAGP(TYPE,'COMPILE) THEN CTYPE:=TYPE 00017600 ELSE <>; 00017800 IF LENGTH CADR EXP>MAXNARGS 00017900 THEN LPRIE LIST("TOO MANY ARGS FOR COMPILER IN",NAME) 00018000 ELSE IF NOT ATOM EXP 00018100 THEN IF !*MODULE THEN MODCMP(NAME,TYPE,EXP) 00018200 ELSE IF DFPRINT!* 00018300 THEN APPLY(DFPRINT!*, 00018400 LIST IF TYPE EQ 'EXPR THEN 'DE . NAME . CDR EXP 00018500 ELSE IF TYPE EQ 'FEXPR 00018600 THEN 'DF . NAME . CDR EXP 00018700 ELSE LIST('PUTD,MKQUOTE NAME,MKQUOTE TYPE, 00018800 MKQUOTE EXP)) 00018900 ELSE BEGIN SCALAR X; 00019000 IF CTYPE EQ 'FSUBR THEN FLAG(LIST NAME,'FEXPR) 00019100 ELSE IF CTYPE EQ 'SUBR THEN FLAG(LIST NAME,'EXPR); 00019200 X := LIST('!*ENTRY,NAME,CTYPE,LENGTH CADR EXP) . 00019300 !&COMPROC(EXP,NAME); 00019400 IF !*PLAP THEN FOR EACH Y IN X DO PRINT Y; 00019500 IF !*SAVEDEF THEN PUT(NAME,'COMPEXP,TYPE . X) 00019600 ELSE LAP X; %LAP must remove old function; 00019700 IF (X:=GETD NAME) AND (CAR X EQ CTYPE OR CAR X EQ TYPE) 00019800 THEN REMFLAG(LIST NAME,TYPE); 00019900 END; 00020000 RETURN NAME 00020100 END; 00020200 00020300 SYMBOLIC PROCEDURE !&COMPROC(EXP,NAME); 00020400 %compiles a function body, returning the generated LAP; 00020500 BEGIN SCALAR CODELIST,FLAGG,IREGS,IREGS1,JMPLIST,LBLIST,LLNGTH, 00020600 REGS,REGS1,ALSTS,EXIT,SLST,STLST,STOMAP,CONDTAIL; 00020700 SCALAR REGS1,IREGS1,FREELST,SWITCH; 00020800 INTEGER NARG; 00020900 LLNGTH := LIST 1; 00021000 NARG := 0; 00021100 EXIT := !&GENLBL(); 00021200 STOMAP := '((NIL 1)); 00021300 CODELIST := LIST ('!*ALLOC . LLNGTH); 00021400 EXP := !&PASS1 EXP; 00021500 FOR EACH Z IN CADR EXP DO 00021600 <>; 00022100 IF NULL REGS THEN REGS := LIST(1 . NIL); 00022200 ALSTS := !&FREEBIND(CADR EXP,T); 00022300 !&PASS2 CADDR EXP; 00022400 !&FREERSTR(ALSTS,0); 00022500 !&PASS3(); 00022600 RPLACA(LLNGTH,1-CAR LLNGTH); 00022700 RETURN CODELIST 00022800 END; 00022900 00023000 SYMBOLIC PROCEDURE NONLOCAL X; 00023100 IF FLUIDP X THEN 'FLUID 00023200 ELSE IF GLOBALP X THEN 'GLOBAL 00023300 ELSE NIL; 00023400 00023500 FLUID '(VBLS); 00023600 00023700 SYMBOLIC PROCEDURE !&PASS1 EXP; !&PA1(EXP,NIL); 00023800 00023900 SYMBOLIC PROCEDURE !&PA1(U,VBLS); 00024000 BEGIN SCALAR X; 00024100 RETURN 00024200 IF ATOM U THEN IF CONSTANTP U OR U MEMQ '(NIL T) 00024300 THEN MKQUOTE U 00024400 ELSE IF U MEMBER VBLS THEN U 00024500 ELSE IF GLOBALP U OR FLUIDP U THEN U 00024600 ELSE <> 00024700 ELSE IF NOT ATOM CAR U THEN !&PA1(CAR U,VBLS) . !&PALIS(CDR U,VBLS) 00024800 ELSE IF (X := GETD CAR U) 00024900 AND CAR X EQ 'MACRO AND NOT GET(CAR U,'COMPFN) 00025000 THEN !&PA1(APPLY(CDR X,LIST U),VBLS) 00025100 ELSE IF CAR U EQ 'NOT THEN !&PA1('NULL . CDR U,VBLS) 00025200 ELSE IF CAR U EQ 'COND 00025300 THEN 'COND . 00025400 FOR EACH Z IN CDR U 00025500 COLLECT LIST(!&PA1(CAR Z,VBLS),!&PA1(CADR Z,VBLS)) 00025600 ELSE IF CAR U MEMBER '(GO QUOTE) THEN U 00025700 ELSE IF CAR U EQ 'LAMBDA 00025800 THEN 'LAMBDA . CADR U . !&PALIS(CDDR U,APPEND(CADR U,VBLS)) 00025900 ELSE IF CAR U EQ 'FUNCTION THEN IF ATOM CADR U THEN !&MKFUNC CADR U 00026000 ELSE !&MKFUNC COMPD(!&MKNAM NAME,'EXPR,CADR U) 00026100 ELSE IF X := GET(CAR U,'PA1FN) THEN APPLY(X,LIST(U,VBLS)) 00026200 ELSE IF CAR U EQ 'PROG 00026300 THEN 'PROG . CADR U . !&PAPROG(CDDR U,APPEND(CADR U,VBLS)) 00026400 ELSE IF FLAGP(CAR U,'FEXPR) 00026500 OR NOT FLAGP(CAR U,'EXPR) AND (X := GETD CAR U) 00026600 AND CAR X MEMQ '(FEXPR FSUBR) 00026700 AND NOT GET(CAR U,'COMPFN) 00026800 THEN <> 00027000 ELSE CAR U . !&PALIS(CDR U,VBLS) 00027100 END; 00027200 00027300 SYMBOLIC PROCEDURE !&PALIS(U,VBLS); 00027400 FOR EACH X IN U COLLECT !&PA1(X,VBLS); 00027500 00027600 SYMBOLIC PROCEDURE !&PAPROG(U,VBLS); 00027700 FOR EACH X IN U COLLECT IF ATOM X THEN X ELSE !&PA1(X,VBLS); 00027800 00027900 SYMBOLIC PROCEDURE MKNONLOCAL U; 00028000 %make an undeclared non-local variable FLUID; 00028100 <>; 00028200 00028300 SYMBOLIC PROCEDURE !&MKNAM U; 00028400 %generates unique name for auxiliary function in U; 00028500 INTERN COMPRESS APPEND(EXPLODE U,EXPLODE GENSYM()); 00028600 00028700 UNFLUID '(VBLS); 00028800 00028900 SYMBOLIC PROCEDURE !&PASS2 EXP; !&COMVAL(EXP,0); 00029000 00029100 SYMBOLIC PROCEDURE !&COMVAL(EXP,STATUS); 00029200 %computes code for value of EXP; 00029300 IF !&ANYREG(EXP,NIL) THEN IF STATUS>1 THEN NIL 00029400 ELSE !&LREG1(EXP,STATUS) 00029500 ELSE !&COMVAL1(EXP,STOMAP,STATUS); 00029600 00029700 SYMBOLIC PROCEDURE !&COMVAL1(EXP,STOMAP,STATUS); 00029800 BEGIN SCALAR X; 00029900 IF ATOM EXP THEN IF STATUS<2 THEN !&LREG1(EXP,STATUS) ELSE NIL 00030000 ELSE IF NOT ATOM CAR EXP 00030100 THEN IF CAAR EXP EQ 'LAMBDA 00030200 THEN !&COMPLY(CAR EXP,CDR EXP,STATUS) 00030300 ELSE !&COMVAL(LIST('APPLY,CAR EXP,!&PALIST CDR EXP), 00030400 STATUS) 00030500 ELSE IF X := GET(CAR EXP,'COMPFN) THEN APPLY(X,LIST(EXP,STATUS)) 00030600 ELSE IF ATSOC(CAR EXP,STOMAP) 00030700 THEN !&COMVAL(LIST('APPLY,CAR EXP,!&PALIST CDR EXP),STATUS) 00030800 ELSE IF !*R2I AND CAR EXP EQ NAME AND STATUS=0 AND NULL FREELST 00030900 THEN !&COMREC(EXP,STATUS) 00031000 ELSE !&CALL(CAR EXP,CDR EXP,STATUS); 00031100 RETURN NIL 00031200 END; 00031300 00031400 SYMBOLIC PROCEDURE !&ANYREG(U,V); 00031500 %determines if U can be loaded in any register; 00031600 %!*ORD = T means force correct order, unless safe; 00031700 NOT ATOM U AND CAR U EQ 'QUOTE 00031800 OR ((IF ATOM U 00031900 THEN NOT NONLOCAL U AND ATSOC(U,STOMAP) 00032000 OR !&ANYREGL V 00032100 ELSE GET(CAR U,'ANYREG) AND !&ANYREG(CADR U,NIL)) 00032200 AND (NULL !*ORD OR !&ANYREGL V)); 00032300 00032400 SYMBOLIC PROCEDURE !&ANYREGL U; 00032500 NULL U OR !&ANYREG(CAR U,NIL) AND !&ANYREGL CDR U; 00032600 00032700 SYMBOLIC PROCEDURE !&CALL(FN,ARGS,STATUS); 00032800 !&CALL1(FN,!&COMLIS ARGS,STATUS); 00032900 00033000 SYMBOLIC PROCEDURE !&CALL1(FN,ARGS,STATUS); 00033100 %ARGS is reversed list of compiled arguments of FN; 00033200 BEGIN INTEGER ARGNO; 00033300 ARGNO := LENGTH ARGS; 00033400 !&LOADARGS(ARGS,STATUS); 00033500 !&ATTACH LIST('!*LINK,FN,ARGNO); 00033600 REGS := LIST (1 . NIL) 00033700 END; 00033800 00033900 SYMBOLIC PROCEDURE !&COMLIS EXP; 00034000 %returns reversed list of compiled arguments; 00034100 BEGIN SCALAR ACUSED,Y; 00034200 WHILE EXP DO 00034300 <>; 00034900 EXP := CDR EXP>>; 00035000 RETURN Y 00035100 END; 00035200 00035300 SYMBOLIC PROCEDURE !&STORE1(); 00035400 %Marks contents of register 1 for storage; 00035500 BEGIN SCALAR X; 00035600 X := CADAR REGS; 00035700 IF NULL X OR EQCAR(X,'QUOTE) THEN RETURN NIL 00035800 ELSE IF NOT ATSOC(X,STOMAP) THEN !&FRAME X; 00035900 !&STORE(X,1) 00036000 END; 00036100 00036200 SYMBOLIC PROCEDURE !&COMPLY(FN,ARGS,STATUS); 00036300 BEGIN SCALAR ALSTS,VARS; INTEGER N,I; 00036400 VARS := CADR FN; 00036500 ARGS := !&COMLIS ARGS; 00036600 N := LENGTH ARGS; 00036700 IF N>MAXNARGS THEN LPRIE LIST("TOO MANY LAMBDA ARGS IN ",NAME); 00036800 !&LOADARGS(ARGS,1); 00036900 ARGS:=!&REMVARL VARS; % The stores that were protected; 00037000 I:=1; 00037100 FOR EACH V IN VARS DO <>; 00037400 ALSTS := !&FREEBIND(VARS,T); %Old fluid values saved; 00037500 I:=1; 00037600 FOR EACH V IN VARS DO 00037700 <>; 00037900 !&COMVAL(CADDR FN,STATUS); 00038000 !&FREERSTR(ALSTS,STATUS); 00038100 % Should now REMVAR names again, ? BEFORE OR AFTER ? ; 00038200 !&RSTVARL(VARS,ARGS) 00038300 END; 00038400 00038500 SYMBOLIC PROCEDURE !&COMREC(EXP,STATUS); 00038600 BEGIN SCALAR X,Z; 00038700 !&LOADARGS(!&COMLIS CDR EXP,STATUS); 00038800 Z := CODELIST; 00038900 WHILE CDDR Z DO Z := CDR Z; 00039000 IF CAAR Z EQ '!*LBL THEN X := CDAR Z 00039100 ELSE <>; 00039300 !&ATTJMP X 00039400 END; 00039500 00039600 SYMBOLIC PROCEDURE !&LOADARGS(ARGS,STATUS); 00039700 BEGIN INTEGER N; 00039800 N := LENGTH ARGS; 00039900 IF N>MAXNARGS THEN LPRIE LIST("TOO MANY ARGUMENTS IN",NAME); 00040000 IF STATUS>0 THEN !&CLRREGS(); 00040100 WHILE ARGS DO 00040200 <>; 00040400 END; 00040500 00040600 SYMBOLIC PROCEDURE !&LOCATE X; 00040700 BEGIN SCALAR Y,VTYPE; 00040800 IF EQCAR(X,'QUOTE) THEN RETURN LIST X 00040900 ELSE IF Y := !&RASSOC(X,REGS) 00041000 THEN RETURN LIST CAR Y 00041100 ELSE IF NOT ATOM X THEN RETURN LIST(CAR X . !&LOCATE CADR X) 00041200 ELSE IF (VTYPE := NONLOCAL X) THEN RETURN LIST LIST(VTYPE,X); 00041300 WHILE Y := ATSOC(X,SLST) DO SLST := DELETE(Y,SLST); 00041400 RETURN IF Y := ATSOC(X,STOMAP) THEN CDR Y 00041500 ELSE LIST MKNONLOCAL X 00041600 END; 00041700 00041800 SYMBOLIC PROCEDURE !&LREG(REG,U,V,STATUS); 00041900 BEGIN SCALAR X,Y; 00042000 IF (X := ASSOC(REG,REGS)) AND U MEMBER CDR X THEN RETURN NIL 00042100 ELSE IF (Y := ASSOC(REG,IREGS)) 00042200 AND (STATUS>0 OR !&MEMLIS(CADR Y,V)) 00042300 THEN <>; 00042400 !&ATTACH ('!*LOAD . REG . !&LOCATE U); 00042500 REGS := !&REPASC(REG,U,REGS) 00042600 END; 00042700 00042800 SYMBOLIC PROCEDURE !&LREG1(X,STATUS); 00042900 !&LREG(1,X,NIL,STATUS); 00043000 00043100 SYMBOLIC PROCEDURE !&PALIST U; 00043200 'LIST . U; 00043300 00043400 00043500 COMMENT Functions for Handling Non-local Variables; 00043600 00043700 SYMBOLIC PROCEDURE !&FREEBIND(VARS,LAMBP); 00043800 %bind FLUID variables in lambda or prog lists; 00043900 %LAMBP is true for LAMBDA, false for PROG; 00044000 BEGIN SCALAR FALST,FREGS,X,Y; INTEGER I; 00044100 I := 1; 00044200 FOR EACH X IN VARS DO 00044300 <> 00044600 ELSE IF GLOBALP X 00044700 THEN LPRIE LIST("CANNOT BIND GLOBAL ",X); 00044800 I := I+1>>; 00044900 IF NULL FALST THEN RETURN NIL; 00045000 IF LAMBP THEN !&ATTACH LIST('!*LAMBIND,FREGS,FALST) 00045100 ELSE !&ATTACH LIST('!*PROGBIND,FALST); 00045200 RETURN FALST 00045300 END; 00045400 00045500 SYMBOLIC PROCEDURE !&FREERSTR(ALSTS,STATUS); 00045600 %restores FLUID variables; 00045700 IF ALSTS THEN !&ATTACH LIST('!*FREERSTR,ALSTS); 00045800 00045900 SYMBOLIC PROCEDURE !&ATTACH U; 00046000 CODELIST := U . CODELIST; 00046100 00046200 SYMBOLIC PROCEDURE !&STORE(U,REG); 00046300 %marks expression U in register REG for storage; 00046400 BEGIN SCALAR X; 00046500 X := '!*STORE . REG . !&GETFRM U; 00046600 STLST := X . STLST; 00046700 !&ATTACH X; 00046800 IF NULL CONDTAIL AND (X := ATSOC(U,SLST)) 00046900 THEN <>; 00047200 IF ATOM U THEN SLST := (U . CODELIST) . SLST 00047300 END; 00047400 00047500 00047600 COMMENT Functions for general tests; 00047700 00047800 SYMBOLIC PROCEDURE !&COMTST(EXP,LABL); 00047900 %compiles boolean expression EXP. 00048000 %If EXP has the same value as SWITCH then branch to LABL, 00048100 %otherwise fall through; 00048200 %REGS/IREGS are active registers for fall through, 00048300 %REGS1/IREGS1 for branch; 00048400 BEGIN SCALAR X; 00048500 WHILE EQCAR(EXP,'NULL) DO 00048600 <>; 00048700 IF NOT ATOM EXP AND ATOM CAR EXP 00048800 AND (X := GET(CAR EXP,'COMTST)) 00048900 THEN APPLY(X,LIST(EXP,LABL)) 00049000 ELSE <>; 00049700 REGS1 := REGS; IREGS1 :=IREGS>>; 00049800 IF EQCAR(CAR CODELIST,'!*JUMPT) 00049900 THEN REGS := (1 . '(QUOTE NIL) . CDAR REGS) . CDR REGS 00050000 ELSE IF EQCAR(CAR CODELIST,'!*JUMPNIL) 00050100 THEN REGS1 := (1 . '(QUOTE NIL) . CDAR REGS1) . CDR REGS1 00050200 END; 00050300 00050400 COMMENT Specific Function Open Coding; 00050500 00050600 SYMBOLIC PROCEDURE !&COMANDOR(EXP,STATUS); 00050700 BEGIN SCALAR FN,LABL,IREGSL,REGSL; 00050800 FN := CAR EXP EQ 'AND; 00050900 LABL := !&GENLBL(); 00051000 IF STATUS>1 THEN BEGIN SCALAR REGS1; !&TSTANDOR(EXP,LABL); 00051100 REGS := !&RMERGE2(REGS,REGS1) END 00051200 ELSE BEGIN 00051300 IF STATUS>0 THEN !&CLRREGS(); 00051400 EXP := CDR EXP; 00051500 WHILE EXP DO 00051600 <>; 00052200 EXP := CDR EXP>>; 00052300 IREGS := !&RMERGE IREGSL; 00052400 REGS := !&RMERGE REGSL; 00052500 END; 00052600 !&ATTLBL LABL 00052700 END; 00052800 00052900 SYMBOLIC PROCEDURE !&TSTANDOR(EXP,LABL); 00053000 BEGIN SCALAR FLG,FLG1,FN,LAB2,REGSL,REGS1L,TAILP; 00053100 %FLG is initial switch condition; 00053200 %FN is appropriate AND/OR case; 00053300 %FLG1 determines appropriate switching state; 00053400 FLG := SWITCH; 00053500 SWITCH := NIL; 00053600 FN := CAR EXP EQ 'AND; 00053700 FLG1 := FLG EQ FN; 00053800 EXP := CDR EXP; 00053900 LAB2 := !&GENLBL(); 00054000 !&CLRREGS(); 00054100 WHILE EXP DO 00054200 <> 00054800 ELSE <> 00055300 ELSE <>>>; 00055600 IF NULL TAILP 00055700 THEN <>; 00055800 EXP := CDR EXP>>; 00055900 !&ATTLBL LAB2; 00056000 REGS := IF NOT FLG1 THEN CAR REGSL ELSE !&RMERGE REGSL; 00056100 REGS1 := IF FLG1 THEN CAR REGS1L ELSE !&RMERGE REGS1L; 00056200 IF TAILP THEN CONDTAIL := CDR CONDTAIL; 00056300 SWITCH := FLG 00056400 END; 00056500 00056600 PUT('AND,'COMPFN,'!&COMANDOR); 00056700 00056800 PUT('OR,'COMPFN,'!&COMANDOR); 00056900 00057000 SYMBOLIC PROCEDURE !&COMCOND(EXP,STATUS); 00057100 %compiles conditional expressions; 00057200 %registers REGS and IREGS are set for dropping through, 00057300 %REGS1 and IREGS1 are set for a branch; 00057400 BEGIN SCALAR IREGS1,REGS1,FLAGG,SWITCH,LAB1,LAB2, 00057500 REGSL,IREGSL,TAILP,TRANSFERP; 00057600 EXP := CDR EXP; 00057700 LAB1 := !&GENLBL(); 00057800 TRANSFERP := T; 00057900 IF STATUS>0 THEN !&CLRREGS(); 00058000 FOR EACH X IN EXP DO 00058100 <>; 00058700 !&COMVAL(CADR X,STATUS); % Branch code; 00058800 %test if need jump to LAB1; 00058900 IF NOT(FLAGP(CAAR CODELIST,'TRANSFER) 00059000 OR CAAR CODELIST EQ '!*LINK 00059100 AND FLAGP(CADAR CODELIST,'TRANSFER)) 00059200 THEN <>; 00059300 IREGSL := IREGS . IREGSL; 00059400 REGSL := REGS . REGSL; 00059500 REGS := REGS1; %restore register status for next iteration; 00059600 IREGS := IREGS1; 00059700 IREGS1 := NIL; 00059800 %we do not need to set REGS1 to NIL since all COMTSTs 00059900 %are required to set it; 00060000 !&ATTLBL LAB2>>; 00060100 IF NULL FLAGG AND STATUS<2 00060200 THEN <>; 00060500 %missing ELSE clause; 00060600 IF NULL TRANSFERP THEN <>; 00060800 !&ATTLBL LAB1; 00060900 IF TAILP THEN CONDTAIL := CDR CONDTAIL 00061000 END; 00061100 00061200 SYMBOLIC PROCEDURE !&RMERGE U; 00061300 IF NULL U THEN NIL ELSE !&RMERGE1(CAR U,CDR U); 00061400 00061500 SYMBOLIC PROCEDURE !&RMERGE1(U,V); 00061600 IF NULL V THEN U 00061700 ELSE !&RMERGE1(!&RMERGE2(U,CAR V),CDR V); 00061800 00061900 SYMBOLIC PROCEDURE !&RMERGE2(U,V); 00062000 IF NULL U OR NULL V THEN NIL 00062100 ELSE (LAMBDA X; 00062200 IF X THEN (CAAR U . XN(CDAR U,CDR X)) 00062300 . !&RMERGE2(CDR U,DELETE(X,V)) 00062400 ELSE !&RMERGE2(CDR U,V)) 00062500 ASSOC(CAAR U,V); 00062600 00062700 FLAG('(!*JUMP !*LINKE ERROR REDERR SYMERR),'TRANSFER); 00062800 00062900 PUT('COND,'COMPFN,'!&COMCOND); 00063000 00063100 SYMBOLIC PROCEDURE !&COMCONS(EXP,STATUS); 00063200 IF NULL (EXP := CDR EXP) OR NULL CDR EXP OR CDDR EXP 00063300 THEN LPRIE "MISMATCH OF ARGUMENTS" 00063400 ELSE IF CADR EXP= '(QUOTE NIL) 00063500 THEN !&CALL('NCONS,LIST CAR EXP,STATUS) 00063600 ELSE IF !&ANYREG(CADR EXP,NIL) 00063700 THEN !&CALL('CONS,EXP,STATUS) 00063800 ELSE !&CALL1('XCONS,REVERSIP !&COMLIS EXP,STATUS); 00063900 00064000 PUT('CONS,'COMPFN,'!&COMCONS); 00064100 00064200 SYMBOLIC PROCEDURE !&COMGO(EXP,STATUS); 00064300 IF STATUS>2 00064400 THEN <> 00064500 ELSE LPRIE "INVALID GO STATEMENT"; 00064600 00064700 PUT('GO,'COMPFN,'!&COMGO); 00064800 00064900 SYMBOLIC PROCEDURE !&COMLIST(EXP,STATUS); 00065000 %we only support explicit functions up to 5 registers here; 00065100 BEGIN SCALAR M,N,FN; 00065200 EXP := CDR EXP; 00065300 M := MIN(MAXNARGS,5); 00065400 N := LENGTH EXP; 00065500 IF N=0 THEN !&LREG1('(QUOTE NIL),STATUS) 00065600 ELSE IF N>M THEN !&COMVAL(!&COMLIST2 EXP,STATUS) 00065700 ELSE !&CALL(IF N=1 THEN 'NCONS 00065800 ELSE IF N=2 THEN 'LIST2 00065900 ELSE IF N=3 THEN 'LIST3 00066000 ELSE IF N=4 THEN 'LIST4 ELSE 'LIST5, 00066100 EXP,STATUS) 00066200 END; 00066300 00066400 SYMBOLIC PROCEDURE LIST2(U,V); U . V . NIL; 00066500 00066600 SYMBOLIC PROCEDURE LIST3(U,V,W); U . V . W . NIL; 00066700 00066800 SYMBOLIC PROCEDURE LIST4(U,V,W,X); U . V . W . X . NIL; 00066900 00067000 SYMBOLIC PROCEDURE LIST5(U,V,W,X,Y); U . V . W . X . Y . NIL; 00067100 00067200 SYMBOLIC PROCEDURE !&COMLIST2 EXP; 00067300 BEGIN SCALAR L1,N; 00067400 N := MIN(MAXNARGS,5); 00067500 WHILE N>0 DO 00067600 <>; 00067700 RETURN LIST('NCONC,'LIST . REVERSIP L1,'LIST . EXP) 00067800 END; 00067900 00068000 PUT('LIST,'COMPFN,'!&COMLIST); 00068100 00068200 COMMENT an alternative definition for COMLIST; 00068300 00068400 %SYMBOLIC PROCEDURE !&COMLIST(EXP,STATUS); 00068500 % Map to sequence of CONS's; 00068600 % !&COMVAL(!&COMLIST1 CDR EXP,STATUS); 00068700 00068800 %SYMBOLIC PROCEDURE !&COMLIST1 EXP; 00068900 % IF NULL EXP THEN '(QUOTE NIL) ; 00069000 % ELSE LIST('CONS,CAR EXP,!&COMLIST1 CDR EXP); 00069100 00069200 SYMBOLIC PROCEDURE !&PAMAP(U,VARS); 00069300 IF EQCAR(CADDR U,'FUNCTION) 00069400 THEN (LAMBDA X; LIST(CAR U,!&PA1(CADR U,VARS), 00069500 MKQUOTE IF ATOM X THEN X ELSE !&PA1(X,VARS))) 00069600 CADR CADDR U 00069700 ELSE CAR U . !&PALIS(CDR U,VARS); 00069800 00069900 PUT('MAP,'PA1FN,'!&PAMAP); 00070000 00070100 PUT('MAPC,'PA1FN,'!&PAMAP); 00070200 00070300 PUT('MAPCAN,'PA1FN,'!&PAMAP); 00070400 00070500 PUT('MAPCAR,'PA1FN,'!&PAMAP); 00070600 00070700 PUT('MAPCON,'PA1FN,'!&PAMAP); 00070800 00070900 PUT('MAPLIST,'PA1FN,'!&PAMAP); 00071000 00071100 SYMBOLIC PROCEDURE !&MAP(EXP,STATUS); 00071200 BEGIN SCALAR BODY,FN,LAB1,LAB2,MTYPE,ONP,RESULT,SLST1,VAR,X; 00071300 BODY := CADR EXP; FN := CADDR EXP; 00071400 LAB1 := !&GENLBL(); LAB2 := !&GENLBL(); 00071500 MTYPE := IF CAR EXP MEMQ '(MAPCAR MAPLIST) THEN 'CONS 00071600 ELSE IF CAR EXP MEMQ '(MAPCAN MAPCON) THEN 'NCONC 00071700 ELSE NIL; 00071800 ONP := CAR EXP MEMQ '(MAP MAPCON MAPLIST); 00071900 !&CLRREGS(); 00072000 IF MTYPE 00072100 THEN <>; 00072200 !&FRAME(VAR := GENSYM()); 00072300 !&COMVAL(BODY,1); 00072400 REGS := LIST LIST(1,VAR); 00072500 !&ATTLBL LAB1; 00072600 !&ATTACH LIST('!*JUMPNIL,CAR LAB2); 00072700 !&ADDJMP CODELIST; 00072800 !&STORE(VAR,1); 00072900 X := IF ONP THEN VAR ELSE LIST('CAR,VAR); 00073000 IF EQCAR(FN,'QUOTE) THEN FN := CADR FN; 00073100 SLST1 := SLST; %to allow for store in function body; 00073200 !&COMVAL(LIST(FN,X),IF MTYPE THEN 1 ELSE 3); 00073300 IF MTYPE 00073400 THEN <>; 00074000 SLST := XN(SLST,SLST1); 00074100 !&COMVAL(LIST('CDR,VAR),1); 00074200 !&ATTJMP LAB1; 00074300 !&ATTLBL LAB2; 00074400 IF MTYPE THEN <> 00074700 ELSE REGS := LIST LIST(1,MKQUOTE NIL); 00074800 END; 00074900 00075000 SYMBOLIC PROCEDURE XN(U,V); 00075100 IF NULL U THEN NIL 00075200 ELSE IF CAR U MEMBER V THEN CAR U . XN(CDR U,DELETE(CAR U,V)) 00075300 ELSE XN(CDR U,V); 00075400 00075500 PUT('MAP,'COMPFN,'!&MAP); 00075600 00075700 PUT('MAPC,'COMPFN,'!&MAP); 00075800 00075900 PUT('MAPCAN,'COMPFN,'!&MAP); 00076000 00076100 PUT('MAPCAR,'COMPFN,'!&MAP); 00076200 00076300 PUT('MAPCON,'COMPFN,'!&MAP); 00076400 00076500 PUT('MAPLIST,'COMPFN,'!&MAP); 00076600 00076700 SYMBOLIC PROCEDURE !&COMPROG(EXP,STATUS); 00076800 %compiles program blocks; 00076900 BEGIN SCALAR ALSTS,GOLIST,PG,PROGLIS,EXIT; INTEGER I; 00077000 PROGLIS := CADR EXP; 00077100 EXP := CDDR EXP; 00077200 EXIT := !&GENLBL(); 00077300 PG := !&REMVARL PROGLIS; %protect prog variables; 00077400 FOR EACH X IN PROGLIS DO !&FRAME X; 00077500 ALSTS := !&FREEBIND(PROGLIS,NIL); 00077600 FOR EACH X IN PROGLIS DO 00077700 IF NOT NONLOCAL X THEN !&STORE(X,NIL); 00077800 FOR EACH X IN EXP DO 00077900 IF ATOM X THEN GOLIST := (X . !&GENLBL()) . GOLIST; 00078000 WHILE EXP DO 00078100 <> 00078500 %since we do not know how we arrived here; 00078600 ELSE !&COMVAL(CAR EXP,IF STATUS>2 THEN 4 ELSE 3); 00078700 IF NULL CDR EXP AND STATUS<2 00078800 AND (ATOM CAR EXP OR NOT CAAR EXP MEMBER '(GO RETURN)) 00078900 THEN EXP := LIST '(RETURN (QUOTE NIL)) 00079000 ELSE EXP := CDR EXP>>; 00079100 !&ATTLBL EXIT; 00079200 IF CDR !&FINDLBL EXIT THEN REGS := LIST(1 . NIL); 00079300 !&FREERSTR(ALSTS,STATUS); 00079400 !&RSTVARL(PROGLIS,PG) 00079500 END; 00079600 00079700 PUT('PROG,'COMPFN,'!&COMPROG); 00079800 00079900 SYMBOLIC PROCEDURE !&REMVARL VARS; 00080000 FOR EACH X IN VARS COLLECT !&REMVAR X; 00080100 00080200 SYMBOLIC PROCEDURE !&REMVAR X; 00080300 %removes references to variable X from IREGS and REGS 00080400 %and protects SLST; 00080500 BEGIN 00080600 FOR EACH Y IN IREGS DO 00080700 IF X EQ CADR Y THEN <>; 00080900 FOR EACH Y IN REGS DO 00081000 WHILE X MEMBER CDR Y DO RPLACD(Y,!&DELEQ(X,CDR Y)); 00081100 RETURN !&PROTECT X 00081200 END; 00081300 00081400 SYMBOLIC PROCEDURE !&PROTECT U; 00081500 BEGIN SCALAR X; 00081600 IF (X := ATSOC(U,SLST)) THEN SLST := !&DELEQ(X,SLST); 00081700 RETURN X 00081800 END; 00081900 00082000 SYMBOLIC PROCEDURE !&RSTVARL(VARS,LST); 00082100 WHILE VARS DO 00082200 <>; 00082300 00082400 SYMBOLIC PROCEDURE !&RSTVAR(VAR,VAL); 00082500 BEGIN 00082600 FOR EACH X IN IREGS DO 00082700 IF VAR EQ CADR X THEN <>; 00082900 FOR EACH X IN REGS DO 00083000 WHILE VAR MEMBER CDR X DO RPLACD(X,!&DELEQ(VAR,CDR X)); 00083100 !&CLRSTR VAR; 00083200 !&UNPROTECT VAL 00083300 END; 00083400 00083500 SYMBOLIC PROCEDURE !&CLRSTR VAR; 00083600 %removes unneeded stores; 00083700 BEGIN SCALAR X; 00083800 IF CONDTAIL THEN RETURN NIL; 00083900 X := ATSOC(VAR,SLST); 00084000 IF NULL X THEN RETURN NIL; 00084100 STLST := !&DELEQ(CADR X,STLST); 00084200 SLST := !&DELEQ(X,SLST); 00084300 RPLACA(CADR X,'!*NOOP) 00084400 END; 00084500 00084600 SYMBOLIC PROCEDURE !&UNPROTECT VAL; 00084700 %restores VAL to SLST; 00084800 IF VAL THEN SLST := VAL . SLST; 00084900 00085000 SYMBOLIC PROCEDURE !&COMPROGN(EXP,STATUS); 00085100 BEGIN 00085200 EXP := CDR EXP; 00085300 WHILE CDR EXP DO 00085400 <>; 00085600 !&COMVAL(CAR EXP,STATUS) 00085700 END; 00085800 00085900 PUT('PROG2,'COMPFN,'!&COMPROGN); 00086000 PUT('PROGN,'COMPFN,'!&COMPROGN); 00086100 00086200 SYMBOLIC PROCEDURE !&COMRETURN(EXP,STATUS); 00086300 <>; 00086600 00086700 PUT('RETURN,'COMPFN,'!&COMRETURN); 00086800 00086900 SYMBOLIC PROCEDURE !&COMSETQ(EXP,STATUS); 00087000 BEGIN SCALAR X; 00087100 EXP := CDR EXP; 00087200 IF STATUS>1 AND (NULL CADR EXP OR CADR EXP='(QUOTE NIL)) 00087300 THEN !&STORE2(CAR EXP,NIL) 00087400 ELSE <> 00087900 END; 00088000 00088100 SYMBOLIC PROCEDURE !&REMSETVAR(U,V); 00088200 IF NULL U THEN NIL 00088300 ELSE (CAAR U . !&REMS1(CDAR U,V)) . !&REMSETVAR(CDR U,V); 00088400 00088500 SYMBOLIC PROCEDURE !&REMS1(U,V); 00088600 IF NULL U THEN NIL 00088700 ELSE IF ATOM U 00088800 THEN IF U EQ V THEN !&REMS1(CDR U,V) 00088900 ELSE CAR U . !&REMS1(CDR U,V) 00089000 ELSE IF CAR U EQ 'QUOTE OR NOT V MEMBER FLATTEN CAR U 00089100 THEN CAR U . !&REMS1(CDR U,V) 00089200 ELSE !&REMS1(CDR U,V); 00089300 00089400 SYMBOLIC PROCEDURE FLATTEN U; 00089500 IF NULL U THEN NIL 00089600 ELSE IF ATOM U THEN LIST U 00089700 ELSE IF ATOM CAR U THEN CAR U . FLATTEN CDR U 00089800 ELSE NCONC(FLATTEN CAR U,FLATTEN CDR U); 00089900 00090000 SYMBOLIC PROCEDURE !&STORE2(U,V); 00090100 BEGIN SCALAR VTYPE; 00090200 REGS := !&REMSETVAR(REGS,U); 00090300 IF VTYPE := NONLOCAL U 00090400 THEN !&ATTACH LIST('!*STORE,V,LIST(VTYPE,U)) 00090500 ELSE IF NOT ATSOC(U,STOMAP) 00090600 THEN !&ATTACH LIST('!*STORE,V,MKNONLOCAL U) 00090700 ELSE !&STORE(U,V); 00090800 END; 00090900 00091000 PUT('SETQ,'COMPFN,'!&COMSETQ); 00091100 00091200 00091300 COMMENT Specific Test Open Coding; 00091400 00091500 PUT('AND,'COMTST,'!&TSTANDOR); 00091600 PUT('OR,'COMTST,'!&TSTANDOR); 00091700 00091800 SYMBOLIC PROCEDURE !&CEQ(EXP,LABL); 00091900 BEGIN SCALAR U,V,W; 00092000 U := CADR EXP; 00092100 V := CADDR EXP; 00092200 IF U MEMBER CDAR REGS THEN W := !&CEQ1(V,U) 00092300 ELSE IF V MEMBER CDAR REGS THEN W := !&CEQ1(U,V) 00092400 ELSE IF !&ANYREG(V,NIL) THEN <> 00092600 ELSE IF !&ANYREG(U,LIST V) THEN <> 00092800 ELSE <>; 00092900 !&ATTACH ((IF SWITCH THEN '!*JUMPE ELSE '!*JUMPN) 00093000 . CAR LABL . W); 00093100 IREGS1 := IREGS; REGS1 := REGS; 00093200 !&ADDJMP CODELIST 00093300 END; 00093400 00093500 SYMBOLIC PROCEDURE !&CEQ1(U,V); 00093600 IF !&ANYREG(U,LIST V) THEN !&LOCATE U 00093700 ELSE <>; 00093800 00093900 PUT('EQ,'COMTST,'!&CEQ); 00094000 00094100 00094200 COMMENT Support Functions; 00094300 00094400 SYMBOLIC PROCEDURE !&MEMLIS(U,V); 00094500 V AND (!&MEMB(U,CAR V) OR !&MEMLIS(U,CDR V)); 00094600 00094700 SYMBOLIC PROCEDURE !&MEMB(U,V); 00094800 IF ATOM V THEN U EQ V ELSE !&MEMB(U,CADR V); 00094900 00095000 SYMBOLIC PROCEDURE !&RASSOC(U,V); 00095100 IF NULL V THEN NIL 00095200 ELSE IF U MEMBER CDAR V THEN CAR V 00095300 ELSE !&RASSOC(U,CDR V); 00095400 00095500 SYMBOLIC PROCEDURE !&REPASC(REG,U,V); 00095600 IF NULL V THEN LIST LIST(REG,U) 00095700 ELSE IF REG=CAAR V THEN LIST(REG,U) . CDR V 00095800 ELSE CAR V . !&REPASC(REG,U,CDR V); 00095900 00096000 SYMBOLIC PROCEDURE !&CLRREGS(); 00096100 %store deferred values in IREGS; 00096200 WHILE IREGS DO <>; 00096400 00096500 SYMBOLIC PROCEDURE !&GENLBL(); 00096600 BEGIN SCALAR L; 00096700 L := GENSYM(); 00096800 LBLIST := LIST L . LBLIST; 00096900 RETURN LIST L; 00097000 END; 00097100 00097200 SYMBOLIC PROCEDURE !&GETLBL LABL; 00097300 BEGIN SCALAR X; 00097400 X := ATSOC(LABL,GOLIST); 00097500 IF NULL X THEN LPRIE LIST(LABL," - MISSING LABEL -"); 00097600 RETURN CDR X 00097700 END; 00097800 00097900 SYMBOLIC PROCEDURE !&FINDLBL LBLST; 00098000 ASSOC(CAR LBLST,LBLIST); 00098100 00098200 SYMBOLIC PROCEDURE !&RECHAIN(OLBL,NLBL); 00098300 % Fix OLBL to now point at NLBL; 00098400 BEGIN SCALAR X,Y,USES; 00098500 X := !&FINDLBL OLBL; 00098600 Y := !&FINDLBL NLBL; 00098700 RPLACA(OLBL,CAR NLBL); % FIX L VAR; 00098800 USES:=CDR X; % OLD USES; 00098900 RPLACD(X,NIL); 00099000 RPLACD(Y,APPEND(USES,CDR Y)); 00099100 FOR EACH X IN USES DO RPLACA(CDR X,CAR NLBL) 00099200 END; 00099300 00099400 SYMBOLIC PROCEDURE !&MOVEUP U; 00099500 IF CAADR U EQ '!*JUMP 00099600 THEN <> 00099900 ELSE RPLACW(U,CDR U); 00100000 00100100 SYMBOLIC PROCEDURE !&ATTLBL LBL; 00100200 IF CAAR CODELIST EQ '!*LBL THEN !&RECHAIN(LBL,CDAR CODELIST) 00100300 ELSE !&ATTACH ('!*LBL . LBL); 00100400 00100500 SYMBOLIC PROCEDURE !&ATTJMP LBL; 00100600 BEGIN 00100700 IF CAAR CODELIST EQ '!*LBL THEN 00100800 <>; 00101000 IF CAAR CODELIST EQ '!*JUMP THEN RETURN; 00101100 !&ATTACH ('!*JUMP . LBL); 00101200 !&ADDJMP CODELIST 00101300 END; 00101400 00101500 SYMBOLIC PROCEDURE !&ADDJMP CLIST; 00101600 BEGIN SCALAR X; 00101700 X := !&FINDLBL CDAR CLIST; RPLACD(X,CAR CLIST . CDR X); 00101800 JMPLIST := CLIST . JMPLIST 00101900 END; 00102000 00102100 SYMBOLIC PROCEDURE !&REMJMP CLIST; 00102200 BEGIN SCALAR X; 00102300 X := !&FINDLBL CDAR CLIST; 00102400 RPLACD(X,!&DELEQ(CAR CLIST,CDR X)); 00102500 JMPLIST := !&DELEQ(CLIST,JMPLIST); 00102600 !&MOVEUP CLIST; 00102700 END; 00102800 00102900 SYMBOLIC PROCEDURE !&DELEQ(U,V); 00103000 IF NULL V THEN NIL 00103100 ELSE IF U EQ CAR V THEN CDR V 00103200 ELSE CAR V . !&DELEQ(U,CDR V); 00103300 00103400 00103500 SYMBOLIC PROCEDURE !&FRAME U; 00103600 % ALLOCATES SPACE FOR U IN FRAME; 00103700 BEGIN SCALAR Z; 00103800 STOMAP := LIST(U,Z := CADAR STOMAP-1) . STOMAP; 00103900 IF Z>; 00106200 !&FIXUP1(); 00106300 IF FLAGG THEN <>; 00107200 CODELIST := !&FIXUP2() 00107300 END; 00107400 00107500 SYMBOLIC PROCEDURE !&FIXUP1; 00107600 BEGIN SCALAR EJMPS,EJMPS1,P,Q; 00107700 IF NOT CAR CODELIST ='!*LBL . EXIT THEN !&ATTLBL EXIT; 00107800 CODELIST := CDR CODELIST; 00107900 IF NOT CAR CODELIST = '!*JUMP . EXIT THEN !&ATTJMP EXIT; 00108000 %find any common chains of code; 00108100 EJMPS := REVERSE JMPLIST; 00108200 WHILE EJMPS DO 00108300 BEGIN 00108400 P := CAR EJMPS; EJMPS := CDR EJMPS; 00108500 IF CAAR P EQ '!*JUMP 00108600 THEN <> 00109200 ELSE EJMPS1 := CDR EJMPS1>> 00109300 END; 00109400 %replace LINK by LINKE where appropriate; 00109500 EJMPS := JMPLIST; 00109600 IF NOT !*NOLINKE THEN WHILE EJMPS DO 00109700 BEGIN 00109800 P := CAR EJMPS; Q := CDR P; EJMPS := CDR EJMPS; 00109900 IF NOT CADAR P EQ CAR EXIT THEN RETURN NIL 00110000 ELSE IF NOT CAAR P EQ '!*JUMP OR NOT CAAR Q EQ '!*LINK 00110100 THEN RETURN FLAGG := T; 00110200 RPLACW(CAR Q,'!*LINKE . CADAR Q . CADDAR Q . LLNGTH); 00110300 !&REMJMP P; 00110400 END ELSE FLAGG := T; 00110500 !&FIXFRM(); 00110600 !&ATTLBL EXIT 00110700 END; 00110800 00110900 SYMBOLIC PROCEDURE !&FINDBLK(U,LBL); 00111000 IF NULL CDR U THEN NIL 00111100 ELSE IF CAADR U EQ '!*LBL AND CAADDR U MEMBER '(!*LINKE !*JUMP) 00111200 THEN U 00111300 ELSE IF GET(CAADR U,'NEGJMP) AND CADADR U EQ LBL THEN U 00111400 ELSE !&FINDBLK(CDR U,LBL); 00111500 00111600 PUT('!*NOOP,'OPTFN,'!&MOVEUP); 00111700 00111800 PUT('!*LBL,'OPTFN,'!&LABOPT); 00111900 00112000 SYMBOLIC PROCEDURE !&LABOPT U; 00112100 BEGIN SCALAR Z; 00112200 IF CADAR U EQ CADADR U 00112300 THEN RETURN !&REMJMP CDR U %(JUMPx lab) (LAB lab); 00112400 ELSE IF CAADR U EQ '!*JUMP AND (Z := GET(CAADDR U,'NEGJMP)) 00112500 AND CADAR U EQ CADR CADDR U 00112600 THEN RETURN <> %(JUMPx lab1) (JUMP lab2) (LAB lab1); 00113200 ELSE RETURN NIL 00113300 END; 00113400 00113500 SYMBOLIC PROCEDURE !&FIXUP2; 00113600 %'peep-hole' optimization for various cases; 00113700 BEGIN SCALAR LABS,TLABS,X,Y,Z; 00113800 %local code fixes; 00113900 Z := CODELIST; 00114000 WHILE Z DO IF NOT (X := GET(CAAR Z,'OPTFN)) 00114100 OR NOT APPLY(X,LIST Z) 00114200 THEN Z := CDR Z; 00114300 WHILE CODELIST DO 00114400 <> 00115800 ELSE <>>>>> 00116300 %case of (JUMPx lab) M1 ... Mn ... (LAB lab) M1 ... Mn 00116400 %where Mi do not affect reg 1; 00116500 ELSE IF GET(CAAR CODELIST,'NEGJMP) 00116600 AND (Z := ATSOC(CAR CODELIST,LABS)) 00116700 THEN <>; 00117400 CODELIST := X . CODELIST; 00117500 Y:= X . Y>> 00117600 ELSE IF CAAR CODELIST EQ '!*JUMP 00117700 AND (Z := ATSOC(CADAR CODELIST,TLABS)) 00117800 AND (X := !&FINDBLK(CDR CODELIST, 00117900 IF CAAR Y EQ '!*LBL THEN CADAR Y 00118000 ELSE NIL)) 00118100 THEN BEGIN SCALAR W; 00118200 IF NOT CAADR X EQ '!*LBL 00118300 THEN <> 00119000 ELSE X := CDR X; 00119100 W := NIL; 00119200 REPEAT <> UNTIL Y EQ CDR Z; 00119300 RPLACD(X,NCONC(W,CDR X)); 00119400 !&REMJMP CODELIST; 00119500 TLABS := NIL; %since code chains have changed; 00119600 CODELIST := NIL . CAR Y . CODELIST; 00119700 Y := CDR Y 00119800 END 00119900 ELSE Y := CAR CODELIST . Y; 00120000 CODELIST := CDR CODELIST>>; 00120100 RETURN Y 00120200 END; 00120300 00120400 SYMBOLIC PROCEDURE !&NOLOADP(ARGS,INSTRS); 00120500 %determines if a LOAD is not necessary in instruction stream; 00120600 ATOM CADR ARGS AND 00120700 (CAAR INSTRS EQ '!*LOAD AND CDAR INSTRS=ARGS 00120800 OR CAAR INSTRS EQ '!*STORE AND (CDAR INSTRS=ARGS 00120900 OR NOT(CADDAR INSTRS=CADR ARGS) 00121000 AND !&NOLOADP(ARGS,CDR INSTRS))); 00121100 00121200 SYMBOLIC PROCEDURE !&FIXCHN(U,V); 00121300 BEGIN SCALAR X; 00121400 WHILE CAR U=CAR V DO <>; 00121500 X := !&GENLBL(); 00121600 IF CAAR V EQ '!*LBL THEN !&RECHAIN(X,CDAR V) 00121700 ELSE RPLACW(V,('!*LBL . X) . CAR V . CDR V); 00121800 IF CAAR U EQ '!*LBL 00121900 THEN <>; 00122000 IF CAAR U EQ '!*JUMP THEN RETURN; 00122100 RPLACW(U,('!*JUMP . X) . CAR U . CDR U); 00122200 !&ADDJMP U 00122300 END; 00122400 00122500 SYMBOLIC PROCEDURE !&FIXFRM; 00122600 BEGIN SCALAR HOLES,LST,X,Y,Z; INTEGER N; 00122700 IF NULL STLST AND NULL FREELST THEN RETURN RPLACA(LLNGTH,1); 00122800 N := 0; 00122900 WHILE NOT(N>; 00123700 Y := Z; 00123800 IF CAAR Z>CAR LLNGTH THEN RPLACA(LLNGTH,CAAR Z); 00123900 WHILE HOLES DO << 00124000 WHILE HOLES AND CAR HOLES>>>; 00125100 %now see if we can map stack to registers; 00125200 IF FREELST 00125300 OR NULL !®P CODELIST OR 1-CAR LLNGTH>MAXNARGS-NARG 00125400 THEN RETURN; 00125500 N := IF NARG<3 THEN 3 ELSE NARG+1; 00125600 FOR EACH X IN STLST DO 00125700 RPLACW(X,LIST('!*LOAD,N-CADDR X+1, 00125800 IF NULL CADR X THEN '(QUOTE NIL) 00125900 ELSE CADR X)); 00126000 WHILE Y DO 00126100 <0) AND RPLACA(X,N-CAR X+1); 00126300 %first test makes sure replacement only occurs once; 00126400 Y := CDR Y>>; 00126500 RPLACA(LLNGTH,1) 00126600 END; 00126700 00126800 SYMBOLIC PROCEDURE !®P U; 00126900 %there is no test for LAMBIND/PROGBIND 00127000 %since FREELST tested explicitly in FIXFRM; 00127100 IF NULL CDR U THEN T 00127200 ELSE IF FLAGP(CAADR U,'LINK) 00127300 AND NOT(FLAGP!*!*(CADADR U,'TWOREG) OR CAR U =('!*JUMP . EXIT)) 00127400 THEN NIL 00127500 ELSE !®P CDR U; 00127600 00127700 SYMBOLIC PROCEDURE FLAGP!*!*(U,V); 00127800 00127900 ATOM U AND NOT NUMBERP U AND FLAGP(U,V); 00128000 00128100 FLAG('(!*LINK !*LINKE),'LINK); 00128200 00128300 PUT('!*JUMPN,'NEGJMP,'!*JUMPE); 00128400 PUT('!*JUMPE,'NEGJMP,'!*JUMPN); 00128500 PUT('!*JUMPNIL,'NEGJMP,'!*JUMPT); 00128600 PUT('!*JUMPT,'NEGJMP,'!*JUMPNIL); 00128700 00128800 SYMBOLIC PROCEDURE MODCMP(A,B,C)$$ 00128900 00129000 END; 00129100