Forgot your password?
Document Actions
TORECREATE/B6700.sqd_m, also written in RLISP, contains the code specific to the B6000/7000 series.
TORECREATE/B6700.sqd_m, also written in RLISP, contains the code specific to the B6000/7000 series.
Size 30.1 kB - File type text/plain
Click here to get the file
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