Personal tools
You are here: Home Projects LISP Utah REDUCE 2 and Standard LISP for Burroughs B6700 TORECREATE/ASSEMBLER.sqd_m is an RLISP program that converts LAP (LISP assembly code as output by the compiler) to a Burroughs ALGOL program.
Document Actions

TORECREATE/ASSEMBLER.sqd_m is an RLISP program that converts LAP (LISP assembly code as output by the compiler) to a Burroughs ALGOL program.

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

TORECREATE/ASSEMBLER.sqd_m is an RLISP program that converts LAP (LISP assembly code as output by the compiler) to a Burroughs ALGOL program. See GENERATED/LISP/ALGOL.alg_m for an example of its output.

Click here to get the file

Size 41.2 kB - File type text/plain

File contents

% THIS FILE CONTAINS THE CODE TO CHANGE "LAP" TO ALGOL.  IT ALSO        00000100    
   CONTAINS CODE WHICH MAKES MODIFICATIONS TO THE STANDARD REDUCE       00000200    
   COMPILER WHICH IMPROVES THE B6000/7000 OBJECT CODE;      %PPDMTL99;  00000300    
                                                                        00000400    
SYMBOLIC;                                                               00000500    
                                                                        00000600    
!*NOLINKE:=T$ MAXNARGS:=14$ !*SAVEDEF:=NIL$ !*R2I:=T$ !*ORD:=NIL$       00000700    
REMFLAG('(ATSOC),'LOSE);                                                00000800    
GLOBAL '(!$QPROG!.PTR QUOTED !*PWDS GENCNT NUMERICONSTANT EXTRAS        00000900    
    !*FLINKLIST TRANSLIST YNUMBER YFUNCTIONS AFIL LFIL FFIL BASEQ);     00001000    
FLUID '(SWITCH REGS1 REGS CODELIST FLAGG IREGS1 IREGS)$                 00001100    
                                                                        00001200    
SMACRO PROCEDURE !&MKFUNC X; MKQUOTE X;                                 00001300    
                                                                        00001400    
YNUMBER:=0;                                                             00001500    
QUOTED:=NIL$                                                            00001600    
                                                                        00001700    
                                                                        00001800    
SYMBOLIC PROCEDURE B6700 X$                                             00001900    
  IF ATOM X THEN NIL                                                    00002000    
   ELSE IF EQ(CAR X,'DE) THEN <<LAP                                     00002100    
      (LIST('!*ENTRY,CAR CDR X,'SUBR,LENGTH CAR CDR CDR X) .            00002200    
            !&COMPROC(LIST('LAMBDA,CAR CDR CDR X,CAR CDR CDR CDR X),CAR 00002300    
      CDR X))$ '!   >>                                      %PPDMTL99;  00002400    
   ELSE IF EQ(CAR X,'DF) THEN <<LAP                                     00002500    
      (LIST('!*ENTRY,CAR CDR X,'FSUBR,LENGTH CAR CDR CDR X) .           00002600    
            !&COMPROC(LIST('LAMBDA,CAR CDR CDR X,CAR CDR CDR CDR X),CAR 00002700    
      CDR X))$ '!   >>                                      %PPDMTL99;  00002800    
   ELSE IF CAR X='QUOTE THEN NIL                                        00002900    
   ELSE <<EXTRAS:=NCONC(EXTRAS,IF CAR X='PROGN THEN CDR X ELSE LIST X)$ 00003000    
        IF FLAGP(CAR X,'EVAL) THEN EVAL X>>$                            00003100    
                                                                        00003200    
SYMBOLIC PROCEDURE LAP A$                                               00003300    
 BEGIN SCALAR LOCLIS,OFIL;                                              00003400    
        OFIL:=WRS AFIL;                                                 00003500    
        LINELENGTH 70;                                                  00003600    
        LOCLIS:=LIST 'EXIT;                                             00003700    
        FOREACH XX IN A DO                                              00003800    
                IF CAR XX EQ '!*LBL THEN LOCLIS:=CAR CDR XX.LOCLIS;     00003900    
        !*ENTRY(CAR CDR CAR A,CAR CDR CDR CAR A,CAR CDR CDR CDR CAR A); 00004000    
        PRIN2 " BEGIN LABEL "; PRINTLIST(LOCLIS,";");                   00004100    
        FOREACH XX IN CDR A DO                                          00004200    
                IF ATOM XX THEN << PRIN2 XX; PRIN2 '!: >>               00004300    
                ELSE APPLY(CAR XX,CDR XX);                              00004400    
        TERPRI(); PRIN2 "EXIT: END "; PRIN2 ALGOLIZE CAR CAR YFUNCTIONS;00004500    
        PRIN2 ";"; TERPRI();                                            00004600    
        WRS LFIL;                                                       00004700    
        LINELENGTH 60;                                                  00004800    
        PRIN1 CAR CAR YFUNCTIONS; PRIN2 " "; PRIN2 CAR CDR CDR CAR      00004900    
                                             YFUNCTIONS;     %PPDMTL99; 00004901    
        PRIN2 " "; PRIN2 '!=; PRINT YNUMBER; YNUMBER:=YNUMBER+1;        00005000    
        FOR EACH XX IN QUOTED DO !$PLANTWORD XX;                        00005100    
        PRIN2 '!); TERPRI();                                            00005200    
        WRS OFIL                                                        00005300    
 END$                                                                   00005400    
                                                                        00005500    
SYMBOLIC PROCEDURE GENERATEFORWARD();                                   00005600    
 BEGIN SCALAR CHAR,OFIL;                                                00005700    
  OFIL:=WRS FFIL; CHAR:='!    ; TERPRI();                               00005800    
  YFUNCTIONS := REVERSIP YFUNCTIONS;                                    00005900    
 %PRIN2 "DEFINE LISTOFARGNUM = "., TERPRI().,                           00006000    
 %FOREACH XX IN YFUNCTIONS DO <<                                        00006100    
 %      PRIN2 CHAR., IF POSN()>45 THEN TERPRI()., TTAB().,              00006200    
 %      PRIN2 CDR CDR CDR XX., CHAR:='!,                                00006300    
 %      >>., PRIN2 "#.,"., TERPRI();                                    00006400    
  PRIN2 "DEFINE LISTOFPROCCALLS ="; CHAR:='! ;                          00006500    
  FOREACH XX IN YFUNCTIONS DO <<                                        00006600    
        PRIN2 CHAR; IF POSN()>45 THEN TERPRI(); TTAB();                 00006700    
        PRIN2 ALGOLIZE CAR XX; CHAR:='!;                                00006800    
        >>;                                                             00006900    
        PRIN2 "#;"; TERPRI();                                           00007000    
  FOREACH XX IN YFUNCTIONS DO <<                                        00007100    
     IF CAR XX NEQ 'EVAL AND NOT FLAGP(CAR XX,'NOFORWARD) THEN        <<00007200    
        PRIN2 "PROCEDURE "; PRIN2 ALGOLIZE CAR XX; PRIN2 "; FORWARD;";  00007300    
        TERPRI() >> >>;                                                 00007400    
  WRS OFIL                                                              00007500    
 END;                                                                   00007600    
                                                                        00007700    
SYMBOLIC PROCEDURE MAKEINITIALIZE();                                    00007800    
   LAP(LIST('!*ENTRY,'INITIALISE,'SUBR,0) .                             00007900    
        !&COMPROC(LIST('LAMBDA,NIL,EXTRAS),'INITIALISE))$               00008000    
                                                                        00008100    
                                                                        00008200    
                                                                        00008300    
COMMENT LAP MACROS for new LAP$                                         00008400    
                                                                        00008500    
                                                                        00008600    
SYMBOLIC PROCEDURE !*ENTRY(!*NAME,TYPE,NARG)$                           00008700    
   BEGIN                                                                00008800    
      BASEQSET()$ ALLOCQ(!*NAME)$                                       00008900    
      TERPRI()$                                                         00009000    
      YFUNCTIONS:=CONS((!*NAME.YNUMBER.TYPE.NARG),YFUNCTIONS);          00009100    
      PRIN2 "PROCEDURE "; PRIN2 ALGOLIZE !*NAME;                        00009200    
      PRIN2 '!; ; TERPRI();                                             00009300    
      RETURN NIL                                                        00009400    
   END$                                                                 00009500    
                                                                        00009600    
SYMBOLIC PROCEDURE !*ALLOC NW$                                          00009700    
   EMIT3('KALLOC,NW,BASEQ,CDR CDR CDR CAR YFUNCTIONS);                  00009800    
                                                                        00009900    
SYMBOLIC PROCEDURE !*DEALLOC NW$                                        00010000    
   EMIT0 "KDEALLOC";                                                    00010100    
                                                                        00010200    
SYMBOLIC PROCEDURE !*EXIT$ NIL$                                         00010300    
                                                                        00010400    
SYMBOLIC PROCEDURE !*LOAD(REG,EXP)$                                     00010500    
  << IF POSN()>45 THEN TERPRI(); TTAB();                                00010600    
     PRIN2 "KLOAD(ARG"; PRIN2 REG; PRIN2 ",";                           00010700    
     EMITN1 LOADANY EXP; PRIN2 ");" >>;                                 00010800    
                                                                        00010900    
SYMBOLIC PROCEDURE !*STORE(REG,SLOC)$                                   00011000    
  <<IF REG='NIL THEN REG:=16;                                           00011100    
    IF ATOM SLOC THEN EMITN('KSET,-SLOC,LOADANY REG) ELSE               00011200    
      IF EQCAR(SLOC,'GLOBAL) OR EQCAR(SLOC,'FLUID) THEN                 00011300    
        EMITN('KSTORE,ALLOCQ CADR SLOC,LOADANY REG)                     00011400    
      ELSE ERROR(200,"FUNNY STORE")>>$                                  00011500    
                                                                        00011600    
SYMBOLIC PROCEDURE !*LINK(FN,NOARGS);                                   00011700    
  BEGIN SCALAR FST;                                                     00011800    
    IF !*FLINKLIST THEN                                                 00011900    
        !*FLINKLIST := !*SETUP !*FLINKLIST;                             00012000    
    IF FST:=GET(FN,'ALGOLMACRO) THEN                                    00012100    
         EMIT0 FST                                                      00012200    
    ELSE EMIT('KLINK,NOARGS,ALGOLIZE FN);                               00012300    
  END;                                                                  00012400    
                                                                        00012500    
SYMBOLIC PROCEDURE !*LAMBIND(RGLST,ALST)$                               00012600    
BEGIN                                                                   00012700    
    SCALAR N$ N:=LENGTH QUOTED$                                         00012800    
    QUOTED:=NCONC(QUOTED,LIST LENGTH ALST)$                             00012900    
    WHILE ALST DO <<                                                    00013000    
        QUOTED:=NCONC(QUOTED,LIST(CAR RGLST -1,CAR CAR ALST))$          00013100    
        ALST:=CDR ALST$ RGLST:=CDR RGLST >>$                            00013200    
    RETURN EMIT1('KLAMBIND,N)                                           00013300    
END$                                                                    00013400    
                                                                        00013500    
SYMBOLIC PROCEDURE !*PROGBIND ALST$                                     00013600    
    !*PRBND ALST$                                                       00013700    
SYMBOLIC PROCEDURE !*PRBND ALST$                                        00013800    
  BEGIN SCALAR N$ N:=LENGTH QUOTED$                                     00013900    
    QUOTED:=NCONC(QUOTED,LIST LENGTH ALST)$                             00014000    
    WHILE ALST DO <<                                                    00014100    
        QUOTED:=NCONC(QUOTED,LIST CAR CAR ALST)$                        00014200    
        ALST:=CDR ALST >>$                                              00014300    
    RETURN EMIT1('KPROGBIND,N)                                          00014400    
  END$                                                                  00014500    
                                                                        00014600    
SYMBOLIC PROCEDURE !*FREERSTR ALST$                                     00014700    
        EMIT0 'KFREERST$                                                00014800    
                                                                        00014900    
SYMBOLIC PROCEDURE !*LBL ADR$                                           00015000    
   << TERPRI(); PRIN2 ADR; PRIN2 ":  " >>;                              00015100    
                                                                        00015200    
SYMBOLIC PROCEDURE !*JUMP ADR$                                          00015300    
        EMIT1('KGOTO,ADR);                                              00015400    
                                                                        00015500    
SYMBOLIC PROCEDURE !*JUMPT ADR$                                         00015600    
        EMIT1('KJUMPT,ADR)$                                             00015700    
                                                                        00015800    
SYMBOLIC PROCEDURE !*JUMPNIL ADR$                                       00015900    
    EMIT1('KJUMPNIL,ADR)$                                               00016000    
                                                                        00016100    
SYMBOLIC PROCEDURE !*TESTT(LAB,EXP,TST);                                00016200    
    EMITN('IFTRUE,LAB,LIST(TST,LOADANY CAR EXP));                       00016300    
                                                                        00016400    
SYMBOLIC PROCEDURE !*TESTN(LAB,EXP,TST);                                00016500    
    EMITN('IFNOT,LAB,LIST(TST,LOADANY CAR EXP));                        00016600    
                                                                        00016700    
SYMBOLIC PROCEDURE !*TEST2N(LAB,E1,E2,TST);                             00016800    
    !*TEST2('IFNOT,LAB,E1,E2,TST);                                      00016900    
                                                                        00017000    
SYMBOLIC PROCEDURE !*TEST2T(LAB,E1,E2,TST);                             00017100    
    !*TEST2('IFTRUE,LAB,E1,E2,TST);                                     00017200    
                                                                        00017300    
SYMBOLIC PROCEDURE !*TEST2(MAC,LAB,E1,E2,TST);                          00017400    
  BEGIN SCALAR U,V;                                                     00017500    
      U := LOADANY CAR E2;                                              00017600    
      IF TST EQ 'EQUAL OR TST EQ 'EQN THEN                              00017700    
      <<TST:=IF NULL U OR U EQ T OR NUMERICONSTANT OR                   00017800    
                  (CAR U EQ 'QUOTE AND ATOM CADAR E2)                   00017900    
             THEN 'ZEQ ELSE IF TST='EQN THEN 'ZEQN ELSE 'ZEQUAL>>       00018000    
      ELSE IF (V:=GET(TST,'MACFN)) THEN                                 00018100    
             TST := V                                                   00018200    
      ELSE ERROR(201,LIST(TST," UNKNOWN TEST"));                        00018300    
      IF POSN()>45 THEN TERPRI(); TTAB();                               00018400    
      PRIN2 MAC; PRIN2 "("; PRIN2 LAB; PRIN2 ",";                       00018500    
      IF POSN()>45 THEN <<TERPRI(); TTAB()>>;                           00018600    
      PRIN2 TST; PRIN2 "(";                                             00018700    
      IF POSN()>45 THEN <<TERPRI(); TTAB()>>;                           00018800    
      EMITN1 LOADANY CAR E1; PRIN2 ","; EMITN1 U;                       00018900    
      PRIN2 "));";                                                      00019000    
  END;                                                                  00019100    
                                                                        00019200    
SYMBOLIC PROCEDURE !*1PARM(EXP,FN);                                     00019300    
   EMITN('KMOVE,0,LIST(FN,LOADANY CAR EXP));                            00019400    
                                                                        00019500    
SYMBOLIC PROCEDURE !*2PARM(N,E1,E2,MAC);                                00019600    
  BEGIN SCALAR U,V;                                                     00019700    
      U := LOADANY CAR E2;                                              00019800    
      IF MAC EQ 'EQUAL OR MAC EQ 'EQN THEN                              00019900    
      <<MAC:=IF NULL U OR U EQ T OR NUMERICONSTANT OR                   00020000    
                         (CAR U EQ 'QUOTE AND ATOM CADAR E2)            00020100    
             THEN 'VEQ ELSE IF MAC EQ 'EQN THEN 'VEQN ELSE 'VEQUAL>>    00020200    
      ELSE IF NUMERICONSTANT AND (MAC='PLUS2 OR MAC='DIFFERENCE) THEN   00020300    
             <<U := NUMERICONSTANT;                                     00020400    
                      MAC := IF MAC='PLUS2 THEN 'LPLUS2 ELSE 'LDIFF>>   00020500    
      ELSE IF (V:=GET(MAC,'PARMFN)) THEN                                00020600    
             MAC := V                                                   00020700    
      ELSE ERROR(201,LIST(MAC," UNKNOWN FUNCTION"));                    00020800    
      IF POSN()>45 THEN TERPRI(); TTAB();                               00020900    
      PRIN2 "KLOAD(ARG"; PRIN2 N; PRIN2 ",";                            00021000    
      IF POSN()>45 THEN <<TERPRI(); TTAB()>>;                           00021100    
      PRIN2 MAC; PRIN2 "(";                                             00021200    
      IF POSN()>45 THEN <<TERPRI(); TTAB()>>;                           00021300    
      EMITN1 LOADANY CAR E1; PRIN2 ","; EMITN1 U;                       00021400    
      PRIN2 "));";                                                      00021500    
  END;                                                                  00021600    
                                                                        00021700    
                                                                        00021800    
                                                                        00021900    
COMMENT THIS SECTION CONTAINS VARIOUS SERVICE ROUTINES;                 00022000    
                                                                        00022100    
                                                                        00022200    
SYMBOLIC PROCEDURE LOADANY EXP$                                         00022300    
  BEGIN SCALAR X;                                                       00022400    
   IF NOT ATOM EXP AND NULL CDR EXP THEN EXP := CAR EXP;                00022500    
   NUMERICONSTANT := NIL;                                               00022600    
   RETURN                                                               00022700    
    IF NUMBERP EXP THEN IF EXP<1 THEN LIST('LOCAL,-EXP)                 00022800    
        ELSE LIST('ARGS,EXP-1)                                          00022900    
    ELSE IF EQCAR(EXP,'GLOBAL) THEN                                     00023000    
            LIST('GLOBAL,ALLOCQ CAR CDR EXP)                            00023100    
    ELSE IF EQCAR(EXP,'FLUID) THEN                                      00023200    
            LIST('FLUID,ALLOCQ CAR CDR EXP)                             00023300    
    ELSE IF EQCAR(EXP,'QUOTE) THEN                                      00023400    
      IF (X:=CAR CDR EXP)='NIL THEN NIL                                 00023500    
      ELSE                                                              00023600    
      IF X='T THEN T                                                    00023700    
      ELSE                                                              00023800    
        IF NUMBERP X THEN                                               00023900    
        <<NUMERICONSTANT := X;                                          00024000    
          IF X=0 THEN 'ZERO ELSE                                        00024100    
          IF X=1 THEN 'ONE ELSE                                         00024200    
          IF X=2 THEN 'TWO ELSE                                         00024300    
          IF X=3 THEN 'THREE ELSE                                       00024400    
            LIST('NUMB,X)>>                                             00024500    
        ELSE                                                            00024600    
            LIST('QUOTE,ALLOCQ X)                                       00024700    
    ELSE IF (X:=GET(CAR EXP,'ANYREG)) THEN                              00024800    
        LIST(X,LOADANY CADR EXP)                                        00024900    
    ELSE ERROR(201,LIST(CAR EXP," UNKNOWN ANYREG"));                    00025000    
  END;                                                                  00025100    
                                                                        00025200    
                                                                        00025300    
SYMBOLIC PROCEDURE EMIT(NAME,A1,A2);                                    00025400    
    << IF POSN()>45 THEN TERPRI(); TTAB();                              00025500    
       PRIN2 NAME;                                                      00025600    
       PRIN2 "("; PRIN2 A1; PRIN2 ",";                                  00025700    
       PRIN2 A2; PRIN2 ");" >>;                                         00025800    
                                                                        00025900    
SYMBOLIC PROCEDURE EMIT0 X;                                             00026000    
  << IF POSN()>45 THEN TERPRI(); TTAB();                                00026100    
        PRIN2 X; PRIN2 ";" >>;                                          00026200    
                                                                        00026300    
SYMBOLIC PROCEDURE EMIT1(NAME,A1);                                      00026400    
    << IF POSN()>45 THEN TERPRI(); TTAB();                              00026500    
       PRIN2 NAME;                                                      00026600    
       PRIN2 "("; PRIN2 A1; PRIN2 ");" >>;                              00026700    
                                                                        00026800    
SYMBOLIC PROCEDURE EMIT3(NAME,A1,A2,A3);                                00026900    
    << IF POSN()>45 THEN TERPRI(); TTAB();                              00027000    
        PRIN2 NAME;                                                     00027100    
        PRIN2 "("; PRIN2 A1; PRIN2 ",";                                 00027200    
        IF POSN()>45 THEN << TERPRI(); TTAB(); TTAB() >>;               00027300    
        PRIN2 A2; PRIN2 ",";                                            00027400    
        IF POSN()>45 THEN << TERPRI(); TTAB(); TTAB() >>;               00027500    
        PRIN2 A3; PRIN2 ");" >>;                                        00027600    
                                                                        00027700    
SYMBOLIC PROCEDURE EMITN(MAC,RG,LL);                                    00027800    
  << IF POSN()>45 THEN TERPRI(); TTAB();                                00027900    
        PRIN2 MAC; PRIN2 "("; PRIN2 RG; PRIN2 ",";                      00028000    
        EMITN1 LL; PRIN2 ");" >>;                                       00028100    
                                                                        00028200    
SYMBOLIC PROCEDURE EMITN1 LL;                                           00028300    
  IF ATOM LL THEN PRIN2 LL ELSE                                         00028400    
  IF CAR LL ='ARGS THEN                                                 00028500    
       <<PRIN2 'ARG; PRIN2((CADR LL)+1)>>                               00028600    
  ELSE << IF POSN()>45 THEN <<TERPRI(); TTAB() >>;                      00028700    
        PRIN2 CAR LL; PRIN2 "["; EMITN1 CAR CDR LL;                     00028800    
        PRIN2 "]" >>;                                                   00028900    
                                                                        00029000    
SYMBOLIC PROCEDURE TTAB();                                              00029100    
  BEGIN SCALAR I;                                                       00029200    
    I:=REMAINDER(POSN(),6);                                             00029300    
    PRIN2 IF I<3 THEN <<                                                00029400    
            IF I=0 THEN "      " ELSE IF I=1 THEN "     " ELSE "    ">> 00029500    
            ELSE << IF I=3 THEN "   " ELSE IF I=4 THEN "  " ELSE " ">>; 00029600    
                                                            %PPDMTL99;  00029601    
  END;                                                                  00029700    
                                                                        00029800    
SYMBOLIC PROCEDURE PRINTLIST(X,CHAR);                                   00029900    
<<                                                                      00030000    
  IF POSN()>60 THEN <<TERPRI(); TTAB() >>;                              00030100    
  PRIN2 CAR X;                                                          00030200    
  IF CDR X THEN <<PRIN2 ",";                                            00030300    
        PRINTLIST(CDR X,CHAR) >>                                        00030400    
  ELSE <<PRIN2 CHAR; TERPRI() >> >>$                                    00030500    
                                                                        00030600    
SYMBOLIC PROCEDURE ALGOLIZE X;                                          00030700    
  INTERN COMPRESS ('Y . INSERTESC EXPLODE X)$                           00030800    
                                                                        00030900    
SYMBOLIC PROCEDURE INSERTESC X;                                         00031000    
  IF NULL X THEN NIL                                                    00031100    
  ELSE IF CAR X EQ 'Q THEN APPEND('(Q 9 9),INSERTESC CDR X)             00031200    
  ELSE IF CAR X EQ '!! THEN                                             00031300    
        APPEND(CDR ASSOC(CAR CDR X,TRANSLIST),INSERTESC CDR CDR X)      00031400    
  ELSE CONS(CAR X,INSERTESC CDR X)$                                     00031500    
                                                                        00031600    
                                                                        00031700    
SYMBOLIC PROCEDURE ALLOCQ N$                                            00031800    
    ALLOCQ1(N,0,QUOTED)$                                                00031900    
                                                                        00032000    
SYMBOLIC PROCEDURE BASEQSET$                                            00032100    
    BEGIN  SCALAR N$                                                    00032200    
        QUOTED:=NIL$                                                    00032300    
        BASEQ:= !$QPROG!.PTR                                            00032400    
    END$                                                                00032500    
                                                                        00032600    
SYMBOLIC PROCEDURE !$PLANTWORD N$                                       00032700    
 << !$QPROG!.PTR:=!$QPROG!.PTR+1$ PRINT N >>$                           00032800    
                                                                        00032900    
SYMBOLIC PROCEDURE ALLOCQ1(N,L,Q)$                                      00033000    
    IF NULL Q THEN BEGIN QUOTED:=NCONC(QUOTED,LIST N)$                  00033100    
            RETURN L$ END                                               00033200    
    ELSE IF CAR Q = N THEN L                                            00033300    
        ELSE ALLOCQ1(N,PLUS2(L,1),CDR Q)$                               00033400    
                                                                        00033500    
SYMBOLIC PROCEDURE !*SETUP U;                                           00033600    
 IF U THEN                                                              00033700    
  <<PUT(CAAR U,'ALGOLMACRO,CDAR U); !*SETUP CDR U>>                     00033800    
 ELSE NIL;                                                              00033900    
                                                                        00034000    
                                                                        00034100    
                                                                        00034200    
COMMENT THIS SECTION CONTAINS THE MODIFICATION TO THE COMPILER TO       00034300    
   GENERATE CODE MORE REASONABLE FOR THE B6700;                         00034400    
                                                                        00034500    
                                                                        00034600    
SYMBOLIC PROCEDURE !&COMTST(EXP,LABL);                                  00034700    
   %compiles boolean expression EXP.                                    00034800    
   %If EXP has the same value as SWITCH then branch to LABL,            00034900    
   %otherwise fall through;                                             00035000    
   %REGS/IREGS are active registers for fall through,                   00035100    
   %REGS1/IREGS1 for branch;                                            00035200    
   BEGIN SCALAR X;                                                      00035300    
        WHILE EQCAR(EXP,'NULL) DO                                       00035400    
          <<SWITCH := NOT SWITCH; EXP := CADR EXP>>;                    00035500    
        IF NOT ATOM EXP AND ATOM CAR EXP                                00035600    
                AND (X := GET(CAR EXP,'COMTST))                         00035700    
            THEN APPLY(X,LIST(EXP,LABL))                                00035800    
 ELSE IF (X := GET('NULL,'COMTST)) AND NOT EXP = '(QUOTE T) THEN        00035900    
    <<SWITCH := NOT SWITCH; APPLY(X,LIST(LIST('NULL,EXP),LABL)) >>      00036000    
         ELSE <<IF EXP = '(QUOTE T)                                     00036100    
          THEN IF SWITCH THEN !&ATTJMP LABL                             00036200    
                ELSE FLAGG := T                                         00036300    
           ELSE <<!&COMVAL(EXP,1);                                      00036400    
                !&ATTACH LIST(IF SWITCH THEN '!*JUMPT ELSE '!*JUMPNIL,  00036500    
                              CAR LABL);                                00036600    
                !&ADDJMP CODELIST>>;                                    00036700    
        REGS1 := REGS; IREGS1 :=IREGS>>;                                00036800    
        IF EQCAR(CAR CODELIST,'!*JUMPT)                                 00036900    
          THEN REGS := (1 . '(QUOTE NIL) . CDAR REGS) . CDR REGS        00037000    
         ELSE IF EQCAR(CAR CODELIST,'!*JUMPNIL)                         00037100    
          THEN REGS1 := (1 . '(QUOTE NIL) . CDAR REGS1) . CDR REGS1     00037200    
   END;                                                                 00037300    
                                                                        00037400    
SYMBOLIC PROCEDURE !&CALL1(FN,ARGS,STATUS);                             00037500    
   BEGIN INTEGER ARGNO;                                                 00037600    
        ARGNO := LENGTH ARGS;                                           00037700    
        !&LOADARGS(ARGS,STATUS);                                        00037800    
        !&ATTACH LIST('!*LINK,FN,ARGNO);                                00037900    
        IF FLAGP(FN,'ONEREG) THEN REGS := (1 .NIL) . CDR REGS           00038000    
         ELSE IF FLAGP(FN,'TWOREG)                                      00038100    
          THEN REGS := (1 . NIL) . DELASC(2,CDR REGS)                   00038200    
         ELSE REGS := LIST (1 . NIL)                                    00038300    
   END;                                                                 00038400    
                                                                        00038500    
SYMBOLIC PROCEDURE !&COMSETQ(EXP,STATUS);                               00038600    
   BEGIN SCALAR X,Y;                                                    00038700    
      EXP := CDR EXP;                                                   00038800    
   IF STATUS>1 AND (NULL CADR EXP OR CADR EXP='(QUOTE NIL))             00038900    
    THEN !&STORE2(CAR EXP,NIL)                                          00039000    
    ELSE <<                                                             00039100    
  IF STATUS>1 AND !&ANYREG(CADR EXP,NIL) THEN                           00039200    
  << X:=!&LOCATE CADR EXP;                                              00039300    
>> ELSE << X:=1; !&COMVAL(CADR EXP,1)>>;                                00039400    
           !&STORE2(CAR EXP,X);                                         00039500    
           IF Y := !&RASSOC(CAR EXP,IREGS)                              00039600    
                THEN IREGS := DELETE(Y,IREGS);                          00039700    
    REGS:=!&PPP(REGS,X,EXP );                                           00039800    
  >>;                                                                   00039900    
   END;                                                                 00040000    
                                                                        00040100    
SYMBOLIC PROCEDURE !&PPP(L,R,E);                                        00040200    
  <<                                                                    00040300    
  IF NULL L THEN NIL                                                    00040400    
  ELSE IF CAAR L EQ R THEN                                              00040500    
     (R . CAR E . CDAR L) . CDR L                                       00040600    
  ELSE CONS(CAR L, !&PPP(CDR L,R,E))                                    00040700    
>>;                                                                     00040800    
                                                                        00040900    
SYMBOLIC PROCEDURE !&TEST(EXP,LABL);                                    00041000    
   BEGIN SCALAR X;                                                      00041100    
        IF NOT (X := !&ANYREG(CADR EXP,NIL))                            00041200    
          THEN !&COMVAL(CADR EXP,1);                                    00041300    
        !&CLRREGS();                                                    00041400    
        !&ATTACH LIST(IF SWITCH THEN '!*TESTT ELSE '!*TESTN,            00041500    
                      CAR LABL,                                         00041600    
                      IF X THEN !&LOCATE CADR EXP ELSE LIST(1),         00041700    
                      GET(CAR EXP,'MACFN));                             00041800    
        REGS1 := REGS;                                                  00041900    
        !&ADDJMP CODELIST                                               00042000    
   END;                                                                 00042100    
                                                                        00042200    
SYMBOLIC PROCEDURE !&TEST2(EXP,LABL);                                   00042300    
   BEGIN                                                                00042400    
        SCALAR REG,U,V,W,X;                                             00042500    
        U := CADR EXP;                                                  00042600    
        V := CADDR EXP;                                                 00042700    
        !&CLRREGS();                                                    00042800    
        IF !&ANYREG(U,LIST V) THEN                                      00042900    
             IF !&ANYREG(V,NIL)                                         00043000    
          THEN <<U := !&LOCATE U; V := !&LOCATE V>>                     00043100    
          ELSE <<!&COMVAL(V,1); U := !&LOCATE U; V := LIST(1)>>         00043200    
        ELSE IF !&ANYREG(V,NIL)                                         00043300    
          THEN <<!&COMVAL(U,1); U := LIST(1); V:= !&LOCATE V>>          00043400    
               ELSE <<U := !&COMLIS CDR EXP; U := !&LOCATE CADR U;      00043500    
                      V  := LIST(1)>>;                                  00043600    
        !&ATTACH LIST ((IF SWITCH THEN                                  00043700    
                          '!*TEST2T ELSE '!*TEST2N),                    00043800    
                        CAR LABL,U,V,CAR EXP);                          00043900    
        REGS1 := REGS;                                                  00044000    
        !&ADDJMP CODELIST                                               00044100    
   END;                                                                 00044200    
                                                                        00044300    
SYMBOLIC PROCEDURE !&1PARM(EXP,STATUS);                                 00044400    
   BEGIN SCALAR X;                                                      00044500    
        IF NOT (X := !&ANYREG(CADR EXP,NIL))                            00044600    
          THEN !&COMVAL(CADR EXP,1);                                    00044700    
        !&CLRREGS();                                                    00044800    
        !&ATTACH LIST('!*1PARM,                                         00044900    
                      IF X THEN !&LOCATE CADR EXP ELSE LIST(1),         00045000    
                      GET(CAR EXP,'PARMFN));                            00045100    
        REGS := (1 . NIL) . CDR REGS;                                   00045200    
   END;                                                                 00045300    
                                                                        00045400    
SYMBOLIC PROCEDURE !&2PARM(EXP,STATUS);                                 00045500    
   BEGIN                                                                00045600    
        SCALAR REG,U,V,W,X;                                             00045700    
        U := CADR EXP;                                                  00045800    
        V := CADDR EXP;                                                 00045900    
        !&CLRREGS();                                                    00046000    
        IF !&ANYREG(U,LIST V) THEN                                      00046100    
             IF !&ANYREG(V,NIL)                                         00046200    
          THEN <<U := !&LOCATE U; V := !&LOCATE V>>                     00046300    
          ELSE <<!&COMVAL(V,1); U := !&LOCATE U; V := LIST(1)>>         00046400    
        ELSE IF !&ANYREG(V,NIL)                                         00046500    
          THEN <<!&COMVAL(U,1); U := LIST(1); V:= !&LOCATE V>>          00046600    
               ELSE <<U := !&COMLIS CDR EXP; U := !&LOCATE CADR U;      00046700    
                      V  := LIST(1)>>;                                  00046800    
        !&ATTACH LIST ('!*2PARM,1,U,V,CAR EXP);                         00046900    
        REGS := (1 . NIL) . CDR REGS;                                   00047000    
   END;                                                                 00047100    
                                                                        00047200    
                                                                        00047300    
END;                                                                    00047400    
%                                                                       10000100    
%                                                                       10000200    
%*********************************************************************  10000300    
%**                                                                 **  10000400    
%**         COMMENTS ON THE PATCHES WRITTEN BY MONTREAL PPD         **  10000500    
%**                                                                 **  10000600    
%*********************************************************************  10000700    
%                                                                       10000800    
%PPDMTL99               08/28/85                       L. SANS CARTIER  10002000    
%THESE ARE ONLY MINOR MODIFICATIONS THAT HAD TO BE MADE WHEN WE DECIDED 10002100    
%TO CHANGE THE FILE TYPE FROM "DATA" (80 CHAR./REC.) TO "SEQ" (ONLY     10002200    
%72 CHAR./REC.). CHANGING THE FILE TYPE WAS NECESSARY IN ORDER TO BE    10002300    
%ABLE TO MANAGE PATCHES.                                                10002400    
%                                                                       10002500    
« 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: