Personal tools
You are here: Home Projects LISP Utah REDUCE 2 and Standard LISP for Burroughs B6700 TORECREATE/B6700.sqd_m, also written in RLISP, contains the code specific to the B6000/7000 series.
Document Actions

TORECREATE/B6700.sqd_m, also written in RLISP, contains the code specific to the B6000/7000 series.

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

TORECREATE/B6700.sqd_m, also written in RLISP, contains the code specific to the B6000/7000 series.

Click here to get the file

Size 30.1 kB - File type text/plain

File contents

% THIS FILE CONTAINS CODE WHICH IS SPECIFIC TO THE BURROUGHS B6000/7000 00000100    
   SERIES MACHINES AND CODE WHICH MAKES SOME MINOR EFFICIENCY           00000200    
   ENHANCEMENTS TO REDUCE;                                   %PPDMTL99; 00000300    
                                                                        00000400    
                                                                        00000500    
SYMBOLIC;                                                               00000600    
                                                                        00000700    
GLOBAL '(TIME1!* TIME2!* DATE!* PROGRAM!-NAME IMODE!*)$                 00000800    
                                                                        00000900    
GLOBAL '(!*!*EOF !*!*ESC !*!*FMARK)$                                    00001000    
!*!*ESC:='!|;                                                           00001100    
!*!*EOF:='!$EOF!$;                                                      00001200    
!*!*FMARK:='!&;                                                         00001300    
                                                                        00001400    
GLOBAL '(CRCHAR!* NXTSYM!* TTYPE!*);                                    00001500    
                                                                        00001600    
SMACRO PROCEDURE PRETTYPRINT U; PRINT U;                                00001700    
SMACRO PROCEDURE RPRINT U; PRINT U;                                     00001800    
SMACRO PROCEDURE FLAGP!*!*(U,V); FLAGP(U,V);                            00001900    
                                                                        00002000    
SYMBOLIC PROCEDURE BEGIN;                                               00002100    
   BEGIN                                                                00002200    
        TIME1!* := TIME2!* := EVAL '(TIME NIL);                         00002300    
        !*INT := T;                                                     00002400    
        !*ECHO := NIL;                                                  00002500    
        CONTL!* := IFL!* := IPL!* := OFL!* := OPL!* := NIL;             00002600    
        IF DATE!* THEN                                                  00002700    
        <<                                                              00002800    
           PRIN2 PROGRAM!-NAME;                                         00002900    
           PRIN2 "(";                                                   00003000    
           PRIN2 DATE!*;                                                00003100    
           PRIN2 ") ...";                                               00003200    
           TERPRI();                                                    00003300    
           DATE!* := NIL;                                               00003400    
        >>;                                                             00003500    
        !*MODE := IMODE!*;                                              00003600    
        CRCHAR!* := '! ;                                                00003700    
        BEGIN1();                                                       00003800    
        TERPRI();                                                       00003900    
        PRIN2 "ENTERING LISP...";                                       00004000    
        TERPRI()                                                        00004100    
   END;                                                                 00004200    
                                                                        00004300    
FLAG('(BEGIN),'GO);                                                     00004400    
                                                                        00004500    
SMACRO PROCEDURE DELCP U; (U='!; OR U='!$);                             00004600    
                                                                        00004700    
SYMBOLIC PROCEDURE MKFIL U; U;                                          00004800    
                                                                        00004900    
SYMBOLIC PROCEDURE SEPRP U; U='!  OR U=!$EOL!$;                         00005000    
                                                                        00005100    
SYMBOLIC PROCEDURE BEGIN1;                                              00005200    
   BEGIN SCALAR PARSERR,RESULT;                                         00005300    
    A0: CURSYM!* := '!*SEMICOL!*;                                       00005400    
    A:  PARSERR := NIL;                                                 00005500    
        IF !*OUTPUT AND !*INT AND NULL IFL!* AND NULL OFL!*             00005600    
          THEN TERPRI();                                                00005700    
        IF !*TEST THEN STIME 'TIME2!*;                                  00005800    
        IF TMODE!* AND (!*MODE := TMODE!*) THEN TMODE!* := NIL;         00005900    
        MAPCAR(INITL!*,FUNCTION SINITL);                                00006000    
        IF !*INT THEN ERFG!* := NIL;    %to make editing work properly; 00006100    
        IF CURSYM!* EQ 'END THEN GO TO ND0;                             00006200    
        PROGRAM!* := ERRORSET('(COMMAND),T,!*BACKTRACE);                00006300    
        IF !*OUTPUT AND !*EXTRAECHO AND (NULL !*INT OR IFL!*)           00006400    
          THEN TERPRI();                                                00006500    
        IF ATOM PROGRAM!* OR CDR PROGRAM!* THEN GO TO ERR1;             00006600    
        PROGRAM!* := CAR PROGRAM!*;                                     00006700    
        IF EQCAR(PROGRAM!*,'!*COMMA!*) THEN GO TO ER                    00006800    
         ELSE IF CURSYM!* EQ !*!*EOF THEN GO TO ND1                     00006900    
         ELSE IF CURSYM!* EQ 'END THEN GO TO ND0;                       00007000    
        PROGRAM!* := IF EQCAR(PROGRAM!*,'RETRY) THEN LIST PROGRAML!*    00007100    
                     ELSE ERRORSET('(MKEX PROGRAM!*),T,!*BACKTRACE);    00007200    
        IF ATOM PROGRAM!* OR CDR PROGRAM!* THEN GO TO ERR3;             00007300    
        PROGRAM!* := CAR PROGRAM!*;                                     00007400    
        IF !*DEFN THEN GO TO D;                                         00007500    
    B:  IF !*OUTPUT AND IFL!* AND !*ECHO THEN TERPRI();                 00007600    
        RESULT := ERRORSET(EVAL 'PROGRAM!*,T,!*BACKTRACE);              00007700    
        IF ATOM RESULT OR CDR RESULT OR ERFG!* THEN GO TO ERR2          00007800    
         ELSE IF !*DEFN THEN GO TO A;                                   00007900    
        RESULT := CAR RESULT;                                           00008000    
        IF NULL !*OUTPUT THEN GO TO C;                                  00008100    
        IF SEMIC!* EQ '!;                                               00008200    
          THEN IF !*MODE EQ 'SYMBOLIC THEN BEGIN                        00008300    
            TERPRI(); PRINT RESULT END                                  00008400    
         ELSE IF RESULT THEN PROGN(TERPRI!* T,                          00008500    
                                   VARPRI(RESULT,ASSGNL PROGRAM!*,T));  00008600    
    C:  IF NULL(!*MODE EQ 'SYMBOLIC) AND RESULT THEN !*ANS:= RESULT;    00008700    
        GO TO A;                                                        00008800    
    D:  IF ERFG!* THEN GO TO A                                          00008900    
         ELSE IF FLAGP!*!*(KEY!*,'IGNORE) OR EQCAR(PROGRAM!*,'QUOTE)    00009000    
          THEN GO TO B;                                                 00009100    
        DFPRINT PROGRAM!*;                                              00009200    
        IF FLAGP!*!*(KEY!*,'EVAL) THEN GO TO B ELSE GO TO A;            00009300    
    ND0:COMM1 'END;                                                     00009400    
    ND1: EOF!* := NIL;                                                  00009500    
    CURSYM!* := '!*SEMICOL!*;                                           00009600    
        IF NULL IPL!*   %terminal END;                                  00009700    
          THEN BEGIN                                                    00009800    
                IF OFL!* THEN WRS NIL;                                  00009900    
            AA: IF NULL OPL!* THEN RETURN(OFL!* := NIL);                00010000    
                CLOSE CDAR OPL!*;                                       00010100    
                OPL!* := CDR OPL!*;                                     00010200    
                GO TO AA                                                00010300    
              END;                                                      00010400    
        RETURN NIL;                                                     00010500    
    ERR1:                                                               00010600    
        IF EOF!* OR PROGRAM!* EQ !*!*EOF THEN GO TO ND1                 00010700    
         ELSE IF PROGRAM!* EQ 'EXTRA! BEGIN THEN GO TO A                00010800    
         ELSE IF PROGRAM!* EQ !*!*ESC THEN GO TO A0                     00010900    
         ELSE GO TO ER1;                                                00011000    
    ER: LPRIE IF NULL ATOM CADR PROGRAM!*                               00011100    
                  THEN LIST(CAADR PROGRAM!*,"UNDEFINED")                00011200    
                 ELSE "SYNTAX ERROR";                                   00011300    
    ER1:                                                                00011400    
        PARSERR := T;                                                   00011500    
        GO TO ERR3;                                                     00011600    
    ERR2:                                                               00011700    
        PROGRAML!* := PROGRAM!*;                                        00011800    
    ERR3:                                                               00011900    
        COMM1 T;                                                        00012000    
        IF NULL ERFG!* OR ERFG!* EQ 'HOLD                               00012100    
         THEN LPRIE "ERROR TERMINATION *****";                          00012200    
        ERFG!* := T;                                                    00012300    
        IF NULL !*INT THEN GO TO E;                                     00012400    
        RESULT := PAUSE1 PARSERR;                                       00012500    
        IF RESULT THEN RETURN NULL EVAL RESULT;                         00012600    
        ERFG!* := NIL;                                                  00012700    
        GO TO A;                                                        00012800    
    E:  !*DEFN := T;    %continue syntax analyzing but not evaluation;  00012900    
        !*ECHO := T;                                                    00013000    
        IF NULL CMSG!* THEN LPRIE "CONTINUING WITH PARSING ONLY ...";   00013100    
        CMSG!* := T;                                                    00013200    
        GO TO A                                                         00013300    
   END;                                                                 00013400    
                                                                        00013500    
SYMBOLIC PROCEDURE SCAN;                                                00013600    
   BEGIN SCALAR X,Y;                                                    00013700    
        IF NULL (CURSYM!* EQ '!*SEMICOL!*) THEN GO TO B;                00013800    
    A:  NXTSYM!* := TOKEN();                                            00013900    
    B:  IF NULL ATOM NXTSYM!* THEN GO TO Q1                             00014000    
         ELSE IF NXTSYM!* EQ 'ELSE OR CURSYM!* EQ '!*SEMICOL!*          00014100    
         THEN OUTL!* := NIL;                                            00014200    
        PRIN2X NXTSYM!*;                                                00014300    
    C:  IF NUMBERP NXTSYM!* THEN GO TO L                                00014400    
         ELSE IF X:=GET(NXTSYM!*,'NEWNAM) THEN GO TO NEW                00014500    
         ELSE IF NXTSYM!* EQ 'COMMENT OR NXTSYM!* EQ '!% AND TTYPE!*=3  00014600    
          THEN GO TO COMM                                               00014700    
         ELSE IF NXTSYM!* EQ !*!*ESC THEN ERROR(99,!*!*ESC)             00014800    
         ELSE IF NULL(TTYPE!* = 3) THEN GO TO L                         00014900    
         ELSE IF NXTSYM!* EQ '!' THEN GO TO QUOTE                       00015000    
         ELSE IF NULL (X:= GET(NXTSYM!*,'SWITCH!*)) THEN GO TO L        00015100    
         ELSE IF CADR X EQ '!*SEMICOL!* THEN GO TO DELIM;               00015200    
   SW1: NXTSYM!* := TOKEN();                                            00015300    
        IF CAR X AND TTYPE!*=3 THEN GO TO SW3;                          00015400    
   SW2: CURSYM!*:=CADR X;                                               00015500    
        IF CURSYM!* EQ '!*RPAR!* THEN GO TO L2                          00015600    
         ELSE RETURN CURSYM!*;                                          00015700    
   SW3: IF NULL (Y:= ATSOC(NXTSYM!*,CAR X)) THEN GO TO SW2;             00015800    
        PRIN2X NXTSYM!*;                                                00015900    
        X := CDR Y;                                                     00016000    
        GO TO SW1;                                                      00016100    
  COMM: IF DELCP CRCHAR!* THEN GO TO COM1;                              00016200    
        CRCHAR!* := READCH();                                           00016300    
        GO TO COMM;                                                     00016400    
  COM1: CRCHAR!* := '! ;                                                00016500    
        IF !*OUTPUT AND !*EXTRAECHO AND (NULL !*INT OR IFL!*)           00016600    
          THEN TERPRI();                                                00016700    
        GO TO A;                                                        00016800    
  DELIM:                                                                00016900    
        SEMIC!*:=NXTSYM!*;                                              00017000    
        RETURN (CURSYM!*:='!*SEMICOL!*);                                00017100    
  NEW:  NXTSYM!* := X;                                                  00017200    
        IF ATOM X THEN GO TO C ELSE GO TO Q1;                           00017300    
  QUOTE:                                                                00017400    
        NXTSYM!* := MKQUOTE RREAD1();                                   00017500    
        GO TO L;                                                        00017600    
  Q1:   IF NULL (CAR NXTSYM!* EQ 'STRING) THEN GO TO L;                 00017700    
        PRIN2X " ";                                                     00017800    
        PRIN2X CADR(NXTSYM!* := 'QUOTE . CDR NXTSYM!*);                 00017900    
  L:    IF NXTSYM!* EQ !*!*EOF                                          00018000    
          THEN <<NXTSYM!* := '!*SEMICOL!*;                              00018100    
                   RETURN CURSYM!* := !*!*EOF>>;                        00018200    
        CURSYM!*:=NXTSYM!*;                                             00018300    
  L1:   NXTSYM!* := TOKEN();                                            00018400    
  L2:   IF NUMBERP NXTSYM!*                                             00018500    
           OR (ATOM NXTSYM!* AND NULL GET(NXTSYM!*,'SWITCH!*))          00018600    
          THEN PRIN2X " ";                                              00018700    
        RETURN CURSYM!*                                                 00018800    
   END;                                                                 00018900    
                                                                        00019000    
SYMBOLIC PROCEDURE TOKEN;                                               00019100    
   BEGIN SCALAR X,Y;                                                    00019200    
         CRCHAR!* := '! ;                                               00019300    
         Y := TTYPE!* := !$SCAN(T);                                     00019400    
         X := !$SCNVAL;                                                 00019500    
         IF Y=0 THEN     %IDENTIFIER;                                   00019600    
              <<NXTSYM!* := INTERN X >> ELSE                            00019700    
         IF Y=2 THEN     %NUMBER;                                       00019800    
              <<NXTSYM!* := X>> ELSE                                    00019900    
         IF Y=1 THEN     %STRING;                                       00020000    
              <<NXTSYM!* := LIST('STRING,X)>> ELSE                      00020100    
         IF Y=3 THEN     %SPECIAL CHARACTER;                            00020200    
              IF X="'" THEN                                             00020300    
                   <<NXTSYM!* := MKQUOTE RREAD(); TTYPE!* := 4>>        00020400    
              ELSE NXTSYM!* := INTERN X ELSE                            00020500    
         IF Y=4 OR X=!*!*EOF THEN                                       00020600    
                NXTSYM!* := !*!*EOF;                                    00020700    
         RETURN NXTSYM!*;                                               00020800    
    END;                                                                00020900    
                                                                        00021000    
SYMBOLIC PROCEDURE COMMAND;                                             00021100    
   BEGIN SCALAR X;                                                      00021200    
        IF SCAN() EQ !*!*EOF THEN RETURN !*!*EOF;                       00021300    
        KEY!* := CURSYM!*;                                              00021400    
        X := XREAD1 NIL;                                                00021500    
        IF !*PRET THEN PROGN(TERPRI(),RPRINT X);                        00021600    
        RETURN REFORM X                                                 00021700    
   END;                                                                 00021800    
                                                                        00021900    
                                                                        00022000    
                                                                        00022100    
                                                                        00022200    
SYMBOLIC PROCEDURE STIME U;                                             00022300    
  BEGIN SCALAR X;                                                       00022400    
    X := EVAL U;                                                        00022500    
    SET(U,EVAL '(TIME NIL));                                            00022600    
    TERPRI();                                                           00022700    
    PRIN2(EVAL U-X);                                                    00022800    
    PRIN2 " MS";                                                        00022900    
    TERPRI();                                                           00023000    
  END;                                                                  00023100    
                                                                        00023200    
SYMBOLIC PROCEDURE TIMSTAT;                                             00023300    
  <<SCAN(); '(STIME (QUOTE TIME2!*))>>;                                 00023400    
                                                                        00023500    
DEFLIST ('((TIME TIMSTAT)),'STAT);                                      00023600    
                                                                        00023700    
FLAG('(TIMSTAT),'ENDSTAT);                                              00023800    
                                                                        00023900    
FLAG('(STIME),'NOCHANGE);                                               00024000    
                                                                        00024100    
                                                                        00024200    
SYMBOLIC PROCEDURE KERNP U;                                             00024300    
   DENR U=1 AND NOT DOMAINP(NUMR U)                                     00024400    
        AND NULL RED(U:=NUMR U) AND (LC U=1 OR LC U=1.0) AND LDEG U=1;  00024500    
                                                                        00024600    
%                        2.10.3 FOR STATEMENT                           00024700    
%********************************************************************;  00024800    
                                                                        00024900    
SYMBOLIC PROCEDURE FORLOOP;                                             00025000    
   BEGIN SCALAR ACTION,BODY,INCR,VAR,X;                                 00025100    
      X := XREAD1 'FOR;                                                 00025200    
      IF ATOM X OR NOT CAR X MEMQ '(EQUAL SETQ) THEN SYMERR('FOR,T);    00025300    
      VAR := CADR X;                                                    00025400    
      X := CADDR X;                                                     00025500    
      IF NOT IDP VAR THEN SYMERR('FOR,T);                               00025600    
      VAR := CAR FLAGTYPE(LIST VAR,'INTEGER);                           00025700    
      IF CURSYM!* EQ 'STEP                                              00025800    
        THEN <<INCR := MKEX XREAD T;                                    00025900    
               IF INCR EQ 0 THEN                             %PPDMTL16; 00025950    
                << LPRIM "THE MINIMUM VALUE FOR 'STEP' IS 1";%PPDMTL16; 00025970    
                   INCR := 1 >> ;                            %PPDMTL16; 00025990    
                IF NOT CURSYM!* EQ 'UNTIL THEN SYMERR('FOR,T)>>         00026000    
       ELSE IF CURSYM!* EQ '!*COLON!* THEN INCR := 1                    00026100    
       ELSE SYMERR('FOR,T);                                             00026200    
      INCR := LIST(X,INCR,MKEX XREAD T);                                00026300    
      IF NOT GET(ACTION := CURSYM!*,'BIN) AND NOT ACTION EQ 'DO         00026400    
        THEN SYMERR('FOR,T);                                            00026500    
      BODY := MKEX XREAD T;                                             00026600    
      REMTYPE LIST VAR;                                                 00026700    
      X := NOT !*COMP AND NUMBERP CADR INCR AND CADR INCR > 0 AND       00026800    
             NUMBERP CADDR INCR;                                        00026900    
      IF X THEN RETURN FORDIRECT(VAR,INCR,ACTION,BODY)                  00027000    
           ELSE RETURN FORMACRO(VAR,INCR,ACTION,BODY)                   00027100    
   END;                                                                 00027200    
                                                                        00027300    
SYMBOLIC PROCEDURE FORDIRECT(VAR,INCR,ACTION,BODY);                     00027400    
     MKPROG(VAR . NIL,LIST(LIST('RETURN,LIST('FORPROCEDURE,             00027500    
             VAR,INCR,ACTION,BODY))));                                  00027600    
                                                                        00027700    
SYMBOLIC PROCEDURE FORMACRO(VAR,INCR,ACTION,BODY);                      00027800    
   BEGIN SCALAR EXP,LAB1,LAB2,RESULT,TAIL,X;                            00027900    
      RESULT := LIST LIST('SETQ,VAR,CAR INCR);                          00028000    
      INCR := CDR INCR;                                                 00028100    
      X:=LIST('NOT, IF NUMBERP CAR INCR AND CAR INCR > 0 THEN           00028200    
                       LIST('LESSP,CADR INCR,VAR)                       00028300    
                    ELSE                                                00028400    
                       LIST('MINUSP,LIST('TIMES2,CAR INCR,              00028500    
                          LIST('DIFFERENCE,CADR INCR,VAR))));           00028600    
      IF NOT ACTION EQ 'DO                                              00028700    
        THEN <<ACTION := GET(ACTION,'BIN);                              00028800    
                EXP := GENSYM();                                        00028900    
                BODY := LIST('SETQ,EXP,                                 00029000    
                              LIST(CAR ACTION,LIST('SIMP,BODY),EXP));   00029100    
                RESULT := LIST('SETQ,EXP,MKQUOTE CDR ACTION) . RESULT;  00029200    
                TAIL := LIST LIST('RETURN,LIST('MK!*SQ,EXP));           00029300    
                EXP := LIST EXP>>;                                      00029400    
      LAB1 := GENSYM();                                                 00029500    
      RESULT := NCONC(RESULT,                                           00029600    
                 LAB1 .                                                 00029700    
                LIST('COND,LIST(X,LIST('PROGN,                          00029800    
                BODY,                                                   00029900    
                LIST('SETQ,VAR,LIST('PLUS2,VAR,CAR INCR)),              00030000    
                LIST('GO,LAB1)))) .                                     00030100    
                TAIL);                                                  00030200    
      RETURN MKPROG(VAR . EXP,RESULT)                                   00030300    
   END;                                                                 00030400    
                                                                        00030500    
SYMBOLIC FEXPR PROCEDURE FORPROCEDURE U;                                00030600    
   BEGIN SCALAR CURVAL,VALUE,LIMIT,VAR,INCR,ACTION,BODY;                00030700    
     VAR := CAR U;                                                      00030800    
     INCR := CADR U;                                                    00030900    
     ACTION := CADDR U;                                                 00031000    
     BODY := CAR CDDDR U;                                               00031100    
     CURVAL := CAR INCR;                                                00031200    
     IF NOT NUMBERP CURVAL THEN CURVAL := EVAL CURVAL;                  00031300    
     SET(VAR,CURVAL);                                                   00031400    
     LIMIT := CADDR INCR;                                               00031500    
     INCR := CADR INCR;                                                 00031600    
     IF NOT ACTION = 'DO                                                00031700    
       THEN <<IF NOT (ACTION := GET(ACTION,'BIN))                       00031800    
                 THEN REDERR "INVALID FOR STATEMENT";                   00031900    
              VALUE := CDR ACTION; ACTION := CAR ACTION;                00032000    
              WHILE NOT (CURVAL>LIMIT) DO                               00032100    
              <<VALUE := APPLY(ACTION,LIST(SIMP EVAL BODY,VALUE));      00032200    
                CURVAL := CURVAL+INCR;                                  00032300    
                SET(VAR,CURVAL)                                         00032400    
              >>;                                                       00032500    
              RETURN MK!*SQ VALUE                                       00032600    
       >> ELSE <<                                                       00032700    
              WHILE NOT (CURVAL>LIMIT) DO                               00032800    
              <<EVAL BODY;                                              00032900    
                CURVAL := CURVAL+INCR;                                  00033000    
                SET(VAR,CURVAL)                                         00033100    
              >>;                                                       00033200    
              RETURN NIL                                                00033300    
       >>;                                                              00033400    
   END;                                                                 00033500    
                                                                        00033600    
END;                                                                    00033700    
%                                                                       10000100    
%                                                                       10000200    
%*********************************************************************  10000300    
%**                                                                 **  10000400    
%**         COMMENTS ON THE PATCHES WRITTEN BY MONTREAL PPD         **  10000500    
%**                                                                 **  10000600    
%*********************************************************************  10000700    
%                                                                       10000800    
%PPDMTL16               08/30/85                       L. SANS CARTIER  10000900    
%THIS PATCH WILL DETECT THE CASE WHERE A STATEMENT "FOR..STEP 0.." IS   10001000    
%GIVEN . IT WILL REPLACE "0" BY "1", SINCE IT IS THE MINIMUM VALUE THAT 10001100    
%IS ALLOWED (INSTEAD OF LOOPING).                                       10001200    
%                                                                       10001300    
%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    
« May 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: