Personal tools
You are here: Home Projects LISP Utah REDUCE 2 and Standard LISP for Burroughs B6700 TORECREATE/COMPILER.sqd_m is the Standard LISP compiler, written in RLISP.
Document Actions

TORECREATE/COMPILER.sqd_m is the Standard LISP compiler, written in RLISP.

by Paul McJones last modified 2022-10-16 18:50

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.

Click here to get the file

Size 108.4 kB - File type text/plain

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 !&REGP 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 !&REGP 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 !&REGP 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    
« October 2024 »
Su Mo Tu We Th Fr Sa
1 2 3 4 5
6 7 8 9 10 11 12
13 14 15 16 17 18 19
20 21 22 23 24 25 26
27 28 29 30 31
 

Powered by Plone CMS, the Open Source Content Management System

This site conforms to the following standards: