Forgot your password?
Document Actions
TORECREATE/COMPILER.sqd_m is the Standard LISP compiler, written in RLISP.
TORECREATE/COMPILER.sqd_m is the Standard LISP compiler, written in RLISP -- Standard LISP with REDUCE (essentially ALGOL 60) syntax. As it notes, the machine dependent parts are in a separate file.
Size 108.4 kB - File type text/plain
Click here to get the file
File contents
%********************************************************************* 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 <func>) 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 <<PRIN2 X; PRIN2 " ">>; 00003000
00003100
SYMBOLIC PROCEDURE LPRIE U; 00003200
<<LPRI ("*****" . IF ATOM U THEN LIST U ELSE U); 00003300
ERFG!* := T; 00003400
TERPRI()>>; 00003500
00003600
SYMBOLIC PROCEDURE LPRIM U; 00003700
<<TERPRI(); 00003800
LPRI("***" . IF ATOM U THEN LIST U ELSE U); 00003900
TERPRI()>>; 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 <<X := CDR U; Y := RPLACD(U,Y); U := X>>; 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 (<reg> . <contents>) 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
<<FNAME!& := CAR X; 00016500
EXP := GETD FNAME!&; 00016600
IF NULL EXP THEN LPRIM LIST(FNAME!&,'UNDEFINED) 00016700
ELSE COMPD(FNAME!&,CAR EXP,CDR EXP); 00016800
X := CDR X>> 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 <<LPRIM LIST("UNCOMPILABLE FUNCTION",NAME,"OF TYPE",TYPE); 00017700
RETURN NIL>>; 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
<<!&FRAME Z; 00021700
NARG := NARG+1; 00021800
IF NOT NONLOCAL Z 00021900
THEN IREGS := NCONC(IREGS,LIST LIST(NARG,Z)); 00022000
REGS := NCONC(REGS,LIST LIST(NARG,Z))>>; 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 <<MKNONLOCAL U; U>> 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 <<!&PALIS(CDR U,NIL); %to check for fluid VBLS; 00026900
LIST(CAR U,MKQUOTE CDR U)>> 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
<<LPRIM LIST(U,"declared fluid"); FLUID LIST U; LIST('FLUID,U)>>; 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
<<IF !&ANYREG(CAR EXP,CDR EXP) THEN Y := CAR EXP . Y 00034400
ELSE <<IF ACUSED THEN !&STORE1(); 00034500
!&COMVAL1(CAR EXP,STOMAP,1); 00034600
ACUSED := GENSYM(); 00034700
REGS := (1 . ACUSED . CDAR REGS) . CDR REGS; 00034800
Y:=ACUSED . Y>>; 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 <<!&FRAME V; 00037200
REGS:=!&REPASC(I,V,REGS); 00037300
I:=I+1>>; 00037400
ALSTS := !&FREEBIND(VARS,T); %Old fluid values saved; 00037500
I:=1; 00037600
FOR EACH V IN VARS DO 00037700
<<IF NOT NONLOCAL V THEN !&STORE(V,I); 00037800
I:=I+1>>; 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 <<X := !&GENLBL(); 00039200
RPLACD(Z,LIST(('!*LBL . X),CADR Z))>>; 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
<<!&LREG(N,CAR ARGS,CDR ARGS,STATUS); 00040300
N := N-1; ARGS := CDR ARGS>>; 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 <<!&STORE(CADR Y,REG); IREGS := DELETE(Y,IREGS)>>; 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
<<IF FLUIDP X 00044400
THEN <<FALST := (X . !&GETFFRM X) . FALST; 00044500
FREGS := I . FREGS>> 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 <<STLST := !&DELEQ(CADR X,STLST); 00047000
SLST := !&DELEQ(X,SLST); 00047100
RPLACA(CADR X,'!*NOOP)>>; 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
<<SWITCH := NOT SWITCH; EXP := CADR EXP>>; 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 <<IF EXP = '(QUOTE T) 00049100
THEN IF SWITCH THEN !&ATTJMP LABL 00049200
ELSE FLAGG := T 00049300
ELSE <<!&COMVAL(EXP,1); 00049400
!&ATTACH LIST(IF SWITCH THEN '!*JUMPT ELSE '!*JUMPNIL, 00049500
CAR LABL); 00049600
!&ADDJMP CODELIST>>; 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
<<!&COMVAL(CAR EXP,IF CDR EXP THEN 1 ELSE STATUS); 00051700
%to allow for recursion on last entry; 00051800
IREGSL := IREGS . IREGSL; REGSL := REGS . REGSL; 00051900
IF CDR EXP THEN <<!&ATTACH LIST(IF FN THEN '!*JUMPNIL 00052000
ELSE '!*JUMPT,CAR LABL); 00052100
!&ADDJMP CODELIST>>; 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
<<SWITCH := NIL; 00054300
IF NULL CDR EXP AND FLG1 00054400
THEN <<IF FN THEN SWITCH := T; 00054500
!&COMTST(CAR EXP,LABL); 00054600
REGSL := REGS . REGSL; 00054700
REGS1L := REGS1 . REGS1L>> 00054800
ELSE <<IF NOT FN THEN SWITCH := T; 00054900
IF FLG1 00055000
THEN <<!&COMTST(CAR EXP,LAB2); 00055100
REGSL := REGS1 . REGSL; 00055200
REGS1L := REGS . REGS1L>> 00055300
ELSE <<!&COMTST(CAR EXP,LABL); 00055400
REGSL := REGS . REGSL; 00055500
REGS1L := REGS1 . REGS1L>>>>; 00055600
IF NULL TAILP 00055700
THEN <<CONDTAIL := NIL . CONDTAIL; TAILP := T>>; 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
<<LAB2 := !&GENLBL(); 00058200
SWITCH := NIL; 00058300
!&COMTST(CAR X,LAB2); 00058400
%update CONDTAIL; 00058500
IF NULL TAILP 00058600
THEN <<CONDTAIL := NIL . CONDTAIL; TAILP := T>>; 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 <<TRANSFERP := NIL; !&ATTJMP LAB1>>; 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 <<!&LREG1('(QUOTE NIL),STATUS); 00060300
IREGSL := IREGS . IREGSL; 00060400
REGSL := REGS . REGSL>>; 00060500
%missing ELSE clause; 00060600
IF NULL TRANSFERP THEN <<IREGS := !&RMERGE(IREGS . IREGSL); 00060700
REGS := !&RMERGE(REGS . REGSL)>>; 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 <<!&CLRREGS(); !&ATTJMP !&GETLBL CADR EXP; SLST := NIL>> 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
<<L1 := CAR EXP . L1; EXP := CDR EXP; N := N-1>>; 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 <<!&FRAME(RESULT := GENSYM()); !&STORE(RESULT,NIL)>>; 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 <<IF MTYPE EQ 'NCONC 00073500
THEN !&ATTACH '(!*LINK REVERSE 1); 00073600
!&LREG(2,RESULT,NIL,1); 00073700
!&ATTACH LIST('!*LINK,MTYPE,2); 00073800
!&STORE(RESULT,1); 00073900
REGS := LIST(1 . NIL)>>; 00074000
SLST := XN(SLST,SLST1); 00074100
!&COMVAL(LIST('CDR,VAR),1); 00074200
!&ATTJMP LAB1; 00074300
!&ATTLBL LAB2; 00074400
IF MTYPE THEN <<!&LREG1(RESULT,1); 00074500
!&ATTACH LIST('!*LINK,'REVERSIP,1); 00074600
REGS := LIST(1 . NIL)>> 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
<<IF ATOM CAR EXP 00078200
THEN <<!&CLRREGS(); 00078300
!&ATTLBL !&GETLBL CAR EXP; 00078400
REGS:= LIST(1 . NIL)>> 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 <<!&STORE(CADR Y,CAR Y); 00080800
IREGS := DELETE(Y,IREGS)>>; 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
<<!&RSTVAR(CAR VARS,CAR LST); VARS := CDR VARS; LST := CDR LST>>; 00082300
00082400
SYMBOLIC PROCEDURE !&RSTVAR(VAR,VAL); 00082500
BEGIN 00082600
FOR EACH X IN IREGS DO 00082700
IF VAR EQ CADR X THEN <<!&STORE(CADR X,CAR X); 00082800
IREGS := DELETE(X,IREGS)>>; 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
<<!&COMVAL(CAR EXP,IF STATUS<2 THEN 2 ELSE STATUS); 00085500
EXP := CDR EXP>>; 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
<<IF STATUS<4 OR NOT !&ANYREG(CADR EXP,NIL) 00086400
THEN !&LREG1(CAR !&COMLIS LIST CADR EXP,STATUS); 00086500
!&ATTJMP EXIT>>; 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 <<!&COMVAL(CADR EXP,1); 00087500
!&STORE2(CAR EXP,1); 00087600
IF X := !&RASSOC(CAR EXP,IREGS) 00087700
THEN IREGS := DELETE(X,IREGS); 00087800
REGS := (1 . CAR EXP . CDAR REGS) . CDR REGS>> 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 <<!&COMVAL(U,1); 00092500
W := !&LOCATE V>> 00092600
ELSE IF !&ANYREG(U,LIST V) THEN <<!&COMVAL(V,1); 00092700
W := !&LOCATE U>> 00092800
ELSE <<U := !&COMLIS CDR EXP; W := !&LOCATE CADR U>>; 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 <<!&COMVAL(U,1); !&LOCATE V>>; 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 <<!&STORE(CADAR IREGS,CAAR IREGS); 00096300
IREGS := CDR IREGS>>; 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 <<JMPLIST:=!&DELEQ(CDR U,JMPLIST); 00099700
RPLACW(U,CDR U); 00099800
JMPLIST:=U . JMPLIST>> 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
<<!&RECHAIN(CDAR CODELIST,LBL); 00100900
CODELIST := CDR CODELIST>>; 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<CAR LLNGTH THEN RPLACA(LLNGTH,Z) 00104000
END; 00104100
00104200
SYMBOLIC PROCEDURE !&GETFRM U; 00104300
(LAMBDA X; 00104400
IF X THEN CDR X 00104500
ELSE LPRIE LIST("COMPILER ERROR: LOST VAR",U)) 00104600
ATSOC(U,STOMAP); 00104700
00104800
SYMBOLIC PROCEDURE !&GETFFRM U; 00104900
BEGIN SCALAR X; 00105000
X := !&GETFRM U; 00105100
FREELST := X . FREELST; 00105200
RETURN X 00105300
END; 00105400
00105500
00105600
COMMENT Post Code Generation Fixups; 00105700
00105800
SYMBOLIC PROCEDURE !&PASS3; 00105900
BEGIN SCALAR FLAGG; 00106000
FOR EACH J IN SLST 00106100
DO <<STLST := !&DELEQ(CADR J,STLST); RPLACA(CADR J,'!*NOOP)>>; 00106200
!&FIXUP1(); 00106300
IF FLAGG THEN <<IF NOT !*NOLINKE 00106400
AND CAAR CODELIST EQ '!*LBL 00106500
AND CAADR CODELIST EQ '!*LINKE 00106600
THEN RPLACA(CDR CODELIST, 00106700
LIST('!*LINK,CADADR CODELIST, 00106800
CADR CDADR CODELIST)); 00106900
%removes unnecessary LINKE; 00107000
!&ATTACH('!*DEALLOC . LLNGTH); 00107100
!&ATTACH LIST '!*EXIT>>; 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 <<EJMPS1 := EJMPS; 00108700
WHILE EJMPS1 DO 00108800
IF CAR P=CAAR EJMPS1 AND CADR P=CADAR EJMPS1 00108900
THEN <<!&REMJMP P; 00109000
!&FIXCHN(P,CDAR EJMPS1); 00109100
EJMPS1 := NIL>> 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 <<Z := Z . CADADR U . CDDR CADDR U; 00112700
!&REMJMP CDR U; 00112800
!&REMJMP CDR U; 00112900
RPLACD(U,Z . CADR U . CDDR U); 00113000
!&ADDJMP CDR U; 00113100
T>> %(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
<<IF CAAR CODELIST EQ '!*LBL 00114500
THEN <<!&LABOPT CODELIST; 00114600
%since block transfers may cause new chains to emerge; 00114700
IF CDR (Z := !&FINDLBL CDAR CODELIST) 00114800
THEN <<Y := CAR CODELIST . Y; 00114900
IF NULL CDDR Z 00115000
AND CAADR Z MEMBER '(!*JUMP !*LINKE) 00115100
AND CAADR Y EQ '!*LOAD 00115200
AND !&NOLOADP(CDADR Y, 00115300
CDR ATSOC(CADR Z,JMPLIST)) 00115400
THEN <<IF NOT !&NOLOADP(CDADR Y,CDR CODELIST) 00115500
THEN RPLACW(CDR CODELIST,CADR Y . 00115600
CADR CODELIST . CDDR CODELIST); 00115700
RPLACW(CDR Y,CDDR Y)>> 00115800
ELSE <<IF NULL CDDR Z AND CAADR CODELIST EQ '!*JUMP 00115900
AND GET(CAADR Z,'NEGJMP) 00116000
THEN LABS := (CADR Z . Y) . LABS; 00116100
IF CAADR CODELIST MEMBER '(!*JUMP !*LINKE) 00116200
THEN TLABS := (CADAR Y . Y) . TLABS>>>>>> 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 <<X := CAR CODELIST; CODELIST := CDR CODELIST; 00116800
Z := CDDR Z; 00116900
WHILE CAR Y=CAR Z AND (CAAR Y EQ '!*STORE 00117000
OR CAAR Y EQ '!*LOAD AND NOT(CADAR Y=1)) DO 00117100
<<CODELIST := CAR Y . CODELIST; 00117200
RPLACW(Z,CADR Z . CDDR Z); 00117300
Y := CDR Y>>; 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 <<IF NOT CAAR X EQ '!*LBL 00118400
THEN X := CDR RPLACD(X,('!*LBL . !&GENLBL()) 00118500
. CDR X); 00118600
W:= GET(CAADR X,'NEGJMP) . CADAR X . CDDADR X; 00118700
!&REMJMP CDR X; 00118800
RPLACD(X,W . CADR X . CDDR X); 00118900
!&ADDJMP CDR X>> 00119000
ELSE X := CDR X; 00119100
W := NIL; 00119200
REPEAT <<W := CAR Y . W; Y := CDR Y>> 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 <<!&MOVEUP U; V := CDR V>>; 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 <<!&RECHAIN(CDAR U,X);!&MOVEUP U>>; 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<CAR LLNGTH) DO 00123000
<<Y:= NIL; 00123100
FOR EACH LST IN STLST DO 00123200
IF N = CADDR LST THEN Y := CDDR LST . Y; 00123300
FOR EACH LST IN FREELST DO 00123400
IF N=CAR LST THEN Y := LST . Y; 00123500
IF NULL Y THEN HOLES := N . HOLES ELSE Z := (N . Y) . Z; 00123600
N := N-1>>; 00123700
Y := Z; 00123800
IF CAAR Z>CAR LLNGTH THEN RPLACA(LLNGTH,CAAR Z); 00123900
WHILE HOLES DO << 00124000
WHILE HOLES AND CAR HOLES<CAR LLNGTH 00124100
DO HOLES := CDR HOLES; 00124200
IF HOLES 00124300
THEN <<HOLES := REVERSIP HOLES; 00124400
FOR EACH X IN CDAR Z DO RPLACA(X,CAR HOLES); 00124500
RPLACA(LLNGTH, 00124600
IF NULL CDR Z OR CAR HOLES<CAADR Z 00124700
THEN CAR HOLES 00124800
ELSE CAADR Z); 00124900
HOLES := REVERSIP CDR HOLES; 00125000
Z := CDR Z>>>>; 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
<<FOR EACH X IN CDAR Y DO 00126200
NOT(CAR X>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