% 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 <> ELSE 00020100 IF Y=3 THEN %SPECIAL CHARACTER; 00020200 IF X="'" THEN 00020300 <> 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 <>; 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 <> ; %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 <>; 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 <LIMIT) DO 00032100 <>; 00032500 RETURN MK!*SQ VALUE 00032600 >> ELSE << 00032700 WHILE NOT (CURVAL>LIMIT) DO 00032800 <>; 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