perm filename PUB.SAI[XGP,TES] blob
sn#027198 filedate 1973-02-22 generic text, type T, neo UTF8
00100 BEGIN "PUB" COMMENT Begun April 23, 1971, Completed Asymptotically ;
00200
00300
00400 COMMENT FILES TO COMPILE:
00500
00600 PUB.SAI (This one)
00700 FILLER.SAI (The Line Filler)
00800 PARSER.SAI (The Command Scanner/Parser)
00900
01000 REQUIRED FILES:
01100 By all: PUBDFS.SAI PUBINR.SAI
01200 By FILLER and PARSER only:
01300 PUBMAI.SAI PUBPRO.SAI
01400
01500 NEEDED TO RUN PUB:
01600 PUB.DMP (From this compilation)
01700 PUB2.DMP (From compiling PUB2.SAI)
01800 PUBSTD.DFS (Standard Macro File)
01900 SYS:TXTF80.DMP (For microfilm output only)
02000
02100 FORMS FOR THE DEBUG SWITCH (BREAKPOINTS A LINE):
02200 /Z04100/2/ or (Z04100/2/) Manuscript P. 2 Line 04100
02300 /ZPUB33/1/ or (ZPUB33/1/) PUBSTD.DFS P. 1 Line 33
02400
02500 DOCUMENTATION FILES:
02600 PUB.DOC[S,DOC]
02700 PUBMAC.DOC[S,DOC]
02800
02900 DO FILE FOR GENERATING SYSTEM (DO NIT):
03000 LOAD PUB.SAI(5000S),PARSER.SAI(5000S),FILLER.SAI(5000SR)↔SAVE PUB↔DO NIT(2)↔|
03100 LOAD PUB2.SAI(5000SR)↔SAVE PUB2↔
03200
03300 If the user is logged in as xx2,TES then PUB expects
03400 PUB2.DMP and PUBSTD.DFS to be in the same directory.
03500 Otherwise, it expects them to be in 1,3
03600 ;
03700
03800 DEFINE TERNAL = "INTERNAL", PRELOAD = "PRELOAD_WITH" ;
03900 REQUIRE "PUBDFS.SAI" SOURCE_FILE ;
04000 CMU CHANGE: ADD THESE DEFINES. FIRST IS FOR DEBUG VERSION
04100 WHICH USERS WILL GET FROM [A700PU00] AREA.
04200 SECOND SET IS FOR CUSP VERSION. COMMENT OUT
04300 THE APPROPRIATE DEFINES;
04400 DEFINE SYSPPN="""[A700PU00]""", SYSDEV="""DSK""";
04500 CMU DEFINE SYSPPN="NULL", SYSDEV="""SYS""";
04600 comment, The DEFINEs, constant-bound arrays, and global variables ;
04700
04800 REQUIRE 5000 STRING_SPACE ; REQUIRE 400 SYSTEM_PDL ; REQUIRE 200 STRING_PDL ;
00010 EXTERNAL INTEGER PROCEDURE XLENGTH(STRING S);
00020
00100 COMMENT The following INTERNAL SIMPLE PROCEDUREs are EXTERNAL in PUBMAI.SAI ;
00200
00300 INTERNAL STRING SIMPLE PROCEDURE SPS(INTEGER N) ; IF N≤10 THEN RETURN(SPSARR[N MAX 0]) ELSE
00400 BEGIN
00500 STRING S ; INTEGER I ;
00600 S ← " " ;
00700 FOR I ← 20 STEP 10 UNTIL N DO S ← S & " " ;
00800 RETURN(S & SPSARR[N-I+10]) ;
00900 END ;
01000
01100 COMMENT DYNAMIC ARRAY MANIPULATION PACKAGE (ARRSER.SAI[1,DCS]) ;
01200
01300 EXTERNAL INTEGER GOGTAB ;
01400
01500 DSCR PTR←WHATIS(ARRAY)
01600 PAR ARRAY OF ANY ARITHMETIC OR SET BREED
01700 RES PTR←DSCRPTR, SAIL CAN THEN TREAT IT AS AN INTEGER
01800 ;
01900
02000 INTERNAL INTEGER SIMPLE PROCEDURE WHATIS(INTEGER ARRAY A);
02100 START_CODE "WHATIS"
02200 MOVE 1,A;
02300 END "WHATIS";
02400
02500
02600
02700 DSCR PTR←SWHATIS(ARRAY)
02800 PAR STRING ARRAY
02900 RES PTR←DSCRPTR, SAIL CAN THEN TREAT IT AS AN INTEGER
03000 ;
03100
03200 INTERNAL INTEGER SIMPLE PROCEDURE SWHATIS(STRING ARRAY A);
03300 START_CODE "SWHATIS"
03400 MOVE 1,A;
03500 END "SWHATIS";
03600
03700
03800 DSCR GOAWAY(PTR)
03900 PAR PTR IS ARRAY DESCRIPTOR
04000 DES ARRAY IS RLEASD
04100 ;
04200
04300 INTERNAL SIMPLE PROCEDURE GOAWAY(INTEGER I) ;
04400 BEGIN COMMENT Be SURE Left Half is -1 for String Arrays! ;
04500 START_CODE MOVE '15, GOGTAB END ;
04600 IF LH(I) THEN
04700 START_CODE "SARID"
04800 HRRZ 1, I ; MOVE 1, 0(1) ; COMMENT [PREV,,NEXT] ;
04900 HLRZ 2, 1 ; HRRM 1, 0(2) ; COMMENT PREV ← [...,,NEXT] ;
05000 HRRZ 2, 1 ; SKIPE 2 ; HLLM 1, 0(2) ; COMMENT NEXT ← [PREV,,...] ;
05100 END "SARID" ;
05200 ARYEL(I) ;
05300 END "GOAWAY" ;
00100 INTERNAL INTEGER SIMPLE PROCEDURE BIGGER(INTEGER PTR,HM);
00200 BEGIN "BIGGER"
00300 INTEGER PT,L,U;
00400 INTEGER ARRAY OLDX,NEWX[0:ONE];
00500 MAKEBE(PTR,OLDX);
00600 L←ARRINFO(OLDX,1);
00700 U←ARRINFO(OLDX,2);
00800 PT←LRMAK(L,U+HM,1);
00900 MAKEBE(PT,NEWX);
01000 ARRTRAN(NEWX,OLDX);
01100 GOAWAY(PTR);
01200 RETURN(PT);
01300 END "BIGGER";
01400
01500
01600 DSCR PTR1←SBIGGER(PTR,HOWMUCH)
01700 PAR PTR IS ARRAY (1-D STRING) DESCRIPTOR
01800 HOWMUCH NUMBER OF ELEMENTS INCREASE DESIRED
01900 RES PTR1 IS DESCRIPTOR OF BIGGER ARRAY
02000 THE OLD DATA IS COPIED, THE OLD ARRAY HAS DISAPPEARED
02100 ;
02200
02300 CMU: SBIGGER BELOW IS ALL NEW...STRNGC PROBLEMS!;
02400
02500 INTERNAL INTEGER SIMPLE PROCEDURE SBIGGER(INTEGER PTR,HM);
02600 BEGIN "SBIGGER"
02700 EXTERNAL INTEGER PROCEDURE ARRINFO(STRING ARRAY S; INTEGER I);
02800 EXTERNAL PROCEDURE ARRTRAN(STRING ARRAY S1,S2);
02900 INTEGER PT,L,U;
03000 STRING ARRAY SOLD,SNEW[0:ONE];
03100 SMAKEBE(PTR,SOLD);
03200 L←ARRINFO(SOLD,1);
03300 U←ARRINFO(SOLD,2);
03400 PT←LRMAK(L,U+HM,-1 LSH 18 + 1);
03500 SMAKEBE(PT,SNEW);
03600 ARRTRAN(SNEW,SOLD);
03700 GOAWAY(PTR);
03800 RETURN(PT);
03900 END "SBIGGER";
00100 COMMENT Declares
00200 IDA ← [S]CREATE(LOWBND, HIGHBND) to create a (string or) integer array
00300 MAKEBE(IDA,ALIAS) to give its descriptor to array ALIAS
00400 IDA ← [S]WHATIS(ALIAS) to take it back
00500 GOAWAY(IDA) to destroctulate it
00600 IDA ← [S]BIGGER(IDA,XTRA) to add XTRA words to its length ;
00700
00800 INTEGER SA_LL ;
00900
01000 INTEGER SIMPLE PROCEDURE SCREATE(INTEGER LB1, UB1) ;
01100 BEGIN
01200 INTEGER IDA ;
01300 START_CODE MOVE '15, GOGTAB END ;
01400 IDA ← LRMAK(LB1, UB1, -1 LSH 18 + 1) ;
01500 START_CODE "LLSAC"
01600 LABEL ENDLIST ;
01700 HRRZ 4, IDA ; HRRZ 5, SA_LL ; JUMPE 5, ENDLIST ; HRLM 4, 0(5) ; COMMENT: NEXT ← [ARR,,...] ;
01800 ENDLIST: HRLI 5, SA_LL ; MOVEM 5, 0(4) ; COMMENT: ARR ← [SA_LL,,NEXT] ;
01900 MOVEM 4, SA_LL ; COMMENT: SA_LL ← [0,,ARR] ;
02000 END "LLSAC" ;
02100 RETURN(IDA) ;
02200 END "SCREATE" ;
02300
02400 INTERNAL INTEGER SIMPLE PROCEDURE CREATE2(INTEGER LB1, UB1, LB2, UB2) ;
02500 BEGIN
02600 EXTERNAL INTEGER SIMPLE PROCEDURE LRMAK(INTEGER LB1, UB1, LB2, UB2, D) ;
02700 START_CODE MOVE '15, GOGTAB END ; COMMENT LRCOP BUG ;
02800 RETURN(LRMAK(LB1, UB1, LB2, UB2, 2)) ;
02900 END "CREATE2" ;
03000
03100 INTERNAL STRING SIMPLE PROCEDURE ERRLINE ;
03200 RETURN(IF EQU(MAINFILE, THISFILE) THEN SRCLINE
03300 ELSE THISFILE[1 TO 3]&SRCLINE) ;
03400
03500 INTERNAL STRING SIMPLE PROCEDURE WARN(STRING SHORT_VERSION,LONG_VERSION) ;
03600 BEGIN
03700 USERERR(0, 1, LONG_VERSION&CRLF&" just above (or on) "&ERRLINE&"/"&SRCPAGE&"["&MACLINE&"]") ;
03800 IF DEBUG ∧ MESGS<MESSMAX ∧ LENGTH(SHORT_VERSION) THEN
03900 MESSAGE[MESGS←MESGS+1] ← IF SHORT_VERSION = "=" THEN LONG_VERSION ELSE SHORT_VERSION ;
04000 RETURN(NULL) ;
04100 END "WARN" ;
00100 INTEGER GENEXT; RKJ;
00200 SIMPLE PROCEDURE ANYSTART(STRING COMDLINE) ; NB Both RPGSTART and SSTART call this one;
00300 BEGIN
00400 STRING WD, OPTIONS, N, M ; INTEGER FIL, EXT, PPN ;
00500 SETBREAK(1, "←/()", CR&LF&TB&FF&SP, "INS") ;
00600 SETBREAK(2, DIGS, SP, "XNS") ;
00700 OUTFILE ← SCAN(COMDLINE, 1, BRC) ;
00800 IF BRC ≠ "←" THEN INFILE ← OUTFILE ;
00900 FIL ← CVFIL(OUTFILE, EXT, PPN) ; N ← IF PPN THEN CVXSTR(PPN) ELSE NULL ;
01000 GENEXT ← EXT=0 ∨ BRC≠"←";
01100 IF GENEXT THEN OUTFILE ← CVXSTR(FIL);
01200 CMU: DELETE & (IF PPN=0 THEN NULL ELSE "[" & N[1 TO 3] & "," & N[4 TO 6] & "]") ;
01300 TMPFILE ← CVXSTR(FIL) & ".RPG" ;
01400 WHILE BRC ∧ BRC≠"(" ∧ BRC≠"/" DO
01500 BEGIN "INPUT FILE NAME"
01600 WD ← SCAN(COMDLINE, 1, BRC) ;
01700 IF FULSTR(WD) THEN
01800 BEGIN
01900 IF FULSTR(INFILE) THEN
02000 WARN(NULL,"ONLY 1 INPUT FILE ALLOWED -- "
02100 & INFILE & " SKIPPED") ;
02200 INFILE ← WD ;
02300 END ;
02400 END "INPUT FILE NAME" ;
02500 WHILE BRC="/" DO OPTIONS ← OPTIONS & SCAN(COMDLINE,1,BRC) ;
02600 IF BRC = "(" THEN DO OPTIONS ← OPTIONS & SCAN(COMDLINE,1,BRC) & (IF BRC="/" THEN BRC ELSE NULL)
02700 UNTIL BRC = 0 OR BRC = ")" ;
02800 IF FULSTR(OPTIONS) THEN
02900 DO BEGIN
03000 N ← SCAN(OPTIONS, 2, BRC) ;
03100 IF BRC = "d" ∨ BRC = "D" THEN DEBUG ← -1
03200 ELSE IF BRC = "s" ∨ BRC = "S" THEN PREFMODE ← IF NULSTR(N) THEN 1 ELSE CVD(N)
03300 ELSE IF BRC = "m" ∨ BRC = "M" THEN DEVICE ← -MIC
03400 ELSE IF BRC = "t" ∨ BRC = "T" THEN DEVICE ← -TTY
03500 ELSE IF BRC = "l" ∨ BRC = "L" THEN DEVICE ← -LPT
03600 ELSE IF BRC = "x" ∨ BRC = "X" THEN DEVICE ← -XGP RKJ;
03700 ELSE IF BRC = "z" ∨ BRC = "Z" THEN
03800 LSTOP ← SCAN(OPTIONS,1,BRC) & "/" & SCAN(OPTIONS,1,BRC)
03900 ELSE IF BRC="n" ∨ BRC="N" ∨ BRC="y" ∨ BRC="Y" ∨ BRC="a" ∨ BRC="A" THEN DELINT ← BRC
04000 ELSE IF BRC = "c" ∨ BRC = "C" THEN CONTENTS ← -1
04100 ELSE IF BRC = "b" ∨ BRC = "B" THEN SYMNO ← BIG_SIZE - 1
04200 ELSE IF BRC = "h" ∨ BRC = "H" THEN SYMNO ← HUGE_SIZE - 1
04300 ELSE IF BRC = "t" ∨ BRC = "T" THEN M ← N
04400 ELSE IF BRC = "p" ∨ BRC = "P" OR (BRC = 0 AND FULSTR(M)) THEN
04500 BEGIN
04600 IF BRC = 0 THEN N ← "99999" ;
04700 IF INPGS ≥ 10 THEN WARN(NULL,"ONLY 10 mTnP OPTIONS ALLOWED")
04800 ELSE INPG[INPGS←INPGS+1] ← LHRH("CVD(IF NULSTR(M) THEN N ELSE M)", "CVD(N)") ;
04900 M ← NULL ;
05000 END
05100 ELSE IF BRC ≠ 0 THEN WARN(NULL,"NEVER HEARD OF A " & BRC & " OPTION") ;
05200 END
05300 UNTIL BRC = 0 ;
05400 XCRIBL ← IF DEVICE = -XGP THEN TRUE ELSE FALSE; RKJ;
05500 BREAKSET(1, NULL, "O") ; BREAKSET(2, NULL, "O") ;
05600 END "ANYSTART" ;
05700 SIMPLE PROCEDURE RPGSTART ;
05800 BEGIN
05900 EOF ← 0 ; OPEN(0, "DSK", 0, 1, 0, 50, BRC, EOF) ; LOOKUP(0, "QQPUB.RPG", FLAG) ;
06000 SETBREAK(1, LF, CR, "INS") ;
06100 ANYSTART(INPUT(0,1)) ; RELEASE(0) ;
06200 END "RPGSTART" ;
06300
06400 SIMPLE PROCEDURE SSTART ;
06500 BEGIN
06600 STRING S;
06700 DO BEGIN OUTCHR("*"); S←INCHWL; END UNTIL FULSTR(S);
06800 ANYSTART(S);
06900 END;
07000
07100
07200
07300
07400
07500 COMMENT E X E C U T I O N B E G I N S . . . . ;
07600
07700 ONE ← 1 ; NB Variable upper bound for ALIAS arrays;
07800 SYMNO ← REGULAR_SIZE - 1 ; NB Assume for now that symbol table is regular size;
07900 INPGS ← 0 ; INFILE ← NULL ; PREFMODE ← 1 ; DEVICE ← LPT ; DELINT ← "Y" ;
08000 IF RPGSW THEN RPGSTART ELSE SSTART; NB Read file names and options;
08100 INITSIZES ;
00100 BEGIN "VARIABLE BOUND ARRAY BLOCK"
00200
00300 REQUIRE "PUBINR.SAI[A700PU00]" SOURCE_FILE ;
00400 comment, Arrays whose sizes depend on CUSP options. Also SYMSER.SAI variables ;
00500
00600 COMMENT
00700 SYMSER.SAI package -- LOOKUP and ENTER procedures for hashed
00800 symbol tables -- STRINGS -- uses quadratic search.
00900
01000 REQUIRED --
01100 1. DEFINE SYMNO="1 less than some relatively prime number big
01200 enough to hold all entries"
01300 2. REQUIRE "SYMSER.SAI[1,DCS]" SOURCE_FILE in outer block
01400 declaration code
01500
01600 WHAT YOU GET ---
01700 1. An array, SYM, to hold the (STRING) symbols you enter.
01800 2. Another array, NUMBER, to hold the (INTEGER) values
01900 associated with the array
02000 3. An index, SYMBOL, set to the correct SYM/NUMBER element
02100 after a lookup
02200
02300 4. An integer, ERRFLAG, set to TRUE if errors occur in ENTERSYM
02400
02500
02600 5. A Procedure, FLAG←LOOKSYM("A") which returns:
02700 TRUE if the symbol is already present in the SYM table.
02800 FALSE if the symbol is not found --
02900 SYMBOL will have the value -1 (table full), or
03000 will be an index of a free entry (see ENTERSYM)
03100
03200 6. A Procedure, ENTERSYM("SYM",VAL) which does:
03300 Checks for symbol full or duplicate symbol -- if detected,
03400 types message and sets ERRFLAG TRUE
03500 Puts SYM and VAL in SYM/NUMBER arrays at SYMBOL index
03600
03700 7. A Procedure, SYMSET, which initializes the table.
03800 SYM[0] is initted to a blank string -- you can use
03900 this information if you wish.
04000
04100 ;
00100 COMMENT Most of the procedures in this block are INTERNAL. They are EXTERNAL in PUBPRO.SAI ;
00200
00300 INTERNAL SIMPLE PROCEDURE SETSYM;
00400 BEGIN
00500 INTEGER I;
00600 FOR I← 1 STEP 1 UNTIL SYMNO DO SYM[I]←NULL;
00700 SYM[0]←" ";
00800 ERRFLAG←FALSE
00900 END "SETSYM";
01000
01100 INTERNAL INTEGER SIMPLE PROCEDURE LOOKSYM(STRING A);
01200 BEGIN "LOOKSYM"
01300 INTEGER H,Q,R;
01400 DEFINE SCON="10";
01500 H←CVASC(A) +LENGTH(A) LSH 6;
01600 R←SYMBOL←(H←ABS(H⊗(H LSH 2))) MOD (SYMNO+1);
01700
01800 IF EQU(SYM[SYMBOL],A) THEN RETURN(-1);
01900 IF NULSTR(SYM[SYMBOL]) THEN RETURN(0);
02000
02100 Q←H%(SYMNO+1) MOD (SYMNO+1);
02200 IF (H←Q+SCON)≥SYMNO THEN H←H-SYMNO;
02300
02400 WHILE (IF (SYMBOL←SYMBOL+H)>SYMNO
02500 THEN SYMBOL←SYMBOL-(SYMNO+1) ELSE SYMBOL) ≠R DO
02600 BEGIN "LK1"
02700 IF EQU(SYM[SYMBOL],A) THEN RETURN(-1);
02800 IF NULSTR(SYM[SYMBOL]) THEN RETURN(0);
02900 IF (H←H+Q)>SYMNO THEN H←H-(SYMNO+1);
03000 END "LK1";
03100 SYMBOL←-1; RETURN(0);
03200 END "LOOKSYM";
03300
03400 INTERNAL SIMPLE PROCEDURE ENTERSYM(STRING WORD; INTEGER VAL);
03500 BEGIN "ENTERSYM"
03600 IF LENGTH(SYM[SYMBOL])∨SYMBOL<0 THEN
03700 BEGIN
03800 ERRFLAG←1;
03900 IF SYMBOL≥0 THEN PRINT "DUPLICATE SYMBOL "&WORD MSG
04000 ELSE PRINT "SYMBOL TABLE FULL" MSG ;
04100 END
04200 ELSE
04300 BEGIN
04400 SYM[SYMBOL]←WORD;
04500 NUMBER[SYMBOL]←VAL;
04600 END;
04700 END "ENTERSYM";
00100 COMMENT P A S S O N E P R O C E D U R E S - - - - - - - - - - - - - - - ;
00200
00300 EXTERNAL RECURSIVE PROCEDURE DBREAK ;
00400 EXTERNAL RECURSIVE BOOLEAN PROCEDURE TEXTLINE ; comment, INTERNAL in FILLER.SAI ;
00500 EXTERNAL RECURSIVE BOOLEAN PROCEDURE CHUNK(BOOLEAN VALID) ;
00600 EXTERNAL RECURSIVE STRING PROCEDURE PASS ; comment, INTERNAL in PARSER.SAI ;
00700 EXTERNAL STRING SIMPLE PROCEDURE EVALV(STRING THISWD ; INTEGER IX, TYP) ;
00800 EXTERNAL RECURSIVE STRING PROCEDURE E(STRING DEFAULT, STOPWORD) ;
00900 EXTERNAL SIMPLE PROCEDURE RDENTITY ;
01000
01100 FORWARD INTERNAL RECURSIVE PROCEDURE CLOSEAREA(INTEGER ITSIX; BOOLEAN DISDECLAREIT) ;
01200 FORWARD INTERNAL RECURSIVE PROCEDURE CLOSEUNIT(INTEGER ITSIX; BOOLEAN DISDECLAREIT) ;
01300
01400 INTERNAL STRING SIMPLE PROCEDURE SOMEINPUT ;
01500 RETURN(SP&THISWD&SP&
01600 (IF THATISFULL THEN LIT_ENTITY&LIT_TRAIL ELSE NULL)&INPUTSTR[1 TO 80]);
01700
01800 INTERNAL SIMPLE PROCEDURE IMPOSSIBLE(STRING WHERE); WARN("=","IMPOSSIBLE CASE INDEX IN "&WHERE&" AT "&SOMEINPUT);
01900
02000 INTERNAL STRING SIMPLE PROCEDURE CAPITALIZE(STRING MIXEDCASE) ;
02100 BEGIN
02200 INTEGER C ; STRING S ; S ← 0&MIXEDCASE ; LOPP(S) ; C ← LENGTH(MIXEDCASE) ; IF ¬C THEN RETURN(NULL);
02300 START_CODE "CAPIT" LABEL NEXC ; MOVE 1, S ; MOVE 2, C ;
02400 NEXC: ILDB 3, 1 ; LDB 3, UPCAS3 ; DPB 3, 1 ; SOJG 2, NEXC ;
02500 END "CAPIT" ; RETURN(S) ;
02600 END "CAPITALIZE" ;
02700
02800 INTEGER ARRAY SA_COLBLK[1:2] ;
02900 EXTERNAL SIMPLE PROCEDURE SGREM(SIMPLE PROCEDURE SAP); EXTERNAL SIMPLE PROCEDURE SGINS(SIMPLE PROCEDURE SAP; REFERENCE INTEGER I);
03000
03100 SIMPLE PROCEDURE SA_PROVIDE ;
03200 BEGIN
03300 INTEGER SA ;
03400 SA ← SA_LL ; COMMENT Provide GC with each string (except 1st) in each SA in SA_LL ;
03500 WHILE SA DO
03600 START_CODE "SAP"
03700 LABEL LOOP ;
03800 HRRZ 1, SA ; HRRZ 2, 0(1) ; MOVEM 2, SA ; COMMENT: SA ← RH(SA) ;
03900 ADDI 1,1 ; HRRZ 7, -2(1) ; CAILE 7, 0 ; COMMENT (1)←1ST STRING, (7)← #REAL STRS ;
04000 LOOP: PUSHJ '17, @-1('17) ; SOJG 7, LOOP ; COMMENT String descriptor sorter ;
04100 END "SAP" ;
04200 END "SA_PROVIDE" ;
04300
04400 SIMPLE PROCEDURE ZEROWORDS(INTEGER WDS; REFERENCE INTEGER LOCN) ;
04500 BEGIN
04600 START_CODE "ZOT"
04700 LABEL DUN ;
04800 SKIPG 1, WDS ;
04900 JRST DUN ; COMMENT NO WDS TO ZERO -- QUIT ;
05000 HRRZ 2, -1('17) ; COMMENT LOCN ;
05100 SETZM 0(2) ;
05200 CAIN 1, 1 ;
05300 JRST DUN ; COMMENT ONLY 1 -- DON'T BLT ! ;
05400 ADDI 1, -1(2) ;
05500 HRL 2, 2 ;
05600 ADDI 2, 1 ;
05700 BLT 2, (1) ;
05800 DUN:
05900 END ;
06000 END "ZEROWORDS" ;
00100 INTERNAL SIMPLE PROCEDURE GROW(REFERENCE INTEGER ARRAY ARR; REFERENCE INTEGER IDA,WDS;
00200 INTEGER EXTRA; STRING WHY) ;
00300 BEGIN
00400 IDA ← RH("BIGGER(WHATIS(ARR),EXTRA)"); WDS ← WDS + EXTRA ;
00500 IF WDS ≥ 2↑14 THEN WARN(NULL,"Table grown to 2↑14 entries. Utterly unmanageable. Goodbye!") ;
00600 END "GROW" ;
00700
00800 INTERNAL SIMPLE PROCEDURE SGROW(REFERENCE STRING ARRAY ARR; REFERENCE INTEGER IDA,WDS;
00900 INTEGER EXTRA; STRING WHY) ;
01000 BEGIN
01100 IDA ← RH("SBIGGER(SWHATIS(ARR),EXTRA)"); WDS ← WDS + EXTRA ;
01200 IF WDS ≥ 2↑14 THEN WARN(NULL,"Table grown to 2↑14 entries. Utterly unmanageable. Goodbye!") ;
01300 START_CODE "LLSAG" LABEL ENDLIST ;
01400 HRRZ 4, @IDA ; HLRZ 5, 0(4) ; HRRM 4, 0(5) ; COMMENT: PREV ← [...,,ARR] ;
01500 HRRZ 5, 0(4) ; JUMPE 5, ENDLIST ; HRLM 4, 0(5) ; COMMENT: NEXT ← [ARR,,...] ;
01600 ENDLIST: END "LLSAG" ;
01700 END "SGROW" ;
01800
01900 INTERNAL SIMPLE PROCEDURE GROWNESTS ;
02000 BEGIN
02100 GROW(INEST, INESTIDA, SIZE, 200, NULL) ; MAKEBE(INESTIDA, INEST) ;
02200 SGROW(SNEST, SNESTIDA, DUMMY←0, 200, NULL) ; SMAKEBE(SNESTIDA, SNEST) ;
02300 END "GROWNESTS" ;
02400
02500 INTERNAL SIMPLE PROCEDURE GROWOWLS(INTEGER EXTRA) ;
02600 BEGIN
02700 GROW(MOLES, MOLESIDA, OLXX, EXTRA, NULL) ; MAKEBE(MOLESIDA, MOLES) ;
02750 GROW(SHORT, SHORTIDA, DUMMY←0, EXTRA, NULL) ; MAKEBE(SHORTIDA, SHORT) ;
02800 GROW(OWLS, OWLSIDA, DUMMY←0, EXTRA, NULL) ;
02900 MAKEBE(OWLSIDA, OWLS) ; OWLSF ← OWLSIDA ; MOLESF ← MOLESIDA ; SHORTF ← SHORTIDA ;
03000 END "GROWOWLS" ;
03100
03200 INTERNAL INTEGER SIMPLE PROCEDURE PUSHI(INTEGER WDS, TYP) ;
03300 BEGIN INTEGER QI ;
03400 IF (IHED ← IHED + WDS+1) > ISIZE THEN
03500 BEGIN
03600 GROW(ISTK, ISTKIDA, ISIZE, 1000, NULL) ;
03700 MAKEBE(ISTKIDA,ISTK)
03800 END ;
03900 ISTK[IHED] ← TYP ROT -9 LOR (IHED-WDS-1) ;
04000 ZEROWORDS(WDS, ISTK[IHED-WDS]) ; RETURN(IHED) ;
04100 END ;
04200
04300 INTERNAL INTEGER SIMPLE PROCEDURE PUSHS(INTEGER WDS; STRING FIRST) ;
04400 BEGIN INTEGER QI ;
04500 IF (SHED ← SHED + WDS) > SSIZE THEN
04600 BEGIN
04700 SGROW(SSTK, SSTKIDA, SSIZE, 200, NULL) ;
04800 SMAKEBE(SSTKIDA,SSTK) ;
04900 END ;
05000 SAT(SSTK,SHED) ; SSTK[SHED] ← FIRST ;
05100 FOR QI←WDS-1 DOWN 1 DO SSTK[SHED-QI]←NULL ; RETURN(SHED) ;
05200 END ;
05300
05400 INTERNAL INTEGER SIMPLE PROCEDURE PUTI(INTEGER WDS, FIRST) ;
05500 BEGIN INTEGER QI ;
05600 IF (IHIGH ← IHIGH + WDS) > ITSIZE THEN
05700 BEGIN
05800 GROW(ITBL, ITBLIDA, ITSIZE, 300, NULL) ;
05900 MAKEBE(ITBLIDA,ITBL) ;
06000 END ;
06100 ITBL[IHIGH] ← FIRST ;
06200 ZEROWORDS(WDS-1, ITBL[IHIGH-WDS+1]) ; RETURN(IHIGH) ;
06300 END ;
06400
06500 INTERNAL INTEGER SIMPLE PROCEDURE PUTS(STRING VAL) ;
06600 BEGIN INTEGER QI ;
06700 IF (SHIGH ← SHIGH + 1) > STSIZE THEN
06800 BEGIN
06900 SGROW(STBL, STBLIDA, STSIZE, 200, NULL) ;
07000 SMAKEBE(STBLIDA,STBL) ;
07100 END ;
07200 SAT(STBL,SHIGH) ; STBL[SHIGH] ← VAL ;
07300 RETURN(SHIGH) ;
07400 END ;
00100 INTERNAL SIMPLE PROCEDURE SWICH(STRING NEWINPUTSTR; INTEGER NEWINPUTCHAN, ARGS) ;
00200 BEGIN comment switch to new input stream ;
00300 IF ARGS THEN
00400 BEGIN "SUBSTITUTE"
00500 INTEGER BRC ; STRING NEWER ; NEWER ← NULL ; LAST ← LAST - ARGS ;
00600 DO BEGIN "VTABS"
00700 NEWER ← NEWER & SCAN(NEWINPUTSTR, TO_VT_SKIP, BRC) ;
00800 IF BRC THEN NEWER ← NEWER & SNEST[LAST + LOP(NEWINPUTSTR)] ;
00900 END "VTABS"
01000 UNTIL BRC = 0 ;
01100 NEWINPUTSTR ← NEWER ;
01200 END "SUBSTITUTE" ;
01300 IF (LAST ← LAST+2) > SIZE THEN GROWNESTS ; SAT(SNEST, LAST) ;
01400 STRSCAN(LAST) ← IF THATISFULL THEN LIT_ENTITY & LIT_TRAIL & INPUTSTR ELSE INPUTSTR ;
01500 CHANSCAN(LAST) ← INPUTCHAN + (IF TECOFILE THEN 100 ELSE 0) ;
01600 LINESCAN(LAST) ← IF INPUTCHAN < 0 THEN MACLINE ELSE THISFILE & SRCLINE ;
01700 PAGESCAN(LAST) ← LHRH(PAGEMARKS, PAGEWAS) ;
01800 EMPTYTHIS ; EMPTYTHAT ;
01900 INPUTSTR ← NEWINPUTSTR ; INPUTCHAN ← NEWINPUTCHAN ; TECOFILE ← 0 ;
02000 END "SWICH" ;
02100
02200 INTERNAL STRING SIMPLE PROCEDURE SWICHBACK ;
02300 BEGIN
02400 EOF ← 0 ; IF INPUTCHAN≥0 THEN BEGIN CHANLS[INPUTCHAN]←0; RELEASE(INPUTCHAN) END ;
02500 PAGEMARKS ← LH("DUMMY ← ABS(PAGESCAN(LAST))") ; PAGEWAS ← RH(DUMMY) ;
02600 IF (INPUTCHAN ← CHANSCAN(LAST))< 0 THEN MACLINE←LINESCAN(LAST)
02700 ELSE BEGIN SRCLINE←LINESCAN(LAST)[7 TO ∞] ; THISFILE←LINESCAN(LAST)[1 TO 6] END ;
02800 IF TECOFILE ← INPUTCHAN > 50 THEN INPUTCHAN ← INPUTCHAN - 100 ;
02900 INPUTSTR ← STRSCAN(LAST) ; LAST←LAST-2; SAT(SNEST,LAST); RETURN(INPUTSTR) ;
03000 END "SWICHBACK" ;
03100
03200 INTERNAL SIMPLE PROCEDURE SWICHF(STRING FILENAME) ;
03300 BEGIN
03400 INTEGER CHAN, FIR, EXT, PPN ; STRING MANEXT, FPPN, SEXT, SFIR ;
03500 IF (CHAN ← GETCHAN) < 0 THEN
03600 BEGIN WARN("=","No channel for reading "&FILENAME) ; RETURN END ;
03700 CHANLS[CHAN] ← -1 ; EOF ← 0 ; OPEN(CHAN, "DSK", 0, 2, 0, 150, BRC, EOF) ;
03800 MANEXT ← NULL ;
03900 FIR ← CVFIL(FILENAME, EXT, PPN) ;
04000 FPPN ← CVXSTR(PPN) ; SEXT ← CVXSTR(EXT) ; SFIR ← CVXSTR(FIR) ;
04100 IF LAST=2 THEN
04200 BEGIN "PRIMARY FILE"
04300 IF EXT = 0 THEN
04400 MANEXT ← SFIR &".PUB"&
04500 CMU: OLD LINE (IF PPN THEN "["&FPPN[1 TO 3]&","&FPPN[4 TO 6]&"]" ELSE NULL) ;
04600 (IF PPN THEN "["&CVOS(LH(PPN))&","&CVOS(RH(PPN))&"]" ELSE NULL) ;
04700 END "PRIMARY FILE" ;
04800 DO BEGIN
04900 LOOKUP(CHAN, IF FULSTR(MANEXT) THEN MANEXT ELSE FILENAME, FLAG) ;
05000 IF FLAG THEN IF FULSTR(MANEXT) THEN MANEXT ← NULL ELSE
05100 BEGIN
05200 OUTSTR("No file named `"&FILENAME&"'--read file:") ;
05300 FILENAME←INCHWL ;
05400 END ;
05500 END
05600 UNTIL ¬FLAG ;
05700 SWICH(NULL, CHAN, 0) ;
05800 IF EQU(SEXT, "PUG ") OR EQU(SEXT, "PUZ ") THEN
05900 BEGIN TECOFILE ← 0 ; LOPP(SFIR) END
06000 ELSE BEGIN INPUT(INPUTCHAN, NO_CHARS) ; TECOFILE ← BRC≥0 END ;
06100 PAGEMARKS ← PAGEWAS ← 1 ; SRCPAGE ← "1" ; SRCLINE ← IF TECOFILE THEN "0" ELSE "00000" ;
06200 THISFILE ← (SFIR & "::::::")[1 TO 6] ;
06300 IF TECOFILE THEN
06400 BEGIN COMMENT IF TVEDIT FILE, SKIP PAGE 1 ;
06500 IF EQU("COMMENT ⊗", INPUT(INPUTCHAN,TO_TERQ_CR)[1 TO 9]) THEN
06600 BEGIN
06700 DO INPUT(INPUTCHAN, TO_TB_FF_SKIP) UNTIL BRC=FF ;
06800 SRCPAGE ← "2" ; PAGEMARKS ← PAGEWAS ← 2 ;
06900 END
07000 ELSE BEGIN CLOSIN(INPUTCHAN) ; COMMENT NOT TVEDIT -- RESTART INPUT ;
07100 LOOKUP(CHAN, IF FULSTR(MANEXT) THEN MANEXT ELSE FILENAME, FLAG) ;
07200 END END ;
07300 END "SWICHF" ;
07400
00100 INTERNAL BOOLEAN SIMPLE PROCEDURE SYMLOOK(STRING NAME) ;
00200 BEGIN comment same as LOOKSYM, but if hash table full, expands it and does linear search ;
00300 comment don't search if it's already here;
00400 IF SYMBOL>0 AND EQU(SYM[SYMBOL],NAME) OR LOOKSYM(NAME) THEN RETURN(TRUE) ;
00500 IF SYMBOL>0 THEN RETURN(FALSE) ; comment it's not there, and table's not full;
00600 FOR SYMBOL ← SYMNO STEP 1 WHILE SYMBOL≤XSYMNO AND FULSTR(SYM[SYMBOL]) AND ¬EQU(SYM[SYMBOL],NAME) DO ;
00700 IF SYMBOL > XSYMNO THEN
00800 BEGIN
00900 SGROW(SYM, SYMIDA, XSYMNO, 1000, "Symbol Table Full") ; SMAKEBE(SYMIDA, SYM) ;
01000 GROW(NUMBER, NUMBIDA, DUMMY, 1000, NULL) ; MAKEBE(NUMBIDA, NUMBER) ;
01100 IF XSYMNO≥2↑13 THEN WARN(NULL,"Symbol Table Enormopotamus. I give up.") ;
01200 FOR SYMBOL ← XSYMNO-999 THRU XSYMNO DO SYM[SYMBOL] ← NULL ;
01300 DUMMY←XSYMNO+1; SAT(SYM,DUMMY); SYMBOL ← XSYMNO - 999 ; RETURN(FALSE) ;
01400 END
01500 ELSE RETURN(FULSTR(SYM[SYMBOL])) ;
01600 END "SYMLOOK" ;
01700
01800 INTERNAL INTEGER SIMPLE PROCEDURE SYMNUM(STRING NAME) ;
01900 BEGIN comment looks up a symbol, and if not there, enters it. returns subscript;
02000 IF ¬SYMLOOK(NAME) THEN ENTERSYM(NAME, 0) ;
02100 RETURN(SYMBOL) ;
02200 END "SYMNUM" ;
02300
02400 INTERNAL BOOLEAN SIMPLE PROCEDURE SIMLOOK(STRING NAME) ;
02500 comment, SIMilar to SYMLOOK, but sets SYMTYPE and SYMIX ;
02600 IF SYMLOOK(NAME) THEN
02700 BEGIN
02800 BYTEWD ← NUMBER[SYMBOL] ;
02900 SYMTYPE ← LDB(TYPEWD(BYTEWD)) ; SYMIX ← LDB(IXWD(BYTEWD)) ;
03000 RETURN(TRUE) ;
03100 END
03200 ELSE RETURN(FALSE) ;
03300
03400 INTERNAL INTEGER SIMPLE PROCEDURE SIMNUM(STRING NAME) ;
03500 BEGIN comment, SIMilar to SYMNUM, but uses SIMLOOK instead of SYMLOOK ;
03600 IF ¬SIMLOOK(NAME) THEN ENTERSYM(NAME, SYMTYPE←SYMIX←0) ;
03700 RETURN(SYMBOL) ;
03800 END "SIMNUM" ;
03900
04000 INTERNAL INTEGER SIMPLE PROCEDURE WRITEON(BOOLEAN BINARY; STRING FILENAME) ;
04100 BEGIN
04200 INTEGER CH ;
04300 CH ← GETCHAN ; K ← 0 ; OPEN(CH, "DSK", IF BINARY THEN 8 ELSE 0, 0, 2, DUMMY, DUMMY, K) ;
04400 ENTER(CH, FILENAME, DUMMY) ; RETURN(CH) ;
04500 END "WRITEON" ;
00100 INTEGER SIMPLE PROCEDURE LOG2(INTEGER BINARY) ;
00200 BEGIN INTEGER I ; I ← 0 ;
00300 WHILE BINARY > 1 DO BEGIN I ← I + 1 ; BINARY ← BINARY DIV 2 END ;
00400 RETURN(I) ;
00500 END "LOG2" ;
00600
00700 INTEGER SVSHED ; comment, value of SHED before Alphabetizing began ;
00800 BOOLEAN SIMPLE PROCEDURE STRLSS(INTEGER XI, YI) ;
00900 BEGIN
01000 INTEGER XL, YL, MINL, L ; STRING X, Y ;
01100 X ← SSTK[SVSHED + XI] ; Y ← SSTK[SVSHED + YI] ;
01200 XL ← LENGTH(X) ; YL ← LENGTH(Y) ; MINL ← XL MIN YL ;
01300 START_CODE "STRCOM"
01400 LABEL NEXC, SAME, DIFF ;
01500 MOVE 2, X ; MOVE 3, Y ; SKIPN 4, MINL ; JRST SAME ;
01600 NEXC: ILDB 5, 2 ; LDB 5, UPCAS5 ; ILDB 6, 3 ; LDB 6, UPCAS6 ;
01700 CAME 5, 6 ; JRST DIFF ; SOJG 4, NEXC ;
01800 SAME: COMMENT SAME FOR FIRST MINL CHARACTERS ;
01900 MOVE 5, XL ; MOVE 6, YL ; CAME 5, 6 ; JRST DIFF ;
02000 COMMENT AND SAME LENGTH: ; MOVE 5, XI ; MOVE 6, YI ;
02100 DIFF: CAML 5, 6 ; TDZA 1,1 ; MOVEI 1, -1 ; MOVEM 1, L ;
02200 END ;
02300 RETURN(L) ;
02400 END "STRLSS" ;
02500
02600 PROCEDURE QUICKERSORT(INTEGER J, BASE) ;
02700 BEGIN comment, Ascending SORT for ALFIZE ;
02800 INTEGER I, K, Q, M, P, T, X ; INTEGER ARRAY UT,LT[1:LOG2(J+2)+1] ;
02900 COMMENT Algorithm 271 (R. S. Scowen) CACM 8,11 (Nov. 1965) pp 669-670 ;
03000 DEFINE A(L) = "ITBL[BASE+L]" ;
03100 LABEL N, L, MM, PP ;
03200 I ← M ← 1 ;
03300 N: IF J-I > 1 THEN
03400 BEGIN
03500 P ← (J+I) DIV 2 ; T ← A(P) ; A(P) ← A(I) ; Q ← J ;
03600 FOR K ← I + 1 THRU Q DO
03700 BEGIN
03800 IF STRLSS(T, A(K)) THEN
03900 BEGIN
04000 FOR Q ← Q DOWN K DO
04100 BEGIN
04200 IF STRLSS(A(Q), T) THEN
04300 BEGIN
04400 A(K) ↔ A(Q) ; Q ← Q - 1 ;
04500 GO TO L ;
04600 END ;
04700 END ;
04800 Q ← K - 1 ;
04900 GO TO MM ;
05000 END ;
05100 L:
05200 END ;
05300 MM:
05400 A(I) ← A(Q) ; A(Q) ← T ;
05500 IF Q+Q > I+J THEN BEGIN LT[M]←I; UT[M]←Q-1; I←Q+1 END
05600 ELSE BEGIN LT[M]←Q+1; UT[M]←J; J←Q-1 END ;
05700 M ← M + 1 ;
05800 GO TO N ;
05900 END
06000 ELSE IF I≥J THEN GO TO PP
06100 ELSE BEGIN
06200 IF STRLSS(A(J),A(I)) THEN A(I)↔A(J) ;
06300 PP: M ← M - 1 ;
06400 IF M > 0 THEN BEGIN I←LT[M]; J←UT[M]; GO TO N END ;
06500 END ;
06600 END "QUICKERSORT" ;
00100 INTERNAL SIMPLE PROCEDURE DAPART ; IF ON THEN
00200 BEGIN
00300 DBREAK ; IF GROUPM=0 THEN RETURN ;
00400 GLINEM←0 ; IF MOLESIDA THEN DPB(0,BELOWM(OLX)) ; GROUPM←0 ;
00500 END "DAPART" ;
00600
00700 INTERNAL SIMPLE PROCEDURE MAKEPAGE(INTEGER HIGH, WIDE) ;
00800 BEGIN
00900 IDASSIGN("FRAMEIDA←CREATE(0,PFREC)", THISFRAME) ;
01000 HIGHF ← HIGH; WIDEF ← WIDE;
01100 END "MAKEPAGE" ;
01200
01300 INTERNAL SIMPLE PROCEDURE MAKEAREA(INTEGER ITSIX) ;
01400 BEGIN
01500 INTEGER C, L, CS, LS, NCH, OCH ;
01600 IF FULWIDE(ITSIX) THEN
01700 BEGIN Comment Make frame width ;
01800 OCH ← CHARCT(ITSIX) ; CHARCT(ITSIX) ← NCH ← IF FRAMEIDA THEN WIDEF ELSE FWIDE ;
01900 COLWID(ITSIX) ← (COLWID(ITSIX) * NCH) DIV OCH ;
02000 END ;
02100 IF FULHIGH(ITSIX) THEN LINECT(ITSIX) ← IF FRAMEIDA THEN HIGHF ELSE FHIGH ;
02200 L←OPEN_ACTIVE(ITSIX)←CREATE(0, AREC) ;
02300 IF NULLAREAS THEN BEGIN IDASSIGN(AREAIDA←NULLAREAS,THISAREA) ; INA←LHRH(L,INA) END ;
02400 IDASSIGN(AREAIDA ← L, THISAREA) ;
02500 DEFA ← ITSIX ; STATA ← 0 ; INA ← LHRH(0, NULLAREAS) ; NULLAREAS ← AREAIDA ;
02600 IDASSIGN("AAA←CREATE2(1, CS←COLCT(ITSIX)*2, 0, LS←LINECT(ITSIX)+((LINECT(ITSIX) DIV 2) MAX 8) ) ", AA) ;
02700 RKJ INCREASED LS ABOVE TO MAKE ROOM FOR XGENLINES;
02800 ZEROWORDS(CS*(LS+1), AA[1,0]) ;
02900 COMMENT FOR C ← 1 THRU CS DO FOR L ← 0 THRU LS DO AA[C,L] ← 0 ;
03000 END "MAKEAREA" ;
03100
03200 FORWARD RECURSIVE PROCEDURE ASSUREAREA; CMU: HAD TO ADD THIS TOO;
03300
03400 INTERNAL SIMPLE PROCEDURE SEND(INTEGER PORTIX; STRING MESSAGE) ;
03500 BEGIN
03600 INTEGER CH ;
03700 IF 0≤ (CH ← PORCH(PORTIX)) THEN OUT(CH,MESSAGE)
03800 CMU: ADDED CALL TO ASSUREAREA ON NEXT LINE;
03900 ELSE IF CH=-1 THEN BEGIN ASSUREAREA; CH←FOOTSTR(AREAIXM); SSTK[CH]←SSTK[CH]&MESSAGE END
04000 ELSE WARN(NULL,"Can't send to a passed PORTION:"&MESSAGE) ;
04100 END "SEND" ;
04200
04300 INTERNAL RECURSIVE PROCEDURE STATEMENT ;
04400 BEGIN
04500 INTEGER LVL ; BOOLEAN VALID ;
04600 LVL ← BLNMS ;
04700 DO VALID ← CHUNK(VALID) UNTIL BLNMS≤LVL ;
04800 END "STATEMENT" ;
00100 STRING SIMPLE PROCEDURE ALFIZE(STRING FILENAME, LEFTRIGHT) ;
00200 BEGIN
00300 INTEGER SVIHIGH, SVSHIGH, CHAN, LEFT, RIGHT, N, I, K ; STRING S, KEY ;
00400 INTEGER SAVW,SAVD; RKJ;
00500 SVSHED ← SHED ; SVIHIGH ← IHIGH ; SVSHIGH ← SHIGH ;
00600 IF (CHAN←GETCHAN)<0 THEN RETURN(WARN(NULL,"No Channel to Alphabetize "&FILENAME)) ;
00700 EOF ← 0 ; OPEN(CHAN, "DSK", 0, 2, 2, 150, BRC, EOF) ;
00800 LOOKUP(CHAN, FILENAME, FLAG) ; IF FLAG THEN RETURN(WARN("=","No Generated file "&FILENAME)) ;
00900 SETBREAK(LOCAL_TABLE, LEFTRIGHT&LF, NULL, "IS") ; LEFT ← LOP(LEFTRIGHT) ; RIGHT ← LOP(LEFTRIGHT) ; N ← 0 ;
01000 GETFORMAT(SAVW,SAVD); SETFORMAT(-4,0); RKJ;
01100 DO BEGIN "SENDEE"
01200 S ← INPUT(CHAN, TO_TB_FF_SKIP) ; IF EOF THEN DONE ; S ← S & TB ;
01300 DO S ← S & INPUT(CHAN, LOCAL_TABLE) UNTIL BRC=LEFT ∨ BRC=LF ∨ EOF ;
01400 IF BRC = LEFT THEN
01500 BEGIN "KEY"
01600 KEY ← NULL ; S ← S & LEFT ;
01700 DO KEY ← KEY & INPUT(CHAN, LOCAL_TABLE) UNTIL BRC=RIGHT OR BRC=LF OR EOF ;
01800 PUSHS(1, CAPITALIZE(KEY)&0&CVS(N)) ; comment, Sort Key in SSTK ;
01900 S ← S & KEY ;
02000 IF BRC = RIGHT THEN
02100 BEGIN
02200 S ← S & RIGHT ;
02300 DO S ← S & INPUT(CHAN, LOCAL_TABLE) UNTIL BRC = LF OR EOF ;
02400 END ;
02500 END "KEY" ;
02600 PUTS(S&LF) ; comment, complete entry in STBL ;
02700 N ← N + 1 ; PUTI(1, N) ; comment, Sort Tags in ITBL ;
02800 END "SENDEE"
02900 UNTIL EOF ;
03000 SETFORMAT(SAVW,SAVD);
03100 QUICKERSORT(N, SVIHIGH) ;
03200 CLOSIN(CHAN) ; FILENAME ← FILENAME[1 TO ∞-1] & "Z" ;
03300 ENTER(CHAN, FILENAME, FLAG) ; comment, "---.PUZ" ;
03400 IF FLAG THEN RETURN(WARN(NULL,"ENTER failed for Alphabetized File "&FILENAME)) ;
03500 FOR I ← 1 THRU N DO OUT(CHAN, STBL[SVSHIGH + ITBL[SVIHIGH + I]]) ;
03600 RELEASE(CHAN) ; SHED ← SVSHED ; IHIGH ← SVIHIGH ; SHIGH ← SVSHIGH ; RETURN(FILENAME) ;
03700 END "ALFIZE" ;
03800
03900 INTERNAL SIMPLE PROCEDURE RECEIVE(INTEGER PORTIX; STRING ALPHABETIZE) ;
04000 BEGIN
04100 INTEGER CH ; STRING FIL ; LABEL TWICE ;
04200 CASE (CH ← PORCH(PORTIX)) + 6 MIN 6 OF
04300 BEGIN
04400 ie -6 ; GO TO TWICE ;
04500 ie -5 Only INSERTed ; IMPOSSIBLE("RECEIVE") ;
04600 ie -4 ; TWICE: WARN(NULL,"Already RECEIVEd generated file for this PORTION") ;
04700 ie -3 ; BEGIN "GENFILE"
04800 FIL ← CVSTR(PORFIL(PORTIX)) & ".PUG" ;
04900 IF FULSTR(ALPHABETIZE) THEN BEGIN FIL←ALFIZE(FIL,ALPHABETIZE) ; PORCH(PORTIX)←-6 END
05000 ELSE PORCH(PORTIX) ← -4 ;
05100 SWICHF(FIL) ; PAGESCAN(LAST) ← -PAGESCAN(LAST) ;
05200 END "GENFILE" ;
05300 ie -2 Never SENT ; BEGIN END ;
05400 ie -1 ; BEGIN CH←FOOTSTR(AREAIXM); SWICH(SSTK[CH],-1,0); SSTK[CH]←NULL END ;
05500 ie 0-15 ; IMPOSSIBLE("RECEIVE") ;
05600 END ;
05700 END "RECEIVE" ;
00100 INTERNAL SIMPLE PROCEDURE PLACE(INTEGER NEWAREAIX) ;
00200 COMMENT If No Place Area, AREAIXM=0. AREAIDA≠0 if STATUS= 0 or 1 ;
00300 IF ON THEN
00400 BEGIN
00500 INTEGER FRM, ALLOW_FOR, MARGIX ;
00600 IF IXTYPE(NEWAREAIX)≠AREATYPE THEN
00700 BEGIN WARN("=","PLACE in non-area"); NEWAREAIX←IXTEXT END;
00800 IF AREAIDA ∧ STATUS=1 THEN
00900 BEGIN
01000 COLA ← COL ; AA[COL,0] ← LHRH(COVERED,LINE) ; AA[PAL,0]←LHRH(COVERED,PINE) ; STATA←STATUS ;
01100 XGENA ← XGENLINES; RKJ;
01200 IF AREAIXM=NEWAREAIX THEN RETURN
01300 ELSE IF COL>COLS THEN BEGIN WARN("=","Can't PLACE inside footnotes!") ; RETURN END ;
01400 END ;
01500 AREAIXM←NEWAREAIX ;
01600 IF (AREAIDA ← OPEN_ACTIVE(AREAIXM)) = 0 THEN MAKEAREA(AREAIXM)
01700 ELSE BEGIN MAKEBE(AREAIDA, THISAREA) ; IDASSIGN(AAA, AA) ; END ;
01800 IF (MARGIX ← MARGINS(AREAIXM)) = 0 THEN BEGIN LMARG ← 0 ; RMARG ← COLWID(AREAIXM) END
01900 ELSE BEGIN LMARG ← LMARGX(MARGIX) ; RMARG ← RMARGX(MARGIX) END ;
02000 ALLOW_FOR ← 2 * COLWID(AREAIXM) ;
02100 IF ALLOW_FOR > LENGTH(OWL) THEN OWL ← OWL&SPS(ALLOW_FOR - LENGTH(OWL)) ;
02200 COLS ← COLCT(AREAIXM) ; LINES ← LINECT(AREAIXM) ; STATUS ← STATA ;
02300 IF STATUS=1 THEN
02400 BEGIN "IT'S OPEN"
02500 COL ← COLA ; PAL ← (COL+COLS-1) MOD (2*COLS) + 1 ; ie, Leg↔Foot;
02600 LINE ← AA[COL,0] ; COVERED ← LH(LINE) ; LINE ← RH(LINE) ; PINE ← RH("AA[PAL,0]") ;
02700 XGENLINES ← XGENA; RKJ;
02800 END "IT'S OPEN"
02900 ELSE COL←PAL←LINE←COVERED←PINE←XGENLINES←0 ; RKJ ADDED XGENLINES;
03000 END "PLACE" ;
03100
03200 INTERNAL SIMPLE PROCEDURE TURN(INTEGER CHR,FUN,ONOFF) ;
03300 BEGIN
03400 INTEGER CODE, X, M, STDCHR ; BOOLEAN HADCHR, DEFD ; LABEL FIN ;
03500 DEFD ← FALSE ; CODE ← LDB(SPCODE(CHR)) ; STDCHR ← LDB(SPCHAR(FUN)) ;
03600 IF ¬CODE THEN HADCHR ← FALSE
03700 ELSE IF CODE=FUN ∧ ONOFF ∧ STDCHR THEN GO TO FIN COMMENT ALREADY ON ;
03800 ELSE IF ¬ONOFF ∨ ¬STDCHR THEN
03900 BEGIN COMMENT REMOVE CHARACTER FROM BREAK TABLE STRING ;
04000 HADCHR ← TRUE ; X ← LENGTH(TEXT_BRC) ;
04100 START_CODE "FINDIT"
04200 LABEL NEXC, DUN ;
04300 MOVE 1, TEXT_BRC ; SKIPN 2, X ; JRST DUN ;
04400 NEXC: ILDB 3,1 ; CAMN 3, CHR ; JRST DUN ; SOJG 2, NEXC ;
04500 DUN: MOVEM 2, M ;
04600 END ;
04700 TEXT_BRC ← TEXT_BRC[1 TO X-M] & TEXT_BRC[X-M+2 TO X] ;
04800 END ;
04900 IF ONOFF ∧ STDCHR THEN
05000 BEGIN "ON"
05100 IF STDCHR < LBRACK THEN TEXT_BRC ← TEXT_BRC & CHR ;
05200 IF FUN="{" THEN
05300 BEGIN
05400 IF DEFN_BRC≠"⎇" THEN LOPP(DEFN_BRC) ; DEFD ← TRUE ;
05500 IF CHR ≠ "⎇" THEN DEFN_BRC ← CHR & DEFN_BRC ; EPSCHAR ← CHR ;
05600 END ;
05700 DPB(STDCHR, SPCODE(CHR)) ;
05800 END "ON"
05900 ELSE BEGIN "OFF"
06000 IF CODE=2 THEN BEGIN EPSCHAR←-1; IF DEFN_BRC≠"⎇" THEN BEGIN DEFD←TRUE; LOPP(DEFN_BRC) END END ;
06100 CMU CHANGE: STANFORD 176 CHAR WENT TO CMU 175;
06200 IF HADCHR THEN DPB(0, SPCODE(CHR)) ;
06300 END "OFF" ;
06400 SETBREAK(TEXT_TBL, TEXT_BRC&SIG_BRC, NULL, "IS") ;
06500 IF DEFD THEN SETBREAK(DEFN_TABLE, DEFN_BRC, NULL, "IS") ;
06600 FIN:
06700 IF ONOFF ≤ 0 THEN ISTK[PUSHI(TURNWDS, TURNTYPE) - 1] ←
06800 CHR LSH 7 LOR CHARSP[CODE FOR 1] ;
06900 END "TURN" ;
00100 INTERNAL SIMPLE PROCEDURE BEGINBLOCK(BOOLEAN MIDPGPH; INTEGER ECASE ; STRING NAME) ;
00200 BEGIN
00300 INTEGER MIX, I, X ;
00400 IF ECASE = 0 THEN STARTS ← STARTS + 1 comment START...END ;
00500 ELSE IF ECASE=-1 THEN ENDCASE←1 comment, ONCE merging with BEGIN ;
00600 ELSE BEGIN "NOT CLUMP"
00700 DBREAK ; DEPTH ← DEPTH + 1 ; MIX ← PUSHI(MODEWDS, MODETYPE) ;
00800 ARRBLT(ISTK[MIX-MODEWDS], BREAKM, MODEWDS) ;
00900 PUSHI(28, TABTYPE) ; I ← 0 ;
01000 DO ISTK[MIX←MIX+1] ← X ← TABSORT[I←I+1] UNTIL X=2↑33 ;
01100 ISTK[MIX+1] ← ISTK[IHED] ; IHED ← MIX + 1 ;
01200 IF MIDPGPH THEN
01300 BEGIN "SAVE FILL PARAMS"
01400 X ← MIDWDS + 1 ; PUSHI(X, MIDTYPE) ;
01500 ILBF ← CVASC(LBF) ; ARRBLT(ISTK[IHED-X], THISTYPE, X-1) ;
01600 ISTK[IHED-1]←PUSHS(1, THISWD) ; NOPGPH ← TRUE ; PLBL←BRKPLBL←-(2↑13) ;
01700 END "SAVE FILL PARAMS" ;
01800 ENDCASE ← ECASE ; STARTS ← 0 ;
01900 END "NOT CLUMP" ;
02000 IF NAME ≠ ALTMODE THEN BLKNAMES[BLNMS←BLNMS+1] ← NAME ; comment not for ONCE! ;
02100 END "BEGINBLOCK" ;
02200
02300 INTERNAL BOOLEAN SIMPLE PROCEDURE FINDINSET(INTEGER HM) ;
02400 BEGIN
02500 INTEGER ARE ;
02600 LLSCAN(LEADRESPS, NEXT_RESP, "(ARE ← CLUE(LLTHIS)) ≥ HM" ) ;
02700 RETURN(LLTHIS ∧ ARE = HM) ;
02800 END "FINDINSET" ;
02900
03000 INTERNAL INTEGER SIMPLE PROCEDURE FINDSIGNAL(INTEGER SIGASC) ;
03100 BEGIN
03200 INTEGER CHR ;
03300 CHR ← SIGASC LSH -29 ;
03400 LLSCAN(SIGNALD[CHR], NEXT_RESP, "SIGASC = SIGNAL(LLTHIS)" ) ;
03500 RETURN(LLTHIS) ;
03600 END "FINDSIGNAL" ;
03700
03800 INTERNAL INTEGER SIMPLE PROCEDURE FINDTRAN(INTEGER UASYMB, VARI) ;
03900 BEGIN
04000 LLSCAN(WAITRESP, NEXT_RESP, "CLUE(LLTHIS) = UASYMB ∧ (VARI=0 ∨ VARIETY(LLTHIS)=VARI)" ) ;
04100 RETURN(LLTHIS) ;
04200 END "FINDTRAN" ;
04300
04400 INTERNAL SIMPLE PROCEDURE COMPMAXIMS ;
04500 BEGIN
04600 FMAXIM ← (RMARG-RIGHTIM)-LMARG ;
04700 NMAXIM ← COLWID(IF AREAIXM THEN AREAIXM ELSE IXTEXT)-LMARG ;
04800 MAXIM ← IF FILL THEN FMAXIM ELSE NMAXIM ;
04900 END ;
05000
05100 INTERNAL SIMPLE PROCEDURE BIND(INTEGER LOC, NEWIX) ;
05200 BEGIN
05300 IF LOC = SYMTEXT THEN IXTEXT ← NEWIX
05400 ELSE IF LOC = SYMPAGE THEN BEGIN IXPAGE ← NEWIX ; PATPAGE ← PATT_STRS(IXPAGE) END ;
05500 DPB(NEWIX, IXN(LOC)) ; IF LDB(TYPEN(LOC)) ≥ 11 THEN DPB(LOC, BIXNUM(NEWIX)) ;
05600 END "BIND" ;
00100 INTERNAL RECURSIVE BOOLEAN PROCEDURE ENDBLOCK ;
00200 IF BLNMS<0 ∧ LAST>2 THEN BEGIN WARN("=","Extra END ignored"); BLNMS←0; RETURN(FALSE) END ELSE
00300 BEGIN
00400 INTEGER TYP, OLD, MIX, I, X, L1, L2, PASSED, NARROWED ; STRING S ;
00500 DBREAK ; NARROWED ← PASSED ← FALSE ;
00600 DO COMMENT Skip through ISTK restoring former state and terminating INDENT etc. ;
00700 BEGIN "ISTK ENTRY"
00800 TYP ← IXTYPE(IHED) ;
00900 CASE TYP - 12 OF
01000 BEGIN COMMENT BY TYPE ;
01100 [AREATYPE-12] IF ¬DISD(IHED) THEN BEGIN CLOSEAREA(IHED,TRUE) ; NUMBER[LDB(BIXNUM(IHED))]←0 END;
01200 [UNITTYPE-12] IF ¬DISD(IHED) THEN BEGIN CLOSEUNIT(IHED,TRUE) ; NUMBER[LDB(BIXNUM(IHED))]←0 END;
01300 [MACROTYPE-12] NUMBER[LDB(BIXNUM(IHED))] ← 0 ;
01400 [RESPTYPE-12] BEGIN "POP RESP"
01500 X ← CLUE(IHED) ; I ← VARIETY(IHED) ; OLD ← OLD_RESP(IHED) ;
01600 CASE I MIN 3 OF
01700 BEGIN "BY VARIETY"
01800 ie 0 ... Phrase ;
01900 BEGIN
02000 S ← SSTK[X] ; L1 ← LOP(S) ; L2 ← LOP(S) ;
02100 LLSCAN("PHRASED[L1,L2]", NEXT_RESP, LLTHIS=IHED) ;
02200 IF LLTHIS THEN
02300 IF ¬OLD THEN LLSKIP("PHRASED[L1,L2]", NEXT_RESP)
02400 ELSE BEGIN
02500 NEXT_RESP(OLD) ← LLPOST ;
02600 IF LLPREV<0 THEN PHRASED[L1,L2]←OLD ELSE NEXT_RESP(LLPREV) ← OLD;
02700 END ;
02800 END ;
02900 ie 1 ... Inset ;
03000 IF FINDINSET(X) THEN
03100 IF ¬OLD THEN LLSKIP(LEADRESPS, NEXT_RESP)
03200 ELSE BEGIN
03300 NEXT_RESP(OLD) ← LLPOST ;
03400 IF LLPREV<0 THEN LEADRESPS←OLD ELSE NEXT_RESP(LLPREV) ← OLD ;
03500 END ;
03600 ie 2 ... Signal ;
03700 BEGIN
03800 X ← SIGNAL(IHED) ; L1 ← X LSH -29 ;
03900 IF FINDSIGNAL(X) THEN
04000 IF ¬OLD THEN BEGIN
04100 S ← NULL ;
04200 WHILE FULSTR(SIG_BRC) ∧ (L2←LOP(SIG_BRC))≠L1 DO S←S&L2;
04300 SIG_BRC ← S & SIG_BRC ;
04400 END
04500 ELSE BEGIN
04600 NEXT_RESP(OLD) ← LLPOST ;
04700 IF LLPREV<0 THEN SIGNALD[L1]←OLD ELSE NEXT_RESP(LLPREV) ← OLD ;
04800 END ;
04900 END ;
00100 ie 3, 4 ... After, Before ;
00200 IF FINDTRAN(X,I) THEN
00300 IF ¬OLD THEN LLSKIP(WAITRESP, NEXT_RESP)
00400 ELSE BEGIN
00500 NEXT_RESP(OLD) ← LLPOST ;
00600 IF LLPREV<0 THEN WAITRESP←OLD ELSE NEXT_RESP(LLPREV) ← OLD ;
00700 END ;
00800 END "BY VARIETY" ;
00900 END "POP RESP" ;
01000 [MARGTYPE-12] IF OLD←AREAX(IHED) THEN
01100 BEGIN NARROWED ← TRUE ; MARGINS(OLD) ← X ← OLD_MARGX(IHED) ;
01200 LMARG ← IF X THEN LMARGX(X) ELSE 0 ;
01300 RMARG ← IF X THEN RMARGX(X) ELSE COLWID(OLD) ;
01400 END ;
01500 [TURNTYPE-12] IF (OLD←ISTK[IHED-1])≥0 THEN TURN(OLD LSH -7 , OLD LAND '177 , 1 ) ;
01600 [MODETYPE-12] BEGIN
01700 I ← GROUPM ; OLD ← AREAIXM ;
01800 ARRBLT(BREAKM, ISTK[IHED-MODEWDS], MODEWDS) ; OLD ↔ AREAIXM ;
01900 SAT(SSTK, SHED) ;
02000 IF I ∧ ¬GROUPM THEN DAPART ;
02100 IF ¬PASSED ∧ NARROWED THEN NOPGPH ← 1 ;
02200 JUSTIFY ← FILL ∧ ADJUST ∨ JUSTJUST ;
02300 PLACE(IF OLD THEN OLD ELSE IXTEXT);
02400 COMPMAXIMS ;
02500 END ;
02600 [NUMTYPE-12] BEGIN
02700 OLD ← OLD_NUMBER(IHED) ;
02800 NUMBER[X ← LDB(SYMBOLWD(OLD))] ← OLD ;
02900 IF X = SYMPAGE THEN BEGIN IXPAGE ← LDB(IXN(X)) ; PATPAGE ← PATT_STRS(IXPAGE) END
03000 ELSE IF X = SYMTEXT THEN IXTEXT ← LDB(IXN(X)) ;
03100 END ;
03200 [TABTYPE-12] BEGIN
03300 MIX ← IXOLD(IHED) ; I ← 0 ;
03400 DO TABSORT[I←I+1] ← X ← ISTK[MIX←MIX+1] UNTIL X=2↑33 ;
03500 END ;
03600 [MIDTYPE-12] BEGIN
03700 IF LENGTH(INPUTSTR)>1 THEN WARN("Imbalance","Unbalanced Response|Footnote! "&SOMEINPUT) ;
03800 THISWD←SSTK[ISTK[IHED-1]] ; OLD←PLBL ;
03900 ARRBLT(THISTYPE,ISTK[X←IXOLD(IHED)+1],IHED-X-1) ;
04000 LBF ← CVSTR(ILBF) ;
04100 WHILE FULSTR(LBF) ∧ LBF[∞ FOR 1]=0 DO LBF←LBF[1 TO ∞-1] ;
04200 IF OLD ≠ -2↑13 THEN
04300 BEGIN COMMENT UNDEFINED PAGE LABELS -- PASS UP TO OUTER BLOCK ;
04400 X ← OLD ;
04500 DO BEGIN L1←X ; X←IF X<0 THEN NUMBER[-X] ELSE ITBL[X] END UNTIL X=-2↑13 ;
04600 IF L1<0 THEN NUMBER[-L1] ← PLBL ELSE ITBL[L1] ← PLBL ;
04700 PLBL ← OLD ;
04800 END ;
04900 INPUTSTR←NULL ; IF THATISFULL THEN RDENTITY ELSE INPUTSTR←SWICHBACK ; PASSED←TRUE ;
05000 END
05100 END ; COMMENT BY TYPE ;
05200 IHED ← IXOLD(IHED) ;
05300 END "ISTK ENTRY"
05400 UNTIL TYP=MODETYPE ∨ IHED=0 ;
05500 DEPTH ← DEPTH - 1 ;
05600 RETURN(PASSED) ;
05700 END "ENDBLOCK" ;
00100 RECURSIVE PROCEDURE TOEND ;
00200 BEGIN
00300 BOOLEAN VALID ;
00400 VALID ← TRUE ;
00500 DO VALID ← CHUNK(VALID) UNTIL MYEND ;
00600 MYEND ← FALSE ;
00700 END "TOEND" ;
00800
00900 INTERNAL SIMPLE PROCEDURE ANYEND(BOOLEAN CHECK) ;
01000 BEGIN
01100 STRING BLOCKNAME ;
01200 BLOCKNAME ← IF BLNMS<0 THEN "!MISSING!" ELSE BLKNAMES[BLNMS] ;
01300 BLNMS ← (BLNMS MAX 0) - 1 ;
01400 IF CHECK ∧ THATISCON THEN
01500 BEGIN
01600 PASS ;
01700 LOPP(THISWD) ;
01800 IF ¬ITSV(BLOCKNAME) THEN WARN("Mismatched BEGIN-END","BEGIN """&BLOCKNAME&""" but END """&THISWD&"""") ;
01900 END
02000 ELSE IF FULSTR(BLOCKNAME) THEN WARN("Mismatched BEGIN-END","BEGIN """&BLOCKNAME&""" but END <blank>") ;
02100 END "ANYEND" ;
02200
02300 INTERNAL RECURSIVE PROCEDURE BEGINEND ;
02400 BEGIN ANYEND(TRUE) ; IF ENDBLOCK THEN WARN("=","Missed END in Response|Footnote") ELSE PASS END ;
02500
02600 INTERNAL RECURSIVE PROCEDURE ONCEEND ;
02700 IF ENDBLOCK THEN WARN("=","Missing END in Response|Footnote") ELSE BEGINEND ;
02800
02900 INTERNAL RECURSIVE PROCEDURE STARTEND ;
03000 BEGIN ANYEND(TRUE) ; STARTS ← STARTS - 1 ; PASS ; END ;
03100
03200 INTERNAL RECURSIVE PROCEDURE RESPOND(INTEGER IX) ;
03300 IF ON THEN
03400 BEGIN
03500 INTEGER ARGS ; STRING COM_ENT ;
03600 ARGS ← IF VARIETY(IX) = 2 THEN NUMARGS(IX) ELSE 0 ;
03700 IF VARIETY(IX) < 3 ∧ IX ≠ SIGNALD[FF] THEN
03800 BEGIN "AT"
03900 SWICH(IF IX=SIGNALD[CR] THEN SSTK[BODY(IX)] ELSE ALTMODE&SSTK[BODY(IX)]&"⎇", -1, ARGS) ;
04000 CMU CHANGE: STANFORD 176 CHAR WENT TO CMU 175;
04100 RETURN ;
04200 END "AT" ;
04300 GENSYM←GENSYM+1 ; COM_ENT ← "!?@"&CVS(GENSYM) ;
04400 BEGINBLOCK( TRUE, 3 , COM_ENT ) ;
04500 SWICH(SSTK[BODY(IX)]&(CRLF&TB&TB&"END """)&COM_ENT&""";;", -1, ARGS) ;
04600 PASS ; TOEND ;
04700 END "RESPOND" ;
04800
04900 INTERNAL RECURSIVE PROCEDURE RESPEND ;
05000 BEGIN ANYEND(TRUE) ; PASS ; IF ENDBLOCK THEN MYEND←TRUE ELSE WARN("=","Extra END") ; END ;
00100 INTERNAL SIMPLE PROCEDURE OPENFRAME ;
00200 BEGIN
00300 MAKEPAGE(FHIGH,FWIDE);
00400 OLXX ← OLMAX ; comment Total of all areas now declared ; OLX ← 0 ;
00500 IDASSIGN("OWLSF←OWLSIDA←CREATE(0,OLXX)", OWLS);
00510 IDASSIGN("MOLESF←MOLESIDA←CREATE(0,OLXX)", MOLES);
00520 IDASSIGN("SHORTF←SHORTIDA←CREATE(0,OLXX)", SHORT);
00600 END "OPENFRAME" ;
00700
00800 INTERNAL SIMPLE PROCEDURE OPENPAGE ;
00900 DO BEGIN OPENFRAME ; IDASSIGN(OLDPGIDA ← FRAMEIDA, OLDPAGE) ;
01000 PAGEVAL ← PATT_VAL(PATPAGE) ;
01100 IF FINDTRAN(SYMPAGE, 4) THEN RESPOND(LLTHIS) ;
01200 END UNTIL FRAMEIDA ;
01300
01400 SIMPLE PROCEDURE REMNULLS ;
01500 BEGIN
01600 INTEGER L, R, I ;
01700 L ← LH(INA) ; R ← RH(INA) ;
01800 IF L ∨ R THEN
01900 BEGIN
02000 I ← AREAIDA ;
02100 IF L THEN BEGIN IDASSIGN(AREAIDA←L,THISAREA); DPB(R, H2(INA)) ; END ELSE NULLAREAS ← R ;
02200 IF R THEN BEGIN IDASSIGN(AREAIDA←R,THISAREA); DPB(L, H1(INA)) ; END ;
02300 IDASSIGN(AREAIDA ← I, THISAREA) ;
02400 END
02500 ELSE NULLAREAS ← 0 ;
02600 END "REMNULLS" ;
02700
02800 INTERNAL RECURSIVE PROCEDURE OPENAREA(INTEGER ITSIX) ;
02900 BEGIN
03000 INTEGER X, PREV, NEX ;
03100 IF FRAMEIDA=0 THEN OPENPAGE ; PLACE(ITSIX) ; IF STATUS=1 THEN RETURN ; REMNULLS ;
03200 INA ← FRAMEIDA ;
03300 PREV ← 0 ; NEX ← ARF ; X ← AREAIDA ; COMMENT KEEP AREAS SORTED BY LEFT EDGE ;
03400 IF CHAR1(ITSIX) > 1 THEN WHILE NEX DO
03500 BEGIN
03600 IDASSIGN(AREAIDA←NEX, THISAREA) ;
03700 IF DEFA THEN IF CHAR1("DEFA") ≥ CHAR1(ITSIX) THEN DONE ELSE BEGIN END
03800 ELSE BEGIN IDASSIGN(AAA,AA) ; IF AA[1,0]≥CHAR1(ITSIX) THEN DONE ; END ;
03900 PREV ← AREAIDA ; NEX ← ARA ;
04000 END ;
04100 IF PREV THEN ARA ← X ELSE ARF ← X ;
04200 IDASSIGN(AREAIDA←X, THISAREA) ; ARA ← NEX ;
04300 STATA ← STATUS←1 ; COL ← 1 ; PAL ← COLS + 1 ;
04400 IF FINDTRAN(LDB(BIXNUM(ITSIX)), 4) THEN RESPOND(LLTHIS) ; comment BEFORE areaname ... ;
04500 END "OPENAREA" ;
00100 INTERNAL RECURSIVE PROCEDURE CLOSET(INTEGER ITSIX; BOOLEAN CLOSEIT, DISDECLAREIT) ;
00200 BEGIN
00300 IF DISDECLAREIT THEN DBREAK ;
00400 IF FINDTRAN(LDB(BIXNUM(ITSIX)), 3) THEN
00500 IF CLOSEIT ∧ ITSIX≠IXPAGE ∧ comment AFTER ;
00600 (IXTYPE(ITSIX)=AREATYPE ∨ FULSTR("CTR_VAL(""PATT_STRS(ITSIX)"")")) THEN RESPOND(LLTHIS) ;
00700 IF DISDECLAREIT THEN DISD(ITSIX) ← -1 ;
00800 END "CLOSET" ;
00900
01000 INTERNAL RECURSIVE PROCEDURE CLOSEAREA(INTEGER ITSIX; BOOLEAN DISDECLAREIT) ;
01100 BEGIN
01200 INTEGER SAVAR, C, WC, NC, CC, LEFC ; BOOLEAN NORESP ;
01300 NORESP ← ITSIX < 0 ; ITSIX ← ABS(ITSIX) ;
01400 IF DISDECLAREIT THEN OLMAX ← OLMAX - LINECT(ITSIX)*COLCT(ITSIX) ;
01500 IF OPEN_ACTIVE(ITSIX) = 0 THEN IF DISDECLAREIT THEN CLOSET(ITSIX, FALSE, TRUE)
01600 ELSE BEGIN END
01700 ELSE BEGIN SAVAR←AREAIXM; PLACE(ITSIX); IF STATUS=0 THEN REMNULLS ; STATA ← STATUS←2;
01800 ULLA ← LINE1(ITSIX) ; AA[1,0] ← LEFC ← CHAR1(ITSIX) ;
01900 IF (NC ← COLCT(ITSIX)) > 1 THEN
02000 BEGIN
02100 WC ← COLWID(ITSIX) ; CC ← CHARCT(ITSIX) ;
02200 FOR C ← 2 THRU NC DO AA[C,0] ← LEFC + ((C-1)*(CC-WC)) DIV (NC-1) ;
02300 END ;
02400 LINECA ← LINECT(ITSIX) ; COLCA ← NC ;
02500 IF ¬NORESP THEN CLOSET(ITSIX, TRUE, DISDECLAREIT) ;
02600 IF DISDECLAREIT THEN BEGIN STATA ← STATUS←3 ; DEFA ← 0 END ;
02700 OPEN_ACTIVE(ITSIX) ← AREAIDA ← 0 ;
02800 IF SAVAR ∧ ¬DISDECLAREIT ∧ SAVAR ≠ ITSIX THEN PLACE(SAVAR) ELSE BEGIN AREAIXM←0; STATUS←-1 END ;
02900 END ;
03000 END "CLOSEAREA" ;
03100
03200 INTERNAL RECURSIVE PROCEDURE CLOSEUNIT(INTEGER ITSIX; BOOLEAN DISDECLAREIT) ;
03300 BEGIN
03400 INTEGER STRS, PP ;
03500 CLOSET(ITSIX, TRUE, DISDECLAREIT) ;
03600 IF DISDECLAREIT THEN
03700 BEGIN
03800 IF (PP ← PARENT(ITSIX)) THEN
03900 BEGIN
04000 LLSCAN("SON(PP)", BROTHER, LLTHIS=ITSIX) ;
04100 LLSKIP("SON(PP) ", BROTHER) ;
04200 END ;
04300 STRS ← PATT_STRS(ITSIX) ;
04400 PATT_VAL(STRS)←PREFIX(STRS)←INFIX(STRS)←SUFFIX(STRS)←CTR_VAL(STRS)←NULL ;
04500 IF STRS=SHED THEN SHED←SHED-5 ;
04600 END ;
04700 END "CLOSEUNIT" ;
00100 INTERNAL SIMPLE PROCEDURE DISDECLARE(INTEGER SYMB, OLDTYPE, OLDIX) ;
00200 IF ON THEN
00300 CASE OLDTYPE OF
00400 BEGIN
00500 [LOCALTYPE] BEGIN SSTK[OLDIX]←NULL; IF IX=SHED THEN SHED←SHED-1 END ;
00600 [INTERNTYPE] WARN("=",SYM[SYMB]&" Redeclared") ;
00700 [AREATYPE] CLOSEAREA(OLDIX,TRUE);
00800 [UNITTYPE] CLOSEUNIT(OLDIX,TRUE) ;
00900 [14]
01000 END ;
01100
01200 INTERNAL INTEGER SIMPLE PROCEDURE DECLARE(INTEGER LOC, NEWTYPE) ;
01300 IF ON THEN
01400 BEGIN
01500 INTEGER NEWDEPTH, OLDDEPTH ; LABEL PURGE ;
01600 BYTEWD ← NUMBER[LOC] ;
01700 NEWDEPTH ← CASE NEWTYPE OF (0,1,DEPTH,0,DEPTH,0,0,0,0,0,1,DEPTH,DEPTH,DEPTH,DEPTH) ;
01800 IF LOC = SYMTEXT ∧ NEWTYPE ≠ AREATYPE ∨ LOC = SYMPAGE ∧ NEWTYPE ≠ UNITTYPE THEN
01900 BEGIN
02000 WARN("=",SYM[LOC] & " may only be type " & (IF LOC=SYMTEXT THEN "AREA" ELSE "UNIT")) ;
02100 GO TO PURGE ;
02200 END ;
02300 IF LDB(TYPEWD(BYTEWD)) THEN
02400 IF (OLDDEPTH ← LDB(DEPTHWD(BYTEWD))) < 1 THEN
02500 BEGIN
02600 WARN("=","YOU MAY NOT REDECLARE RESERVED WORD " & SYM[LOC]) ;
02700 PURGE: LOC ← SYMNUM("(Purged)" & SYM[LOC]) ;
02800 END
02900 ELSE IF OLDDEPTH < NEWDEPTH THEN
03000 BEGIN
03100 PUSHI(NUMWDS, NUMTYPE) ;
03200 OLD_NUMBER(IHED) ← BYTEWD ;
03300 END
03400 ELSE IF OLDDEPTH = 1 THEN
03500 BEGIN
03600 WARN("=","YOU MAY NOT REDECLARE" & SYM[LOC] & ", A GLOBAL VARIABLE OR PORTION") ;
03700 GO TO PURGE ;
03800 END
03900 ELSE IF OLDDEPTH=NEWDEPTH THEN
04000 DISDECLARE(LOC, LDB(TYPEWD(BYTEWD)), LDB(IXWD(BYTEWD)))
04100 ELSE WARN("=","GLOBAL " & SYM[LOC] & " REDECLARING LOCAL") ;
04200 NUMBER[LOC] ← (NEWDEPTH ROT -5) LOR (LOC LSH 18) LOR (NEWTYPE LSH 14) ;
04300 RETURN(LOC) ;
04400 END "DECLARE" ;
00100 RKJ START;
00200 PROCEDURE READKSET(BOOLEAN ITISA); COMMENT READS KSET WIDTHS;
00300 BEGIN "READKSET"
00400 INTEGER CHAN,TEMP,ZILCH,KST,EOF;
00500 STRING FILE;
00600 FILE ← IF ITISA THEN AKSET ELSE BKSET;
00700 KST ← IF ITISA THEN 0 ELSE 128;
00800 OPEN(CHAN←GETCHAN,"DSK",'14,2,0,0,ZILCH,EOF);
00900 LOOKUP(CHAN,FILE,TEMP);
01000 IF TEMP THEN
01100 BEGIN "TRYKS00"
01200 CVFIL(FILE,ZILCH,TEMP);
01300 IF NOT TEMP THEN FILE←FILE&"[A730KS00]";
01400 LOOKUP(CHAN,FILE,TEMP);
01500 END "TRYKS00";
01600
01700 IF TEMP THEN WARN("=","FILE "&FILE&" NOT FOUND")
01800 ELSE COMMENT READ THE FILE;
01900 BEGIN "READIT"
02000 COMMENT FOR TEMP←KST THRU 127+KST DO CW[TEMP] ← 0;
02100 WORDIN(CHAN); WORDIN(CHAN);
02200 WHILE NOT EOF DO
02300 IF (WORDIN(CHAN) LAND 1) THEN BEGIN TEMP ← (WORDIN(CHAN) + KST) LAND '377; CW[TEMP] ← WORDIN(CHAN); END;
02400 END "READIT";
02500 RELEASE(CHAN);
02550 IF ITISA THEN CHARW←CW['177]; COMMENT SET AVERAGE CHAR WIDTH FOR JUSTIFY;
02600 END "READKSET";
02700 RKJ END;
00100 INTERNAL STRING SIMPLE PROCEDURE VASSIGN(INTEGER VSYMB, VTYPE, VIX; STRING VAL) ;
00200 BEGIN comment, NAME←VAL ;
00300 SIMPLE PROCEDURE RDONLY(STRING IV) ; WARN("=","The value of "&IV&" is read-only") ;
00400 IF ON THEN CASE VTYPE OF
00500 BEGIN COMMENT BY TYPE ;
00600 [0] BIND(VSYMB←DECLARE(VSYMB, GLOBALTYPE), PUTS(VAL)) ; ie Undeclared identifier ;
00700 [GLOBALTYPE] STBL[VIX] ← VAL ;
00800 [LOCALTYPE] SSTK[VIX] ← VAL ;
00900 [INTERNTYPE] CASE VIX OF
01000 BEGIN COMMENT INTERNAL ;
01100 ie 0 ... LINES ; RDONLY("LINES") ;
01200 ie 1 ... COLUMNS; RDONLY("COLUMNS") ;
01300 ie 2 ... ! ; ! ← VAL ;
01400 ie 3 ... SPREAD ; SPREADM ← CVD(VAL) ;
01500 ie 4 ... FILLING; RDONLY("FILLING") ;
01600 ie 5 ... _SKIP_ ; MANUS_SKIP_ ← CVD(VAL) ;
01700 ie 6 ... _SKIPL_; DPB(CVD(VAL), H1(MANUS_SKIP_)) ;
01800 ie 7 ... _SKIPR_; DPB(CVD(VAL), H2(MANUS_SKIP_)) ;
01900 ie 8 ... NULL ; RDONLY("NULL") ;
02000 ie 9 ... ∞ ; RDONLY("∞") ;
02100 ie 10... FOOTSEP; FOOTSEP ← VAL ;
02200 ie 11... TRUE ; RDONLY("TRUE") ;
02300 ie 12... FALSE ; RDONLY("FALSE") ;
02400 ie 13... INDENT1; FIRSTIM ← CVD(VAL) ;
02500 ie 14... INDENT2; RESTIM ← CVD(VAL) ;
02600 ie 15... INDENT3; BEGIN RIGHTIM ← CVD(VAL) ; COMPMAXIMS END ;
02700 ie 16... LMARG ; BEGIN LMARG ← CVD(VAL) MAX 0 MIN
02800 COLWID(IF AREAIXM THEN AREAIXM ELSE IXTEXT)-1 ; COMPMAXIMS END ;
02900 ie 17... RMARG ; BEGIN RMARG ← CVD(VAL) MAX 1 MIN
03000 COLWID(IF AREAIXM THEN AREAIXM ELSE IXTEXT) ; COMPMAXIMS END ;
03100 ie 18... CHAR ; RDONLY("CHAR") ;
03200 ie 19... CHARS ; RDONLY("CHARS") ;
03300 ie 20... LINE ; RDONLY("LINE") ;
03400 ie 21... COLUMN ; RDONLY("COLUMN") ;
03500 ie 22... TOPLINE; RDONLY("TOPLINE") ;
03600 RKJ START;
03700 ie 23... XLINESIZE; BEGIN XLINESIZE←VAL; XMAXIM←CVD(VAL); END;
03800 ie 24... AKSET ; BEGIN AKSET←VAL; READKSET(TRUE); END;
03900 ie 25... BKSET ; BEGIN BKSET←VAL; READKSET(FALSE); END;
04000 ie 26... XGENLINES ; XGENLINES ← CVD(VAL);
04100 ie 27... XCRIBL ; RDONLY("XCRIBL");
04200 ie 28... XKSETCON; KSETCON←CVD(VAL);
04300 RKJ END;
04350 ie 29... XSPCSMAX; XSPCSMAX←CVD(VAL); PLK: HYPHENATION SLACK;
04400 END ; COMMENT INTERNAL ;
04500 [MANTYPE] WARN("Improper use of `←'","← after reserved word "&SYM[VSYMB]&" -- assignment ignored") ;
04600 [PORTYPE] WARN("=","← after PORTION NAME "&SYM[VSYMB]) ;
04700 [PUNITTYPE] PATT_VAL("PATT_STRS(VIX)") ← VAL ;
04800 [AREATYPE] WARN("=","← after Area NAME "&SYM[VSYMB]) ;
04900 [UNITTYPE] CTR_VAL("PATT_STRS(VIX)") ← VAL
05000 END ; COMMENT BY TYPE ;
05100 RETURN(VAL) ;
05200 END "VASSIGN" ;
05300
05400 INTERNAL SIMPLE PROCEDURE ASSIGN(STRING NAME, VAL) ;
05500 VASSIGN(SIMNUM(NAME), 0, SYMIX, VAL) ;
05600
05700 SIMPLE PROCEDURE NOPORTION ;
05800 BEGIN
05900 STRING IFIL ; INTEGER PIX ;
06000 WARN("=","No PORTION Declaration Found") ;
06100 IFIL ← "PUI"&CVS(INTERS←INTERS+1) ; THISPORT ← PIX ← PUTI(4, -2) ;
06200 PORINT(PIX) ← CVASC(IFIL) ; PORSEQ(SEQPORT) ← PIX ; PORSEQ(SEQPORT←PIX) ← 0 ;
06300 PORTS ← PORTS + 1 ; INTER ← WRITEON(TRUE, IFIL & ".PUI") ; SINTER ← WRITEON(FALSE, IFIL & "S.PUI") ;
06400 END "NOPORTION" ;
00100 STRING SIMPLE PROCEDURE CVALF(INTEGER ALFABET, VAL) ;
00200 BEGIN COMMENT handles 1aAiI conversions ;
00300 STRING S, A ; INTEGER I ;
00400 PRELOAD_WITH NULL, "i", "ii", "iii", "iv", "v", "vi", "vii", "viii", "ix",
00500 NULL, "x", "xx", "xxx", "xl", "l", "lx", "lxx", "lxxx", "xc",
00600 NULL, "c", "cc", "ccc", "cd", "d", "dc", "dcc", "dccc", "cm" ;
00700 OWN STRING ARRAY LOWROMAN[0:2, 0:9] ;
00800 PRELOAD_WITH NULL, "I", "II", "III", "IV", "V", "VI", "VII", "VIII", "IX",
00900 NULL, "X", "XX", "XXX", "XL", "L", "LX", "LXX", "LXXX", "XC",
01000 NULL, "C", "CC", "CCC", "CD", "D", "DC", "DCC", "DCCC", "CM" ;
01100 OWN STRING ARRAY UPROMAN[0:2, 0:9] ;
01200 DEFINE BEG = "WHILE VAL DO BEGIN", OOPS = "WARN(""="",""I only know roman numerals upto 1000, sorry"")" ;
01300 IF VAL = 0 THEN RETURN("0") ;
01400 IF VAL<0 THEN BEGIN S ← "-" ; VAL ← ABS(VAL) END ELSE S ← NULL ;
01500 A ← NULL ; I ← -1 ;
01600 CASE ALFABET - 1 OF
01700 BEGIN
01800 ie 1 ... "1" ; A ← CVS(VAL) ;
01900 ie 2 ... "i" ; IF VAL < 1000 THEN BEG A ← LOWROMAN[I←I+1, VAL MOD 10]&A ;
02000 VAL← VAL DIV 10 END ELSE OOPS ;
02100 ie 3 ... "I" ; IF VAL < 1000 THEN BEG A ← UPROMAN[I←I+1, VAL MOD 10]&A ;
02200 VAL← VAL DIV 10 END ELSE OOPS ;
02300 ie 4 ... "a" ; BEG A ← ("a" + (VAL-1) MOD 26)&A ; VAL ← VAL DIV 26 END ;
02400 ie 5 ... "A" ; BEG A ← ("A" + (VAL-1) MOD 26)&A ; VAL ← VAL DIV 26 END ;
02500 END ;
02600 RETURN(S & A) ;
02700 END "CVALF" ;
02800
02900 INTEGER SIMPLE PROCEDURE CHRSALF(INTEGER INT, ALFABET) ;
03000 BEGIN
03100 INTEGER LABS, LSIGN ; STRING STR ; PRELOAD_WITH [2]3,2,[5]1,[2]0 ; OWN INTEGER ARRAY L[0:9] ;
03200 LSIGN ← IF INT < 0 THEN 1 ELSE 0 ; INT ← ABS(INT) ; STR ← CVS(INT) ;
03300 CASE ALFABET DIV 2 OF
03400 BEGIN
03500 ie 1 ... "1" ; LABS ← LENGTH(STR) ;
03600 ie 2 ... i,I ; LABS ← 4*LENGTH(STR) - L[STR-"0"] ; comment, Believe-it-or-Not ;
03700 ie 3 ... a,A ; LABS ← LENGTH(CVALF(ALFABET, INT)) ;
03800 END ;
03900 RETURN(LABS + LSIGN) ;
04000 END "CHRSALF" ;
04100
04200 SIMPLE PROCEDURE FIXFRAME(INTEGER FRIDA) ;
04300 BEGIN
04400 IF AREAIDA ∧ STATUS=1 THEN PLACE(AREAIXM) ; COMMENT BE SURE LINE,PINE STORED IN AA ;
04500 MOLES[0] ← OLX ;
04600 IDASSIGN(FRAMEIDA ← FRIDA, THISFRAME) ;
04700 IDASSIGN("OWLSIDA ← OWLSF", OWLS) ;
04710 IDASSIGN("MOLESIDA ← MOLESF", MOLES) ;
04720 IDASSIGN("SHORTIDA ← SHORTF", SHORT) ;
04800 OLX ← MOLES[0] ; AREAIDA ← 0 ;
04900 END "FIXFRAME" ;
00100 INTERNAL SIMPLE PROCEDURE FINPAGE ;
00200 BEGIN COMMENT ***T EMPO RA RY V ERS I ON -- No Boxes **** ;
00300 INTEGER A, CS, LS, C, L, X, LB, LBPAGE, LINK, LINENO, FOOTLINE1, F, OWLINE ;
00400 INTEGER NULINE, NUPINE, NUINE, NLFOOT, NPFOOT, NFOOT, NAREA ;
00500 IF EXNEXTPAGE THEN BEGIN WARN("=","Response to PAGE change called NEXT PAGE again.") ; RETURN END ;
00600 EXNEXTPAGE ← TRUE ;
00700 BEGIN "PAGEOUT"
00800 COMMENT PASS 1 OUTPUT FORMAT FOR EACH PAGE :
00900 Height Width
01000 For each area:
01100 UpperLine NumCols NumLines
01200 For each column:
01300 LeftChar
01400 For each non-null line: LineNo SHORTM Index of PUInS.PUI line
01500 0
01600 -10
01700 ;
01800 IF OLDPGIDA ≠ FRAMEIDA THEN BEGIN WARN("=","FRAME≠PAGE at end of page"); FIXFRAME(OLDPGIDA) END ;
01900 IF AREAIDA ∧ AREAIXM ∧ STATUS=1 THEN CLOSEAREA(AREAIXM, FALSE) ;
02000 IF (A ← ARF) THEN
02100 BEGIN "NONEMPTY"
02200 INTEGER ARRAY XTRALINES[1:HIGHF]; RKJ TO FIXUP "TOPLINES" OF AREAS;
02300 IF INTER ≤ 0 THEN NOPORTION ;
02400 RKJ START;
02500 LS←0;
02600 WHILE A DO BEGIN "COLLECTXGENS"
02700 IDASSIGN(AREAIDA←A, THISAREA) ; A ← ARA ; IDASSIGN(AAA, AA) ;
02800 IF STATA THEN LS ← LS + (XTRALINES[ULLA MAX 1] ← XGENA);
02900 END "COLLECTXGENS";
03000 A←ARF;
03100 RKJ END;
03200 WORDOUT(INTER, HIGHF+LS) ; WORDOUT(INTER, WIDEF) ;
03300 WHILE A DO BEGIN "AFTER AREA RESPONSES"
03400 IDASSIGN(AREAIDA←A, THISAREA) ; A ← ARA ; IDASSIGN(AAA, AA) ;
03500 IF (X ← DEFA) ∧ STATA=1 ∧ FINDTRAN(LDB(BIXNUM(X)), 3) THEN RESPOND(LLTHIS) ;
03600 END "AFTER AREA RESPONSES" ;
03700 A ← ARF ;
03800 WHILE A DO BEGIN "CLOSE ALL AREAS"
03900 IDASSIGN(AREAIDA←A, THISAREA) ; A ← ARA ; IDASSIGN(AAA, AA) ;
04000 IF STATA = 1 THEN CLOSEAREA(-DEFA, FALSE) ;
04100 END "CLOSE ALL AREAS" ;
04200 A ← ARF ;
04300 WHILE A DO
04400 BEGIN "AREAOUT"
04500 IDASSIGN(AREAIDA←A, THISAREA) ; NAREA ← 0 ; IDASSIGN(AAA, AA) ;
00100 IF STATA > 1 THEN
00200 BEGIN "AREAUSED"
00300 IF GRPOLX ∧ (STATUS←STATA)=2 ∧ (X ← DEFA) THEN
00400 BEGIN COMMENT SET UP GROUP OVERFLOW INFO ;
00500 FIXFRAME(NEWPGIDA) ; OPENAREA(X) ; NAREA ← AREAIDA ;
00600 IDASSIGN(AAA, NAA) ; NLFOOT←NPFOOT←NULINE←NUPINE←0 ;
00700 FIXFRAME(OLDPGIDA) ; IDASSIGN(AREAIDA←A, THISAREA) ;
00800 IDASSIGN(AAA, AA) ;
00900 END ;
01000 CS ← COLCA ; LS ← LINECA + XGENA ; RKJ ADDED XGENA;
01100 F←0; RKJ;
01200 FOR C←1 THRU ULLA-1 DO F←F+XTRALINES[C]; RKJ SEE IF ANY AREAS ABOVE THIS ONE HAVE "XTRALINES";
01300 WORDOUT(INTER, ULLA+F) ; RKJ ADDED F; WORDOUT(INTER, CS) ; WORDOUT(INTER, LS) ;
01400 FOR C ← 1 THRU CS DO
01500 BEGIN "AREACOL" WORDOUT(INTER, AA[C,0]) ; FOOTLINE1 ← LS - RH("AA[CS+C,0]") ;
01600 FOR F ← 0, CS DO FOR L ← 1 THRU LS DO IF (X ← AA[F+C, L]) THEN
01700 IF GRPOLX = 0 ∨ X < GRPOLX ∨ X > GRPTOP THEN
01800 BEGIN "AREALINE" LINENO ← IF F=0 THEN L ELSE FOOTLINE1 + L ;
01900 IF (LB ← LDB(LABELM(X))) THEN
02000 BEGIN "A PAGE LABEL"
02100 LBPAGE ← 2 ROT -2 LOR PUTS(PAGEVAL&(IF XCRIBL THEN ALTMODE&CVS(XLENGTH(PAGEVAL)) ELSE NULL)) ;
02200 WHILE LB ≠ -(2↑13) DO
02300 IF (LINK ← LB) < 0 THEN
02400 BEGIN
02500 LB←NUMBER[-LINK] ;
02600 NUMBER[-LINK] ← LBPAGE ;
02700 END
02800 ELSE BEGIN LB←ITBL[LINK] ; ITBL[LINK]←LBPAGE END ;
02900 END "A PAGE LABEL" ;
03000 IF OWLINE ← OWLS[X] THEN BEGIN WORDOUT(INTER, LINENO) ;
03100 WORDOUT(INTER, SHORT[X]) ; WORDOUT(INTER, OWLINE) END ;
03200 END "AREALINE"
03300 ELSE BEGIN "GRP OVERFLOW"
03400 NUINE ← IF F THEN NUPINE ← NUPINE + 1 ELSE NULINE ← NULINE + 1 ;
03500 NFOOT ← IF LDB(FOOTM(X)) = 0 THEN 0
03600 ELSE IF F THEN NPFOOT←NPFOOT+1 ELSE NLFOOT←NLFOOT+1 ;
03700 NAA[F+1, NUINE] ← NOLX ← NOLX + 1 ; NOWLS[NOLX] ← OWLS[X] ;
03800 IF NFOOT THEN DPB(NFOOT, FOOTM(X)) ; NMOLES[NOLX] ← MOLES[X] ;
03850 NSHORT[NOLX] ← SHORT[X] ;
03900 END "GRP OVERFLOW" ;
04000 WORDOUT(INTER, 0) ;
04100 END "AREACOL" ;
04200 END "AREAUSED" ;
04300 A ← ARA ;
04400 GOAWAY(WHATIS(AA)) ; GOAWAY(AREAIDA) ;
04500 IF NAREA THEN
04600 BEGIN
04700 NAA[1, 0] ← NULINE ; NAA[CS+1, 0] ← NUPINE ;
04800 IDASSIGN(AREAIDA←NAREA, THISAREA) ; COLA ← 1 ; AREAIDA ← 0 ;
04900 END ;
05000 END "AREAOUT" ;
05100 WORDOUT(INTER, -10) ;
05200 END "NONEMPTY" ;
05300 GOAWAY(MOLESIDA) ; GOAWAY(SHORTIDA) ; GOAWAY(-1 LSH 18 + OWLSIDA) ;
05310 MOLESIDA ← SHORTIDA ← OWLSIDA ← GROUPM ← GLINEM ← 0 ;
05400 GOAWAY(FRAMEIDA) ; FRAMEIDA ← OLDPGIDA ← AREAIDA ← 0 ; STATUS ← -1 ;
05500 END "PAGEOUT" ;
05600 IF GRPOLX THEN GRPOLX ← 0 ;
05700 EXNEXTPAGE ← FALSE ;
05800 END "FINPAGE" ;
00100 INTERNAL RECURSIVE PROCEDURE USTEP(INTEGER USYMB, UIX) ;
00200 BEGIN "USTEP"
00300 INTEGER PS, PARIX, PARTYPE, SONIX, SONPS, IVAL, SVTY, SVIX, SVSY, SVTHAT ;
00400 INTEGER I;
00500 STRING PARVAL, CVAL, PVAL, SVWD ;
00600 IF UIX>0 ∧ ¬IN_LINE(UIX) THEN DBREAK ;
00700 IF UIX>0 ∧ FULSTR("CTR_VAL(""PATT_STRS(UIX)"")") ∧ FINDTRAN(USYMB, 3) THEN RESPOND(LLTHIS) ;
00800 IF UIX = IXPAGE AND OLDPGIDA
00900 THEN RKJ MADD THIS A COMPOUND FOR FIGURES;
01000 BEGIN
01100 FINPAGE; RKJ THIS WAS THE ONLY THEN ACTION BEFORE;
01200 IF FIGS[1] THEN COMMENT WE HAVE FIGURES TO DO;
01300 BEGIN "DOFIGS"
01400 PLACE(IXTEXT);
01500 ASSUREAREA;
01600 IF FIGS[1]>LINES THEN
01700 BEGIN
01800 WARN("=","Figure too large, full page assumed.");
01900 FIGS[1]←LINES;
02000 END;
02100 WHILE FIGS[1] AND LINE+FIGS[1] ≤ LINES DO
02200 BEGIN
02300 LINE←LINE+FIGS[1];
02400 FOR I←2 THRU MAXFIGS DO
02500 IF NOT (FIGS[I-1]←FIGS[I]) THEN DONE;
02600 END;
02700 END "DOFIGS";
02800 END
02900 ELSE UIX←ABS(UIX);
03000 PS ← PATT_STRS(UIX) ; CVAL ← CTR_VAL(PS) ;
03100 CTR_VAL(PS) ← CVAL ←
03200 CVS(IVAL←IF NULSTR(CVAL) THEN CTR_INIT(UIX)-2↑14 ELSE CVD(CVAL)+CTR_STEP(UIX)-2↑6) ;
03300 PARVAL ← IF PATT_PARENT(UIX) ∧ (PARIX ← PARENT(UIX)) THEN
03400 EVALV("(a parent unit)", PARIX, PUNITTYPE) ELSE NULL ;
03500 IF PATT_ALF(UIX) THEN
03600 PVAL ← ! ← PREFIX(PS)&PARVAL&INFIX(PS)&CVALF(PATT_ALF(UIX),IVAL)&SUFFIX(PS)
03700 ELSE BEGIN
03800 SVTY←THISTYPE ; SVIX←IX ; SVSY←SYMB ; SVWD←THISWD ; SVTHAT←THATISFULL ;
03900 SWICH(PREFIX(PS), -1, 0) ; PASS ; PVAL ← E(NULL, NULL) ;
04000 PASS ; IF ITS(;) THEN PASS ;
04100 IF ¬ITS(!!!) THEN WARN("=","Unbalanced COUNT Template") ;
04200 SWICHBACK ;
04300 THISTYPE←SVTY ; IX←SVIX ; SYMB←SVSY ; THISWD←SVWD ;
04400 IF SVTHAT THEN RDENTITY ELSE EMPTYTHAT;
04500 END ;
04600 IF LENGTH(CVAL) > CTR_CHRS(UIX) THEN
04700 BEGIN
04800 WARN("Counter underestimated","Underestimated counter "&SYM[USYMB]&" -- reached "&CVAL) ;
04900 CTR_CHRS(UIX) ← LENGTH(CVAL) ;
05000 END ;
05100 IF LENGTH(PVAL) > PATT_CHRS(UIX) THEN
05200 BEGIN
05300 IF PATT_STRS(UIX) THEN WARN("Pattern underestimate",
05400 "Underestimated unit "&SYM[USYMB]&": -- reached "&PVAL) ;
05500 PATT_CHRS(UIX) ← LENGTH(PVAL) ;
05600 END ;
05700 PATT_VAL(PS) ← PVAL ; SONIX ← SON(UIX) ;
05800 WHILE SONIX > 0 DO
05900 BEGIN
06000 SONPS ← PATT_STRS(SONIX) ;
06100 IF SONIX≠IXPAGE ∧ FULSTR("CTR_VAL(SONPS)") ∧ FINDTRAN(LDB(BIXNUM(SONIX)),3) THEN RESPOND(LLTHIS) ;
06200 CTR_VAL(SONPS) ← PATT_VAL(SONPS) ← NULL ;
06300 IF SONIX = IXPAGE THEN USTEP(SYMPAGE, SONIX ← -SONIX) ;
06400 DO SONIX ← IF SONIX>0 ∧ (K←SON(SONIX)) THEN K ELSE IF (K←BROTHER(ABS SONIX)) THEN K
06500 ELSE -PARENT(ABS SONIX) UNTIL SONIX>0 ∨ SONIX=-UIX ;
06600 END ;
06700 IF UIX ≠ IXPAGE ∧ FINDTRAN(USYMB, 4) THEN RESPOND(LLTHIS) ;
06800 IF UIX = IXPAGE THEN PAGEVAL ← PATT_VAL(PATPAGE) ;
06900 ! ← PVAL ; C! ← CVAL ; comment RESPOND or USTEP(..PAGE..) might have changed it ;
07000 END "USTEP" ;
07100
07200 INTERNAL SIMPLE PROCEDURE NEXTPAGE ;
07300 BEGIN
07400 INTEGER SAVEAREA ;
07500 SAVEAREA ← IF AREAIXM THEN LDB(BIXNUM(AREAIXM)) ELSE SYMTEXT ;
07600 USTEP(SYMPAGE, IXPAGE) ;
07700 PLACE(LDB(IXN(SAVEAREA))) ;
07800 END ;
07900
08000 SIMPLE PROCEDURE OWT(STRING C) ;
08100 BEGIN
08200 IF NULSTR(C) THEN BEGIN OWLS[OLX] ← 0 ; RETURN END ;
08300 IF INTER ≤ 0 THEN NOPORTION ;
08400 OWLS[OLX] ← OWLSEQ ← OWLSEQ + 1 ;
08500 OUT(SINTER, CVSR(OWLSEQ) & C) ;
08600 END "OWT" ;
00100 INTERNAL PROCEDURE CREUNIT(INTEGER INLINE, PFROM, PTO, PBY, PIN;
00200 STRING PPRINTING; INTEGER USYMB) ;
00300 BEGIN
00400 INTEGER TEMP, LENPAT, PARENTCHARS, POSNALF, POSN!, PS, ALF, UIX, PINIX, PINPS, PCHARS ;
00500 STRING S!, SPAR, SPAR! ;
00600 USYMB ← DECLARE(USYMB, UNITTYPE) ; TEMP ← DECLARE(SYMNUM(SYM[USYMB]&"!"), PUNITTYPE) ;
00700 UIX ← PUSHI(UNITWDS, UNITTYPE) ; PS ← PUSHS(5, NULL) ; PATT_STRS(UIX) ← PS ;
00800 BIND(USYMB, UIX) ; DPB(UIX, IXN(TEMP)) ;
00900 CTR_INIT(UIX) ← PFROM + 2↑14 ; CTR_STEP(UIX) ← PBY + 2↑6 ; IN_LINE(UIX) ← INLINE ;
01000 PINIX ← IF PIN THEN LDB(IXN(PIN)) ELSE 0 ; PARENT(UIX) ← PINIX ;
01100 IF PIN = 0 THEN PARENTCHARS ← PINPS ← 0
01200 ELSE IF LDB(TYPEN(PIN)) = UNITTYPE THEN
01300 BEGIN
01400 PARENTCHARS ← PATT_CHRS(PINIX) ; PINPS ← PATT_STRS(PINIX) ;
01500 BROTHER(UIX) ← SON(PINIX) ; SON(PINIX) ← UIX ;
01600 END
01700 ELSE BEGIN WARN("=","Undeclared Parent Unit "&SYMB) ; PINPS ← 0 ; PARENTCHARS ← 2 END ;
01800 PCHARS ← LENGTH(CVS(PFROM)) MAX LENGTH(CVS(PTO)) ;
01900 IF FULSTR(PPRINTING) ∧ PPRINTING=0 THEN
02000 BEGIN "TEMPLATE"
02100 PREFIX(PS) ← "!←" & PPRINTING[2 TO ∞] & ";!!!;;" ;
02200 PATT_ALF(UIX) ← 0 ;
02300 IF PIN≠0 ∧ PINPS=0 THEN TEMP ← PCHARS + PARENTCHARS comment lousy guess ;
02400 ELSE BEGIN
02500 S! ← ! ; CTR_VAL(PS) ← CVS(PTO - PBY) ; CTR_CHRS(UIX)←PATT_CHRS(UIX)←1000 ;
02600 IF PINPS THEN BEGIN SPAR ← CTR_VAL(PINPS) ; SPAR! ← PATT_VAL(PINPS) ;
02700 CTR_VAL(PINPS) ← "999999"[1 TO CTR_CHRS(PINIX)] ;
02800 PATT_VAL(PINPS) ← ! ← "9999999999999999"[1 TO PARENTCHARS] ; END ;
02900 USTEP(USYMB, -UIX) ; TEMP ← LENGTH(!) ;
03000 ! ← S! ; IF PINPS THEN BEGIN CTR_VAL(PINPS) ← SPAR ; PATT_VAL(PINPS) ← SPAR! END ;
03100 END ;
03200 END "TEMPLATE"
03300 ELSE BEGIN "PATTERN"
03400 STRING PATCOPY ; LABEL FALF ; INTEGER ARRAY PCH[1:LENGTH(PPRINTING)] ;
03500 PRELOAD_WITH "1", "i", "I", "a", "A" ; OWN INTEGER ARRAY ALFS[1:5] ;
03600 PATCOPY ← PPRINTING ; LENPAT ← 0 ; WHILE FULSTR(PATCOPY) DO PCH[LENPAT←LENPAT+1]←LOP(PATCOPY) ;
03700 FOR POSNALF ← LENPAT DOWN 1 DO FOR ALF ← 1 THRU 5 DO IF ALFS[ALF]=PCH[POSNALF] THEN GO TO FALF;
03800 WARN("=","No 1, i, I, a, or A in pattern for "&SYM[SYMB]) ;
03900 POSNALF ← LENPAT + 1 ; PPRINTING ← PPRINTING & "1" ;
04000 FALF: POSN! ← POSNALF - 1 ; WHILE POSN! ∧ PCH[POSN!]≠"!" DO POSN! ← POSN! - 1 ;
04100 PATT_ALF(UIX) ← ALF ; PATT_PARENT(UIX) ← IF POSN! THEN 1 ELSE 0 ;
04200 PREFIX(PS) ← PPRINTING[1 TO POSN!-1] ; INFIX(PS) ← PPRINTING[POSN!+1 TO POSNALF-1] ;
04300 SUFFIX(PS) ← PPRINTING[POSNALF+1 TO ∞] ; PATT_VAL(PS) ← NULL ;
04400 TEMP ← LENGTH(PREFIX(PS)) + PARENTCHARS + LENGTH(INFIX(PS)) +
04500 (CHRSALF(PFROM,ALF) MAX CHRSALF(PTO,ALF)) + LENGTH(SUFFIX(PS));
04600 END "PATTERN" ;
04700 PATT_CHRS(UIX) ← TEMP ; CTR_CHRS(UIX) ← PCHARS ; PATT_VAL(PS)←CTR_VAL(PS)←NULL ;
04800 END "CREUNIT" ;
00100 RECURSIVE PROCEDURE ASSUREAREA ;
00200 IF AREAIDA = 0 ∨ STATUS ≠ 1 THEN OPENAREA(IF AREAIXM THEN AREAIXM ELSE IXTEXT) ;
00300
00400 INTERNAL INTEGER SIMPLE PROCEDURE NEWBLANK(INTEGER MOLE) ;
00500 BEGIN MOLES[OLX←OLX+1]←MOLE ; OWLS[OLX]←0 ; RETURN(OLX); END "NEWBLANK";
00600
00700 RECURSIVE BOOLEAN PROCEDURE MOVEGROUP(BOOLEAN OFFPAGE ; INTEGER TOCOL, TOLINE, EXTRA) ;
00800 BEGIN
00900 INTEGER SAVEAREA, LFOOT, PFOOT, FOOL, C, L, L1, L2, F, TC, TL, X ;
01000 IF ¬OFFPAGE THEN
01100 BEGIN TOCOL←TOCOL+1 ; IF COL≤COLS<TOCOL ∨ TOCOL>2*COLS THEN OFFPAGE←TRUE ELSE TOLINE←1 END ;
01200 IF OFFPAGE THEN
01300 BEGIN "OTHER PAGE"
01400 SAVEAREA ← IF AREAIXM THEN LDB(BIXNUM(AREAIXM)) ELSE SYMTEXT ;
01500 GRPTOP ← OLX ; GRPOLX ← GLINEM ; GLINEM ← 0 ; CLOSEAREA(AREAIXM, FALSE) ;
01600 MOLES[0]←OLX ; OPENFRAME ; IDASSIGN(NEWPGIDA←FRAMEIDA, NEWPAGE) ;
01700 IDASSIGN("MOLESF", NMOLES) ; IDASSIGN("SHORTF", NSHORT) ; SIDASSIGN("OWLSF", NOWLS) ;
01800 NOLX ← OLX ; FIXFRAME(OLDPGIDA) ;
01900 USTEP(SYMPAGE,IXPAGE) ; NMOLES[0]←NOLX ; NSHORT[0]←NOLX ;
02000 FIXFRAME(NEWPGIDA) ; IDASSIGN(OLDPGIDA←NEWPGIDA, OLDPAGE) ;
02100 F ← ARF ;
02200 WHILE F DO
02300 BEGIN
02400 IDASSIGN(AREAIDA←F, THISAREA) ; F ← ARA ;
02500 IF (X ← DEFA) THEN
02600 BEGIN OLD_ACTIVE(X)←NEW_ACTIVE(X); NEW_ACTIVE(X)←0 END ;
02700 END ;
02800 NEWPGIDA ← 0 ; OPENAREA(LDB(IXN(SAVEAREA))) ;
02900 IF TOCOL > COLS THEN COL ← COLS + 1 ;
03000 IF FINDTRAN(SYMPAGE,4) THEN RESPOND(LLTHIS) ;
03100 END "OTHER PAGE"
03200 ELSE BEGIN "SAME PAGE"
03300 GRPOLX ← GLINEM ; LFOOT ← 0 ; FOOL ← IF PAL>COL THEN PINE ELSE LINE ;
03400 PFOOT ← IF FOOL=0 THEN 0 ELSE IF LDB(FOOTM("AA[PAL MAX COL,FOOL]"))=31 THEN 30 ELSE 0;
03500 FOR C ← COL, PAL DO
03600 BEGIN
03700 L1 ← 1 ; L2 ← IF C = COL THEN LINE ELSE PINE ;
03800 TC ← IF C=COL THEN TOCOL ELSE (TOCOL+COLS-1) MOD (2*COLS) + 1 ;
03900 TL ← IF C=COL THEN TOLINE-1 ELSE RH("AA[TC,0]") ;
04000 F ← IF C ≤ COLS THEN LFOOT ELSE PFOOT ;
04100 FOR L ← L1 THRU L2 DO IF (X ← AA[C,L]) ≥ GRPOLX THEN
04200 BEGIN
04300 AA[TC, TL ← TL + 1] ← X ; AA[C, L] ← 0 ;
04400 IF LDB(FOOTM(X)) THEN DPB(F←IF F=31 THEN 1 ELSE F+1, FOOTM(X)) ;
04500 END ;
04600 IF C= COL THEN BEGIN LINE ← TL ; COL ← TC END ELSE BEGIN PINE ← TL ; PAL ← TC END ;
04700 END ;
04800 GRPOLX ← 0 ;
04900 END "SAME PAGE" ;
05000 DAPART ; RETURN(TRUE) ;
05100 END "MOVEGROUP" ;
00100 INTERNAL RECURSIVE INTEGER PROCEDURE FIND_ROOM(INTEGER SOURCE,
00200 EXTRA, FROMCOL, FROMLINE, MORECOMING) ;
00300 BEGIN
00400 INTEGER WANT, LEAD, I, C, L, SAVEAREA, KOLS ; LABEL FOUND, TRYHERE ;
00500 ASSUREAREA ;
00600 IF SOURCE≤0 THEN BEGIN WANT←EXTRA ; LEAD←-SOURCE END ELSE BEGIN WANT←1; LEAD←0 END;
00700 IF WANT > LINES THEN BEGIN WARN("=","CAN'T FIT HERE"); RETURN(FALSE) END;
00800 KOLS ← IF FROMCOL > COLS THEN 2*COLS ELSE COLS ;
00900 TRYHERE:
01000 FOR C ← FROMCOL THRU KOLS DO
01100 RKJ ADDED XGNELINES ON NEXT LINE;
01200 IF (LINES-MORECOMING) - (L← IF C=FROMCOL THEN FROMLINE ELSE 0) + XGENLINES - PINE ≥
01300 (IF L THEN WANT+LEAD ELSE WANT) THEN GO TO FOUND ;
01400 IF GLINEM ∧ C≠FROMCOL ∧ MOVEGROUP(TRUE, 0,0,EXTRA) THEN BEGIN C←COL; L←LINE; GO FOUND END ;
01500 IF TEXTAR(AREAIXM) THEN BEGIN
01600 NEXTPAGE ; OPENAREA(AREAIXM) ;
01700 IF FROMCOL>COLS ∧ COL≤COLS ∨ FROMCOL≤COLS ∧ COL>COLS THEN
01800 BEGIN IF FROMCOL>COLS THEN FOOTTOP←1; RKJ; PAL ↔ COL ; LINE ↔ PINE END ;
01900 FROMCOL ← COL ; FROMLINE ← LINE; GO TO TRYHERE ; END
02000 ELSE BEGIN WARN("=","Title area overflow") ;
02100 FOR C ← 1 THRU COLS DO AA[C, 0] ← AA[COLS+C,0] ← 0 ;
02200 PAL ← (C ← COL ← 1) + COLS ; L ← 0 ;
02300 END ;
02400 FOUND:
02500 IF C=COL THEN LINE←L
02600 ELSE IF GLINEM ∧ MOVEGROUP(FALSE, C, L, EXTRA) THEN BEGIN L ← LINE ; C ← COL END
02700 ELSE BEGIN
02800 COL ← C ; PAL ← (COL+COLS-1) MOD (2*COLS) + 1 ;
02900 LINE ← L ; PINE ← RH("AA[PAL,0]") ;
03000 END ;
03100 IF OLX+WANT+LEAD > OLXX THEN GROWOWLS(WANT+LEAD+25) ;
03200 IF LINE AND LEAD THEN
03300 BEGIN
03400 FOR I ← 1 THRU LEAD DO AA[COL, LINE+I] ← NEWBLANK(IF GROUPM ∨ I>1 THEN ABV_BLW ELSE BLW) ;
03500 LINE ← LINE + LEAD ;
03600 END ;
03700 RETURN(L+1) ;
03800 END "FIND_ROOM" ;
03900
04000 INTERNAL RECURSIVE PROCEDURE TOCOLUMN(INTEGER COLNO) ; IF ON THEN
04100 BEGIN
04200 ASSUREAREA ;
04300 IF COLNO < COL ∨ (COLNO=COL ∧ LINE) THEN NEXTPAGE ;
04400 IF 1≤COLNO≤COLS THEN COL←COLNO ; LINE ← 0 ; IF COL>1 THEN OPENAREA(AREAIXM) ;
04500 END "TOCOLUMN" ;
04600
04700 INTERNAL RECURSIVE PROCEDURE TOLINE(INTEGER LINENO) ; IF ON THEN
04800 BEGIN ASSUREAREA ;
04900 IF LINENO < LINE THEN
05000 IF COL = COLS THEN
05100 BEGIN NEXTPAGE ; IF LINENO>1 THEN OPENAREA(AREAIXM) END
05200 ELSE BEGIN COL ← COL+1 ; LINE ← 0 ; END ;
05300 IF LINENO=1 THEN LINE←1 ELSE FIND_ROOM(0, 0, COL, LINENO-1, 0) ;
05400 END ;
05500
05600 INTERNAL RECURSIVE PROCEDURE SKIPLINES(INTEGER HMLINES) ; IF ON THEN
05700 BEGIN ASSUREAREA ;
05800 IF HMLINES > 0 THEN
05900 IF GROUPM=0 THEN FIND_ROOM(-HMLINES, 0, COL, LINE, 0)
06000 ELSE BEGIN "GROUP SKIP"
06100 INTEGER I ;
06200 FIND_ROOM(0, HMLINES, COL, LINE, 0) ;
06300 IF ¬GLINEM THEN GLINEM ← OLX + 1 ;
06400 FOR I ← 1 THRU HMLINES DO AA[COL, LINE+I] ←
06500 NEWBLANK(IF GLINEM=0 ∧ I=1 THEN ABV ELSE ABV_BLW) ;
06600 LINE ← LINE + HMLINES ;
06700 END "GROUP SKIP" ;
06800 END "SKIPLINES" ;
00100 INTERNAL RECURSIVE PROCEDURE PLACELINE(INTEGER CHARS,POSN,XPOSN,FAKE,
00200 ABOVE,BELOW,LEADB,FIRSTLBL,JUSTIFY,MORECOMING) ;
00300 BEGIN
00400 INTEGER NEEDS, TOPLINE, GR, ATOP, I, TOLBL, LBL, FOOTNUM, WASFRAME, WASCOL, WASOLX ; STRING COWL, XREF ;
00500 IF ¬DEBUG THEN XREF ← ALTMODE
00600 ELSE BEGIN
00700 XREF ← ERRLINE&"/"&SRCPAGE&"["&MACLINE&"]" ;
00800 FOR I ← 1 THRU MESGS DO XREF ← XREF & RUBOUT & MESSAGE[I] ;
00900 MESGS←0 ; XREF ← XREF & ALTMODE ;
01000 END ;
01100 COWL ← XREF & OWL[1 TO CHARS] & CRLF ;
01200 ASSUREAREA ;
01300 IF FOOTNUM ← FOOTTOP ∧ COL > COLS THEN
01400 BEGIN comment First Footnote belonging to a line ;
01500 GR ← GROUPM ; IF GROUPM=0 THEN GLINEM ← FOOTNUM ; GROUPM ← 1 ; FOOTTOP ← 0 ;
01600 IF ATOP ← LINE=0 THEN ABOVE ← ABOVE + 1 ; comment assure room for FOOTSEP ;
01700 END ;
01800 WHILE ¬(TOPLINE ← FIND_ROOM(-LEADB,NEEDS←ABOVE+BELOW+1,COL,LINE,MORECOMING)) DO
01900 BEGIN ABOVE←(ABOVE-1)MAX 0; BELOW←(BELOW-1)MAX 0 END;
02000 WASOLX ← OLX - (LINE + 1 - TOPLINE) ;
02100 IF FOOTNUM OR FOOTTOP AND COL > COLS THEN
02200 BEGIN "FOOT1"
02300 GROUPM ← GR ; IF GROUPM=0 THEN GLINEM ← 0 ;
02400 IF ATOP THEN BEGIN ABOVE ← ABOVE - 1 ; NEEDS ← NEEDS - 1 ; END ;
02500 IF LINE = 0 THEN BEGIN AA[COL, LINE←TOPLINE←LINE+1] ← OLX ← OLX + 1 ;
02600 OWT(XREF&FOOTSEP[1 TO COLWID(AREAIXM)]&CRLF) ; MOLES[OLX] ← BLW ; END ;
02700 END "FOOT1" ;
02800 FOR I ← 1 THRU ABOVE DO AA[COL,LINE+I] ←
02900 NEWBLANK(IF GROUPM ∨ TOPLINE<LINE+I THEN ABV_BLW ELSE BLW) ;
03000 AA[COL, LINE+ABOVE+1] ← OLX ← OLX + 1 ;
03100 OWT(COWL) ;
03200 MOLES[OLX] ← (IF GROUPM ∨ TOPLINE<LINE+ABOVE+1 THEN ABV ELSE 0) LOR (IF GROUPM OR BELOW THEN BLW ELSE 0);
03250 IF XCRIBL THEN I←MAXIM*CHARW - XPOSN ELSE I←MAXIM - (POSN-FAKE);
03300 IF JUSTIFY AND I > 0 THEN SHORT[OLX]←I ;
03400 IF FIRSTLBL≠-(2↑13) THEN
03500 BEGIN "PAGE LABELS"
03600 LBL ← PLBL ; TOLBL ← 0 ;
03700 WHILE LBL≠FIRSTLBL ∧ LBL≠-(2↑13) DO
03800 LBL ← IF (TOLBL←LBL)>0 THEN ITBL[TOLBL] ELSE NUMBER[-TOLBL] ;
03900 IF LBL=-(2↑13) THEN WARN("=","Page label not in Page Label L.L.!!!")
04000 ELSE IF TOLBL=0 THEN PLBL ← -(2↑13)
04100 ELSE IF TOLBL > 0 THEN ITBL[TOLBL] ← -(2↑13)
04200 ELSE NUMBER[-TOLBL] ← -(2↑13) ;
04300 BRKPLBL ← PLBL ;
04400 DPB(IF FIRSTLBL<0 THEN PUTI(1,FIRSTLBL) ELSE FIRSTLBL, LABELM(OLX)) ;
04500 END "PAGE LABELS" ;
04600 FOR I ← ABOVE+2 THRU NEEDS DO AA[COL,LINE+I] ← NEWBLANK(IF GROUPM ∨ I<NEEDS THEN ABV_BLW ELSE BLW) ;
04700 IF GROUPM∧¬GLINEM THEN BEGIN DPB(0,ABOVEM("GLINEM←AA[COL,IF COL>COLS THEN PINE ELSE TOPLINE]")) END;
04800 LINE ← LINE + NEEDS ;
04900 IF COL≤COLS AND FULSTR("SSTK[FOOTSTR(AREAIXM)]") THEN comment, Footnotes ;
05000 BEGIN "FOOTNOTES"
05100 WHILE (FOOTNUM←IF PINE=0 THEN 1 ELSE LDB(FOOTM("AA[PAL,PINE]")) + 1) = 31 DO
05200 BEGIN
05300 WARN("=",">30 lines in col. "&COL&" want footnotes.") ;
05400 FIND_ROOM(LINE, 1, COL+1, 0, 0) ;
05500 END ;
05600 IF FOOTNUM=32 THEN FOOTNUM ← 1 ; DPB(FOOTNUM, FOOTM(OLX)) ;
05700 SEND(IXFOOT, CRLF&TB&TB& "END ""!FOOTNOTES"";;") ;
05800 AA[COL,0] ← LHRH(COVERED, LINE) ; PINE ↔ LINE ; PAL ↔ COL ;
05900 WASCOL ← COL ; WASFRAME ← FRAMEIDA ; BEGINBLOCK(TRUE, 3, "!FOOTNOTES") ; BREAKM ← 0 ;
06000 FOOTTOP ← -1 ; WASOLX ← OLX ; RECEIVE(IXFOOT, NULL) ; PASS ; TOEND ; FOOTTOP ← 0 ;
06100 AA[COL,0] ← LHRH(COVERED, LINE) ;
06200 IF WASCOL ≠ COL ∨ WASFRAME ≠ FRAMEIDA THEN
06300 BEGIN FOOTNUM ← 31 ; IF WASFRAME=FRAMEIDA THEN DPB(31, FOOTM(WASOLX)) END ;
06400 DPB(FOOTNUM, FOOTM("AA[COL,LINE]")) ; PAL ↔ COL ; PINE ↔ LINE ;
06500 END "FOOTNOTES" ;
06600 END "PLACELINE" ;
00100 COMMENT I N I T I A L I Z A T I O N P R O C E D U R E S - - - - - - - - - - ;
00200
00300 INTERNAL SIMPLE PROCEDURE FAMILYHAS(INTEGER FAMNUM; STRING MEMBERS) ;
00400 BEGIN
00500 INTEGER SPECIE, CHAR ;
00600 SPECIE ← -1 ;
00700 WHILE FULSTR(MEMBERS) DO
00800 BEGIN
00900 DPB(FAMNUM, FAMILY("CHAR ← LOP(MEMBERS)")) ;
01000 DPB(SPECIE ← SPECIE+1, SPECIES(CHAR)) ;
01100 END ;
01200 END "FAMILYHAS" ;
01300
01400 EXTERNAL SIMPLE PROCEDURE MANUSCRIPT ;
00100 COMMENT I N I T I A L I Z E A N D G O ! ! ! ! ! ;
00200
00300 CHARW ← 16; KSETCON ← 0; RKJ;
00400
00500 ON ← TRUE ; comment only false if code is to be parsed but not executed ;
00600 SGREM(SA_PROVIDE) ; SGINS(SA_PROVIDE, SA_COLBLK[2]) ; SA_LL ← 0 ;
00700 WISTK←WHATIS(ISTK) ; WITBL←WHATIS(ITBL) ; WINEST←WHATIS(INEST) ;
00800 WSSTK←SWHATIS(SSTK) ; WSTBL←SWHATIS(STBL) ; WSNEST←SWHATIS(SNEST) ;
00900 WSYM←SWHATIS(SYM) ; WNUMBER←WHATIS(NUMBER) ; WOLDPAGE←WHATIS(OLDPAGE) ;
01000 WNEWPAGE←WHATIS(NEWPAGE) ; WTHISFRAME←WHATIS(THISFRAME);
01100 WMOLES←WHATIS(MOLES) ; WOWLS←WHATIS(OWLS) ; WNMOLES←WHATIS(NMOLES) ;
01150 WSHORT←WHATIS(SHORT) ; WNSHORT←WHATIS(NSHORT) ;
01200 WNOWLS←WHATIS(NOWLS) ; WTHISAREA←WHATIS(THISAREA) ; WWAITBOX←WHATIS(WAITBOX) ;
01300 WAVAILREC←WHATIS(AVAILREC) ; WAA←WHATIS(AA) ; WNAA←WHATIS(NAA) ;
01400 ITBLIDA ← RH("CREATE(0, ITSIZE)") ; ISTKIDA ← RH("CREATE(0, ISIZE)") ; INESTIDA ← RH("CREATE(0, SIZE)") ;
01500 STBLIDA ← RH("SCREATE(0, STSIZE)") ; SSTKIDA ← RH("SCREATE(0, SSIZE)") ; SNESTIDA ← RH("SCREATE(0, SIZE)") ;
01600 SYMIDA ← RH("SCREATE(-1, SYMNO)") ; NUMBIDA ← RH("CREATE(-1, SYMNO)") ;
01700 MAKEBE(ITBLIDA, ITBL) ; MAKEBE(ISTKIDA, ISTK) ; MAKEBE(INESTIDA, INEST) ;
01800 SMAKEBE(STBLIDA, STBL) ; SMAKEBE(SSTKIDA, SSTK) ; SMAKEBE(SNESTIDA, SNEST) ;
01900 SMAKEBE(SYMIDA, SYM) ; MAKEBE(NUMBIDA, NUMBER) ;
02000 SETSYM ; XSYMNO ← SYMNO ; comment Initialize the symbol table;
02100 LAST ← IHED ← SHED ← IHIGH ← SHIGH ← 0 ; comment Tops of Stacks;
02200 DUMMY←XSYMNO+1; SAT(SYM,DUMMY) ; SAT(STBL,SHIGH) ; SAT(SSTK, SHED) ; SAT(SNEST, LAST) ;
02300 OLDPGIDA←NEWPGIDA←FRAMEIDA←MOLESIDA←SHORTIDA←OWLSIDA←AREAIDA←WBOXIDA←STATUS←AREAIXM←0 ;
02400 DEPTH ← GENSYM ← 0 ; OLX ← -1 ; OLMAX ← 5 ; LEADRESPS ← WAITRESP ← 0 ;
02500 FOR I ← 0 STEP 1 WHILE FULSTR(MANWD[I]) DO
02600 BIND(DECLARE(SYMNUM(MANWD[I]), MANTYPE), I) ; comment reserved words ;
02700 DEPTH ← 2 ; IXCOMMENT ← LDB(IXN("SYMNUM(""""COMMENT"""")")) ;
02800 SYMTEXT ← SYMNUM("TEXT") ; IXEND←LDB(IXN("SYMNUM(""""END"""")"));
02810
02820 comment The following lines define the special characters...the codes
02830 of some of them are important...be sure you know what you're doing
02840 if you change anything! RKJ;
02900 J ← 0 ;
03000 FOR S ← CR, ALTMODE&"{", RUBOUT, "α", "β", "#", "\", "∂", "←", "→", "∞",
03100 "↑", "↓", "]", "-", ".!?", SP, "_", "π", "∪", "∩", VT, "⊗", "%",
03110 COMMENT ADD MORE HERE RKJ; "[", "&" DO
03200 BEGIN J←J+1; WHILE FULSTR(S) DO DPB(J, SPCHAR("LOP(S)")) ; END ;
03300 AMSAND←J; LBRACK←J-1; UNDERBAR←18; UARROW←12; DARROW←13;
03310 XCMDCHR←23; XNJB←6; KSETSWAP←24;
03320
03600 FOR S ← SP, TB, FF, VT, CR, LF, 0 DO CHARTBL[S] ← CHARTBL[S] LOR 2↑6 ;
03700 CHARSP ← CR & ALTMODE & RUBOUT & "αβ#\∂←→∞↑↓]-? _π∪∩" & VT & "⊗%[&" ;
03800 FOR J ← 0 THRU 127 DO BEGIN DPB(MISCQ, FAMILY(J)) ; DPB(0, SPECIES(J)) END ;
03900 FAMILYHAS(LETTQ, "ABCDEFGHIJKLMNOPQRSTUVWXYZ!") ;
04000 FAMILYHAS(LETTQ, "abcdefghijklmnopqrstuvwxyz_") ;
04100 FAMILYHAS(DIGQ, "0123456789" ) ;
04200 CMU CHANGE: '175 IN NEXT LINE WENT TO '176;
04300 FAMILYHAS(EMPTYQ, '0 & '176 & '177) ;
04400 CMU CHANGE: FIRST CHAR IN STRING ON NEXT LINE CHANGED TO '175 (⎇);
04500 FAMILYHAS(TERQ, "⎇;),]⊂" ) ;
04600 FAMILYHAS(QUOTEQ, """'" ) ;
04700 FAMILYHAS(CURLYQ, "{" ) ;
04800 FAMILYHAS(BROKQ, "[" ) ;
04900 FAMILYHAS(MULQ, "*/%&" ) ;
05000
05100 CMU: FOLLOWING LINE HAD 5 QUOTES AT EACH PLACE, NOT 3. 12-13-71 JN11,LE03;
05200 DPB(LDB(SPECIES("""/""")), SPECIES("""%""")) ;
05300 FAMILYHAS(ADDQ, "+-≡↑⊗" ) ;
05400 FAMILYHAS(RELQ, "<>=≤≥≠" ) ;
05500 FAMILYHAS(NOTQ, "¬" ) ;
05600 FAMILYHAS(ANDQ, "∧" ) ;
05700 FAMILYHAS(ORQ, "∨" ) ;
05800 FAMILYHAS(MISCQ, " :←(∞@|ε" ) ;
05900 FOR S ← "∧AND", "∨OR", "¬NOT", "/DIV", "≡EQV", "⊗XOR", "≡ABS", "⊗LENGTH", "≤LEQ", "≥GEQ", "≠NEQ" DO
06000 BIND(DECLARE(SYMNUM(S[2 TO ∞]), INTERNTYPE), S+200) ; ie, equate with special character ;
06100 J ← '177 ;
06200 CMU: ADDED MOD BELOW;
06300 FOR S ← ODDQ&0&"EVEN", ODDQ&1&"ODD", BOUNDQ&0&"MAX", BOUNDQ&1&"MIN", MULQ&2&"MOD" DO
06400 BEGIN
06500 CMU: SAIL BUG-GET-AROUND. DOESN'T HANDLE DPB(<STRING>,<MUMBLE>)
06600 CORRECTLY; INTEGER TEMP;
06700 BIND(DECLARE(SYMNUM(S[3 TO ∞]), INTERNTYPE), (J←J+1)+200) ;
06800 DPB((TEMP←S[1 FOR 1]), FAMILY(J)) ;
06900 DPB((TEMP←S[2 FOR 1]), SPECIES(J)) ;
07000 END ;
00100 UPCAS3←(UPCASE(0)) LOR '3000000 ; COMMENT POINT 7, CHARTBL(3), 6 ;
00200 UPCAS5←(UPCASE(0)) LOR '5000000 ; UPCAS6←(UPCASE(0)) LOR '6000000 ;
00300 FOR J ← 0 THRU 127 DO DPB(J, UPCASE(J)) ;
00400 FOR J ← "a" THRU "z" DO DPB(J-("a"-"A"), UPCASE(J)) ; DPB(J←"!", UPCASE("_")) ;
00500 J ← -1 ;
00600 FOR S ← "LINES", "COLUMNS", "!", "SPREAD", "FILLING", "!SKIP!", "!SKIPL!", "!SKIPR!",
00700 "NULL", "!INF", "FOOTSEP", "TRUE", "FALSE",
00800 "INDENT1", "INDENT2", "INDENT3", "LMARG", "RMARG",
00900 "CHAR", "CHARS", "LINE", "COLUMN", "TOPLINE",
01000 RKJ ADDED VARIABLES ON NEXT LINE;
01100 "XLINESIZE", "AKSET", "BKSET", "XGENLINES", "XCRIBL", "XKSETCON",
01150 PLK: HYPHENATION SLACK; "XSPCSMAX" DO
01200 BIND(DECLARE(SYMNUM(S), INTERNTYPE), J←J+1) ; comment Internal Variables;
01300 PLBL←BRKPLBL←-(2↑13); NOPGPH ← TRUE ;
01400 BIND(DECLARE(SYMNUM("FOOT"), PORTYPE), IXFOOT ← PUTI(4, -1)) ;
01500 ASSIGN("!CONTENTSW", CONTENTS) ; comment make RPG-switch available to macros;
01600 ASSIGN("FILE", CVXSTR(CVFIL(INFILE,L,M))) ;
01700 ! ← NULL ; K ← CALL(0, "DATE") ;
01800 ASSIGN("MONTH", (STR1 ← MONTH[K DIV 31 MOD 12 + 1])[1 TO ∞-1]) ;
01900 ASSIGN("DAY", STR2 ← CVS(K MOD 31 + 1)) ;
02000 ASSIGN("YEAR", STR3 ← CVS(K DIV 31 DIV 12 + 1964)) ;
02100 ASSIGN("DATE", STR1 & STR2 & ", " & STR3 );
02200 K ← CALL(0,"TIMER")/3600 ; S ← CVS(K MOD 60) ; IF LENGTH(S)=1 THEN S ← "0"&S ;
02300 ASSIGN("TIME", CVS(K DIV 60) & ":" & S) ;
02400 SYMPAGE←SYMNUM("PAGE"); CREUNIT(0,1,18,1,0,"1",SYMPAGE); IXPAGE←LDB(IXN(SYMPAGE));
02500 PATPAGE←PATT_STRS(IXPAGE); PAGEVAL ← NULL ;
02600 INTERS ← PORTS ← THISPORT ← 0 ; PORTLL ← SEQPORT ← PUTI(4, -5) ; PORSEQ(SEQPORT) ← INTER ← -1 ;
02700 INPUTCHAN ← -1 ; LIT_ENTITY ← LIT_TRAIL ← NULL ;
02800 INPUTSTR ← CRLF & "99999/99" & TB & TB & "<<)]⎇⊃>>;END""PAST EOF"";END""PASSED EOF"";" ;
02900 TABSORT[1]←2↑33; EXNEXTPAGE ← FALSE ; ENDCASE←STARTS←0 ; BLNMS←-1 ; AVAILREC[0] ← NULLAREAS ← 0 ;
03000 EMPTYTHIS ; EMPTYTHAT ;
03100 RESP_BODY ← DCLR_ID ← DCLR_LET ← FALSE ; OWLSEQ ← MESGS ← 0 ;
03200 THISFILE ← "::::::" ; MAINFILE ← (CVXSTR(CVFIL(INFILE,J,J))& "::::::")[1 TO 6] ;
03300 COMMAND_CHARACTER ← "." ;
03400 S ← TEXT_BRC ← CRLF & ALTMODE & RUBOUT & VT & " -.!?" ;
03500 WHILE FULSTR(S) DO DPB(LDB(SPCHAR("J ← LOP(S)")), SPCODE(J)) ;
03600 DEFN_BRC ← "⎇⊂⊃∃" & LF & LETTS ; EPSCHAR ← -1 ;
03700 CMU CHANGE: STANFORD 176 CHAR WENT TO CMU 175;
03800 SETBREAK(TO_VT_SKIP, VT, NULL, "IS") ;
03900 SETBREAK(TO_COMMA_RPAR, ",)" & LF, CR & "|", "IR") ;
04000 CMU CHANGE: FIRST CHAR IN STRING ON NEXT LINE CHANGED TO '175 (⎇);
04100 SETBREAK(TO_TERQ_CR, "⎇;),]⊂"&CRLF, NULL, "IR") ;
04200 SETBREAK(TO_SEMI_SKIP, ";⎇"&LF, NULL, "IS") ;
04300 CMU CHANGE: STANFORD 176 CHAR WENT TO CMU 175;
04400 SETBREAK(NO_CHARS, NULL, NULL, "XRL") ;
04500 SETBREAK(ONE_CHAR, NULL, NULL, "XA") ;
04600 SETBREAK(TO_TB_FF_SKIP, TB&FF, LF, "IS") ;
04700 SETBREAK(TO_LF_TB_VT_SKIP, LF&TB&VT, FF, "ISL") ;
04800 SETBREAK(TO_VISIBLE, SP&CR, NULL, "XR") ;
04900 SETBREAK(ALPHA, LETTS&DIGS, NULL, "XR") ;
05000 SETBREAK(DIGITA, DIGS, NULL, "XR") ;
05100 SETBREAK(TO_QUOTE_APPD, """"&LF, NULL, "IA") ;
05200 SETBREAK(TO_NON_SP, SP, NULL, "XR") ;
05300 SETBREAK(TEXT_TBL, TEXT_BRC&SIG_BRC,NULL, "IS") ;
05400 SETBREAK(TO_VBAR_SKIP, "|"&LF, CR, "IS") ;
05500 SETBREAK(DEFN_TABLE, DEFN_BRC, NULL, "IS") ;
05600 SETBREAK(TO_CR_SKIP, CRLF, NULL, "IS") ;
05700 SWICH(CRLF & "9999/98" & TB & TB & "NEXT PAGE ; END ""!MANUSCRIPT"" ", -1, 0) ;
05800 SWICHF(INFILE) ; comment main input file ;
05900 OUTSTR("P U B P A S S O N E - - -"&CRLF&"READING PAGE/" & SRCPAGE & SP) ;
06000 SWICH("BEGIN ""!MANUSCRIPT"" ", -1, 0) ;
06100 CMU: OLD LINE : LIBPPN ← IF EQU(CVXSTR(CALL(0,"GETPPN"))[3 TO 6], "2TES") THEN "[2,TES]" ELSE "[1,3]" ;
06200 LIBPPN← IF CALL(0,"GETPPN")='1305440220 THEN "[A700PU00]" ELSE SYSPPN;
06300 CMU: NEW LINE FOR LIBDEV;
06400 LIBDEV←IF LENGTH(LIBPPN) = 0 THEN SYSDEV ELSE "DSK";
06500 SWICHF("PUBSTD.DFS"&LIBPPN) ; comment standard modes and macros ;
06600 SPREADM ← PREFMODE ;
06700 PASS ; comment get scanner going ;
00100 MANUSCRIPT ; NB NB NB NB T H I S D O E S P A S S O N E ;
00200
00300 COMMENT Write out Labels for Pass Two ;
00400 L ← WRITEON(FALSE, "PULABL.PUI") ;
00450 OUT (L, CVSR(CHARW));
00475 OUT(L, CVSR(XSYMNO MAX IHIGH) ) ;
00500 FOR J ← 1 THRU XSYMNO DO
00600 IF (BYTEWD ← NUMBER[J]) ≠ 0 ∧ (K← LDB(SYMBOLWD(BYTEWD))) = 0 ∨ K='17777 THEN
00700 IF LDB(PLIGHTWD(BYTEWD)) = 2 THEN OUT(L, CVSR(0) & CVSR(J) & STBL[LDB(IXWD(BYTEWD))]&ALTMODE )
00800 ELSE WARN("=","Undefined Label "&SYM[J]) ;
00900 FOR J ← 1 THRU IHIGH DO IF LH(BYTEWD ← ITBL[J]) = '400000 THEN
01000 OUT(L, CVSR(1) & CVSR(J) & STBL[LDB(IXWD(BYTEWD))] & ALTMODE) ;
01100 RELEASE(L) ;
01200
01300 COMMENT Finish Last Page File and write out OUTFILE and Intermediate Sequence File ;
01400 IF INTER ≥ 0 THEN BEGIN FOR DUMMY←1 THRU 5 DO WORDOUT(INTER,-20) ; RELEASE(INTER) ; RELEASE(SINTER) END ;
01500 L ← WRITEON(FALSE,"PUPSEQ.PUI") ;
01600 IF GENEXT THEN OUTFILE ← OUTFILE & (IF XCRIBL THEN ".XGO" ELSE ".DOC");
01700 OUT(L, TMPFILE&ALTMODE&OUTFILE&ALTMODE&CVSR(DEBUG)&CVSR("ABS(DEVICE)")&DELINT&ALTMODE) ;
01800 J ← PORSEQ(PORTLL) ;
01900 OPEN(K ← GETCHAN, "DSK", 0,1,0,20, BRC, EOF) ;
02000 WHILE J > 0 DO
02100 BEGIN
02200 IF PORINT(J) THEN OUT(L, CVSTR(PORINT(J)) & ALTMODE) ;
02300 IF PORCH(J) = -5 ∨ PORSEQ(J) < 0 THEN WARN("=","INSERT Portion not found") ;
02400 IF PORFIL(J) THEN FOR S ← ".PUG", ".PUZ" DO IF EQU(S,".PUG") ∨ PORCH(J)=-6 THEN
02500 BEGIN COMMENT DELETE GENERATED FILES ;
02600 LOOKUP(K, CVSTR(PORFIL(J)) & S, DUMMY) ;
02700 IF DUMMY=0 THEN RENAME(K, NULL, 0, DUMMY) ;
02800 END ;
02900 J ← PORSEQ(J) ;
03000 END ;
03100 RELEASE(L) ; RELEASE(K) ;
03200 OUTSTR(CRLF) ;
03300
03400 FOR J ← ITBLIDA, ISTKIDA, INESTIDA, NUMBIDA DO GOAWAY(J) ;
03500 FOR J ← STBLIDA, SSTKIDA, SNESTIDA, SYMIDA DO GOAWAY(-1 LSH 18 + J) ;
03600
03700 MAKEBE(WISTK, ISTK) ; MAKEBE(WITBL, ITBL) ; MAKEBE(WINEST, INEST) ;
03800 SMAKEBE(WSSTK, SSTK) ; SMAKEBE(WSTBL, STBL) ; SMAKEBE(WSNEST, SNEST) ;
03900 SMAKEBE(WSYM, SYM) ; MAKEBE(WNUMBER, NUMBER) ; MAKEBE(WOLDPAGE, OLDPAGE) ;
04000 MAKEBE(WNEWPAGE, NEWPAGE) ; MAKEBE(WTHISFRAME,THISFRAME);
04100 MAKEBE(WMOLES, MOLES) ; MAKEBE(WOWLS, OWLS) ; MAKEBE(WNMOLES, NMOLES) ;
04150 MAKEBE(WSHORT, SHORT) ; MAKEBE(WNSHORT, NSHORT) ;
04200 MAKEBE(WNOWLS, NOWLS) ; MAKEBE(WTHISAREA, THISAREA) ; MAKEBE(WWAITBOX, WAITBOX) ;
04300 MAKEBE(WAVAILREC, AVAILREC) ; MAKEBE(WAA, AA) ; MAKEBE(WNAA, NAA) ;
04400
04500 END "VARIABLE BOUND ARRAY BLOCK" ;
04600
04700 BEGIN "PASS 2"
04800 INTEGER ARRAY PASSTWO[0:4] ;
04900 PASSTWO[0] ← CVSIX(LIBDEV) ; PASSTWO[1] ← CVFIL("PUBTW0"&LIBPPN, PASSTWO[2], PASSTWO[4]) ;
05000 PASSTWO[3] ← 0 ;
05100 CMU: DELETE CALL(CORELOC(PASSTWO), "SWAP") ;
05200 CMU: AND INSERT THE FOLLOWING CODE:;
05300 COMMENT SYMBOL←CORELOC(PASSTWO);
05400 START!CODE
05500 DEFINE CALLI ="'47000000000";
05600 MOVE 1,PASSTWO;
05700 HRLI 1,1;
05800 CALLI 1,'35;
05900 JRST 4,;
06000 END;
06100 END "PASS 2" ;
06200
06300 END "PUB"