perm filename PARSER.SAI[OK,TES]3 blob
sn#117729 filedate 1974-08-26 generic text, type T, neo UTF8
00100 ENTRY MANUSCRIPT ;
00200 BEGIN "PARSER"
00300
00400 DEFINE TERNAL = "EXTERNAL" , PRELOAD = "COMMENT" ;
00500 REQUIRE "PUBDFS" SOURCE!FILE ;
00600 REQUIRE "PUBMAI" SOURCE!FILE ;
00700 BEGIN "INNER BLOCK"
00800 REQUIRE "PUBINR" SOURCE!FILE ;
00900 REQUIRE "PUBPRO" SOURCE!FILE ;
01000 EXTERNAL INTEGER PROCEDURE XLENGTH(STRING S);
01100
01200 EXTERNAL RECURSIVE BOOLEAN PROCEDURE TEXTLINE ;
01300
01400 EXTERNAL RECURSIVE PROCEDURE DBREAK ;
01500
01600 EXTERNAL STRING SIMPLE PROCEDURE LABELREF(INTEGER USYMB, LEN) ;
01700
01800 FORWARD INTERNAL RECURSIVE BOOLEAN PROCEDURE CHUNK(BOOLEAN VALID) ;
01900
02000 FORWARD INTERNAL RECURSIVE STRING PROCEDURE E(STRING DEFAULT, STOPWORD) ;
02100
02140 FORWARD INTERNAL RECURSIVE STRING PROCEDURE PASS ;
02180
02200 EXTERNAL SIMPLE STRING PROCEDURE PICKFONT(INTEGER F) ;
02300
02400 IFC TENEX THENC
02500 STRING PROCEDURE SCANTO(STRING BRKS; REFERENCE STRING SCANNEE; BOOLEAN INCLUDE) ;
02600 BEGIN
02700 INTEGER DUMMY ;
02800 SETBREAK(LOCAL!TABLE, BRKS, NULL, IF INCLUDE THEN "IA" ELSE "IR") ;
02900 RETURN(SCAN(SCANNEE, LOCAL!TABLE, DUMMY)) ;
03000 END ;
03100
03200 STRING SIMPLE PROCEDURE CVFIL(STRING FILENAME; REFERENCE STRING EXT, PPN) ;
03300 BEGIN
03400 STRING NAME ;
03500 PPN ← IF FILENAME[1 FOR 1] = "<" THEN SCANTO(">", FILENAME, TRUE) ELSE NULL ;
03600 NAME ← SCANTO(".;", FILENAME, FALSE) ;
03700 EXT ← IF FILENAME[1 FOR 1] = "." THEN SCANTO(";", FILENAME, FALSE) ELSE NULL ;
03800 RETURN(NAME) ;
03900 END ;
04000
04100 SIMPLE STRING PROCEDURE INCHWL ;
04200 BEGIN
04300 STRING S ; INTEGER C ;
04400 S ← NULL ;
04500 DO
04600 BEGIN
04700 C ← PBIN ;
04800 IF C = CTLA THEN
04837 IF NULSTR(S) OR EQU(S[∞-3 TO ∞], CRLF&"##") THEN
04875 ELSE BEGIN
05000 TES 8/23/74 ↑A ECHOES ANYWAY, SO FORGET PBOUT("\") ;
05100 PBOUT(S[∞ FOR 1]) ;
05200 S ← S[1 TO ∞-1] ;
05300 END
05400 ELSE IF C = CTLS THEN OUTSTR(" =" & EOL & "#" & S)
05500 ELSE IF C = EOL OR C = ALTMODE THEN RETURN(S)
05600 ELSE IF C = CTLV THEN S ← S & PBIN
05700 ELSE IF C=RUBOUT THEN
05800 BEGIN
05900 OUTSTR(" XXX" & EOL & "#") ;
06000 S ← NULL ;
06100 END
06200 ELSE IF C = LF THEN TES 8/23/74 ;
06300 IF LAST<4 THEN RETURN(S)
06400 ELSE BEGIN OUTSTR(CR&"##") ; S ← S & (CRLF&"##") END
06500 ELSE IF C = CTLQ THEN TES 8/23/74 ;
06600 BEGIN
06700 OUTSTR("←"&CRLF&"#") ;
06710 WHILE FULSTR(S) AND NOT EQU(S[∞-3 TO ∞],CRLF&"##") DO S←S[1 TO ∞-1] ;
06715 IF FULSTR(S) THEN OUTSTR("#") ;
06720 END
06800 ELSE S ← S & C ;
06900 END UNTIL FALSE ;
07000 END "INCHWL" ;
07100 ENDC
07200
07300 SIMPLE STRING PROCEDURE SUBST(STRING STR, OLDS, NEWFIRST, NEWREST) ;
07400 BEGIN TES 8/23/74 FOR PUB!DEBUG AT LEAST ;
07450 INTEGER WHICH ; TES 8/23/74 ;
07500 STRING S ;
07550 S ← NULL ; WHICH ← 0 ;
07600 WHILE FULSTR(STR) DO
07700 IF EQU(STR[1 TO LENGTH(OLDS)], OLDS) THEN
07800 BEGIN
07900 S ← S & (IF (WHICH←WHICH+1)=1 THEN NEWFIRST ELSE NEWREST) ;
08000 STR ← STR[LENGTH(OLDS)+1 TO ∞] ;
08100 END
08200 ELSE S ← S & LOP(STR) ;
08300 RETURN(S) ;
08400 END "SUBST" ;
00100 INTERNAL STRING SIMPLE PROCEDURE RD(INTEGER BRKTBL) ;
00200 BEGIN
00300 COMMENT INPUTSTR = [ [chars] LF line-no TB ]... [chars]
00400 All break tables should break on LF.
00500 RD's value is as if LF line-no TB were null. ;
00600 INTEGER PTR, BYTEWD ; STRING SPTR, RESULT, PART ;
00700 RESULT ← NULL ;
00800 DO BEGIN "PARTIAL"
00900 PART ← SCAN(INPUTSTR, BRKTBL, BRC) ;
01000 IF BRC = LF THEN
01100 BEGIN "MACRO LINE NUMBER"
01200 MACLINE ← SCAN(INPUTSTR, TO!TB!FF!SKIP, DUMMY) ;
01300 IF PART[∞ FOR 1] = LF THEN comment he Appended the break character ;
01400 PART ← IF DEFINING THEN PART & MACLINE & TB ELSE PART[1 TO ∞-1]
01500 ELSE IF DEFINING THEN PART ← PART & LF & MACLINE & TB ;
01600 END "MACRO LINE NUMBER"
01700 ELSE IF BRC = 0 THEN comment, ran out of input ;
01800 IF INPUTCHAN < 0 THEN INPUTSTR ← SWICHBACK comment, done scanning macro body ;
01900 ELSE BEGIN "FROM FILE"
02000 DO BEGIN comment, may be page marks or eof or more lines ;
02100 IF TECOFILE THEN
02200 BEGIN COMMENT CHECK FOR FF AND SUPERFLUOUS LFs ;
02300 SRCLINE ← CVS(CVD(SRCLINE)+1) ;
02400 INPUT(INPUTCHAN, NO!CHARS) ;
02500 WHILE BRC = LF DO
02600 BEGIN
02700 INPUT(INPUTCHAN,ONE!CHAR) ;
02800 INPUT(INPUTCHAN,NO!CHARS) ;
02900 END ;
03000 END
03100 ELSE SRCLINE ← INPUT(INPUTCHAN, TO!TB!FF!SKIP) ;
03200 IF BRC = FF THEN
03300 BEGIN "PGMARK"
03400 PAGEMARKS ← PAGEMARKS + 1 ;
03500 IF TECOFILE THEN
03600 BEGIN
03700 INPUT(INPUTCHAN, ONE!CHAR) ;
03800 SRCLINE ← "0" ;
03900 END ;
04000 WHILE INPGS ∧ LAST=4 ∧ BRC=FF ∧ PAGEMARKS>RH(INPG[INPGX]) DO
04100 IF (INPGX←INPGX+1)>INPGS THEN BEGIN BRC←0 ; EOF←1 END
04200 ELSE IF PAGEMARKS<(K←LH(INPG[INPGX])) THEN
04300 DO BEGIN "SKIP PAGES"
04400 DO INPUT(INPUTCHAN,TO!LF!TB!VT!SKIP)
04500 UNTIL BRC≠TB;
04600 IF BRC = LF THEN
04700 DO BEGIN
04800 SRCLINE←INPUT(INPUTCHAN,TO!TB!FF!SKIP);
04900 IF BRC=FF THEN PAGEMARKS←PAGEMARKS+1 ;
05000 END UNTIL BRC≠FF ;
05100 END "SKIP PAGES"
05200 UNTIL BRC≠TB ∨ PAGEMARKS ≥ K ;
05300 IF ¬EOF THEN
05400 BEGIN COMMENT COMPUTE AND DISPLAY PAGE NUMBER ;
05500 SRCPAGE ← CVS(PAGEMARKS) ;
05600 IF NOT PUBSTD THEN OUTSTR((
05700 IF SWDBACK THEN SPS(LAST-3)
05800 ELSE SP
05900 )&SRCPAGE) ;
06000 SWDBACK ← 0 ;
06100 END ;
06200 END "PGMARK" ;
06300 END
06400 UNTIL BRC ≠ FF ;
06500 MACLINE ← NULL ;
06600 IF FULSTR(LSTOP) ∧ EQU(ERRLINE&"/"&SRCPAGE, LSTOP) THEN
06700 BEGIN
06800 DARN(NULL,VS(THISWD)&VS(THATWD)&VS(INPUTSTR)&CRLF&
06900 VS(OWL[1 TO OAKS])&CRLF&VI(POSN)&VI(BRC)&VI(BRKTBL)) ;
07000 S ← INCHWL ; LSTOP←("0000"&SCAN(S,DIGITA,DUMMY))[∞-4 FOR 5]&S ;
07100 END ;
07200 IF EOF THEN INPUTSTR ← SWICHBACK comment, done scanning a SOURCE!FILE or gen-file;
07300 ELSE BEGIN "FILE LINE"
07400 DO BEGIN "EXPAND TABS"
07500 INPUTSTR ← INPUTSTR & INPUT(INPUTCHAN,TO!LF!TB!VT!SKIP) ;
07600 IF BRC=TB THEN INPUTSTR←INPUTSTR&
07700 (IF PAGESCAN(LAST)≥0 THEN
07800 IF TABTAB=0 THEN
07900 SPS(8-LENGTH(INPUTSTR) MOD 8)
08000 ELSE TABTAB
08100 ELSE TB)
08200 ELSE IF BRC=VT THEN
08300 IF INPUTSTR[∞ FOR 1]=RCBRAK THEN INPUTSTR←INPUTSTR&VT
08400 ELSE
08500 BEGIN "GENVT" COMMENT MAYBE {PAGE!} IN GEN-FILE ;
08600 SPTR ← INPUT(INPUTCHAN, TO!VT!SKIP) ;
08700 IF (PTR ← CVD(SPTR)) ≥ TWO(14)
08800 AND LDB(PLIGHTWD("BYTEWD←ITBL[PTR-TWO(14)]"))=2
08900 THEN
09000 BEGIN
09100 BREAKSET(LOCAL!TABLE,ALTMODE,"IS");
09200 BREAKSET(LOCAL!TABLE,NULL,"O");
09300 S ← STBL[LDB(IXWD(BYTEWD))] ;
09400 INPUTSTR ← INPUTSTR[1 TO ∞-6] &
09500 SCAN(S,LOCAL!TABLE,DUMMY);
09600 END
09700 ELSE INPUTSTR ← INPUTSTR & VT & SPTR & VT ;
09800 END "GENVT"
09900 END "EXPAND TABS"
10000 UNTIL BRC = LF ∨ BRC < 0 ∨ EOF ;
10100 IF BRC≤0 THEN
10200 BEGIN BRC ← LF ;
10300 IF ¬EOF THEN
10400 WARN("=","GARBAGED MANUSCRIPT "&ERRLINE&"/"&SRCPAGE)
10500 END ;
10600 IF DEFINING THEN PART ← PART & LF & SRCLINE & "/" & SRCPAGE & TB ;
10700 END "FILE LINE" ;
10800 END "FROM FILE" ;
10900 IF BRC = LF THEN
11000 IF DEFINING THEN BEGIN BRC←0 ; IF INPUTSTR=COMMAND!CHARACTER THEN
11100 BEGIN PART ← PART & TB ; LOPP(INPUTSTR) ; END END
11200 ELSE IF INPUTSTR = COMMAND!CHARACTER ∨ INPUTSTR = TB THEN
11300 BEGIN
11400 LOPP(INPUTSTR) ;
11500 BRC ← 0 ; comment, keep scanning ;
11600 END
11700 ELSE INPUTSTR ← (BRC ← RCBRAK) & VT & INPUTSTR ;
11800 IF BRC THEN RETURN(IF LENGTH(RESULT)=0 THEN PART
11900 ELSE IF LENGTH(PART)=0 THEN RESULT
12000 ELSE RESULT & PART)
12100 ELSE IF LENGTH(RESULT)=0 THEN RESULT ← PART
12200 ELSE RESULT ← RESULT & PART ;
12300 END "PARTIAL"
12400 UNTIL FALSE ;
12500 END "RD" ;
00100 INTERNAL SIMPLE PROCEDURE RDENTITY ;
00200 BEGIN Comment Sets THATWD, THATTYPE, LIT!ENTITY, LIT!TRAIL ;
00300 STRING SEGMENT, SOURCE ; BOOLEAN DUN, TEXTLN ; INTEGER CC, FAM ; LABEL RETRY ;
00400 TEXTLN ← FALSE ; RETRY: IF CHARTBL[INPUTSTR] LAND TWO(6) THEN RD(TO!VISIBLE) ;
00500 SOURCE ← INPUTSTR ;
00600 FAM ← LDB(FAMILY(SOURCE)) ;
00700 CASE FAM MIN QUOTEQ+1 OF
00800 BEGIN COMMENT BY FAMILY ;
00900 ie 0 ... Letter ;
01000 BEGIN "BUILD ID"
01100 CC ← LENGTH(SEGMENT ← SCAN(SOURCE, ALPHA, BRC)) ;
01200 THATWD ← CAPITALIZE(SEGMENT);
01300 THATTYPE ← 0 ;
01400 END "BUILD ID" ;
01500 ie 1 ... Digit ;
01600 BEGIN "BUILD INTEGER"
01700 CC ← LENGTH(THATWD ← "0" & SCAN(SOURCE, DIGITA, BRC)) - 1 ;
01800 THATTYPE ← -1 ;
01900 END "BUILD INTEGER" ;
02000 ie 2 ... EMPTYQ ; IMPOSSIBLE("RDENTITY") ;
02100 ie 3 ... Terminal ;
02200 BEGIN "MAYBE TEXT"
02300 IF LDB(SPECIES("THATWD ← LOP(SOURCE)")) = 0 THEN TEXTLN ← TRUE ;
02400 CC ← 1 ; THATTYPE ← -TERQ ;
02500 END "MAYBE TEXT" ;
02600 ie 4 ... Quote ;
02700 IF SOURCE = """" THEN
02800 BEGIN "STRING CONSTANT"
02900 DUN ← FALSE ; THATWD ← "7" ; LOPP(SOURCE) ; CC ← 1 ; ie skip " ;
03000 DO BEGIN "TO NEXT QUOTE"
03100 SEGMENT ← SCAN(SOURCE, TO!QUOTE!APPD, BRC) ;
03200 CC ← CC + LENGTH(SEGMENT) ;
03300 IF BRC ≠ """" THEN
03400 BEGIN "ERROR"
03500 THATWD ← THATWD & SEGMENT[1 TO ∞-1] ; DUN ← TRUE ;
03600 WARN("=","Omitted Right Quote From: "&THATWD) ;
03700 END "ERROR"
03800 ELSE IF SOURCE = """" THEN
03900 BEGIN "INTERNAL QUOTE"
04000 THATWD ← THATWD & SEGMENT ;
04100 LOPP(SOURCE) ; CC ← CC + 1 ; ie skip second " ;
04200 END "INTERNAL QUOTE"
04300 ELSE
04400 BEGIN "END STRING"
04500 THATWD ← THATWD & SEGMENT[1 TO ∞-1] ;
04600 DUN ← TRUE ;
04700 END "END STRING"
04800 END "TO NEXT QUOTE"
04900 UNTIL DUN ;
05000 THATTYPE ← -1 ;
05100 END "STRING CONSTANT"
00100 ELSE
00200 BEGIN "OCTAL CONSTANT"
00300 LOPP(SOURCE) ; THATTYPE ← -1 ;
00400 CC ← LENGTH(SEGMENT ← SCAN(SOURCE, DIGITA, BRC)) + 1 ;
00500 THATWD ← "8" & (DUMMY←CVO(SEGMENT)) ; COMMENT a one-character string ;
00600 IF NOT INPICHAR THEN TES 12/6/73 ;
00700 IF DUMMY='0 ∨ '11≤DUMMY≤'15 ∨ DUMMY=ALTMODE ∨ DUMMY=RUBOUT THEN
00800 BEGIN
00900 WARN("ILL OCTAL",
01000 "Illegal octal constant (represents illegal character) "&CVOS(DUMMY)) ;
01100 THATWD ← "7" ;
01200 END ;
01300 END "OCTAL CONSTANT" ;
01400 ie 5 ... Other ;
01500 BEGIN "SINGLE CHARACTER"
01600 THATTYPE ← -FAM ; CC ← 1 ; THATWD ← LOP(SOURCE) ;
01700 IF FAM = MISCQ THEN CASE LDB(SPECIES(THATWD)) OF
01800 BEGIN
01900 [4] ie ∞ ; BEGIN THATTYPE ← 0 ; THATWD ← "!INF" END ;
02000 [0] BEGIN "ILL CHAR"
02100 WARN("=","EXTRANEOUS '" & CVOS(THATWD) & " in command line") ;
02200 LOPP(INPUTSTR) ; GO TO RETRY ;
02300 END "ILL CHAR" ;
02400 [MISCMAX]
02500 END ;
02600 END "SINGLE CHARACTER" ;
02700 END ; COMMENT BY FAMILY ;
02800 LIT!ENTITY ← INPUTSTR[1 TO CC] ;
02900 INPUTSTR ← SOURCE ;
03000 LIT!TRAIL ← IF TEXTLN THEN NULL ELSE IF CHARTBL[INPUTSTR] LAND TWO(6) THEN RD(TO!VISIBLE) ELSE NULL ;
03100 END "RDENTITY" ;
00100 INTEGER SIMPLE PROCEDURE ESTIMATE ;
00200 BEGIN
00300 INTEGER TOT, LEFT ;
00400 TOT ← LEFT ← IF AREAIXM ∧ 0≤STATUS≤2 THEN LINES ELSE LINECT(IXTEXT) ;
00500 LEFT ← LEFT + XGENLINES; RKJ;
00600 IF STATUS=1 THEN LEFT ← LEFT - (LINE + COVERED + PINE) ;
00700 IF NOT NOPGPH THEN LEFT ← LEFT - ( 1+(ABOVEX MAX BRKABX)-(BELOWX MIN BRKBLX)+
00800 (IF NOFILL THEN LEADNM ELSE IF FIRST THEN LEADFM ELSE SPREADM-1) ) ;
00900 RETURN(IF LEFT<0 THEN -(LEFT+TOT) ELSE LEFT) ;
01000 END "ESTIMATE" ;
01100
01200 INTEGER SIMPLE PROCEDURE EMPTYCOLS ;
01300 IF COL = 0 THEN RETURN(COLS)
01400 ELSE BEGIN
01500 INTEGER COUNT, COLUMN ; COUNT ← 0 ;
01600 FOR COLUMN ← (COL - 1) MOD COLS + 1 THRU COLS DO
01700 IF AA[COLUMN, 0] = 0 ∧ AA[COLUMN+COLS,0] = 0 THEN COUNT ← COUNT + 1 ;
01800 RETURN(COUNT-(IF ESTIMATE<0 THEN 1 ELSE 0)) ;
01900 END "EMPTYCOLS" ;
02000
02100 STRING PROCEDURE TYPEIN ;
02200 BEGIN
02300 IF NOT ON THEN RETURN (NULL); RKJ: 5-10-74 ;
02400 IF NOT SWDBACK THEN OUTSTR(CRLF) ; SWDBACK ← TRUE ;
02500 OUTSTR("#") ;
02600 RETURN(INCHWL) ;
02700 END "TYPEIN" ;
02900 INTERNAL STRING SIMPLE PROCEDURE EVALV(STRING THISWD ; INTEGER IX, TYP) ;
03000 BEGIN comment, evaluates the "variable" in THISWD ;
03100 CASE TYP OF
03200 BEGIN COMMENT BY TYPE ;
03300 [0] BEGIN IF ON THEN WARN("=","Undefined Identifier " & THISWD) ; RETURN(VIRGIN) END ;
03400 [GLOBALTYPE] RETURN(STBL[IX]) ;
03500 [LOCALTYPE] RETURN(SSTK[IX]) ;
03600 [INTERNTYPE]
03700 BEGIN "INTERNAL"
03800 RETURN(CASE IX OF (
03900 ie 0 ... LINES ; CVS(ABS(ESTIMATE)),
04000 ie 1 ... COLUMNS; CVS(CASE STATUS+1 OF (
04100 ie -1 ... no place area ; 0,
04200 ie 0 ... unopened area ; COLS-(IF ESTIMATE<0 THEN 1 ELSE 0),
04300 ie 1 ... open area ; EMPTYCOLS,
04400 ie 2 ... closed area ; 0,
04500 ie 3 ... dis-declared ; 0) ),
04600 ie 2 ... ! ; !,
04700 ie 3 ... SPREAD ; CVS(SPREADM),
04800 ie 4 ... FILLING; IF ¬FILL THEN "0" ELSE IF ADJUST THEN "1" ELSE "-1",
04900 ie 5 ... !SKIP! ; CVS(MANUS!SKIP!),
05000 ie 6 ... !SKIPL!; CVS(LH(MANUS!SKIP!)),
05100 ie 7 ... !SKIPR!; CVS(RH(MANUS!SKIP!)),
05200 ie 8 ... NULL ; NULL,
05300 ie 9 ... ∞ ; CVS(INF),
05400 ie 10... FOOTSEP; FOOTSEP,
05500 ie 11... TRUE ; "-1",
05600 ie 12... FALSE ; "0",
05700 ie 13... INDENT1; CVS(FIRSTIM),
05800 ie 14... INDENT2; CVS(RESTIM),
05900 ie 15... INDENT3; CVS(RIGHTIM),
06000 ie 16... LMARG ; CVS(LMARG),
06100 ie 17... RMARG ; CVS(RMARG),
06200 ie 18... CHAR ; IF NOPGPH THEN "0" ELSE CVS(POSN), TES 0->"0" 5/26/74;
06300 ie 19... CHARS ; CVS(IF NOPGPH THEN RMARG-LMARG ELSE MAXIM-POSN),
06400 ie 20... LINE ; CVS(IF STATUS=1 THEN LINE ELSE 0),
06500 ie 21... COLUMN ; CVS(IF STATUS=1 THEN COL ELSE 0),
06600 ie 22... TOPLINE; CVS(LINE1(IF AREAIXM THEN AREAIXM ELSE IXTEXT)),
06700 ie 23... XCRIBL; CVS(XCRIBL),
06800 ie 24... CHARW ; CVS(CHARW),
06900 ie 25... XGENLINES; CVS(XGENLINES),
07000 ie 26... UNDERLINE ; VUNDERLINE, TES 10/22/73 ;
07100 ie 27... THISDEVICE ; TES 11/15/73 ;
07200 CASE ABS(DEVICE)-1 OF ("LPT","TTY","MIC","XGP"),
07300 ie 28... THISFONT ; IF THISFONT < 10 THEN
07400 THISFONT+"0" ELSE THISFONT+("A"-10),
07500 ie 29... FOOTGAP ; CVS(FOOTGAP), TES 11/27/73 ;
07600 ie 30... FOOTSEPFONT ; PICKFONT(FSFONT)[3 FOR 1], TES 11/29/73 ;
07700 ie 31... TTY ; TYPEIN, TES 11/29/73 ;
07800 ie 32... ODDLEFTBORDER ; CVS(ODDLEFTBORDER), TES 6/11/74 ;
07900 ie 33... EVENLEFTBORDER ; CVS(EVENLEFTBORDER), TES 6/11/74 ;
08000 ie 34... FULLFILE ; INFILE, TES 6/13/74 ;
08040 ie 35... THISLINE ; OWL[1 TO OAKS], TES 8/19/74 ;
08080 ie 36... MAXTEMPLATE ; CVS(MAXTEMPLATE), TES 8/19/74 ;
08090 ie 37... ERRLF ; CVS(ERRLF), TES 8/21/74 ;
08095 ie 38... DEBUGFLAG ; CVS(DEBUGFLAG), TES 8/21/74 ;
08100 WARN(NULL,"PUB BUG: EVALV CASE IX")
08200 ) ) ;
08300 END "INTERNAL" ;
08400 [MANTYPE] WARN("=",THISWD&" in an expression") ;
08500 [PORTYPE] RETURN(THISWD) ;
08600 [PUNITTYPE] RETURN(PATT!VAL("PATT!STRS(IX)")) ;
08700 [AREATYPE] RETURN(THISWD) ;
08800 [UNITTYPE] RETURN(CTR!VAL("PATT!STRS(IX)"))
08900 END COMMENT BY TYPE ; ;
09000 RETURN(NULL) ;
09100 END "EVALV" ;
09200
09300 INTERNAL STRING SIMPLE PROCEDURE VEVAL ; RETURN(EVALV(THISWD, IX, THISTYPE)) ;
00100 RECURSIVE PROCEDURE APPLYTOARGUMENTS(BOOLEAN DO!IT, PROCALL) ;
00200 BEGIN TES 8/19/74 EXTRACTED FROM PASS TO HANDLE PROCEDURES AS WELL AS MACROS ;
00300 BOOLEAN WASLPAR, DUMSEMI ;
00500 INTEGER MACIX, MACSYM, ARGS, ARG, ARGSYM, NAMES, K ;
00700 MACIX ← IX ; MACSYM ← SYMB ; ARGS ← NUMARGS(MACIX) ; DUMSEMI ← FALSE ;
00800 IF ARGS THEN
00900 BEGIN "SCAN ARGS"
01000 STRING ARRAY ACTUAL[1:ARGS] ;
01100 IF ¬(WASLPAR ← NEXTSCH("(")) THEN INPUTSTR ← LIT!ENTITY&LIT!TRAIL&INPUTSTR ;
01200 comment , Back up. Pretend just passed comma. ; THISWD ← "," ; EMPTYTHAT ;
01300 NAMES ← NAMEPAR(MACIX) ; comment bit table for name parameters ;
01400 FOR ARG ← 1 THRU ARGS DO
01500 BEGIN "EACH ACTUAL"
01600 IF ¬ITSCH(",") THEN ACTUAL[ARG] ← NULL comment , omitted argument;
01700 ELSE BEGIN RD(TO!VISIBLE) ;
01800 IF NAMES LAND TWO(ARGS-ARG) = 0 THEN
01900 BEGIN PASS ; ACTUAL[ARG] ← E(NULL, NULL&'0) ; END
02000 ELSE BEGIN "CALL BY NAME"
02100 IF BRC ≠ """" THEN
02200 BEGIN comment , Unquoted Call-By-Name ;
02300 IF (K←BRC)="|" THEN RD(ONE!CHAR) ;
02400 ACTUAL[ARG]←RD(IF K="|" THEN TO!VBAR!SKIP
02500 ELSE IF WASLPAR THEN TO!COMMA!RPAR ELSE TO!TERQ!CR) ;
02600 IF BRC=CR ∧ ¬WASLPAR THEN
02700 BEGIN comment force a semicolon ;
02800 INPUTSTR ← ";" & INPUTSTR ;
02900 DUMSEMI ← TRUE ;
03000 END ;
03100 PASS ;
03200 END
03300 ELSE BEGIN PASS ; ACTUAL[ARG]←E(NULL,0) END ;
03400 END "CALL BY NAME"
03500 END
03600 END "EACH ACTUAL" ;
03700 WHILE ITSCH(",") DO
03800 BEGIN
03900 WARN("=","Too Many Arguments to "&SYM[MACSYM]) ;
04000 PASS ; E(NULL, 0) ;
04100 END ;
04200 IF ITSCH(")") ∧ WASLPAR THEN BEGIN comment Easy case; END
04300 ELSE BEGIN
04400 IF WASLPAR THEN WARN("=","Missed ) After Macro Call") ;
04500 comment Back Up -- SWICH only saves THATWD ;
04600 IF THATISFULL THEN comment Unlikely; INPUTSTR ← LIT!ENTITY&LIT!TRAIL&INPUTSTR ;
04700 IF THISISFULL ∧ ¬DUMSEMI THEN BEGIN THATWD ← LIT!ENTITY ← THISWD ;
04800 LIT!TRAIL ← IF THISTYPE<-1 THEN NULL ELSE SP ;
04900 THATTYPE ← THISTYPE MIN 0 END ELSE EMPTYTHAT ;
05000 END ;
05050 IF PROCALL THEN SWICH("RETURN(NULL);;",-2-BLNMS,0) ; TES 8/20/74 ;
05100 IF DO!IT THEN
05200 BEGIN "STACK ARGUMENTS"
05300 IF LAST + ARGS > SIZE THEN GROWNESTS ;
05400 FOR ARG ← 1 THRU ARGS DO
05500 SNEST[LAST + ARG] ← ACTUAL[ARG] ;
05600 LAST ← LAST + ARGS ;
05700 END "STACK ARGUMENTS" ;
05800 END "SCAN ARGS" ;
05850 IF PROCALL AND NOT ARGS THEN SWICH("RETURN(NULL);;",-2-BLNMS,0) ; TES 8/20/74 ;
05900 IF DO!IT THEN SWICH(SSTK[BODY(MACIX)], -1, ARGS)
06000 ELSE BEGIN THISWD ← "7" ; THISTYPE ← -1 END ; ie, Replace by NULL ("") ;
06100 END "APPLYTOARGUMENTS" ;
06200
06300 RECURSIVE STRING PROCEDURE PROCSTATEMENT ;
06400 IF THISTYPE = MACROTYPE THEN
06450 IF ODDMAC(IX)<2 THEN WARN(NULL,"UNEXPANDED MACRO "&THISWD&" (PUB BUG)")
06500 ELSE IF ON THEN
06600 BEGIN
06700 INTEGER PR ;
06800 PR←PROCEDURES←PROCEDURES+1;
06900 APPLYTOARGUMENTS(TRUE, TRUE);
07000 DO STATEMENT UNTIL PROCEDURES<PR;
07100 RETURN(TRUE) ;
07200 END
07300 ELSE BEGIN
07400 APPLYTOARGUMENTS(FALSE, FALSE) ;
07500 RETURN(TRUE) ;
07600 END
07700 ELSE RETURN(FALSE) ;
00100 INTERNAL RECURSIVE STRING PROCEDURE PASS ; comment Value is always NULL ;
00200 BEGIN comment, Load up WD[0:1], TYPE[0:1], SYMB, and IX for the parser.
00300 Calls CHUNK recursively! PASS will expand macro calls,
00400 replace macro/response arguments with their actual values,
00500 skip over comments, and execute asides.;
00600 PRELOAD!WITH 0, [3]3, 2, [4]3, 0, 1, 0, 4, [5]0, 5, 0, 0, 6, [7]0, 7, 0 ;
00700 OWN INTEGER ARRAY SCANTYPE[-15:15] ; comment, computes small case index ;
00800 BOOLEAN FINAL ;
00900 DO BEGIN "LOAD WD 0"
01000 IF ¬THATISFULL THEN RDENTITY ;
01100 THISWD ← THATWD ;
01200 THISTYPE ← IF THATTYPE THEN THATTYPE comment, non-identifier ;
01300 ELSE IF SYMLOOK(THATWD) THEN LDB(TYPEN(SYMBOL))
01400 ELSE 0 ; comment, undeclared identifier ;
01500 IF THISTYPE ≠ -TERQ THEN RDENTITY ;
01600 IF THISISID THEN
01700 BEGIN "IDENTIFIER"
01800 SYMB ← SYMBOL ;
01900 IF ¬DCLR!ID ∧ THATISID ∧ SYMLOOK(THISWD & SP & THATWD) THEN
02000 BEGIN comment, two-word macro name ;
02100 THISWD ← SYM[SYMB←SYMBOL] ; THISTYPE ← MACROTYPE ;
02200 IX ← LDB(IXN(SYMBOL)) ; RDENTITY ;
02300 END
02400 ELSE BEGIN SYMBOL←SYMB ; IF NULSTR(SYM[SYMB]) THEN ENTERSYM(THISWD,0) ; IX←LDB(IXN(SYMB)) ;END ;
02500 END "IDENTIFIER" ;
02600 FINAL ← FALSE ;
02700 DO CASE SCANTYPE[THISTYPE] OF
02800 BEGIN COMMENT DETECT ;
02900 ie 0 ... Nothing to do ; BEGIN END ;
03000 ie 1 ... $ ; IF NEXTSCH("(") THEN
03100 BEGIN EMPTYTHAT ; THISWD←"⊂" ;
03200 IX ← LDB(SPECIES(THISWD)) ; THISTYPE ← -TERQ ;
03300 END
03400 ELSE IX←LDB(SPECIES(THISWD)) ; COMMENT REPLACED OLD "ASIDE" (UNPUBL. FEATURE) 2/20/73 ;
03500 ie 2 ... < Family ; IF ITSCH(<) AND NEXTSCH(<) THEN
03600 BEGIN "<<COMMENT>>" SETBREAK(LOCAL!TABLE, ">"&RCBRAK&LF, NULL, "IS") ;
03700 DO RD(LOCAL!TABLE) UNTIL BRC=">" ∧ INPUTSTR=">" ∨ BRC=RCBRAK ∧ INPUTSTR=VT ;
03800 IF BRC=">" THEN RD(ONE!CHAR)
03900 ELSE BEGIN WARN("=","Unterminated <<comment>>") ; INPUTSTR←BRC&INPUTSTR END ;
04000 EMPTYTHIS ; EMPTYTHAT ;
04100 END "<<COMMENT>>"
04200 ELSE IX ← LDB(SPECIES(THISWD)) ; ie relational operator ;
04300 ie 3 ... Expression Operators ; IX ← LDB(SPECIES(THISWD)) ;
04400 ie 4 ... Terminal ;
04500 BEGIN
04600 IF ITSCH("]") ∧ INPUTSTR="$" THEN
04700 BEGIN LOPP(INPUTSTR) ; THISWD ← RCBRAK END ;
04800 EMPTYTHAT ; IX ← LDB(SPECIES(THISWD)) ;
04900 END ; Comment NOTE!! }),]⊂;
05000 ie 5 ... internal variable ; IF ¬DCLR!ID ∧ IX ≥ 200 THEN
05100 BEGIN "OPERATOR"
05200 IX ← IX-200 ; comment e.g., NOT → ¬ ;
05300 THISTYPE ← -LDB(FAMILY(IX)) ;
05400 IX ← LDB(SPECIES(IX)) ;
05500 END "OPERATOR" ;
05600 ie 6 ... reserved word ; IF IX=IXCOMMENT∧ ¬DCLR!ID THEN
05700 BEGIN "COMMENT"
05800 INPUTSTR ← LIT!ENTITY & INPUTSTR ;
05900 DO RD(TO!SEMI!SKIP) UNTIL BRC=";" ∨ INPUTSTR=VT ;
06000 IF BRC ≠ ";" THEN BEGIN WARN("=","Unterminated COMMENT;") ; INPUTSTR←BRC&INPUTSTR END ;
06100 EMPTYTHIS ; EMPTYTHAT ; ;
06200 END "COMMENT" ;
06300 ie 7 ... macro name ;
06350 IF ¬DCLR!ID AND ODDMAC(IX)<2 THEN APPLYTOARGUMENTS(ON OR ODDMAC(IX), FALSE) ; TES 8/19/74 ;
06400 END COMMENT DETECT ; UNTIL (FINAL ← ¬FINAL) ;
06500 END "LOAD WD 0" UNTIL THISISFULL ;
06600 RETURN(NULL) ;
06700 END "PASS" ;
00100 INTERNAL RECURSIVE STRING PROCEDURE E(STRING DEFAULT, STOPWORD) ;
00200 COMMENT Scan a SAIL-Like <Expression>. First check trivial case. ;
00300 IF ITS(IF) THEN
00400 BEGIN "CONDITIONAL EXPRESSION"
00500 STRING BOOLX, THENX, ELSEX ; BOOLEAN WASON ;
00600 WASON ← ON ; PASS ;
00700 BOOLX ← E(NULL, "THEN") ; ON ← WASON ∧ TRUESTR(BOOLX) ;
00800 IF ITS(THEN) THEN PASS ELSE WARN("=","Missed THEN in conditional expression "&THISWD) ;
00900 THENX ← E(NULL, "ELSE") ;
01000 IF ITS(ELSE) THEN
01100 BEGIN
01200 ON ← WASON ∧ FALSTR(BOOLX) ; PASS ;
01300 ELSEX ← E(NULL, STOPWORD) ;
01400 END
01500 ELSE ELSEX ← NULL ;
01600 ON ← WASON ;
01700 RETURN(IF TRUESTR(BOOLX) THEN THENX ELSE ELSEX) ;
01800 END "CONDITIONAL EXPRESSION"
01900 ELSE IF THISTYPE = -TERQ ∨ THISTYPE = MANTYPE ∨ ITSV(STOPWORD) THEN
02000 RETURN(DEFAULT) comment omitted expression ;
02100 ELSE IF THISTYPE ≥ -1 ∧ (THATTYPE = -TERQ ∨ THATTYPE=MANTYPE ∨ NEXTSV(STOPWORD)) THEN
02200 RETURN(SPASS("IF THISISCON THEN THISWD[2 TO ∞] ELSE VEVAL"))
02300 ELSE IF THISISID ∧ NEXTSCH(←) THEN comment, Assignment Expression ;
02400 RETURN(VASSIGN(SYMB, THISTYPE, IX, E(IPASS(PASS), STOPWORD)))
02500 ELSE
02600 BEGIN "SIMPLE EXPRESSION"
02700 STRING ANY, comment, result of A∨B∨...: has value of first TRUE operand;
02800 ALL, comment, result of A∧B∧...: has value of first FALSE operand;
02900 COMPARE, comment, result of A<B≤...: TRUE if all relations are TRUE;
03000 LEFT, comment, preceding right comparator, saved for another comparison;
03100 BOUNDARY, comment, result of A MAX B MIN... ;
03200 PRODUCT, comment, result of * / MOD & ;
03300 PRIMARY ; comment, <const>|<var>|( <expr> )|<unary><primary>|<primary><substr spec> ;
03400 INTEGER OROP, comment, =0 signals ∨ waiting for right operand ;
03500 ANDOP, NOTOP, comment, =0 signals ∧ or ¬ operator waiting ;
03600 RELOP, ODDOP, BOUNDOP, ADDOP, MULOP, comment, ≥0 signals operator waiting ;
03700 UNARYOP, comment, ≥0 signals unary operators waiting ;
03800 U, comment, last of a series of unary operators ;
03900 SS1, comment, starting byte number in substring spec ;
04000 SAVEINF, comment, saved outside value of ∞ ;
04100 SYMPTR, comment, symbol table number of identifier ;
04200 IDTYPE, comment, type field in its NUMBER entry ;
04300 ICOMPARE, ILEFT, IBOUNDARY, ISUM, IPRODUCT, IPRIMARY ; comment, CVD(corresponding string);
04400 BOOLEAN WASONA, WASONO ; comment value of ON before a series of conjuncts or disjuncts ;
04500 DEFINE TRYFAMILY(FAM) = "IF THISTYPE=-FAM THEN IPASS(IX)";
00100 COMMENT Multiple Unary operators ( + , - , ABS , LENGTH , XLENGTH , and ↑ ) are combined
00200 into a single operator by inventing new operators such as
00300 "-ABS" and "ABS LENGTH" ;
00400 DEFINE P = "0", comment, +X ; M = "1", comment, -X ; A = "2", comment, ABS X ;
00500 MA = "3", comment, -ABS X ; C = "4", comment, ↑X ;
00600 L = "5", comment, LENGTH(X) ; ML = "6", comment -LENGTH(X) ;
00700 AL = "7", comment, ABS LENGTH(X) ; MAL = "8", comment, -ABS LENGTH(X) ;
00740 Z = "9", comment, XLENGTH(X) ; MZ = "10", comment -XLENGTH(X) ;
00770 AZ = "11", comment, ABS XLENGTH(X) ; MAZ = "12"; comment, -ABS XLENGTH(X) ; TES 8/14/74 ;
00800 PRELOAD!WITH comment RIGHT OPERATOR
00900 ---------------------------------
01000 LEFT OPERATOR + - ABS ↑ LENGTH XLENGTH
01100 ------------- --- --- --- --- -------- ---------
01200 none; P, M, A, C, L, Z,
01300 comment P ; P, M, A, P, L, Z,
01400 comment M ; M, P, MA, M, ML, MZ,
01500 comment A ; A, A, A, A, AL, AZ,
01600 comment MA ; MA, MA, MA, MA, MAL, MAZ,
01700 comment C ; P, M, A, C, L, Z ;
01800 OWN INTEGER ARRAY COMBINE[-1:4,0:5] ;
01900 COMMENT This is a top-down expression parser, but iteration is used
02000 instead of recursion for rapidity ;
02100
02200 OROP ← ANDOP ← NOTOP ← RELOP ← BOUNDOP ← ADDOP ← MULOP ← -1 ;
02300 WASONO ← ON ;
02400 DO BEGIN "DISJUNCTS" ie Operands of ∨ ;
02500 WASONA ← ON ;
02600 DO BEGIN "CONJUNCTS" ie Operands of ∧ ;
02700 WHILE THISTYPE = -NOTQ DO BEGIN NOTOP ← -1 - NOTOP ; PASS END ;
02800 ICOMPARE ← TRUE ;
02900 DO BEGIN "COMPARATORS" ie Operands of < = etc. ;
03000 ODDOP ← TRYFAMILY(ODDQ) ELSE -1 ;
03100 DO BEGIN "BOUNDS" ie Operands of MAX and MIN ;
03200 DO BEGIN "TERMS" ie Operands of + - ≡ ⊗ ;
03300 DO BEGIN "FACTORS" ie Operands of * / MOD & ;
03400 UNARYOP ← -1 ; ie check for Unary Operators ;
03500 WHILE UNARYOP≤3 ie no, P, M, A, or MA left operator ;
03600 AND 0 ≤ (U ← TRYFAMILY(ADDQ) ELSE -1) ie some right operator ;
03700 DO UNARYOP ← COMBINE[UNARYOP, U] ;
03800 comment PRIMARY ;
03900 IF THISISCON THEN BEGIN PRIMARY ← THISWD[2 TO ∞] ; PASS END
04000 ELSE IF THISISID THEN
04100 IF ITSV(STOPWORD) THEN
04200 BEGIN
04300 PRIMARY ← DEFAULT ;
04400 WARN("=","Ill-Formed Expression" & THISWD) ;
04500 END
04600 ELSE IF PROCSTATEMENT THEN PRIMARY ← PROCVALUE
06300 ELSE IF NEXTSCH("(") THEN
06400 BEGIN "FUNCALL" TES 8/19/74 ;
06500 IF ITS(DECLARATION) THEN
06600 BEGIN
06650 PASS ; PASS ;
06700 PRIMARY ← CVS(THISTYPE) ; PASS ;
06800 END
07000 ELSE IF ITS(OCTAL) THEN
07100 BEGIN
07200 STRING T ;
07300 PRIMARY ← NULL ; PASS ; PASS ; T ← E(NULL,NULL) ;
07400 WHILE T DO PRIMARY ← PRIMARY & "'" & CVOS(LOP(T)) ;
07500 END
07505 ELSE IF ITS(BEWARE) THEN
07510 BEGIN TES 8/21/74 INVERSE OCTAL ;
07515 STRING T ; INTEGER BRC ;
07525 PRIMARY ← NULL ; PASS ; PASS ; T ← E(NULL,NULL) ;
07530 SETBREAK(LOCAL!TABLE,"'",NULL,"IS") ;
07540 DO BEGIN
07545 SCAN(T, LOCAL!TABLE, BRC) ;
07550 IF BRC THEN PRIMARY ← PRIMARY & CVO(T) ;
07555 END UNTIL NOT BRC ;
07560 END
07600 ELSE IF ITS(SCAN) THEN
07700 BEGIN "SCANCALL"
07800 BOOLEAN ISBRC ;
07900 STRING STR, STOPPERS, IGNORES, OPTIONS ;
08000 INTEGER SYMWAS, IXWAS, TYPEWAS, BRC ;
08050 STOPPERS←IGNORES←OPTIONS←NULL ;
08100 ISBRC ← FALSE ; PASS ; PASS ;
08200 IF THISISID AND NEXTSCH(",") THEN
08300 BEGIN COMMENT VARIABLE TO LOP ;
08400 SYMWAS←SYMBOL; IXWAS←IX; TYPEWAS←THISTYPE;
08500 STR ← VEVAL ; PASS ;
08600 END
08700 ELSE BEGIN COMMENT EXPRESSION ;
08800 IXWAS ← -1 ;
08900 STR ← E(NULL, NULL) ;
09000 END ;
09100 IF ITSCH(",") THEN
09200 BEGIN COMMENT STOPPERS ;
09300 PASS ; STOPPERS←E(NULL, NULL) ;
09400 IF ITSCH(",") THEN
09500 BEGIN COMMENT IGNORES ;
09600 PASS ; IGNORES ← E(NULL,NULL) ;
09700 IF ITSCH(",") THEN
09800 BEGIN COMMENT OPTIONS ;
09900 PASS ; OPTIONS ← E(NULL,NULL) ;
10000 IF ITSCH(",") THEN
10100 BEGIN COMMENT BRC VARIABLE ;
10200 PASS ;
10300 IF THISISID AND NEXTSCH(")") THEN
10400 ISBRC←TRUE
10500 ELSE WARN(NULL, "SCAN'S BRC MUST BE VARIABLE NAME") ;
10600 END ;
10700 END ;
10800 END ;
10900 END ;
11000 SETBREAK(LOCAL!TABLE, STOPPERS, IGNORES,
11005 IF FULSTR(OPTIONS) THEN OPTIONS ELSE "IR") ;
11100 PRIMARY ← SCAN(STR, LOCAL!TABLE, BRC) ;
11200 IF ISBRC THEN
11250 BEGIN
11275 VASSIGN(SYMBOL, THISTYPE, IX, IF BRC=0 THEN NULL ELSE BRC) ;
11287 PASS ;
11293 END ;
11300 IF IXWAS NEQ -1 THEN VASSIGN(SYMWAS, TYPEWAS, IXWAS, STR) ;
11400 END "SCANCALL"
11500 ELSE BEGIN
11600 WARN(NULL,"UNKNOWN FUNCTION " & THISWD) ;
11700 PASS ; PASS ; PRIMARY ← DEFAULT ;
11800 WHILE NOT ITSCH(")") DO
11900 IF ITSCH(",") THEN PASS
12000 ELSE E(NULL,NULL) ;
12100 END ;
12200 IF ITSCH(")") THEN PASS
12300 ELSE WARN(NULL, "MISSING ) AFTER FUNCTION CALL") ;
12400 END "FUNCALL"
40000 ELSE BEGIN PRIMARY ← VEVAL ; PASS END
40100 ELSE IF ITSCH("(") THEN
40200 BEGIN "( <EXPR> )"
40300 PASS ; PRIMARY ← E(DEFAULT, 0) ;
40400 IF ITSCH(")") THEN PASS ELSE WARN("=","Missed )") ;
40500 END "( <EXPR> )"
40600 ELSE BEGIN WARN("=","Ill-Formed expression" & THISWD) ; PRIMARY ← DEFAULT END ;
00100 WHILE THISTYPE=-BROKQ DO ie Substring Specifications ;
00200 BEGIN "SUBSPEC"
00300 PASS ; SAVEINF ← INF ; INF ← LENGTH(PRIMARY) ;
00400 SS1 ← CVD(E("1", IF NEXTS(TO) THEN "TO" ELSE "FOR")) ;
00500 IF ITS(TO) THEN BEGIN PASS ; PRIMARY←PRIMARY[SS1 TO CVD(E("0",0))] END
00600 ELSE IF ITS(FOR) THEN BEGIN PASS ; PRIMARY←PRIMARY[SS1 FOR CVD(E("1",0))] END
00700 ELSE PRIMARY ← PRIMARY[SS1 FOR 1] ;
00800 MANUS!SKIP! ← !SKIP! ;
00900 IF ITSCH(]) THEN PASS ELSE WARN("=","Missed ] in substring spec " & THISWD) ;
01000 INF ← SAVEINF ;
01100 END "SUBSPEC" ;
01200 IF UNARYOP≤3 THEN ie both int & str versions maintained when needed ;
01250 IPRIMARY ← IF PRIMARY="'" THEN CVO(PRIMARY[2 TO ∞]) TES 8/19/74 ;
01275 ELSE CVD(PRIMARY) ;
01300 IF UNARYOP ≥ 0 THEN IF UNARYOP=C THEN IPRIMARY←CVD(PRIMARY←CAPITALIZE(PRIMARY))
01400 ELSE PRIMARY ← CVS(IPRIMARY ← CASE UNARYOP OF (IPRIMARY, -IPRIMARY,
01500 ABS IPRIMARY, -ABS IPRIMARY, 0, LENGTH(PRIMARY), -LENGTH(PRIMARY),
01600 ABS LENGTH(PRIMARY), -ABS LENGTH(PRIMARY),
01650 XLENGTH(PRIMARY), -XLENGTH(PRIMARY),
01675 ABS XLENGTH(PRIMARY), -ABS XLENGTH(PRIMARY) ) ) ; TES 8/14/74;
01700 IF MULOP<0 THEN BEGIN PRODUCT ← PRIMARY ; IPRODUCT ← IPRIMARY END
01800 ELSE IF MULOP = 3 THEN IPRODUCT ← CVD(PRODUCT ← PRODUCT & PRIMARY)
01900 ELSE PRODUCT ← CVS(IPRODUCT ← IF IPRIMARY=0 ∨ ¬ON THEN 0 ELSE CASE MULOP OF
02000 (IPRODUCT*IPRIMARY, IPRODUCT DIV IPRIMARY, IPRODUCT MOD IPRIMARY) ) ;
02100 MULOP ← TRYFAMILY(MULQ) ELSE -1 ;
02200 END "FACTORS" UNTIL MULOP < 0 ;
02300
02400 ISUM ← CASE ADDOP+2 OF (IPRODUCT, IPRODUCT, ISUM + IPRODUCT,
02500 ISUM - IPRODUCT, ISUM ≡ IPRODUCT, ISUM ⊗ IPRODUCT) ;
02600 ADDOP ← TRYFAMILY(ADDQ) ELSE IF ADDOP<0 THEN -1 ELSE -2 ;
02700 END "TERMS" UNTIL ADDOP < 0 ;
02800
02900 IBOUNDARY ← CASE BOUNDOP+2 OF (ISUM, ISUM, IBOUNDARY MAX ISUM, IBOUNDARY MIN ISUM) ;
03000 BOUNDOP ← TRYFAMILY(BOUNDQ) ELSE IF ADDOP=-1 ∧ BOUNDOP<0 THEN -1 ELSE -2 ;
03100 END "BOUNDS" UNTIL BOUNDOP < 0 ;
03200 BOUNDARY ← IF BOUNDOP = -1 THEN PRODUCT ie, hasn't changed since then; ELSE CVS(IBOUNDARY) ;
03300 IF ODDOP≥0 THEN BOUNDARY←CVS(IBOUNDARY←(IBOUNDARY MOD 2)=ODDOP);
03400 IF ICOMPARE THEN CASE RELOP+2 OF BEGIN comment SAIL Bug precludes case expression with relationals;
03500 BEGIN END ; BEGIN END ; ICOMPARE←ILEFT<IBOUNDARY; ICOMPARE←ILEFT>IBOUNDARY; ICOMPARE ←
03600 EQU(LEFT,BOUNDARY); ICOMPARE←ILEFT≤IBOUNDARY; ICOMPARE←ILEFT≥IBOUNDARY;
03700 ICOMPARE←¬EQU(LEFT,BOUNDARY) END ;
03800 RELOP ← TRYFAMILY(RELQ) ELSE IF RELOP < 0 THEN -1 ELSE -2 ;
03900 LEFT ← BOUNDARY ; ILEFT ← IBOUNDARY ;
04000 END "COMPARATORS" UNTIL RELOP < 0 ;
04100 COMPARE ← IF RELOP=-1 THEN BOUNDARY ELSE CVS(ICOMPARE) ;
04200 IF NOTOP = 0 THEN COMPARE ← IF TRUESTR(COMPARE) THEN "0" ELSE "-1" ;
04300 NOTOP ← -1 ;
04400 IF ANDOP < 0 OR TRUESTR(ALL) THEN IF FALSTR(ALL ← COMPARE) THEN ON ← FALSE ;
04500 ANDOP ← TRYFAMILY(ANDQ) ELSE -1 ; ALL ← ALL ; comment SAIL bug -- force it to store;
04600 END "CONJUNCTS" UNTIL ANDOP < 0 ;
04700 ON ← WASONA ;
04800 IF OROP < 0 OR FALSTR(ANY) THEN IF TRUESTR(ANY ← ALL) THEN ON ← FALSE ;
04900 OROP ← TRYFAMILY(ORQ) ELSE -1 ; ANY ← ANY ; comment SAIL bug -- force it to store ;
05000 END "DISJUNCTS" UNTIL OROP < 0 ;
05100 ON ← WASONO ;
05200 RETURN(DUMMYSTR ← ANY) ; comment, DUMMYSTR due to SAIL RECURSIVE STRING PROCEDURE bug (see DCS);
05300 END "SIMPLE EXPRESSION" ;
00010 SIMPLE PROCEDURE WARNLONG(STRING SEGM, MESG) ;
00015 BEGIN
00020 WARN(NULL, MESG & CRLF &
00030 "[YOU PROBABLY OMITTED A TEMPLATE CLOSER, )$ OR ↑P OR HORSESHOE]"
00040 & CRLF & "THE TEMPLATE BEGAN WITH:" & CRLF & SEGM[1 TO 70]) ;
00045 END ;
00050
00100 STRING SIMPLE PROCEDURE DEFN(BOOLEAN SUBSTVARIABLES,FORFILE; INTEGER ARGS, IBASE) ;
00200 BEGIN
00300 STRING SEGMENT, IDENT, PSPCS, SPCS, FML, TXID, TX2 ;
00350 INTEGER SINDX, I, DEEP, PGMKS, REQRS ;
00375 LABEL FORMAL ;
00400 IF ITSCH(;) THEN PASS ; DEFINING ← NOT FORFILE ; comment, makes RD include line nos in result ;
00500 IF ¬ITSCH(⊂) AND NOT(ITSCH($) AND NEXTSCH("("))
00600 THEN BEGIN WARN("=","Missed ⊂ OR $( in definition") ; RETURN(NULL) END ;
00700 DEEP ← 1 ; SINDX ← SHIGH ;
00800 IF SHIGH+20>STSIZE THEN
00900 BEGIN
01000 SGROW(STBL,STBLIDA,STSIZE,100,"Definition") ;
01100 SMAKEBE(STBLIDA, STBL) ; ZEROSTRINGS(100, STBL[STSIZE-99]) ;
01200 END ;
01300 EMPTYTHIS ; comment For page label switch in LABELREF ;
01400 IF FORFILE THEN STBL[SINDX←SINDX+1] ← SRCLINE & "/" & SRCPAGE & TB & ALTMODE ;
01500 IF EQU(INPUTSTR[1:2], RCBRAK&VT) THEN
01600 BEGIN
01700 STBL[SINDX ← SINDX + 1] ← CRLF & SRCLINE & "/" & SRCPAGE & TB ;
01800 INPUTSTR ← INPUTSTR[3:∞] ;
01900 END ;
01950 PGMKS ← PAGEMARKS ; REQRS ← LAST ; TES 8/19/74 ;
02000 WHILE DEEP DO
02100 BEGIN "DEF BODY"
02200 SEGMENT ← RD(DEFN!TABLE) ;
02300 IF BRC = "⊂" ∨ BRC="$"∧INPUTSTR="("∧LOP(INPUTSTR)="(" THEN
02400 BEGIN DEEP ← DEEP + 1 ; SEGMENT ← SEGMENT & "⊂" ; END
02500 ELSE IF BRC = "⊃" ∨ BRC=")"∧INPUTSTR="$"∧LOP(INPUTSTR)="$" THEN
02600 BEGIN DEEP ← DEEP - 1 ;
02700 SEGMENT ← SEGMENT & (IF DEEP THEN "⊃" ELSE SP) ;
02800 END
02900 ELSE IF BRC = "∃" THEN SEGMENT ← SEGMENT & (IF DEEP>1 THEN BRC ELSE NULL) & RD(ONE!CHAR)
03000 ELSE IF LENGTH(TXID←BRC) ∧
03100 (LDB(SPCODE(BRC))=LCURLY ∨
03200 LDB(SPCODE(BRC))=DOLLAR ∧ LDB(SPCODE(INPUTSTR))=LBRACK ∧
03300 LENGTH(TXID←TXID&LOP(INPUTSTR))) THEN
03400 IF SUBSTVARIABLES THEN
03500 BEGIN "{..."
03600 SPCS ← TXID & RD(TO!VISIBLE) ;
03700 IDENT ← SCAN(INPUTSTR,ALPHA,DUMMY) ; PSPCS ← RD(TO!VISIBLE) ;
03800 IF BRC = RCBRAK ∨ BRC="]"∧INPUTSTR[2 FOR 1]="$"THEN
03900 BEGIN
04000 LOPP(INPUTSTR) ;
04100 IF BRC="]" THEN BEGIN TX2←"]$" ; LOPP(INPUTSTR) END ELSE TX2←RCBRAK ;
04200 SEGMENT ← SEGMENT &
04300 (IF FULSTR(IDENT) ∧ SIMLOOK(CAPITALIZE(IDENT))
04400 AND SYMTYPE<MACROTYPE THEN TES 11/29/73 ;
04500 IF SYMIX=IXPAGE THEN ALTMODE&"[@]"&
04600 LABELREF(0,
04700 IF SYMBOL=SYMPAGE THEN CTR!CHRS(IXPAGE)
04800 ELSE PATT!CHRS(IXPAGE))
04900 ELSE EVALV(IDENT, SYMIX, SYMTYPE)
05000 ELSE SPCS & IDENT & PSPCS & TX2)
05100 END
05200 ELSE SEGMENT ← SEGMENT & SPCS & IDENT & PSPCS ;
05300 END "{..."
05400 ELSE SEGMENT ← SEGMENT & TXID
05500 ELSE IF BRC = RCBRAK THEN
05600 IF EQU(INPUTSTR[1:2], RCBRAK&VT) THEN ELSE SEGMENT ← SEGMENT & BRC
05700 ELSE IF LDB(FAMILY(BRC)) = LETTQ THEN
05800 BEGIN "LETTER"
05900 IDENT ← (BRC+0) & SCAN(INPUTSTR, ALPHA, BRC) ;
06000 FOR I ← 1 THRU ARGS DO IF EQU(FML←SYM[ITBL[IBASE+I]], TXID←CAPITALIZE(IDENT)) THEN
06100 FORMAL: BEGIN IDENT ← VT & I ; DONE END
06200 ELSE IF 1 ≤ LENGTH(TXID)-LENGTH(FML) ≤ 2 THEN
06300 BEGIN "MAYBE UNDERLINED"
06400 INTEGER L, R ;
06500 L ← IF TXID="_" THEN 1 ELSE 0 ; R ← IF TXID[∞ FOR 1]="_" THEN 1 ELSE 0 ;
06600 IF EQU(FML, TXID[1+L TO ∞-R]) THEN
06700 BEGIN
06800 IF L THEN SEGMENT ← SEGMENT & "_" ;
06900 IF R THEN INPUTSTR ← "_" & INPUTSTR ;
07000 GO TO FORMAL ;
07100 END ;
07200 END "MAYBE UNDERLINED" ;
07300 SEGMENT ← SEGMENT & IDENT ;
07400 END "LETTER"
07500 ELSE SEGMENT ← SEGMENT & BRC ;
07600 STBL[SINDX ← SINDX+1] ← SEGMENT ;
07700 IF SINDX = SHIGH+20 THEN
07800 BEGIN
07900 SEGMENT ← STBL[SHIGH + 1] ;
08000 FOR I ← SHIGH + 2 THRU SINDX DO BEGIN SEGMENT ← SEGMENT & STBL[I] ; STBL[I]←NULL; END;
08100 SINDX ← SHIGH + 1 ; STBL[SINDX] ← SEGMENT ;
08105 IF DEEP THEN TES 8/19/74 CHECK FOR INFINITE TEMPLATE ;
08110 IF LENGTH(SEGMENT) > MAXTEMPLATE THEN
08115 BEGIN
08120 WARNLONG(SEGMENT, "A TEMPLATE IS LONGER THAN " &
08122 CVS(MAXTEMPLATE) & " CHARACTERS" & CRLF &
08123 "IF YOU REALLY HAVE SUCH A LONG ONE, INCREASE THE VALUE OF MAXTEMPLATE") ;
08125 STBL[SINDX] ← NULL ; DONE ;
08130 END
08135 ELSE IF PAGEMARKS > PGMKS THEN
08140 BEGIN
08145 WARNLONG(SEGMENT,
08147 "A TEMPLATE CROSSES A MANUSCRIPT PAGE MARK (FORM FEED)") ;
08150 STBL[SINDX] ← NULL ; DONE ;
08155 END
08160 ELSE IF LAST NEQ REQRS THEN
08165 BEGIN
08170 WARNLONG(SEGMENT, "A TEMPLATE CROSSES A FILE BOUNDARY (EOF)") ;
08175 STBL[SINDX] ← NULL ; DONE ;
08180 END ;
08200 END ;
08300 END "DEF BODY" ;
08400 SEGMENT ← STBL[SHIGH+1] ; FOR I ← SHIGH+2 THRU SINDX DO SEGMENT ← SEGMENT & STBL[I] ;
08500 IF FORFILE THEN SEGMENT ← SEGMENT & LF ;
08600 DEFINING ← FALSE ; INPUTSTR ← ";" & INPUTSTR ; PASS ;
08700 RETURN(SEGMENT) ;
08800 END "DEFN" ;
00100 RECURSIVE PROCEDURE PARAMS(INTEGER MOST; STRING ARRAY PRE,PAR,POST);
00200 BEGIN comment, Reads arguments for various commands;
00300 INTEGER I, PREWD, SOFAR ; STRING EXPR ;
00400 LABEL RDPAR, SETPAR ;
00500 BOOLEAN GOT ; DEFINE FIND = "FOR I ← 1 THRU MOST DO IF" ;
00600 SOFAR ← I ← GOT ← 0 ;
00700 WHILE SOFAR<MOST ∧ THISTYPE≠-TERQ ∧ THISTYPE≠MANTYPE DO
00800 BEGIN "PARAMETER"
00900 IF THISISID THEN
01000 BEGIN "IDENTIFIER"
01100 IF ITS(TO) ∧ I<MOST ∧ ITSV(PRE[I+1]) THEN BEGIN PASS; I←I+1; GO TO RDPAR END;
01200 FIND ITSV(PRE[I]) ∨ ITSV(PRE[I]&"S") THEN
01300 BEGIN "PRE WORD"
01400 PASS ; IF GOT LAND TWO(I) THEN WARN("=",PRE[I]&" Twice") ;
01500 GO TO RDPAR ;
01600 END "PRE WORD" ;
01700 END "IDENTIFIER" ;
01800 FIND ¬GOT LAND TWO(I) ∧ NULSTR(PRE[I]) ∧ (I=1 ∨ NULSTR(PRE[I-1]) ∨ GOT LAND TWO((I-1))) THEN GO TO RDPAR ;
01900 DONE ;
02000 RDPAR:
02100 PREWD ← I ;
02200 EXPR ← IF EQU(PRE[I],"IN") ∧ FULSTR(PAR[I]) THEN SPASS(THISWD) comment COUNT...IN -- ;
02300 ELSE IF ITSCH(⊂) THEN 0 & DEFN(FALSE, FALSE, 0, 0)
02400 ELSE E(NULL,IF I=MOST∨FULSTR(POST[I]) THEN POST[I] ELSE PRE[I+1]) ;
02500 IF FULSTR(POST[I]) THEN
02600 IF ITSV(POST[I]) THEN PASS
02700 ELSE BEGIN "GUESSED WRONG"
02800 FIND ITSV(POST[I]) THEN BEGIN PASS ; GO TO SETPAR END ;
02900 FIND NULSTR(POST[I]) THEN GO TO SETPAR ;
03000 WARN("=",POST[PREWD] & "Missed.") ;
03100 DONE ;
03200 END "GUESSED WRONG" ;
03300 SETPAR:
03400 IF PRE[I]≠PRE[PREWD] THEN WARN("=",(IF FULSTR(POST[PREWD]) THEN POST[PREWD] ELSE PRE[I])& " Missed.") ;
03500 IF GOT LAND TWO(I) THEN WARN("=","Duplicate Parameter "&PRE[I]&SP&EXPR&SP&POST[I])
03600 ELSE SOFAR ← SOFAR + 1 ;
03700 GOT ← GOT LOR TWO(I) ;
03800 PAR[I] ← EXPR ;
03900 IF ITSCH(",") THEN PASS ;
04000 END "PARAMETER" ;
04100 END "PARAMS" ;
04200
04300 RECURSIVE STRING PROCEDURE SIMPAR ;
04400 RETURN(IF THISISCON THEN THISWD[2 TO ∞] ELSE IF THISISID THEN VEVAL ELSE NULL) ;
00100 SIMPLE PROCEDURE FINPORTION ;
00200 BEGIN
00300 DBREAK ;
00400 IF OLDPGIDA THEN NEXTPAGE ;
00500 END "FINPORTION" ;
00600
00700 RECURSIVE PROCEDURE DAREA(BOOLEAN TITAREA) ;
00800 BEGIN
00900 INTEGER I, IX, SYMB, TEMP, A, B ;
01000 PRELOAD!WITH "LINE", "TO", "CHAR", "TO", "IN", "COLUMN", "COLUMN" ;
01100 OWN STRING ARRAY PRE[1:7] ; STRING ARRAY PAR[1:7] ;
01200 PRELOAD!WITH NULL, NULL, NULL, NULL, NULL, "WIDE", "APART" ;
01300 OWN STRING ARRAY POST[1:7] ;
01400 DBREAK; DPASS ;
01500 IF ¬THISISID THEN BEGIN WARN("=","AREA MUST HAVE NAME"); THISWD←"!DUMMY" END ;
01600 SYMB ← SYMNUM(THISWD) ;
01700 PASS ;
01800 PARAMS(7, PRE, PAR, POST) ;
01900 IF ¬ON THEN RETURN ;
02000 BIND(DECLARE(SYMB, AREATYPE), IX←PUSHI(AREAWDS,AREATYPE)) ;
02100 IF FULHIGH(IX)←NULSTR(PAR[1]) THEN BEGIN A←1 ; B←FHIGH END comment assume LINE 1 TO <frame height> ;
02200 ELSE BEGIN A ← CVD(PAR[1]) ; B ← IF NULSTR(PAR[2]) THEN A ELSE CVD(PAR[2]) END ;
02300 LINE1(IX) ← A MAX 1 ; LINECT(IX) ← B-A+1 MAX 1 ;
02400 IF FULWIDE(IX)← NULSTR(PAR[3]) THEN BEGIN A←1 ; B←FWIDE END
02500 ELSE BEGIN A ← CVD(PAR[3]) ; B ← IF NULSTR(PAR[4]) THEN A ELSE CVD(PAR[4]) END ;
02600 CHAR1(IX) ← A MAX 1 ; CHARCT(IX) ← B←B-A+1 MAX 1 ;
02700 TEXTAR(IX) ← IF TITAREA THEN 0 ELSE 1 ;
02800 IF NULSTR(PAR[5]) THEN A ← 1 comment Assume IN 1 COLUMNS <charct> WIDE ;
02900 ELSE BEGIN "COLUMNS"
03000 A ← CVD(PAR[5]) ; comment How many ;
03100 IF FULSTR(PAR[6]) THEN B ← CVD(PAR[6]) MIN B DIV A
03200 ELSE B ← (B+( TEMP←IF FULSTR(PAR[7]) THEN CVD(PAR[7]) ELSE 5 )) DIV A - TEMP ;
03300 END "COLUMNS" ;
03400 COLCT(IX) ← A MAX 1 ; COLWID(IX) ← B MAX 1 ;
03500 OLMAX ← OLMAX + A*LINECT(IX) ;
03600 FOOTSTR(IX) ← PUSHS(1, NULL) ;
03700 MARGINS(IX) ← FONTS(IX) ← 0 ; TES 11/15/73 ;
03800 TFONT(IX) ← OFONT(IX) ← DEFAULTFONT ; TES 11/15/73 ;
03900 END "DAREA" ;
04000
04100 PROCEDURE BURPAREAS(BOOLEAN VERBOSE) ;
04200 BEGIN TES 8/19/74 CALLED BY DBURP ;
04300 INTEGER NAREAS ; INTEGER ARRAY FOUND[1:100], THISAREA[0:ONE], AA[0:ONE,0:ONE] ;
04400 PROCEDURE BURPAREADECL(INTEGER ILOC, IDA) ;
04500 BEGIN
04600 INTEGER I ;
04700 OUTSTR(TB &
04800 (IF TEXTAR(ILOC) THEN "TEXT " ELSE "TITLE ") &
04900 "AREA " & SYM[LDB(BIXNUM(ILOC))] &
05000 " LINES " & CVS(LINE1(ILOC)) & " TO " & CVS(LINE1(ILOC)+LINECT(ILOC)-1) &
05100 " CHARS " & CVS(CHAR1(ILOC)) & " TO " & CVS(CHAR1(ILOC)+CHARCT(ILOC)-1) &
05200 CRLF & TB & TB &
05300 "IN " & CVS(COLCT(ILOC)) & " COLUMNS " &
05400 CVS(COLWID(ILOC)) & " WIDE" &
05500 (IF FULHIGH(ILOC) THEN " FULL HEIGHT" ELSE NULL) &
05600 (IF FULWIDE(ILOC) THEN " FULL WIDTH" ELSE NULL) &
05650 CRLF & TB & TB &
05700 (IF DISD(ILOC) THEN "DISDECLARED AT " ELSE "DECLARED AT ") &
05800 CVOS(ILOC) &
05900 (IF (I ← OLD!ACTIVE(ILOC)) AND I NEQ IDA THEN " RECORD "&CVOS(I) ELSE NULL) &
06000 (IF (I ← NEW!ACTIVE(ILOC)) THEN "NEWPAGE RECORD " & CVOS(I) ELSE NULL) &
06100 (IF (I←MARGINS(ILOC)) THEN " MARGINS " & CVS(LMARGX(I)) & SP & CVS(RMARGX(I)) ELSE NULL) &
06200 (IF XCRIBL THEN " FONTS " & PICKFONT(TFONT(ILOC))[3 TO ∞] &
06300 "*" & PICKFONT(OFONT(ILOC))[3 TO ∞] ELSE NULL) &
06400 (IF FULSTR("SSTK[FOOTSTR(ILOC)]") THEN " FOOTNOTES PENDING" ELSE NULL) &
06500 CRLF) ;
06600 END "BURPAREADECL" ;
06700 PROCEDURE BURPAREARECORD(INTEGER ARIDA; BOOLEAN INFRAME) ;
06800 BEGIN
06900 INTEGER COLS, LINES, I, J, X, Y ;
07000 BOOLEAN SOME ;
07100 IDASSIGN(ARIDA, THISAREA) ;
07200 IDASSIGN(AAA, AA) ;
07300 OUTSTR("AREA RECORD " & CVOS(ARIDA) &
07400 (IF NOT INFRAME THEN " NOT IN FRAME"
07500 ELSE IF INA NEQ FRAMEIDA THEN " ** FRAME BACKLINK INCORRECT**"
07600 ELSE NULL) &
07700 (CASE STATA OF (" UNOPENED", " OPENED", " CLOSED", " DIS-DECLARED")) &
07800 (CASE STATA MIN 2 OF (NULL,
07900 " PLACING IN COLUMN "&CVS(IF AREAIDA=ARIDA THEN COL ELSE COLA),
08000 " LINES " & CVS(ULLA) & " TO " & CVS(ULLA+LINECA-1) & " IN " & CVS(COLCA) & " COLUMNS")) &
08100 (IF AREAIDA=ARIDA THEN " (CURRENT)" ELSE NULL) &
08200 (IF XCRIBL THEN
08250 (IF XGENA THEN " XGENLINES = "&CVS(XGENA) ELSE NULL)&
08275 (IF OVERA THEN " OVEREST OF COLUMN 1 = "&CVS(OVERA) ELSE NULL)
08287 ELSE NULL) &
08300 CRLF) ;
08400 IF VERBOSE THEN
08500 BEGIN
08600 COLS ← ARRINFO(AA, 2)/2 ; LINES ← ARRINFO(AA,4) ;
08700 OUTSTR(TB&TB) ;
08800 FOR I←1 THRU COLS DO OUTSTR(" COLUMN "&CVS(I)&TB) ;
08900 OUTSTR(CRLF & TB & TB) ;
09000 FOR I ← 1 THRU COLS DO OUTSTR(" CALF FOOT"&TB) ;
09100 OUTSTR(CRLF) ;
09200 FOR J ← 1 THRU LINES DO
09300 BEGIN
09400 SOME ← FALSE ;
09500 FOR I ← 1 THRU 2*COLS DO IF AA[I,J] THEN BEGIN SOME←TRUE;DONE END ;
09600 IF SOME THEN
09700 BEGIN
09800 OUTSTR(TB & " " & CVS(J) & TB) ;
09900 FOR I ← 1 THRU COLS DO
10000 FOR Y←0,COLS DO
10100 OUTSTR(IF (X←AA[I+Y,J]) THEN (" "&CVS(OWLS[X]))[∞-5 TO ∞]&TB ELSE TB) ;
10200 OUTSTR(CRLF) ;
10300 END ;
10400 END ;
10500 OUTSTR(TB & " LAST"&TB) ;
10600 FOR I ← 1 THRU COLS DO
10700 OUTSTR(CVS(RH("AA[I,0]"))&TB&CVS(RH("AA[COLS+I,0]"))&TB) ;
10800 OUTSTR(CRLF) ;
10900 END ;
11000 IF (I←DEFA) THEN BEGIN FOUND[NAREAS←NAREAS+1]←I ; BURPAREADECL(I, ARIDA) END ;
11100 END "BURPAREARECORD" ;
11200 INTEGER A, I, THISIDA, AAIDA ; BOOLEAN DID ;
11300 MAKEBE(THISAREA, THISIDA) ; MAKEBE(AA, AAIDA) ;
11350 IF FRAMEIDA=0 THEN OUTSTR("BETWEEN PAGES" & CRLF)
11375 ELSE BEGIN
11400 A ← ARF ; NAREAS ← 0 ;
11500 WHILE A DO
11600 BEGIN COMMENT SEARCH THIS FRAME ;
11700 BURPAREARECORD(A, TRUE) ;
11800 A ← ARA ;
11900 END ;
11950 END ;
12000 A ← NULLAREAS ;
12100 WHILE A DO
12200 BEGIN COMMENT SEARCH NULL AREAS LIST (MADE BUT UNOPENED) ;
12300 BURPAREARECORD(A, FALSE) ;
12400 A ← RH(INA) ;
12500 END ;
12600 A ← IHED ;
12700 WHILE A > 1 DO
12800 BEGIN COMMENT SEARCH ISTK ;
12900 IF IXTYPE(A) = AREATYPE THEN
13000 BEGIN
13100 DID ← FALSE ;
13200 FOR I ← 1 THRU NAREAS DO IF FOUND[I]=A THEN
13300 BEGIN DID ← TRUE ; DONE END ;
13400 IF NOT DID THEN
13500 BEGIN
13600 OUTSTR("AREA HAVING NO RECORDS" & CRLF) ;
13700 BURPAREADECL(A, 0) ;
13800 END ;
13900 END ;
14000 A ← IXOLD(A) ;
14100 END ;
14200 MAKEBE(THISIDA, THISAREA) ; MAKEBE(AAIDA, AA) ;
14300 END "BURPAREAS" ;
14400
14500 SIMPLE PROCEDURE BURPINPUT(BOOLEAN VERBOSE) ;
14600 BEGIN
14700 INTEGER L; STRING SL ;
14800 OUTSTR("LINE/PAGE "&ERRLINE&"/"&SRCPAGE&TB&
14900 SOMEINPUT[1 TO (IF VERBOSE THEN 300 ELSE 60)] ) ;
15000 OUTSTR(CRLF&" - - - - - - - - - - - - - - - - - - - -"&CRLF) ;
15100 FOR L ← LAST STEP -2 UNTIL (IF VERBOSE THEN 6 ELSE 6 MAX LAST-6) DO
15200 BEGIN
15300 SL ← LINESCAN(L) ;
15400 IF CHANSCAN(L) GEQ 0 THEN OUTSTR(SCAN(SL,TO!VT!SKIP,DUMMY)) ;
15600 OUTSTR(SP & SL & "/" & CVS(LH("DUMMY←ABS(PAGESCAN(L))")) & TB) ;
15700 OUTSTR(STRSCAN(L)[1 TO (IF VERBOSE THEN 300 ELSE 60)]) ;
15800 OUTSTR(CRLF&" - - - - - - - - - - - - - - - - - - - -"&CRLF) ;
15900 END ;
16000 END "BURPINPUT" ;
00100 SIMPLE PROCEDURE DBELOW ;
00200 BEGIN
00300 END "DBELOW" ;
00400
00500 RECURSIVE PROCEDURE DBLANKPAGE ;
00600 BEGIN COMMENT LEAVE N BLANK PAGES WITHOUT AFFECTING THE PAGE NUMBER ;
00700 INTEGER I, J, N ;
00800 PASS ; N ← CVD(E("1", NULL)) ;
00900 IF ¬ON THEN RETURN ;
01000 DBREAK ;
01100 IF OLDPGIDA THEN NEXTPAGE ;
01200 IF INTER ≤ 0 THEN NOPORTION ;
01300 FOR I ← 1 THRU N DO FOR J ← PHIGH, PWIDE, ODDLEFTBORDER, -10 DO WORDOUT(INTER, J) ;
01400 END ;
01500
01600 SIMPLE PROCEDURE DBURP ;
01700 BEGIN TES 8/19/74 DEBUG PRINTOUTS ;
01750 BOOLEAN VERBOSE ;
01800 IF ON AND NOT SWDBACK THEN BEGIN OUTSTR(CRLF); SWDBACK←TRUE END ;
01900 PASS ;
01910 IF ITS(INPUT) THEN
01920 BEGIN
01930 PASS ;
01940 VERBOSE ← IF ITS(VERBOSE) THEN IPASS(TRUE) ELSE FALSE ;
01950 IF ON THEN BURPINPUT(VERBOSE) ;
01960 END
02000 ELSE IF ITS(AREAS) THEN
02100 BEGIN
02150 PASS ;
02200 VERBOSE ← IF ITS(VERBOSE) THEN IPASS(TRUE) ELSE FALSE ;
02300 IF ON THEN BURPAREAS(VERBOSE) ;
02500 END
02600 ELSE WARN(NULL, "UNRECOGNIZED BURP COMMAND " & THISWD) ;
02700 END "DBURP" ;
02800
02900 SIMPLE PROCEDURE DCC ;
03000 BEGIN
03100 END "DCC" ;
03200
03300 RECURSIVE PROCEDURE DCLOSE ;
03400 BEGIN
03500 DBREAK ; PASS ;
03600 IF ON THEN
03700 IF THISTYPE=AREATYPE THEN CLOSEAREA(IX,FALSE)
03800 ELSE IF IX=IXPAGE THEN comment, * * * * * * * * * * * * * ;
03900 ELSE WARN("=","CLOSE What? "&SOMEINPUT) ;
04000 PASS ;
04100 END "DCLOSE" ;
04200
04300 SIMPLE PROCEDURE DCOMMANDCHARACTER ;
04400 BEGIN
04500 INTEGER X ;
04600 INPUTSTR ← ";;" & INPUTSTR ; COMMENT couple extra semicolons to assure next line read right ;
04700 PASS ; X ← SIMPAR ;
04800 IF LENGTH(X) ≠ 1 THEN WARN("=","COMMAND CHARACTER must be a single character, not `"&X&"'")
04900 ELSE IF ON THEN COMMAND!CHARACTER ← X ;
05000 PASS ; PASS ; PASS ;
05100 END "DCOMMANDCHARACTER" ;
05200
05300 SIMPLE PROCEDURE DCOUNT ;
05400 BEGIN
05500 INTEGER USYMB, INLINE ;
05600 PRELOAD!WITH "FROM", "TO", "BY", "IN", "PRINTING" ;
05700 OWN STRING ARRAY PRE[1:5] ; OWN STRING ARRAY PAR[1:5] ;
05800 DPASS ; IF ¬THISISID THEN BEGIN WARN("=","Unit must have a name") ; THISWD ← "!DUMMY" END ;
05900 USYMB ← SYMNUM(THISWD) ; PASS ; IF ITS(INLINE) THEN BEGIN INLINE←TRUE; PASS END ELSE INLINE←FALSE ;
06000 PAR[1]←PAR[2]←PAR[3]←PAR[5]←NULL;
06100 PAR[4] ← 0 ; PARAMS(5, PRE, PAR, NULLS) ;
06200 IF ON THEN CREUNIT( INLINE,
06300 IF NULSTR(PAR[1]) THEN 1 ELSE CVD(PAR[1]), comment, FROM -- ;
06400 IF NULSTR(PAR[2]) THEN 18 ELSE CVD(PAR[2]), comment, TO -- ;
06500 IF NULSTR(PAR[3]) THEN 1 ELSE CVD(PAR[3]), comment, BY -- ;
06600 IF PAR[4] = 0 THEN 0 ELSE SYMNUM(PAR[4]), comment IN -- ;
06700 IF NULSTR(PAR[5]) THEN "1" ELSE PAR[5], comment, PRINTING -- ;
06800 USYMB ) ;
06900 END "DCOUNT" ;
07000
07100 SIMPLE PROCEDURE DDEVICE ;
07200 BEGIN PASS ;
07300 RKJ: 19-AUG-74 ADDED ON BELOW;
07400 IF DEVICE ≥ 0 AND ON THEN COMMENT IF <0, WAS SET BY /SWITCH, WHICH TAKES PRECEDENCE ;
07500 IF ITS(MIC) THEN DEVICE←MIC ELSE IF ITS(TTY) THEN DEVICE←TTY
07600 ELSE IF ITS(LPT) THEN DEVICE←LPT
07700 ELSE IF ITS(XGP) THEN BEGIN DEVICE ← XGP; XCRIBL ← TRUE; OUTSTR(" XCRIBL!"); END
07800 ELSE WARN("=","No such device: "&THISWD) ;
07900 PASS ;
08000 END "DDEVICE" ;
08100
08200 SIMPLE PROCEDURE DDONE(BOOLEAN RETURNS) ;
08300 BEGIN TES 8/14/74 (DONE) 8/19/74 (RETURN);
08400 INTEGER B ; STRING VAL ; BOOLEAN GOT ;
08500 PASS ;
08600 IF ON THEN
08700 IF NOT RETURNS AND REPEATS=0 THEN WARN(NULL,"IGNORED A DONE WITHOUT A REPEAT")
08800 ELSE IF RETURNS AND PROCEDURES=0 THEN WARN(NULL, "IGNORED A RETURN NOT IN A PROCEDURE")
08900 ELSE
09000 BEGIN
09100 IF RETURNS THEN
09200 BEGIN
09300 PROCEDURES ← PROCEDURES - 1 ;
09400 IF ITSCH("(") THEN
09500 BEGIN COMMENT VALUE TO RETURN ;
09550 PASS ;
09600 VAL ← E(NULL, NULL) ;
09700 IF NOT ITSCH(")") THEN WARN(NULL, "MISSED ) AFTER RETURN") ;
09800 END
09900 ELSE VAL ← NULL ;
10000 END
10100 ELSE REPEATS ← REPEATS - 1 ;
10200 EMPTYTHIS ; EMPTYTHAT ; INPUTSTR ← NULL ;
10300 DO BEGIN
10400 WHILE LAST AND CHANSCAN(LAST) > -2 DO
10500 INPUTSTR ← SWICHBACK ;
10600 GOT ← RETURNS EQV EQU("RETURN(", STRSCAN(LAST)[1 TO 7]) ;
10700 STRSCAN(LAST) ← NULL ;
10800 IF NOT GOT THEN CHANSCAN(LAST)←-1 ;
10900 END UNTIL GOT ;
11000 B ← -2 - CHANSCAN(LAST) ;
11100 WHILE B<BLNMS DO
11200 CASE IF STARTS THEN 0 ELSE ENDCASE OF
11300 BEGIN
11400 BEGIN BLNMS←BLNMS-1 ; STARTS←STARTS-1 ; END ;
11500 BEGIN BLNMS←BLNMS-1 ; IF ENDBLOCK THEN WARN("=","MISSED END") END ;
11600 IF ENDBLOCK THEN WARN("=", "MISSED END") ELSE
11700 BEGIN BLNMS←BLNMS-1 ; IF ENDBLOCK THEN WARN("=","MISSED END") END ;
11800 BEGIN BLNMS←BLNMS-1 ; IF ENDBLOCK THEN MYEND ← TRUE ELSE WARN("=","EXTRA END") END ;
11900 END ;
12000 CHANSCAN(LAST) ← -1 ;
12100 INPUTSTR ← SWICHBACK ;
12200 PASS ;
12300 IF RETURNS THEN PROCVALUE ← VAL ;
12400 END ;
12500 END "DDONE" ;
00100 RECURSIVE PROCEDURE DCONDITIONAL ;
00200 BEGIN
00300 BOOLEAN WASON ;
00400 WASON ← ON ; PASS ; ON ← TRUESTR("E(NULL,""THEN"")") ∧ WASON ;
00500 IF ITS(THEN) THEN PASS ELSE WARN("=","Missed THEN in conditional statement") ;
00600 IF STATEMENT THEN BEGIN ON←TRUE; RETURN END; TES 8/14/74 DONE FROM REPEAT ;
00700 IF ITS(ELSE) THEN BEGIN ON←WASON∧¬ON; PASS ; IF STATEMENT THEN BEGIN ON←TRUE; RETURN END END ;
00800 ON ← WASON ;
00900 END "DCONDITIONAL" ;
01000
01100 INTERNAL SIMPLE PROCEDURE READFONT(INTEGER WHICH; STRING FILENAME, BFILENAME) ;
01200 IF ON THEN
01300 BEGIN "READFONT"
01400 INTEGER SAVCW, CHAN, ZILCH, EOF;
01500 IFC TENEX THENC STRING ELSEC INTEGER ENDC NAME, EXT, PPN ;
01600 STRING XFILENAME ;
01700 LABEL TRYAGAIN ; COMMENT SAIL DEFFICIENCY ;
01800 IF NULSTR(BFILENAME) THEN
01900 IFC TENEX THENC
02000 BEGIN
02100 NAME←CVFIL(FILENAME,EXT,PPN) ;
02200 XFILENAME ← NAME & EXT ;
02300 END
02400 ELSEC
02500 XFILENAME ← FILENAME TES 1/22/74 ;
02600 ENDC
02700 ELSE XFILENAME ← BFILENAME ;
02800 SAVCW ← WHATIS(CW);
02900 IF FONTFIL[WHICH] = 0 THEN FONTFIL[WHICH] ← CREATE(0,127);
03000 DUMMY ← FONTFIL[WHICH] ;
03100 IF SAVCW=WCW AND WHICH=DEFAULTFONT THEN SAVCW←DUMMY;
03200 MAKEBE(DUMMY,CW);
03300 OPEN(CHAN←GETCHAN,"DSK",'14, 2,0,0,ZILCH,EOF);
03400 IFC TENEX THENC
03500 LOOKUP(CHAN, FILENAME, FLAG) ;
03600 IF FLAG THEN
03700 BEGIN "HUNTFONT"
03800 ENDC
03900 TRYAGAIN: NAME←CVFIL(FILENAME,EXT,PPN);
04000 WHILE TRUE DO
04100 BEGIN "LKUPLOOP"
04200 IF XLOOKUP(CHAN,NAME,EXT,0,PPN) THEN DONE;
04300 IF EXT=0 THEN EXT←FONTEXT ELSE
04400 IF PPN=0 THEN PPN←FONTPPN ELSE
04500 IF FULSTR(BFILENAME) AND NOT EQU(FILENAME,BFILENAME) THEN
04600 BEGIN
04700 FILENAME ← BFILENAME ;
04800 GO TRYAGAIN ;
04900 END ELSE
05000 BEGIN "NOTFOUND"
05100 OUTSTR("Font file " & FILENAME & " not found. Read file: ");
05200 IFC TENEX THENC
05300 RELEASE(CHAN);
05400 CHAN ← OPENFILE(NULL,"ROC") ;
05500 DONE ;
05600 ELSEC
05700 FILENAME ← INCHWL ;
05800 GO TRYAGAIN ;
05900 ENDC
06000 END "NOTFOUND";
06100 END "LKUPLOOP";
06200 IFC TENEX THENC
06300 END "HUNTFONT" ;
06400 ENDC
06500
06600 IFC VERSION=ITSVER THENC PJ 5/28/74 ;
06700 WORDIN(CHAN);
06800 FNTINF[WHICH]←WORDIN(CHAN);
06900 IF WHICH=DEFAULTFONT THEN BASELINE←LDB(POINT(9,FNTINF[WHICH],17));
07000 FNTINF[WHICH]←LDB(POINT(18,FNTINF[WHICH],35)); ie HEIGHT;
07100 WHILE NOT EOF DO
07200 IF (WORDIN(CHAN) LAND 1) THEN
07300 BEGIN
07400 DUMMY←LDB(POINT(18,DUMMY←WORDIN(CHAN),35));
07500 CW[DUMMY]←LDB(POINT(18,CW[DUMMY]←WORDIN(CHAN),35));
07600 END
07700 ENDC
07800 IFC VERSION=CMUVER THENC
07900 WORDIN(CHAN);
08000 FNTINF[WHICH]←WORDIN(CHAN); COMMENT RKJ 10-10-73;
08100 WHILE NOT EOF DO
08200 IF (WORDIN(CHAN) LAND 1) THEN
08300 BEGIN DUMMY←WORDIN(CHAN); CW[DUMMY]←WORDIN(CHAN) END
08400 ENDC
08500 IFC VERSION=SAILVER THENC
08600 ARRYIN(CHAN,CW[0],128);
08700 FOR I ← 0 THRU 127 DO CW[I] ← CW[I] LSH -18;
08800 WORDIN(CHAN); FNTINF[WHICH]←WORDIN(CHAN);
08900 WORDIN(CHAN);
09000 IF WHICH=DEFAULTFONT THEN BASELINE←WORDIN(CHAN);
09100 ENDC
09200 IFC VERSION=PARCVER THENC
09300 BEGIN
09400 EXTERNAL INTEGER GOGTAB;
09500 INTEGER K,I;
09600 IFC TENEX THENC
09700 DEFINE JSYS="'104000000000", SFBSZ="JSYS '46";
09800 K ← CVJFN(CHAN) ;
09900 START!CODE "BYTE16"
10000 MOVE 1,K; MOVEI 2,16; SFBSZ ;
10100 END "BYTE16" ;
10200 ELSEC
10300 START!CODE "BYTE16" MOVE 1,GOGTAB; ADD 1,CHAN; MOVE 1,'13(1); comment now we have pointer to cdb;
10400 HRRZ 1,2(1); comment now pointer to IBUF;
10500 HRLI 2,'442000;
10600 HLLM 2,1(1);
10700 END "BYTE16";
10800 ENDC
10900 K←WORDIN(CHAN); WORDIN(CHAN);
11000 FNTINF[WHICH]←WORDIN(CHAN); WORDIN(CHAN);
11100 FOR I←1 THRU K DO WORDIN(CHAN);
11200 K←(K MIN 128)-1;
11300 FOR I←0 THRU K DO CW[I]←WORDIN(CHAN);
11400 END;
11500 ENDC;
11600
11700 IFC VERSION=SAILVER THENC CMDFILE ← CMDFILE & "/FONT#" & CVS(WHICH-1) & "=" & FILENAME ENDC;
11710 IFC VERSION=ITSVER THENC PJ 6/12/74 ;
11720 CMDFILE ← CMDFILE & ";KSET "&(",,,,,,,,,,"[1 FOR WHICH-1])&FILENAME & CRLF ;
11730 ENDC
11800 TES 1/7/74 ADDED NEXT LINE: ; TES 1/22/74 PUT XFILENAME ;
11900 FNTNAME[WHICH]←XFILENAME; HIFONT←WHICH MAX HIFONT ;
12000 RELEASE(CHAN);
12100 MAKEBE(SAVCW,CW);
12200 END "READFONT";
00100 INTERNAL SIMPLE PROCEDURE SWITCHFONT(INTEGER WHICH) ;
00200 BEGIN TES 11/15/73 TO DO IT BY AREA ;
00300 INTEGER NEWIX ;
00400 IF AREAIXM AND FONTS(AREAIXM) < OLDIHED THEN
00500 BEGIN TES FIRST CHANGE IN THIS BLOCK IN THIS AREA ;
00600 NEWIX ← PUSHI(FONTWDS, FONTYPE) ;
00700 AREAX(NEWIX) ← AREAIXM ;
00800 OUTERX(NEWIX) ← FONTS(AREAIXM) ;
00900 THISFONTX(NEWIX) ← THISFONT ;
01000 OLDFONTX(NEWIX) ← OLDFONT ;
01100 FONTS(AREAIXM) ← NEWIX ;
01200 END ;
01300 OLDFONT ← THISFONT;
01400 IF THISFONT NEQ WHICH THEN
01500 BEGIN
01600 THISFONT ← WHICH;
01700 WHICH ← FONTFIL[WHICH]; MAKEBE(WHICH,CW);
01800 END ;
01900 END ;
02000
02100 INTERNAL SIMPLE PROCEDURE SELECTFONT(INTEGER WHICH);
02200 IF ON THEN
02300 BEGIN "SELECTFONT"
02400 INTEGER F;
02500 DBREAK;
02600 IF NOT XCRIBL OR LAST<4 THEN RETURN;
02700 F←(IF WHICH<10 THEN (WHICH+"0") ELSE (WHICH+("A"-10)));
02800 IF FONTFIL[WHICH]=0 THEN BEGIN WARN("=","Unknown font `"& F & "'");
02900 RETURN END;
03000 SWITCHFONT(WHICH) ; TES 11/14/73 SUBROUTINIZED ;
03100 TES 11/15/73 erased: XGPCMD ← (FONTCHAR & "F") & F ;
03200 END "SELECTFONT";
03300
03400 INTERNAL SIMPLE INTEGER PROCEDURE RFONT(INTEGER F) ;
03500 RETURN( TES SUBROUTINIZED AND CASED 11/29/73 ;
03600 IFC VERSION = SAILVER OR VERSION=ITSVER PJ 5/28/74 ; THENC
03700 IF "1"≤F≤"9" THEN F←F-"0"
03800 ELSE IF "A"≤F≤"Z" THEN F←F-("A"-10)
03900 ELSE IF "a"≤F≤"z" THEN F←F-("a"-10)
04000 ELSE -1
04100 ENDC
04200 IFC VERSION = PARCVER THENC
04300 IF "1"≤F≤"9" THEN F←F-"0"
04400 ELSE -1
04500 ENDC
04600 IFC VERSION = CMUVER THENC
04700 IF "A"≤F≤"B" THEN F←F-("A"-10)
04800 ELSE IF "a"≤F≤"b" THEN F←F-("a"-10)
04900 ELSE IF "1"≤F≤"2" THEN F←F-"0"
05000 ELSE -1
05100 ENDC
05200 ) ;
05300
05400 SIMPLE PROCEDURE DFONT(BOOLEAN SELECT);
05500 BEGIN "DFONT"
05600 INTEGER F;
05700 PASS;
05800 IF LENGTH(THISWD)=1 AND THISTYPE GEQ 0 AND (F←RFONT(THISWD)) GEQ 0 THEN PASS
05900 ELSE F ← RFONT(E(NULL,NULL)) ; TES 11/29/73 ;
06000 IF F<0 THEN
06100 BEGIN WARN("=","Illegal font `"&F&"'"); RETURN END;
06200 IF SELECT THEN SELECTFONT(F) TES 1/22/74 ADDED OPTIONAL XGP FILENAME ;
06300 ELSE READFONT(F,E(NULL,NULL), IF ITSCH(",") THEN PASS&E(NULL,NULL) ELSE NULL);
06400 END "DFONT";
00100 RECURSIVE PROCEDURE DFRAME(BOOLEAN BOXFRM) ;
00200 BEGIN
00300 INTEGER L, I ;
00400 PRELOAD!WITH "HIGH", "WIDE" ; OWN STRING ARRAY POST[1:2];
00500 STRING ARRAY PAR[1:2] ;
00600 DAPART ; PASS ; PARAMS(2,NULLS,PAR,POST);
00700 IF ON THEN
00800 IF BOXFRM THEN BEGIN END
00900 ELSE
01000 BEGIN
01100 PHIGH←FHIGH←IF NULSTR(PAR[1]) THEN 1 ELSE CVD(PAR[1]) ;
01200 PWIDE←FWIDE←IF NULSTR(PAR[2]) THEN 1 ELSE CVD(PAR[2]) ;
01300 IF OLDPGIDA THEN NEXTPAGE ;
01400 L ← NULLAREAS ;
01500 WHILE L DO BEGIN
01600 I ← AREAIDA ; IDASSIGN(AREAIDA←L,THISAREA) ; L ← RH(INA) ;
01700 OPEN!ACTIVE(DEFA) ← 0 ; GOAWAY(AREAIDA) ; IF (AREAIDA←I) THEN IDASSIGN(AREAIDA,THISAREA) ;
01800 END ;
01900 NULLAREAS ← 0 ;
02000 END ;
02100 END "DFRAME" ;
02200
02300 SIMPLE PROCEDURE DINDENT ;
02400 BEGIN
02500 STRING X ;
02600 DBREAK ; PASS ; X ← E(NULL,NULL) ; IF ON ∧ FULSTR(X) THEN FIRSTIM ← CVD(X) ;
02700 IF ITSCH(",") THEN BEGIN PASS ; X←E(NULL, NULL) END ELSE X←NULL ;
02800 IF ON ∧ FULSTR(X) THEN RESTIM←CVD(X) ;
02900 IF ITSCH(",") THEN BEGIN PASS ; X←E(NULL, NULL) END ELSE X←NULL ;
03000 IF ON ∧ FULSTR(X) THEN RIGHTIM←CVD(X) ;
03100 END "DINDENT" ;
00100 SIMPLE PROCEDURE DINSERT ;
00200 BEGIN
00300 INTEGER CHAN, PIX, ROTTEN ;
00400 IF ON THEN BEGIN TES 4/11/74;
00500 FINPORTION ;
00600 IF INTER ≥ 0 THEN
00700 BEGIN FOR DUMMY←1 THRU 5 DO WORDOUT(INTER,-20) ; RELEASE(INTER) ; RELEASE(SINTER) ; SINTER←INTER←-1 END ;
00800 END ;
00900 DO BEGIN "COLLATE"
01000 DPASS ; IF ¬THISISID THEN BEGIN WARN("=","Unnamed INSERT Portion!") ; RETURN END ;
01100 IF ON THEN
01200 BEGIN ROTTEN ← FALSE ;
01300 IF THISTYPE ≠ PORTYPE THEN
01400 BEGIN
01500 BIND(SYMB←DECLARE(SYMB, PORTYPE), PIX ← PUTI(4, -5));
01600 PORSTR(PIX) ← PUTS(NULL) ; PUTS(NULL) ; TES 3/21/74;
01700 END
01800 ELSE IF (CHAN ← PORCH(PIX ← IX)) = -1 THEN BEGIN WARN("=","Can't INSERT FOOT!"); ROTTEN←TRUE END
01900 ELSE IF ¬(0 ≤ CHAN ≤ 15) THEN BEGIN WARN("=","Can't INSERT passed Portion "&THISWD) ; ROTTEN←TRUE END ;
02000 IF ¬ROTTEN THEN BEGIN PORSEQ(SEQPORT) ← PIX ; PORSEQ(SEQPORT ← PIX) ← -1 END ;
02100 PASS ;
02200 END ;
02300 END "COLLATE" UNTIL ¬ITSCH(",") ;
02400 END "DINSERT" ;
02500
02600 SIMPLE PROCEDURE DLET ;
02700 BEGIN
02800 INTEGER LOC ; LABEL BADLET ;
02900 DPASS ; IF THATISID THEN BEGIN THATWD ← THISWD & THATWD ; DPASS END ; LOC ← SYMB ;
03000 IF ¬THISISID THEN GO TO BADLET ; PASS ; IF ¬ITSCH(=) THEN GO TO BADLET ; DPASS ;
03100 IF THISTYPE≠MANTYPE AND THATISID THEN BEGIN THATWD←THISWD&THATWD ; PASS END ;
03200 IF THISTYPE≠MANTYPE THEN GO TO BADLET ; IF ON THEN BIND(LOC←DECLARE(LOC, MANTYPE), IX) ; PASS ;
03300 RETURN ;
03400 BADLET: WARN("=","LET <ID>=<RESWD>, please!") ; DO PASS UNTIL THISISID ∨ THISTYPE=-TERQ ;
03500 END "DLET" ;
03600
03700 SIMPLE PROCEDURE DLOCK ;
03800 BEGIN
03900 END "DLOCK" ;
00100 SIMPLE PROCEDURE DLOCAL ;
00200 DO BEGIN
00300 DPASS ;
00400 IF THISISID THEN
00500 BEGIN
00600 IF ON THEN
00700 BIND(SYMB←DECLARE(SYMB, LOCALTYPE), IX←PUSHS(1,NULL)) ;
00800 PASS ;
00900 END
01000 ELSE BEGIN WARN("=","LOCAL declaration missing identifier"); IF THISTYPE≠TERQ THEN PASS END ;
01100 END UNTIL ¬ITSCH(",") ;
01200
01300 SIMPLE PROCEDURE DMACRO(INTEGER ODDONE) ; TES 8/19/74 ODDONE= 0:RECURSIVE MACRO 1:MACRO 2:PROCEDURE;
01400 BEGIN COMMENT, OLD VERSION NOT GARBAGED BUT COULD BE ;
01500 INTEGER SIHIGH, MIX, ARGS, J, NAMES, NAME ; BOOLEAN ROTTEN ;
01600 SIHIGH ← IHIGH ; DPASS ; IF ¬THISISID THEN BEGIN WARN("=","Macro name not identifier") ; RETURN END ;
01700 IF THATISID THEN BEGIN "TWO WORD" THISWD ← THISWD & SP & THATWD ; RDENTITY ; END "TWO WORD" ;
01800 PUTI(1, SYMNUM(THISWD)) ; PASS ;
01900 IF ITSCH("(") THEN
02000 BEGIN "FORMALS"
02100 ROTTEN ← FALSE ; THISWD ← "," ; NAMES ← 0 ;
02200 DO BEGIN
02300 IF ITSCH(",") THEN DPASS
02400 ELSE BEGIN WARN("=","Missed comma in macro formal list") ; ROTTEN←TRUE END ;
02500 IF ITSCH(ε) THEN BEGIN DPASS ; NAME ← 0 ; END ELSE NAME ← 1 ;
02600 IF ¬THISISID THEN BEGIN WARN("=","Formal parameters must be identifiers") ; ROTTEN←TRUE END
02700 ELSE BEGIN PUTI(1, SYMB) ; NAMES ← 2*NAMES + NAME ; DPASS END ;
02800 END
02900 UNTIL ITSCH(")") ∨ ROTTEN ;
03000 IF ITSCH(")") THEN PASS ;
03100 END "FORMALS" ;
03200 IF ROTTEN ∨ ¬ON THEN BEGIN IHIGH ← SIHIGH ; DEFN(FALSE, FALSE,0,0) ; RETURN END ;
03300 ARGS ← IHIGH - SIHIGH - 1 ; BIND(DECLARE(ITBL[SIHIGH+1], MACROTYPE), MIX←PUSHI(MACROWDS,MACROTYPE)) ;
03400 NUMARGS(MIX) ← ARGS ; ODDMAC(MIX) ← ODDONE ; BODY(MIX) ← PUSHS(1,DEFN(FALSE, FALSE,ARGS,SIHIGH+1)) ;
03500 IHIGH ← SIHIGH ; NAMEPAR(MIX) ← NAMES ;
03600 END "DMACRO" ;
00100 SIMPLE PROCEDURE DMARGINS(BOOLEAN INWARD) ;
00200 BEGIN
00300 STRING S ; INTEGER L, R, W, ARIX, OLDIX, NEWIX ;
00400 IF ON THEN DBREAK ;
00500 ARIX ← IF AREAIXM THEN AREAIXM ELSE IXTEXT ; OLDIX ← MARGINS(ARIX) ; PASS ;
00600 S ← IF THISTYPE > INTERNTYPE ∨ THISTYPE=-TERQ ∨ NEXTSCH(←) ∨ NEXTSCH(:) THEN NULL
00700 ELSE E(NULL, NULL) ;
00800 IF FULSTR(S) ∨ ITSCH(",") THEN
00900 BEGIN "HAS PARAMS"
01000 L ← IF FULSTR(S) THEN CVD(S) ELSE 0 ;
01100 IF ITSCH(",") THEN BEGIN PASS ; R ← CVD(E("0",NULL)) END ELSE R ← 0 ;
01200 IF ¬ON THEN RETURN ;
01300 MARGINS(ARIX) ← NEWIX ← PUSHI(MARGWDS, MARGTYPE) ; W ← COLWID(ARIX) ;
01400 LMARG ← (IF OLDIX THEN LMARGX(OLDIX) ELSE 0) + INWARD*L MAX 0 MIN W-1 ;
01500 RMARG ← (IF OLDIX THEN RMARGX(OLDIX) ELSE W) - INWARD*R MIN W MAX LMARG+1 ;
01600 LMARGX(NEWIX) ← LMARG ; RMARGX(NEWIX) ← RMARG ;
01700 AREAX(NEWIX) ← ARIX ; OLD!MARGX(NEWIX) ← OLDIX ;
01800 END "HAS PARAMS"
01900 ELSE IF ¬ON THEN RETURN
02000 ELSE IF OLDIX THEN
02100 BEGIN "UNNEST"
02200 AREAX(OLDIX) ← 0 ; comment, so ENDBLOCK won't use it ;
02300 MARGINS(ARIX) ← NEWIX ← OLD!MARGX(OLDIX) ;
02400 LMARG ← IF NEWIX THEN LMARGX(NEWIX) ELSE 0 ;
02500 RMARG ← IF NEWIX THEN RMARGX(NEWIX) ELSE COLWID(ARIX) ;
02600 IF OLDIX = IHED THEN IHED ← IHED - 1 - MARGWDS ;
02700 END "UNNEST"
02800 ELSE WARN("=","Extra "&(IF INWARD>0 THEN "NARROW" ELSE "WIDEN")&" in Margin Nest") ;
02900 END "DMARGINS" ;
03000
03100 RECURSIVE PROCEDURE DNEXT ;
03200 BEGIN
03300 COMMENT Already PASSed "NEXT" ;
03400 IF ¬THISISID ∨ (THISTYPE ≠ UNITTYPE ∧ THISTYPE ≠ PUNITTYPE) THEN WARN("=","NEXT what?")
03500 ELSE IF ON THEN IF IX=IXPAGE THEN NEXTPAGE ELSE USTEP(SYMB, IX) ;
03600 PASS ;
03700 END "DNEXT" ;
03800
03900 SIMPLE PROCEDURE DPACK ;
04000 BEGIN
04100 END "DPACK" ;
04200
04300 RECURSIVE PROCEDURE DPICHAR ;
04400 BEGIN TES 11/29/73 ;
04500 INTEGER KEY, IX, F, N ; STRING S ;
04600 INPICHAR ← TRUE ;
04700 PASS ;
04800 KEY ←E(NULL,NULL) ;
04900 IF ITSCH("(") THEN
05000 BEGIN COMMENT TURN ON ;
05100 PASS ;
05200 DO S ← S & E(NULL,NULL) UNTIL ITSCH(")") ;
05300 PASS ;
05400 IF ITS(WIDTH) THEN
05500 BEGIN PASS ;
05600 IF ITS(OF) THEN BEGIN PASS ; F←'177; N←CVD(E(NULL,NULL)) END
05700 ELSE BEGIN F←CVD(E(NULL,NULL)); N←F MOD '177; F←F DIV '177 END
05800 END
05900 ELSE BEGIN F←'177 ; N ← SP END ;
06000 S ← F & N & S ;
06100 END
06200 ELSE S ← NULL ; COMMENT TURN OFF ;
06300 IX ← PUSHI(PIWDS,PITYPE) ;
06400 PIKEY(IX) ← KEY ; PIVAL(IX) ← PUSHS(1, PICHAR[KEY]) ;
06500 PICHAR[KEY] ← S ;
06600 INPICHAR ← FALSE ;
06700 END "DPICHAR" ;
00100 SIMPLE PROCEDURE DPORTION ;
00200 BEGIN
00300 INTEGER CHAN, PSIX, PIX ; STRING IFIL ; LABEL WASFWD ;
00400 DPASS ; IF ¬THISISID THEN BEGIN WARN("=","Unnamed PORTION!") ; RETURN END ;
00500 IF ¬ON THEN BEGIN PASS ; RETURN END ;
00600 FINPORTION ;
00700 IF THISTYPE ≠ PORTYPE THEN
00800 BEGIN
00900 BIND(SYMB←DECLARE(SYMB, PORTYPE), PIX ← PUTI(4, -2)) ;
01000 PORSTR(PIX) ← PUTS(NULL) ; PUTS(NULL);
01100 PORSEQ(PIX) ← 0 ;
01200 END
01300 ELSE IF 0 ≤ (CHAN ← PORCH(PIX ← IX)) THEN BEGIN RELEASE(CHAN) ; PORCH(PIX) ← -3 ; GO TO WASFWD END
01400 ELSE IF CHAN = -1 THEN BEGIN WARN("=","Can't declare PORTION FOOT!") ; PASS ; RETURN END
01500 ELSE IF CHAN ≠ -5 THEN WARN("=","PORTION "&THISWD&" already declared!")
01600 ELSE IF PORSEQ(THISPORT) ≠ PIX THEN
01700 BEGIN PORCH(PIX) ← -2 ; COMMENT ADDED FEB 6, 1973 ;
01800 WASFWD: BEGIN
01900 IF INTER ≥ 0 THEN
02000 BEGIN FOR DUMMY←1 THRU 5 DO WORDOUT(INTER,-20) ; RELEASE(INTER) ; RELEASE(SINTER) END ;
02100 INTER ← SINTER ← -1 ;
02200 END ;
02300 END ;
02400 IF INTER < 0 THEN
02500 BEGIN
02600 PSIX ← PORSTR(PIX) ;
02700 IFC TENEX THENC
02800 IFIL ← CVS(INTERS←INTERS+1) ; PORINT(PSIX) ← IFIL ;
02900 INTER ← WRITEON(TRUE,IFILENAME&OCTEXT&IFIL) ;
03000 SINTER← WRITEON(FALSE,IFILENAME&TXTEXT&IFIL) ;
03100 ELSEC
03200 IFIL ← "PUI"&CVS(INTERS←INTERS+1) ;
03300 PORINT(PSIX)←IFIL ;
03400 INTER←WRITEON(TRUE,IFIL&PUIEXT) ; SINTER←WRITEON(FALSE,IFIL&"S"&PUIEXT) ;
03500 ENDC
03600 END ;
03700 IF PORSEQ(PIX) = 0 THEN
03800 BEGIN
03900 PORSEQ(SEQPORT) ← PIX ;
04000 SEQPORT ← PIX ;
04100 END ;
04200 THISPORT ← PIX ; PORTS ← PORTS + 1 ;
04300 PASS ;
04400 END "DPORTION" ;
04500
04515 SIMPLE PROCEDURE DPUB!DEBUG ;
04520 IF NOT ON THEN PASS ELSE
04525 BEGIN "BUGLOOP"
04530 STRING INPT ;
04535 IF FULSTR(INPT←TYPEIN) THEN
04540 BEGIN
04545 SWICH("TTY←" & SUBST(SUBST(INPT, TB, SP, SP), CRLF&"##", ";"&CRLF&TB, CRLF&TB) & TES 8/23/74 SUBST;
04547 (CRLF & TB & TB & "PUB!DEBUG" & CRLF & TB & TB),
04548 -1, 0) ;
04550 PASS ;
04555 END
04560 ELSE PASS ;
04565 END "BUGLOOP" ;
04595
04600 SIMPLE PROCEDURE DRECEIVE ;
04700 BEGIN
04800 STRING A ;
04900 IF THATISCON ∧ 1≤ LENGTH(THATWD)-1 ≤2 THEN BEGIN PASS ; A ← THISWD[2 TO ∞] END
05000 ELSE A ← NULL ;
05100 IF ON THEN RECEIVE(THISPORT, A) ; PASS ;
05200 END "DRECEIVE" ;
05300
05400 SIMPLE PROCEDURE DREPEAT ;
05500 BEGIN TES 8/14/74 ;
05600 STRING BOD ;
05700 PASS ;
05800 BOD ← DEFN(FALSE, FALSE, 0, 0) ;
05900 IF ON THEN
06000 BEGIN
06100 REPEATS ← REPEATS + 1 ;
06200 SWICH(BOD, -2-BLNMS, 0) ;
06300 SWICH(BOD, -1, 0) ;
06350 PASS ;
06400 END ;
06500 END "DREPEAT" ;
00100 SIMPLE PROCEDURE DRESPONSE(INTEGER COMDWD) ;
00200 BEGIN
00300 INTEGER ARGS, SIHIGH, L1, L2, SIG, CLU, VARI, S, A, RIX, J, TYP, XIX, OLDIX ;
00400 STRING PHR, X, BOD ; BOOLEAN ROTTEN, HASBODY ;
00500 SIMPLE PROCEDURE RESPREPL ;
00600 BEGIN
00700 RIX ← PUSHI(RESPWDS, RESPTYPE) ;
00800 NEXT!RESP(RIX) ← LLPOST ; OLD!RESP(RIX) ← LLTHIS ;
00900 END "RESPREPL" ;
01000 ROTTEN ← FALSE ; ARGS ← 0 ; SIHIGH ← IHIGH ;
01100 IF COMDWD = 1 THEN
01200 BEGIN "AT"
01300 PASS ;
01400 IF ITS(PAGEMARK) THEN BEGIN VARI←2 ; CLU←0 ; L1←FF ; SIG←FF ROT -7 ; PASS END
01500 ELSE BEGIN
01600 X ← SIMPAR ; L1 ← X ;
01700 IF NULSTR(X) THEN BEGIN VARI←2 ; CLU←0 ; L1←CR ; SIG←CR ROT -7 ; PASS END
01800 ELSE IF THISWD[1 FOR 1]="0" THEN BEGIN VARI←1 ; CLU←CVD(X) ; PASS END
01900 TES 11/15/73: TEST ABOVE USED TO BE "0" LEQ L1 LEQ "9".
02000 ALSO, TOOK OUT "PHRASE RESPONSE", VARI=0;
02100 ELSE BEGIN VARI ← 2 ; L1 ← X ; SIG ← CVASC(X) ; CLU ← LENGTH(X) ;
02200 DPASS ; A ← 0 ;
02300 WHILE ¬(ITSCH(;) ∨ ITSCH(⊂)) DO
02400 BEGIN
02500 IF ¬THISISID THEN
02600 BEGIN
02700 WARN("=","Argument must be identifier.") ;
02800 ROTTEN←TRUE ;
02900 END ;
03000 S←SYMB ; PASS ; IF LENGTH(X←SIMPAR)≠1 THEN WARN("=","Separator 1 character only");
03100 PUTI(1, S) ; A ← A LSH 7 LOR X ; DPASS ;
03200 END ;
03300 ARGS ← IHIGH - SIHIGH ;
03400 END ;
03500 END ;
03600 END "AT"
03700 ELSE BEGIN
03800 PASS ; IF ¬THISISID THEN BEGIN WARN("=","BEFORE/AFTER need area/unit name") ; ROTTEN←TRUE END
03900 ELSE BEGIN VARI←IF COMDWD THEN 3 ELSE 4; CLU←SYMB; TYP←THISTYPE; XIX←IX; PASS END ;
04000 END ;
04100 BOD ← DEFN(FALSE, FALSE,ARGS,SIHIGH) ; OLDIX ← RIX ← -1 ;
04200 IF ROTTEN ∨ ¬ON THEN BEGIN IHIGH ← SIHIGH ; RETURN END ;
04300 X ← BOD ; SCAN(X, TO!NON!SP, HASBODY) ; IF ¬HASBODY THEN BOD ← NULL ;
00100 CASE VARI-1 MIN 2 OF
00200 BEGIN
00300 ie 0... Phrase TES 11/15/73 removed this case ;
00400 ie 1 ... Inset ;IF FINDINSET(CLU) THEN
00500 IF DEPTH!RESP(LLTHIS) < DEPTH THEN
00600 BEGIN
00700 RESPREPL ;
00800 IF LLPREV<0 THEN LEADRESPS←RIX ELSE NEXT!RESP(LLPREV) ← RIX ;
00900 END
01000 ELSE IF HASBODY THEN OLDIX ← RIX ← LLTHIS TES 11/29/73 OLDIX;
01100 ELSE BEGIN
01200 OLDIX ← LLTHIS ; TES 11/29/73 ;
01300 LLSKIP(LEADRESPS, NEXT!RESP)
01400 END
01500 ELSE BEGIN
01600 RIX←PUSHI(RESPWDS,RESPTYPE) ;
01700 LLINS(LEADRESPS,NEXT!RESP,RIX) ;
01800 END ;
01900 ie 2 ... Signal;BEGIN S ← 0 ; comment Old response of same signal: >0 for outer block, <0 same block;
02000 IF FINDSIGNAL(SIG) THEN
02100 BEGIN
02200 S ← IF DEPTH!RESP(LLTHIS) < DEPTH THEN LLTHIS ELSE -LLTHIS ;
02300 IF S<0 THEN OLDIX ← LLTHIS; TES 11/29/73 ;
02400 LLSKIP(SIGNALD[L1], NEXT!RESP) ; LLTHIS ← LLPOST ;
02500 END ;
02600 IF HASBODY ∨ S > 0 THEN
02700 BEGIN
02800 RIX←PUSHI(SIGWDS,RESPTYPE); SIGNAL(RIX)←SIG ; NUMARGS(RIX) ← ARGS ;
02900 LLINS(SIGNALD[L1], NEXT!RESP, RIX) ; RESP!SEP(RIX) ← A ;
03000 IF S = 0 THEN SIG!BRC ← (SIG LSH -29) & SIG!BRC ; OLD!RESP(RIX) ← S MAX 0;
03100 END ;
03200 IF NULSTR(BOD) ∧ S THEN
03300 BEGIN
03400 X ← NULL ;
03500 WHILE FULSTR(SIG!BRC) ∧ (A ← LOP(SIG!BRC)) ≠ L1 DO X ← X & A ;
03600 SIG!BRC ← X & SIG!BRC ;
03700 END ;
03800 SETBREAK(TEXT!TBL, TEXT!BRC&SIG!BRC, NULL, "IS") ;
03900 END ;
00100 ie 3,4... AFTER/BEFORE area|unit ;
00200 IF FINDTRAN(CLU, VARI) THEN
00300 IF DEPTH!RESP(LLTHIS) < DEPTH THEN
00400 BEGIN
00500 RESPREPL ;
00600 IF LLPREV < 0 THEN WAITRESP←RIX ELSE NEXT!RESP(LLPREV) ← RIX ;
00700 END
00800 ELSE IF HASBODY THEN OLDIX ← RIX ← LLTHIS
00900 ELSE BEGIN
01000 OLDIX ← LLTHIS ; TES 11/29/73 ;
01100 LLSKIP(WAITRESP, NEXT!RESP)
01200 END
01300 ELSE BEGIN
01400 RIX←PUSHI(RESPWDS,RESPTYPE) ;
01500 LLINS(WAITRESP,NEXT!RESP,RIX) ;
01600 END ;
01700 END ;
01800 IF OLDIX GEQ 0 THEN SSTK[BODY(OLDIX)] ← NULL ; TES 11/29/73 GC ;
01900 IF RIX ≥ 0 THEN
02000 BEGIN
02100 CLUE(RIX) ← CLU ; VARIETY(RIX) ← VARI ;
02200 BODY(RIX) ← PUSHS(1,BOD) ; DEPTH!RESP(RIX) ← DEPTH ;
02300 END ;
02400 END "DRESPONSE" ;
02500
02600 SIMPLE PROCEDURE DREQUIRE ;
02700 BEGIN
02800 STRING F ;
02900 PASS ; F ← E(NULL, "SOURCE!FILE") ;
03000 IF ¬EQU(THISWD[1 TO 6],"SOURCE") THEN WARN("=","REQUIRE -- SOURCE!FILE only!") ;
03100 IF FULSTR(F) ∧ ON THEN SWICHF(F) ; PASS ;
03200 END "DREQUIRE" ;
03300
03400 SIMPLE PROCEDURE DSEND ;
03500 BEGIN
03600 INTEGER PIX; STRING FI ;
03700 INTEGER SIMPLE PROCEDURE OPORT ;
03800 BEGIN INTEGER CH ; CH←WRITEON(FALSE,
03900 IFC TENEX THENC IFILENAME&GENEXT&(FI←THISWD) ELSEC
04000 (FI←(CVS(PORTS←PORTS+1)&THISWD)[1 TO 5])&PUGEXT ENDC) ;
04100 RETURN(CH) ; END "OPORT" ;
04200 PASS ; IF ¬THISISID THEN BEGIN WARN("=","SEND Where?") ; RETURN END ;
04300 IF ¬ON THEN BEGIN PASS ; DEFN(FALSE, FALSE,0,0) ; RETURN END ;
04400 IF THISTYPE ≠ PORTYPE THEN
04500 BEGIN
04600 BIND(SYMB←DECLARE(SYMB, PORTYPE), PIX ← PUTI(4, OPORT) ) ;
04700 PORSTR(PIX) ← PUTS(NULL) ; PUTS(NULL) ;
04800 PORSEQ(PIX) ← 0 ; PORFIL("PORSTR(PIX)") ← FI ;
04900 END
05000 ELSE IF PORCH(PIX←IX)=-5 THEN
05100 BEGIN PORCH(PIX)←OPORT ; PORFIL("PORSTR(PIX)")←FI END ;
05200 PASS ;
05300 SEND(PIX, DEFN(TRUE,PORCH(PIX)≠-1,0,0)) ;
05400 END "DSEND" ;
05500
05600 SIMPLE PROCEDURE DSHOW ;
05700 BEGIN
05800 END "DSHOW" ;
05900
06000 SIMPLE PROCEDURE DSUPERIMPOSE ;
06100 BEGIN
06200 INTEGER N ;
06300 DBREAK ; PASS ; N ← CVD(E("0",NULL)) MIN 50 ;IF N<1 THEN N←50 ; IF ¬ON THEN RETURN ;
06400 TWEENLFM ← N-1; SINCELFM ← 0; BREAKM ← 5;
06500 END "DSUPERIMPOSE" ;
00100 RECURSIVE PROCEDURE DSKIP(BOOLEAN GRPSKIP) ;
00200 BEGIN
00300 BOOLEAN GM ;
00400 DBREAK ; PASS ;
00500 IF GRPSKIP THEN BEGIN GM←GROUPM ; GROUPM ←1 ; END ;
00600 IF ITS(TO) THEN
00700 BEGIN "SKIP TO"
00800 DAPART ; PASS ;
00900 IF ITS(COLUMN) THEN BEGIN PASS; TOCOLUMN(CVD(E(CVS(COL+1),NULL))) END
01000 ELSE BEGIN IF ITS(LINE) THEN PASS ; TOLINE(CVD(E("1", NULL))) END ;
01100 END "SKIP TO"
01200 ELSE SKIPLINES(IF THISTYPE>INTERNTYPE ∨ THISTYPE=-TERQ ∨ NEXTSCH(←) ∨ NEXTSCH(:)
01300 THEN 1 ELSE CVD(E("1", NULL))) ;
01400 IF GRPSKIP ∧ GM = 0 THEN DAPART ;
01500 END "DSKIP" ;
01600
01700 SIMPLE PROCEDURE DTABS ;
01800 BEGIN
01900 INTEGER NUMB, I ; BOOLEAN TOO ;
02000 IF ON THEN TABSORT[1] ← TWO(33) ; TOO ← FALSE ;
02100 DO BEGIN
02200 PASS ; NUMB ← CVD(E("-9999", NULL)) MIN 9999 ;
02300 IF ON THEN
02400 BEGIN
02500 FOR I ← 1 THRU 27 DO IF TABSORT[I] ≥ NUMB THEN DONE ; IF I>27 THEN TOO←TRUE;
02600 IF ¬TOO ∧ NUMB > -9999 THEN
02700 IF TABSORT[I] > NUMB THEN DO BEGIN TABSORT[I] ↔ NUMB ; I ← I + 1 END UNTIL TABSORT[I-1]=TWO(33) ;
02800 END ;
02900 END
03000 UNTIL ¬ITSCH(",") ;
03100 IF TOO THEN WARN("=","Too many Tab Stops") ;
03200 END "DTABS" ;
03300
03400 SIMPLE PROCEDURE DTURN(BOOLEAN TURNON) ;
03500 BEGIN
03600 comment TURN ON|OFF {"c" [FOR "c"]},... ;
03700 INTEGER C1, C2 ; STRING S1, S2 ;
03800 PASS ;
03900 IF THISTYPE>INTERNTYPE ∨ THISTYPE=-TERQ ∨ NEXTSCH(:) ∨ NEXTSCH(←) THEN
04000 BEGIN "TURN BACK"
04100 C1 ← IHED ;
04200 WHILE C1>0 ∧ (C2←IXTYPE(C1))≠MODETYPE ∧ (C2≠TURNTYPE ∨ ISTK[C1-1]<0) DO C1 ← IXOLD(C1) ;
04300 IF C2=TURNTYPE THEN DO BEGIN TURN((C2←ISTK[C1-1]) LSH -7,C2 LAND '177,1) ;
04400 ISTK[C1-1] ← -2 ; C1 ← IXOLD(C1) END UNTIL C1≤0 ∨ IXTYPE(C1)≠TURNTYPE ∨ ISTK[C1-1]<0 ;
04500 END "TURN BACK"
04600 ELSE BEGIN "TURN CHARS"
04700 PUSHI(TURNWDS, TURNTYPE) ; ISTK[IHED-1] ← -1 ;
04800 DO BEGIN
04900 IF ITSCH(",") THEN PASS ;
05000 S1 ← IF NOT ITS(TAB) THEN SIMPAR ELSE TB ; PASS ;
05100 COMMENT 2/27/73 TES ;
05200 IF ITS(FOR) THEN BEGIN PASS ; S2 ← SIMPAR ; PASS END ELSE IF TURNON THEN S2 ← S1 ELSE S2 ← NULL ;
05300 IF ON THEN
05400 BEGIN
05500 IF 0 ≠ LENGTH(S2) ≠ LENGTH(S1) THEN
05600 WARN(NULL,"Strings each side of FOR are unequal length") ;
05700 WHILE FULSTR(S1) DO
05800 TURN(LOP(S1), IF FULSTR(S2) THEN LOP(S2) ELSE 0, TURNON) ;
05900 END ;
06000 END UNTIL ¬ITSCH(",") ;
06100 END "TURN CHARS" ;
06200 END "DTURN" ;
06300
06400 SIMPLE PROCEDURE DUSERERR ; RKJ: 1-9-74;
06500 BEGIN "DUSERERR"
06600 STRING USER!MESSAGE;
06700 PASS;
06800 USER!MESSAGE ← E(NULL,NULL);
06900 IF ON THEN WARN("=",USER!MESSAGE);
07000 END "DUSERERR";
00100 INTEGER SIMPLE PROCEDURE COUNTERSTMT ;
00200 IF ITS(NEXT) THEN
00300 BEGIN
00400 INTEGER USYMB ; ie, unit name symbol number ;
00500 PASS ; USYMB←IF THISTYPE=UNITTYPE THEN SYMB ELSE IF THISTYPE=PUNITTYPE THEN -SYMB ELSE TWO(20) ;
00600 DNEXT ; RETURN(USYMB) ;
00700 END
00800 ELSE RETURN(0) ;
00900
01000 BOOLEAN SIMPLE PROCEDURE LABELDEF ;
01100 IF ¬NEXTSCH(:) THEN RETURN(FALSE)
01200 ELSE IF ¬ON THEN
01300 BEGIN
01400 WHILE THISISID ∧ NEXTSCH(:) DO BEGIN PASS ; PASS END ;
01500 IF ¬ COUNTERSTMT THEN E(0, 0) ; RETURN(TRUE) ;
01600 END
01700 ELSE
01800 BEGIN
01900 INTEGER LINK, PTR, PLIGHT, USYMB, WASSYMB, VALPTR ; STRING DEFVAL ;
02000 SIMPLE PROCEDURE CHECK!CONSISTENCY ;
02100 IF WASSYMB ∧ USYMB≠0 ∧ LDB(IXN(WASSYMB)) ≠ LDB(IXN(ABS(USYMB))) THEN
02200 WARN("=","Label "&SYM[LINK]&" was cross-referenced as a "&
02300 SYM[WASSYMB]&" but is being defined as a "&
02400 SYM[ABS(USYMB)]) ;
02500 LINK ← 0 ;
02600 DO BEGIN "MULTIPLE LABELS"
02700 PTR ← SYMNUM(THISWD&":") ; BYTEWD ← NUMBER[PTR] ;
02800 IF BYTEWD=0 OR ( PLIGHT ← LDB(PLIGHTWD(BYTEWD)) ) = 1 THEN
02900 BEGIN NUMBER[PTR] ← BYTEWD LSH 13 LOR LINK ; LINK ← PTR END
03000 ELSE WARN("=","Label "&SYM[PTR]&" is already defined as "&
03100 (IF PLIGHT=2 THEN STBL[IX] ELSE "a recent page number")) ;
03200 PASS ; PASS ;
03300 END "MULTIPLE LABELS"
03400 UNTIL ¬(THISISID ∧ NEXTSCH(:)) ;
03500 IF LINK = 0 THEN RETURN(TRUE) ; TES 11/29/73 ;
03600 DEFVAL ← IF (USYMB←COUNTERSTMT)=0 THEN E(0,0)
03700 ELSE IF USYMB>TWO(13) THEN "??"
03800 ELSE IF USYMB>0 THEN C! ELSE !;
03900 IF EQU(DEFVAL,0) OR USYMB = SYMPAGE THEN
04000 DO BEGIN "PAGE LABELS"
04100 NUMBER[LINK] ↔ PLBL ; WASSYMB ← PLBL LSH -13 ;
04200 CHECK!CONSISTENCY ;
04300 PLBL ↔ LINK ; LINK ← LINK LAND '17777 ; PLBL ← -PLBL ;
04400 END "PAGE LABELS"
04500 UNTIL LINK=0
04600 ELSE BEGIN "OTHER UNIT"
04700 VALPTR ← 2 ROT -2 LOR PUTS(DEFVAL&(IF XCRIBL THEN ALTMODE&CVS(XLENGTH(DEFVAL)) ELSE NULL)) ;
04800 DO BEGIN
04900 PTR ← VALPTR ; NUMBER[LINK] ↔ PTR ; WASSYMB ← PTR LSH -13 ;
05000 CHECK!CONSISTENCY ;
05100 LINK ← PTR LAND '17777 ;
05200 END
05300 UNTIL LINK=0 ;
05400 END "OTHER UNIT" ;
05500 RETURN(TRUE) ;
05600 END "LABELDEF" ;
00100 RECURSIVE BOOLEAN PROCEDURE ASSIGNMENT ;
00200 IF NEXTSCH(←) THEN
00300 BEGIN
00400 VASSIGN(SYMB, THISTYPE, IX, E(SPASS(PASS), 0)) ;
00500 IF ITSCH(;) THEN PASS ; RETURN(TRUE) ;
00600 END
00700 ELSE RETURN(FALSE) ;
00800
00900 BOOLEAN SIMPLE PROCEDURE EMPTYCHUNK ;
01000 RETURN(IF ITSCH(;) THEN IPASS(TRUE) ELSE FALSE) ;
01100
01200 BOOLEAN SIMPLE PROCEDURE NONSENSE(BOOLEAN VALID) ;
01300 BEGIN
01400 IF VALID THEN WARN("=","Can't make sense out of: "&SOMEINPUT) ;
01500 PASS ; RETURN(FALSE) ;
01600 END "NONSENSE" ;
00100 RECURSIVE BOOLEAN PROCEDURE COMMAND ;
00200 BEGIN
00300 DEFINE DB(WHAT) = "BEGIN IF ON THEN WHAT; PASS END",
00400 BDB(WHAT)="BEGIN IF ON THEN BEGIN DBREAK; WHAT END; PASS END";
00500 IF THATISID ∧ SYMLOOK(THISWD&THATWD) ∧ LDB(TYPEN(SYMBOL))=MANTYPE THEN
00600 BEGIN THISWD ← SYM[SYMB←SYMBOL] ; THISTYPE ← MANTYPE ;
00700 IX ← LDB(IXN(SYMB)) ; RDENTITY ; END
00800 ELSE IF THISTYPE ≠ MANTYPE THEN RETURN(FALSE) ;
00900 CASE IX OF
01000 BEGIN COMMENT COMMANDS ; comment THISWD is command word.;
01100 ie ADJUST ; BDB(JUSTM←1) ;
01200 ie AFTER ; DRESPONSE(2) ;
01300 ie APART ; BEGIN DAPART ; PASS END ;
01400 ie AREA ; DAREA(FALSE) ;
01500 ie AT ; DRESPONSE(1) ;
01600 ie BEFORE ; DRESPONSE(0) ;
01700 ie BEGIN ; BEGIN BEGINBLOCK(FALSE, IF ENDCASE=2 ∧ ON THEN -1 ELSE 1,
01800 IF THATISCON THEN SPASS(THATWD[2 TO ∞]) ELSE NULL) ; PASS END ;
01900 ie BELOW ; DBELOW ;
02000 ie BLANK PAGE ; DBLANKPAGE ;
02100 ie BOX FRAME ; DFRAME(TRUE) ;
02200 ie BREAK ; BEGIN DBREAK ; PASS END ;
02210 ie BURP ; DBURP ; TES 8/19/74 BURP OUT STATE INFO ;
02400 ie CENTER ; BDB(BREAKM←4) ;
02500 ie CLOSE ; DCLOSE ;
02600 ie COMMAND CHARACTER ; DCOMMANDCHARACTER ;
02700 ie COMMENT ; BEGIN IMPOSSIBLE("COMMAND") ; PASS END ;
02800 ie COMPACT ; DB(SPACEM←IF FILL THEN 1 ELSE 2) ;
02900 ie CONTINUE ; BDB(NOPGPH ← 1) ;
03000 ie COUNT ; DCOUNT ;
03100 ie CRBREAK ; DB(CRBM←1) ;
03200 ie CRSPACE ; DB(CRBM←0) ;
03250 ie DDT ; BEGIN ERROR(0, "DDT", "D") ; PASS END ;
03300 ie DEVICE ; DDEVICE ;
03350 ie DONE ; DDONE(FALSE) ; TES 8/14/74 AND 8/19/74 ;
03400 ie END ; CASE IF STARTS THEN 0 ELSE ENDCASE OF BEGIN STARTEND; BEGINEND; ONCEEND; RESPEND END ;
03500 ie FILL ; BDB(BREAKM ← 0 ; SPACEM ← SPACEM MIN 1) ;
03600 ie FLUSH LEFT ; BDB(BREAKM←2) ;
03700 ie FLUSH RIGHT ; BDB(BREAKM←3) ;
03800 ie FONT ; DFONT(FALSE);
03900 ie GROUP ; IF GROUPM THEN PASS ELSE BDB(GROUPM←1) ;
04000 ie GROUP SKIP ; DSKIP(TRUE) ;
04100 ie IF ; DCONDITIONAL ;
04200 ie INDENT ; DINDENT ;
04300 ie INSERT ; DINSERT ;
04400 ie JUSTJUST ; BDB(BREAKM←1) ;
04500 ie LET ; DLET ;
04600 ie LOCK ; DLOCK ;
04700 ie MACRO ; DMACRO(1) ;
00100 ie NARROW ; DMARGINS(1) ; COMMENT SEMI-OBSOLETE ;
00200 ie NEXT ; BEGIN PASS ; DNEXT END ;
00300 ie NOFILL ; BDB(BREAKM←7) ;
00400 ie NOJUST ; BDB(JUSTM←0) ;
00500 ie ONCE ; BEGIN IF ON∧ENDCASE≠2 THEN BEGIN INTEGER S ; S ← STARTS ; STARTS ← 0 ;
00600 BEGINBLOCK(FALSE,2,ALTMODE) ; STARTS ← S ; END ; PASS END ;
00700 ie PACK ; DPACK ;
00800 ie PAGE FRAME ; DFRAME(FALSE) ;
00900 ie PICHAR ; DPICHAR ;
01000 ie PLACE ; BEGIN IF ON THEN DBREAK ; PASS ; PLACE(IX) ; PASS END ;
01100 ie PORTION ; DPORTION ;
01200 ie PREFACE ; BEGIN DBREAK; PASS; K←CVD(E("0",NULL)); IF ON THEN IF FILL THEN LEADFM←K ELSE LEADNM←K END ;
01250 ie PROCEDURE ; DMACRO(2) ; TES 8/19/74 ;
01275 ie PUB!DEBUG ; DPUB!DEBUG ; TES 8/21/74 ;
01300 ie RECEIVE ; DRECEIVE ;
01400 ie RECURSIVE MACRO ; DMACRO(0) ;
01450 ie REPEAT ; DREPEAT ;
01500 ie REQUIRE ; DREQUIRE ;
01600 ie RETAIN ; DB(SPACEM←0) ;
01650 ie RETURN ; DDONE(TRUE) ; TES 8/19/74 ;
01700 ie SELECT ; DFONT(TRUE) ;
01800 ie SEND ; DSEND ;
01900 ie SHOW ; DSHOW ;
02000 ie SKIP ; DSKIP(FALSE) ;
02100 ie START ; BEGIN BEGINBLOCK(FALSE,0,IF THATISCON THEN SPASS(THATWD[2 TO ∞]) ELSE NULL) ; PASS END;
02200 ie SUPERIMPOSE ; DSUPERIMPOSE ;
02300 ie TABS ; DTABS ;
02400 ie TEXT AREA ; DAREA(FALSE) ;
02500 ie TITLE AREA ; DAREA(TRUE) ;
02600 ie TURN OFF ; DTURN(0) ;
02700 ie TURN ON ; DTURN(-1) ;
02800 ie USERERR ; DUSERERR ; RKJ: 1-9-74;
02900 ie VARIABLE ; DLOCAL ;
03000 ie VERBATIM ; BDB(BREAKM←6) ;
03100 ie WIDEN ; DMARGINS(-1) ; COMMENT SEMI-OBSOLETE ;
03200 END ; COMMENT COMMANDS ;
03300 IF ITSCH(;) THEN PASS ;
03400 RETURN(TRUE) ;
03500 END ;
00100 INTERNAL RECURSIVE BOOLEAN PROCEDURE CHUNK(BOOLEAN VALID) ;
00200 BEGIN
00300 IF PAGEMARKS > PAGEWAS THEN
00400 BEGIN comment, might be AT PAGEMARK response ;
00500 FOR PAGEWAS ← PAGEWAS + 1 THRU PAGEMARKS DO IF SIGNALD[FF] THEN RESPOND(SIGNALD[FF]) ;
00600 PAGEWAS ← PAGEMARKS ;
00700 END ;
00800 RETURN(THISISID AND (ASSIGNMENT OR LABELDEF OR COMMAND OR PROCSTATEMENT)
00850 OR TEXTLINE OR EMPTYCHUNK OR NONSENSE(VALID)) ;
00875 TES ADDED PROCSTATEMENT 8/20/74 ;
00900 END "CHUNK" ;
01000
01100 INTERNAL SIMPLE PROCEDURE MANUSCRIPT ;
01200 BEGIN
01300 BOOLEAN VALID ;
01400 VALID ← TRUE ;
01500 DO VALID ← CHUNK(VALID) UNTIL LAST < 1 ;
01600 IF ¬NEXTS(7!MANUSCRIPT) THEN WARN("=","BRACKETS DON'T PAIR UP!!!!!!!!!") ;
01700 FINPORTION ; IF BLNMS=0 THEN BEGINEND ELSE IF BLNMS>0 THEN
01800 WARN("=",CVS(BLNMS) & " EXTRA BEGIN'S AND STARTS") ;
01900 END "MANUSCRIPT" ;
02000
02100 END "INNER BLOCK" ;
02200
02300 END "PARSER"