perm filename PUB.SAI[2,TES]8 blob
sn#073666 filedate 1973-11-20 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00037 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00006 00002 BEGIN "PUB" COMMENT Begun April 23, 1971, Completed Asymptotically
C00009 00003 EXTERNAL INTEGER SIMPLE PROCEDURE XLENGTH(STRING S)
C00012 00004 INTERNAL INTEGER SIMPLE PROCEDURE BIGGER(INTEGER PTR,HM)
C00015 00005 COMMENT Declares
C00018 00006 BOOLEAN GENEXT
C00022 00007 SIMPLE PROCEDURE RPGSTART
C00024 00008 BEGIN "VARIABLE BOUND ARRAY BLOCK"
C00027 00009 COMMENT Most of the procedures in this block are INTERNAL. They are EXTERNAL in PUBPRO.SAI
C00029 00010 COMMENT P A S S O N E P R O C E D U R E S - - - - - - - - - - - - - - -
C00033 00011 INTERNAL SIMPLE PROCEDURE GROW(REFERENCE INTEGER ARRAY ARR REFERENCE INTEGER IDA,WDS
C00039 00012 INTERNAL SIMPLE PROCEDURE SWICH(STRING NEWINPUTSTR INTEGER NEWINPUTCHAN, ARGS)
C00045 00013 INTERNAL BOOLEAN SIMPLE PROCEDURE SYMLOOK(STRING NAME)
C00049 00014 INTEGER SIMPLE PROCEDURE LOG2(INTEGER BINARY)
C00052 00015 INTERNAL SIMPLE PROCEDURE DAPART IF ON THEN
C00055 00016 STRING SIMPLE PROCEDURE ALFIZE(STRING FILENAME, LEFTRIGHT)
C00059 00017 INTERNAL SIMPLE PROCEDURE PLACE(INTEGER NEWAREAIX)
C00065 00018 INTERNAL SIMPLE PROCEDURE BEGINBLOCK(BOOLEAN MIDPGPH INTEGER ECASE STRING NAME)
C00069 00019 INTERNAL RECURSIVE BOOLEAN PROCEDURE ENDBLOCK
C00072 00020 ie 3, 4 ... After, Before
C00077 00021 RECURSIVE PROCEDURE TOEND
C00080 00022 INTERNAL SIMPLE PROCEDURE OPENFRAME
C00084 00023 INTERNAL RECURSIVE PROCEDURE CLOSET(INTEGER ITSIX BOOLEAN CLOSEIT, DISDECLAREIT)
C00087 00024 INTERNAL SIMPLE PROCEDURE DISDECLARE(INTEGER SYMB, OLDTYPE, OLDIX)
C00090 00025 INTERNAL STRING SIMPLE PROCEDURE VASSIGN(INTEGER VSYMB, VTYPE, VIX STRING VAL)
C00095 00026 STRING SIMPLE PROCEDURE CVALF(INTEGER ALFABET, VAL)
C00099 00027 INTERNAL PROCEDURE FINPAGE
C00102 00028 IF STATA > 1 THEN
C00106 00029 INTERNAL RECURSIVE PROCEDURE USTEP(INTEGER USYMB, UIX)
C00111 00030 INTERNAL PROCEDURE CREUNIT(INTEGER INLINE, PFROM, PTO, PBY, PIN
C00116 00031 RECURSIVE PROCEDURE ASSUREAREA
C00120 00032 INTERNAL RECURSIVE INTEGER PROCEDURE FIND_ROOM(INTEGER SOURCE,
C00125 00033 INTERNAL RECURSIVE PROCEDURE PLACELINE(INTEGER CHARS,POSN,XPOSN,FAKE,
C00131 00034 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 - - - - - - - - - -
C00132 00035 COMMENT I N I T I A L I Z E A N D G O ! ! ! ! !
C00138 00036 UPCAS3←(UPCASE(0)) LOR '3000000 COMMENT POINT 7, CHARTBL(3), 6
C00144 00037 MANUSCRIPT NB NB NB NB T H I S D O E S P A S S O N E
C00152 ENDMK
C⊗;
BEGIN "PUB" COMMENT Begun April 23, 1971, Completed Asymptotically ;
COMMENT FILES TO COMPILE:
PUB.SAI (This one)
FILLER.SAI (The Line Filler)
PARSER.SAI (The Command Scanner/Parser)
REQUIRED FILES:
By all: PUBDFS.SAI PUBINR.SAI
By FILLER and PARSER only:
PUBMAI.SAI PUBPRO.SAI
NEEDED TO RUN PUB:
PUB.DMP (From this compilation)
PUB2.DMP (From compiling PUB2.SAI)
PUBSTD.DFS (Standard Macro File)
SYS:TXTF80.DMP (For microfilm output only)
FORMS FOR THE DEBUG SWITCH (BREAKPOINTS A LINE):
/Z04100/2/ or (Z04100/2/) Manuscript P. 2 Line 04100
/ZPUB33/1/ or (ZPUB33/1/) PUBSTD.DFS P. 1 Line 33
DOCUMENTATION FILES:
PUB.DOC[S,DOC]
PUBMAC.DOC[S,DOC]
DO FILE FOR GENERATING SYSTEM (DO NIT):
LOAD PUB.SAI(5000S),PARSER.SAI(5000S),FILLER.SAI(5000SR)↔SAVE PUB↔DO NIT(2)↔|
LOAD PUB2.SAI(5000SR)↔SAVE PUB2↔
If the user is logged in as xx2,TES then PUB expects
PUB2.DMP and PUBSTD.DFS to be in the same directory.
Otherwise, it expects them to be in 1,3
;
DEFINE TERNAL = "INTERNAL", PRELOAD = "PRELOAD_WITH" ;
REQUIRE "PUBDFS.SAI" SOURCE_FILE ;
comment, The DEFINEs, constant-bound arrays, and global variables ;
REQUIRE 4000 STRING_SPACE ; REQUIRE 400 SYSTEM_PDL ; REQUIRE 200 STRING_PDL ;
EXTERNAL INTEGER SIMPLE PROCEDURE XLENGTH(STRING S);
EXTERNAL PROCEDURE READFONT(INTEGER WHICH; STRING FILENAME);
COMMENT The following INTERNAL SIMPLE PROCEDUREs are EXTERNAL in PUBMAI.SAI ;
INTERNAL STRING SIMPLE PROCEDURE SPS(INTEGER N) ; IF N≤10 THEN RETURN(SPSARR[N MAX 0]) ELSE
BEGIN
STRING S ; INTEGER I ;
S ← " " ;
FOR I ← 20 STEP 10 UNTIL N DO S ← S & " " ;
RETURN(S & SPSARR[N-I+10]) ;
END ;
COMMENT DYNAMIC ARRAY MANIPULATION PACKAGE (ARRSER.SAI[1,DCS]) ;
EXTERNAL INTEGER GOGTAB ;
DSCR PTR←WHATIS(ARRAY)
PAR ARRAY OF ANY ARITHMETIC OR SET BREED
RES PTR←DSCRPTR, SAIL CAN THEN TREAT IT AS AN INTEGER
;
INTERNAL INTEGER SIMPLE PROCEDURE WHATIS(INTEGER ARRAY A);
START_CODE "WHATIS"
MOVE 1,A;
END "WHATIS";
DSCR PTR←SWHATIS(ARRAY)
PAR STRING ARRAY
RES PTR←DSCRPTR, SAIL CAN THEN TREAT IT AS AN INTEGER
;
INTERNAL INTEGER SIMPLE PROCEDURE SWHATIS(STRING ARRAY A);
START_CODE "SWHATIS"
MOVE 1,A;
END "SWHATIS";
DSCR GOAWAY(PTR)
PAR PTR IS ARRAY DESCRIPTOR
DES ARRAY IS RLEASD
;
INTERNAL SIMPLE PROCEDURE GOAWAY(INTEGER I) ;
BEGIN COMMENT Be SURE Left Half is -1 for String Arrays! ;
START_CODE MOVE '15, GOGTAB END ;
IF LH(I) THEN
START_CODE "SARID"
HRRZ 1, I ; MOVE 1, 0(1) ; COMMENT [PREV,,NEXT] ;
HLRZ 2, 1 ; HRRM 1, 0(2) ; COMMENT PREV ← [...,,NEXT] ;
HRRZ 2, 1 ; SKIPE 2 ; HLLM 1, 0(2) ; COMMENT NEXT ← [PREV,,...] ;
END "SARID" ;
ARYEL(I) ;
END "GOAWAY" ;
INTERNAL INTEGER SIMPLE PROCEDURE BIGGER(INTEGER PTR,HM);
BEGIN "BIGGER"
INTEGER PT;
START_CODE "BIG1"
MOVE '15, GOGTAB ; COMMENT BECAUSE OF LRCOP BUG ;
MOVE TEMPO,HM;
MOVE LPSA,PTR;
ADDM TEMPO,-3(LPSA);
ADDM TEMPO,-1(LPSA);
MOVNS TEMPO;
ADDM TEMPO,-6(LPSA);
END "BIG1";
PT←LRCOP(PTR); "DO THE COPY AND INCREASE"
START_CODE "BIG2"
MOVE TEMPO,HM;
MOVE LPSA,PTR;
ADDM TEMPO,-6(LPSA);
END "BIG2";
GOAWAY(PTR); "DELETE THE OLD COPY"
RETURN(PT); "HERE IS THE NEW COPY";
END "BIGGER";
DSCR PTR1←SBIGGER(PTR,HOWMUCH)
PAR PTR IS ARRAY (1-D STRING) DESCRIPTOR
HOWMUCH NUMBER OF ELEMENTS INCREASE DESIRED
RES PTR1 IS DESCRIPTOR OF BIGGER ARRAY
THE OLD DATA IS COPIED, THE OLD ARRAY HAS DISAPPEARED
;
INTERNAL INTEGER SIMPLE PROCEDURE SBIGGER(INTEGER PTR,HM);
BEGIN "SBIGGER"
INTEGER PT;
START_CODE "SBIG1"
MOVE '15, GOGTAB ;
MOVE TEMPO,HM;
MOVE LPSA,PTR;
ADDM TEMPO,-4(LPSA);
LSH TEMPO,1;
ADDM TEMPO,-2(LPSA);
MOVNS TEMPO;
ADDM TEMPO,-7(LPSA);
END "SBIG1";
PT←LRCOP(PTR); "DO THE COPY AND INCREASE"
START_CODE "SBIG2"
MOVE TEMPO,HM;
MOVE LPSA,PTR;
LSH TEMPO,1;
ADDM TEMPO,-7(LPSA);
END "SBIG2";
GOAWAY(PTR); "DELETE THE OLD COPY"
RETURN(PT); "HERE IS THE NEW COPY";
END "SBIGGER";
COMMENT Declares
IDA ← [S]CREATE(LOWBND, HIGHBND) to create a (string or) integer array
MAKEBE(IDA,ALIAS) to give its descriptor to array ALIAS
IDA ← [S]WHATIS(ALIAS) to take it back
GOAWAY(IDA) to destroctulate it
IDA ← [S]BIGGER(IDA,XTRA) to add XTRA words to its length ;
INTEGER SIMPLE PROCEDURE SCREATE(INTEGER LB1, UB1) ;
BEGIN "SCREATE"
INTEGER IDA ;
START_CODE MOVE '15, GOGTAB END ;
IDA ← LRMAK(LB1, UB1, -1 LSH 18 + 1) ;
RETURN(IDA) ;
END "SCREATE" ;
INTERNAL INTEGER SIMPLE PROCEDURE CREATE2(INTEGER LB1, UB1, LB2, UB2) ;
BEGIN "CREATE2"
EXTERNAL INTEGER SIMPLE PROCEDURE LRMAK(INTEGER LB1, UB1, LB2, UB2, D) ;
START_CODE MOVE '15, GOGTAB END ; COMMENT LRCOP BUG ;
RETURN(LRMAK(LB1, UB1, LB2, UB2, 2)) ;
END "CREATE2" ;
INTERNAL STRING SIMPLE PROCEDURE ERRLINE ;
RETURN(IF EQU(MAINFILE, THISFILE) THEN SRCLINE
ELSE THISFILE&SP&SRCLINE) ;
INTERNAL STRING SIMPLE PROCEDURE WARN(STRING SHORT_VERSION,LONG_VERSION) ;
BEGIN "WARN"
IF SWDBACK ≤ 0 THEN OUTSTR(CRLF) ; COMMENT 2/27/73 TES ;
USERERR(0, 1, LONG_VERSION&CRLF&" just above (or on) "&ERRLINE&"/"&SRCPAGE&"["&MACLINE&"]") ;
IF DEBUG ∧ MESGS<MESSMAX ∧ LENGTH(SHORT_VERSION) THEN
MESSAGE[MESGS←MESGS+1] ← IF SHORT_VERSION = "=" THEN LONG_VERSION ELSE SHORT_VERSION ;
SWDBACK ← 1 ; COMMENT 2/27/73 TES ;
RETURN(NULL) ;
END "WARN" ;
BOOLEAN GENEXT ;
SIMPLE PROCEDURE ANYSTART(STRING COMDLINE) ; NB Both RPGSTART and SSTART call this one;
BEGIN "ANYSTART"
STRING WD, OPTIONS, N, M ; INTEGER FIL, EXT, PPN ;
SETBREAK(1, "←/()", CR&LF&TB&FF&SP, "INS") ;
SETBREAK(2, DIGS, SP, "XNS") ;
OUTFILE ← SCAN(COMDLINE, 1, BRC) ;
IF BRC ≠ "←" THEN INFILE ← OUTFILE ;
FIL ← CVFIL(OUTFILE, EXT, PPN) ; N ← IF PPN THEN CVXSTR(PPN) ELSE NULL ;
M ← CVXSTR(FIL) ;
GENEXT ← EXT=0 OR BRC≠"←";
IF GENEXT THEN OUTFILE ← CVXSTR(FIL);
TMPFILE ← CVXSTR(FIL) & ".RPG" ;
WHILE BRC ∧ BRC≠"(" ∧ BRC≠"/" DO
BEGIN "INPUT FILE NAME"
WD ← SCAN(COMDLINE, 1, BRC) ;
IF FULSTR(WD) THEN
BEGIN
IF FULSTR(INFILE) THEN
WARN(NULL,"ONLY 1 INPUT FILE ALLOWED -- "
& INFILE & " SKIPPED") ;
INFILE ← WD ;
END ;
END "INPUT FILE NAME" ;
WHILE BRC="/" DO OPTIONS ← OPTIONS & SCAN(COMDLINE,1,BRC) ;
IF BRC = "(" THEN DO OPTIONS ← OPTIONS & SCAN(COMDLINE,1,BRC) & (IF BRC="/" THEN BRC ELSE NULL)
UNTIL BRC = 0 OR BRC = ")" ;
IF FULSTR(OPTIONS) THEN
DO BEGIN
N ← SCAN(OPTIONS, 2, BRC) ;
IF BRC = "d" ∨ BRC = "D" THEN DEBUG ← -1
ELSE IF BRC = "s" ∨ BRC = "S" THEN PREFMODE ← IF NULSTR(N) THEN 1 ELSE CVD(N)
ELSE IF BRC = "m" ∨ BRC = "M" THEN DEVICE ← -MIC
ELSE IF BRC = "t" ∨ BRC = "T" THEN DEVICE ← -TTY
ELSE IF BRC = "l" ∨ BRC = "L" THEN DEVICE ← -LPT
ELSE IF BRC = "x" ∨ BRC = "X" THEN DEVICE ← -XGP RKJ;
ELSE IF BRC = "z" ∨ BRC = "Z" THEN
LSTOP ← SCAN(OPTIONS,1,BRC) & "/" & SCAN(OPTIONS,1,BRC)
ELSE IF BRC="n" ∨ BRC="N" ∨ BRC="y" ∨ BRC="Y" ∨ BRC="a" ∨ BRC="A" THEN DELINT ← BRC
ELSE IF BRC = "c" ∨ BRC = "C" THEN CONTENTS ← -1
ELSE IF BRC = "b" ∨ BRC = "B" THEN SYMNO ← BIG_SIZE - 1
ELSE IF BRC = "h" ∨ BRC = "H" THEN SYMNO ← HUGE_SIZE - 1
ELSE IF BRC = "t" ∨ BRC = "T" THEN M ← N
ELSE IF BRC = "P" AND OPTIONS = "U" THEN
OPTIONS ← OPTIONS[3 TO ∞] COMMENT /PUB ;
ELSE IF BRC = "p" ∨ BRC = "P" OR (BRC = 0 AND FULSTR(M)) THEN
BEGIN
IF BRC = 0 THEN N ← "99999" ;
IF INPGS ≥ 10 THEN WARN(NULL,"ONLY 10 mTnP OPTIONS ALLOWED")
ELSE INPG[INPGS←INPGS+1] ← LHRH("CVD(IF NULSTR(M) THEN N ELSE M)", "CVD(N)") ;
M ← NULL ;
END
ELSE IF BRC ≠ 0 THEN WARN(NULL,"NEVER HEARD OF A " & BRC & " OPTION") ;
END
UNTIL BRC = 0 ;
XCRIBL ← IF DEVICE = -XGP THEN TRUE ELSE FALSE; RKJ;
BREAKSET(1, NULL, "O") ; BREAKSET(2, NULL, "O") ;
END "ANYSTART" ;
SIMPLE PROCEDURE RPGSTART ;
BEGIN "RPGSTART"
BOOLEAN QQSVCM ; STRING CMD ;
EOF ← 0 ; OPEN(0, "DSK", 0, 1, 0, 50, BRC, EOF) ;
LOOKUP(0, "QQSVCM.RPG", FLAG) ;
IF FLAG THEN
BEGIN
LOOKUP(0, "QQPUB.RPG", FLAG) ;
IF FLAG THEN WARN(NULL,"NO RPG FILES") ELSE QQSVCM←FALSE ;
END
ELSE QQSVCM ← TRUE ;
SETBREAK(1, LF, CR, "INS") ;
CMD ← INPUT(0,1) ;
IF QQSVCM THEN
BEGIN
COMMENT THE QQSVCM FILE HAS A SUPERFLUOUS COMPILE AND MAYBE /PUB ;
WHILE CMD=SP OR CMD=TB DO LOPP(CMD) ;
WHILE CMD NEQ SP AND CMD NEQ TB DO LOPP(CMD) ;
WHILE CMD=SP OR CMD=TB DO LOPP(CMD) ;
IF EQU(CMD[1 TO 4], "/PUB") THEN CMD ← CMD[5 TO ∞] ;
END ;
ANYSTART(CMD) ; RELEASE(0) ;
END "RPGSTART" ;
SIMPLE PROCEDURE SSTART ;
BEGIN "SSTART"
STRING S ;
DO BEGIN OUTCHR("*"); S←INCHWL; END UNTIL FULSTR(S);
ANYSTART(S);
END "SSTART";
COMMENT E X E C U T I O N B E G I N S . . . . ;
ONE ← 1 ; NB Variable upper bound for ALIAS arrays;
SYMNO ← REGULAR_SIZE - 1 ; NB Assume for now that symbol table is regular size;
INPGS ← 0 ; INFILE ← NULL ; PREFMODE ← 1 ; DEVICE ← LPT ; DELINT ← "Y" ;
IF RPGSW THEN RPGSTART ELSE SSTART; NB Read file names and options;
INITSIZES ;
BEGIN "VARIABLE BOUND ARRAY BLOCK"
REQUIRE "PUBINR.SAI" SOURCE_FILE ;
comment, Arrays whose sizes depend on CUSP options. Also SYMSER.SAI variables ;
COMMENT
SYMSER.SAI package -- LOOKUP and ENTER procedures for hashed
symbol tables -- STRINGS -- uses quadratic search.
REQUIRED --
1. DEFINE SYMNO="1 less than some relatively prime number big
enough to hold all entries"
2. REQUIRE "SYMSER.SAI[1,DCS]" SOURCE_FILE in outer block
declaration code
WHAT YOU GET ---
1. An array, SYM, to hold the (STRING) symbols you enter.
2. Another array, NUMBER, to hold the (INTEGER) values
associated with the array
3. An index, SYMBOL, set to the correct SYM/NUMBER element
after a lookup
4. An integer, ERRFLAG, set to TRUE if errors occur in ENTERSYM
5. A Procedure, FLAG←LOOKSYM("A") which returns:
TRUE if the symbol is already present in the SYM table.
FALSE if the symbol is not found --
SYMBOL will have the value -1 (table full), or
will be an index of a free entry (see ENTERSYM)
6. A Procedure, ENTERSYM("SYM",VAL) which does:
Checks for symbol full or duplicate symbol -- if detected,
types message and sets ERRFLAG TRUE
Puts SYM and VAL in SYM/NUMBER arrays at SYMBOL index
7. A Procedure, SYMSET, which initializes the table.
SYM[0] is initted to a blank string -- you can use
this information if you wish.
;
COMMENT Most of the procedures in this block are INTERNAL. They are EXTERNAL in PUBPRO.SAI ;
INTERNAL SIMPLE PROCEDURE SETSYM;
BEGIN "SETSYM"
INTEGER I;
FOR I← 1 STEP 1 UNTIL SYMNO DO SYM[I]←NULL;
SYM[0]←" ";
ERRFLAG←FALSE
END "SETSYM";
INTERNAL INTEGER SIMPLE PROCEDURE LOOKSYM(STRING A);
BEGIN "LOOKSYM"
INTEGER H,Q,R;
DEFINE SCON="10";
H←CVASC(A) +LENGTH(A) LSH 6;
R←SYMBOL←(H←ABS(H⊗(H LSH 2))) MOD (SYMNO+1);
IF EQU(SYM[SYMBOL],A) THEN RETURN(-1);
IF NULSTR(SYM[SYMBOL]) THEN RETURN(0);
Q←H%(SYMNO+1) MOD (SYMNO+1);
IF (H←Q+SCON)≥SYMNO THEN H←H-SYMNO;
WHILE (IF (SYMBOL←SYMBOL+H)>SYMNO
THEN SYMBOL←SYMBOL-(SYMNO+1) ELSE SYMBOL) ≠R DO
BEGIN "LK1"
IF EQU(SYM[SYMBOL],A) THEN RETURN(-1);
IF NULSTR(SYM[SYMBOL]) THEN RETURN(0);
IF (H←H+Q)>SYMNO THEN H←H-(SYMNO+1);
END "LK1";
SYMBOL←-1; RETURN(0);
END "LOOKSYM";
INTERNAL SIMPLE PROCEDURE ENTERSYM(STRING WORD; INTEGER VAL);
BEGIN "ENTERSYM"
IF LENGTH(SYM[SYMBOL])∨SYMBOL<0 THEN
BEGIN
ERRFLAG←1;
IF SYMBOL≥0 THEN PRINT "DUPLICATE SYMBOL "&WORD MSG
ELSE PRINT "SYMBOL TABLE FULL" MSG ;
END
ELSE
BEGIN
SYM[SYMBOL]←WORD;
NUMBER[SYMBOL]←VAL;
END;
END "ENTERSYM";
COMMENT P A S S O N E P R O C E D U R E S - - - - - - - - - - - - - - - ;
EXTERNAL SIMPLE PROCEDURE SELECTFONT(INTEGER WHICH);
EXTERNAL RECURSIVE PROCEDURE DBREAK ;
EXTERNAL RECURSIVE BOOLEAN PROCEDURE TEXTLINE ; comment, INTERNAL in FILLER.SAI ;
EXTERNAL RECURSIVE BOOLEAN PROCEDURE CHUNK(BOOLEAN VALID) ;
EXTERNAL RECURSIVE STRING PROCEDURE PASS ; comment, INTERNAL in PARSER.SAI ;
EXTERNAL STRING SIMPLE PROCEDURE EVALV(STRING THISWD ; INTEGER IX, TYP) ;
EXTERNAL RECURSIVE STRING PROCEDURE E(STRING DEFAULT, STOPWORD) ;
EXTERNAL SIMPLE PROCEDURE RDENTITY ;
FORWARD INTERNAL RECURSIVE PROCEDURE CLOSEAREA(INTEGER ITSIX; BOOLEAN DISDECLAREIT) ;
FORWARD INTERNAL RECURSIVE PROCEDURE CLOSEUNIT(INTEGER ITSIX; BOOLEAN DISDECLAREIT) ;
INTERNAL STRING SIMPLE PROCEDURE SOMEINPUT ;
RETURN(SP&THISWD&SP&
(IF THATISFULL THEN LIT_ENTITY&LIT_TRAIL ELSE NULL)&INPUTSTR[1 TO 80]);
INTERNAL SIMPLE PROCEDURE IMPOSSIBLE(STRING WHERE); WARN("=","IMPOSSIBLE CASE INDEX IN "&WHERE&" AT "&SOMEINPUT);
INTERNAL STRING SIMPLE PROCEDURE CAPITALIZE(STRING MIXEDCASE) ;
BEGIN "CAPITALIZE"
INTEGER C ; STRING S ; S ← 0&MIXEDCASE ; LOPP(S) ; C ← LENGTH(MIXEDCASE) ; IF ¬C THEN RETURN(NULL);
START_CODE "CAPIT" LABEL NEXC ; MOVE 1, S ; MOVE 2, C ;
NEXC: ILDB 3, 1 ; LDB 3, UPCAS3 ; DPB 3, 1 ; SOJG 2, NEXC ;
END "CAPIT" ; RETURN(S) ;
END "CAPITALIZE" ;
SIMPLE PROCEDURE ZEROWORDS(INTEGER WDS; REFERENCE INTEGER LOCN) ;
BEGIN "ZEROWORDS"
START_CODE "ZOT"
LABEL DUN ;
SKIPG 1, WDS ;
JRST DUN ; COMMENT NO WDS TO ZERO -- QUIT ;
HRRZ 2, -1('17) ; COMMENT LOCN ;
SETZM 0(2) ;
CAIN 1, 1 ;
JRST DUN ; COMMENT ONLY 1 -- DON'T BLT ! ;
ADDI 1, -1(2) ;
HRL 2, 2 ;
ADDI 2, 1 ;
BLT 2, (1) ;
DUN:
END ;
END "ZEROWORDS" ;
INTERNAL SIMPLE PROCEDURE ZEROSTRINGS(INTEGER STRS; REFERENCE STRING LOCN) ;
BEGIN
START_CODE "ZOS"
LABEL DUN ;
SKIPG 1, STRS ;
JRST DUN ; COMMENT NO STRS TO ZERO -- QUIT ;
ADD 1, 1 ; COMMENT TWO WORDS PER STRING ;
HRRZ 2, -1('17) ; COMMENT LOCN ;
SUBI 2, 1 ; COMMENT POINT TO COUNT WORD FIRST ;
SETZM 0(2) ;
ADDI 1, -1(2) ;
HRL 2, 2 ;
ADDI 2, 1 ;
BLT 2, (1) ;
DUN:
END ;
END "ZEROSTRINGS" ;
INTERNAL SIMPLE PROCEDURE GROW(REFERENCE INTEGER ARRAY ARR; REFERENCE INTEGER IDA,WDS;
INTEGER EXTRA; STRING WHY) ;
BEGIN "GROW"
IDA ← RH("BIGGER(WHATIS(ARR),EXTRA)"); WDS ← WDS + EXTRA ;
IF WDS ≥ TWO(14) THEN WARN(NULL,"Table grown to 2↑14 entries. Utterly unmanageable. Goodbye!") ;
END "GROW" ;
INTERNAL SIMPLE PROCEDURE SGROW(REFERENCE STRING ARRAY ARR; REFERENCE INTEGER IDA,WDS;
INTEGER EXTRA; STRING WHY) ;
BEGIN "SGROW"
IDA ← RH("SBIGGER(SWHATIS(ARR),EXTRA)"); WDS ← WDS + EXTRA ;
IF WDS ≥ TWO(14) THEN WARN(NULL,"Table grown to 2↑14 entries. Utterly unmanageable. Goodbye!") ;
END "SGROW" ;
INTERNAL SIMPLE PROCEDURE GROWNESTS ;
BEGIN "GROWNESTS"
GROW(INEST, INESTIDA, SIZE, 200, NULL) ; MAKEBE(INESTIDA, INEST) ;
DUMMY ← 0 ; COMMENT OTHERWISE SPURIOUS MESSAGE FROM SGROW 2/28/73 TES ;
SGROW(SNEST, SNESTIDA, DUMMY, 200, NULL) ; SMAKEBE(SNESTIDA, SNEST) ;
ZEROSTRINGS(200, SNEST[SIZE-199]) ;
END "GROWNESTS" ;
INTERNAL SIMPLE PROCEDURE GROWOWLS(INTEGER EXTRA) ;
BEGIN "GROWOWLS"
GROW(MOLES, MOLESIDA, OLXX, EXTRA, NULL) ; MAKEBE(MOLESIDA, MOLES) ;
GROW(SHORT, SHORTIDA, DUMMY←0, EXTRA, NULL) ; MAKEBE(SHORTIDA, SHORT) ;
DUMMY ← 0 ; COMMENT OTHERWISE SPURIOUS MESSAGE FROM GROW 2/28/73 TES ;
GROW(OWLS, OWLSIDA, DUMMY, EXTRA, NULL) ;
MAKEBE(OWLSIDA, OWLS) ; OWLSF ← OWLSIDA ; MOLESF ← MOLESIDA ; SHORTF ← SHORTIDA ;
END "GROWOWLS" ;
INTERNAL INTEGER SIMPLE PROCEDURE PUSHI(INTEGER WDS, TYP) ;
BEGIN "PUSHI"
INTEGER QI ;
IF (IHED ← IHED + WDS+1) > ISIZE THEN
BEGIN
GROW(ISTK, ISTKIDA, ISIZE, 1000, NULL) ;
MAKEBE(ISTKIDA,ISTK)
END ;
ISTK[IHED] ← TYP ROT -9 LOR (IHED-WDS-1) ;
ZEROWORDS(WDS, ISTK[IHED-WDS]) ; RETURN(IHED) ;
END "PUSHI" ;
INTERNAL INTEGER SIMPLE PROCEDURE PUSHS(INTEGER WDS; STRING FIRST) ;
BEGIN"PUSHS"
INTEGER QI ;
IF (SHED ← SHED + WDS) > SSIZE THEN
BEGIN
SGROW(SSTK, SSTKIDA, SSIZE, 200, NULL) ;
SMAKEBE(SSTKIDA,SSTK) ; ZEROSTRINGS(200, SSTK[SSIZE-199]) ;
END ;
SSTK[SHED] ← FIRST ;
FOR QI←WDS-1 DOWN 1 DO SSTK[SHED-QI]←NULL ; RETURN(SHED) ;
END "PUSHS" ;
INTERNAL INTEGER SIMPLE PROCEDURE PUTI(INTEGER WDS, FIRST) ;
BEGIN"PUTI"
INTEGER QI ;
IF (IHIGH ← IHIGH + WDS) > ITSIZE THEN
BEGIN
GROW(ITBL, ITBLIDA, ITSIZE, 300, NULL) ;
MAKEBE(ITBLIDA,ITBL) ;
END ;
ITBL[IHIGH] ← FIRST ;
ZEROWORDS(WDS-1, ITBL[IHIGH-WDS+1]) ; RETURN(IHIGH) ;
END "PUTI" ;
INTERNAL INTEGER SIMPLE PROCEDURE PUTS(STRING VAL) ;
BEGIN"PUTS"
INTEGER QI ;
IF (SHIGH ← SHIGH + 1) > STSIZE THEN
BEGIN
SGROW(STBL, STBLIDA, STSIZE, 200, NULL) ;
SMAKEBE(STBLIDA,STBL) ; ZEROSTRINGS(200, STBL[STSIZE-199]) ;
END ;
STBL[SHIGH] ← VAL ;
RETURN(SHIGH) ;
END "PUTS" ;
IFC TENEX THENC TES 10/25/73 ;
INTERNAL BOOLEAN SIMPLE PROCEDURE XLOOKUP(INTEGER CHAN; STRING NAME, EXT; INTEGER JUNK; STRING PPN) ;
BEGIN COMMENT RETURNS TRUE IF SUCCESSFUL ;
BOOLEAN FLAG ;
LOOKUP(CHAN, PPN & NAME & EXT, FLAG) ;
RETURN(NOT FLAG) ;
END ;
STRING PROCEDURE SCANTO(STRING BRKS; REFERENCE STRING SCANNEE; BOOLEAN INCLUDE) ;
BEGIN
INTEGER DUMMY ;
SETBREAK(LOCAL_TABLE, BRKS, NULL, IF INCLUDE THEN "IA" ELSE "IR") ;
RETURN(SCAN(SCANNEE, LOCAL_TABLE, DUMMY)) ;
END ;
STRING SIMPLE PROCEDURE CVFIL(STRING FILENAME; REFERENCE STRING EXT, PPN) ;
BEGIN
STRING NAME ;
PPN ← IF FILENAME[1 FOR 1] = "<" THEN SCANTO(">", FILENAME, TRUE) ELSE NULL ;
NAME ← SCANTO(".;", FILENAME, FALSE) ;
EXT ← IF FILENAME[1 FOR 1] = "." THEN SCANTO(";", FILENAME, FALSE) ELSE NULL ;
RETURN(NAME) ;
END ;
ELSEC
INTERNAL BOOLEAN SIMPLE PROCEDURE XLOOKUP(INTEGER CHAN, NAME, EXT, JUNK, PPN) ;
START_CODE "XLOOKUP"
MOVE 2,CHAN;
LSH 2,23;
IOR 2,['076017777774]; COMMENT LOOKUP 0,-4(17) ;
SETO 1,0; COMMENT TRUE ;
XCT 0,2;
SETZ 1,0; COMMENT FALSE ;
END "XLOOKUP";
ENDC
INTERNAL SIMPLE PROCEDURE SWICH(STRING NEWINPUTSTR; INTEGER NEWINPUTCHAN, ARGS) ;
BEGIN "SWICH" comment switch to new input stream ;
IF ARGS THEN
BEGIN "SUBSTITUTE"
INTEGER BRC ; STRING NEWER ; NEWER ← NULL ; LAST ← LAST - ARGS ;
DO BEGIN "VTABS"
NEWER ← NEWER & SCAN(NEWINPUTSTR, TO_VT_SKIP, BRC) ;
IF BRC THEN NEWER ← NEWER & SNEST[LAST + LOP(NEWINPUTSTR)] ;
END "VTABS"
UNTIL BRC = 0 ;
NEWINPUTSTR ← NEWER ;
END "SUBSTITUTE" ;
IF (LAST ← LAST+2) > SIZE THEN GROWNESTS ;
STRSCAN(LAST) ← IF THATISFULL THEN LIT_ENTITY & LIT_TRAIL & INPUTSTR ELSE INPUTSTR ;
CHANSCAN(LAST) ← INPUTCHAN + (IF TECOFILE THEN 100 ELSE 0) ;
LINESCAN(LAST) ← IF INPUTCHAN < 0 THEN MACLINE ELSE THISFILE & VT & SRCLINE ;
PAGESCAN(LAST) ← LHRH(PAGEMARKS, PAGEWAS) ;
EMPTYTHIS ; EMPTYTHAT ;
INPUTSTR ← NEWINPUTSTR ; INPUTCHAN ← NEWINPUTCHAN ; TECOFILE ← 0 ;
END "SWICH" ;
INTERNAL STRING SIMPLE PROCEDURE SWICHBACK ;
BEGIN "SWICHBACK"
EOF ← 0 ; IF INPUTCHAN≥0 THEN
BEGIN
IF PUBSTD THEN PUBSTD ← FALSE ELSE SWDBACK ← TRUE ;
CHANLS[INPUTCHAN]←0; RELEASE(INPUTCHAN) ;
END ;
PAGEMARKS ← LH("DUMMY ← ABS(PAGESCAN(LAST))") ; PAGEWAS ← RH(DUMMY) ;
SRCPAGE ← CVS(PAGEMARKS) ;
IF (INPUTCHAN ← CHANSCAN(LAST))< 0 THEN MACLINE←LINESCAN(LAST)
ELSE BEGIN SRCLINE←LINESCAN(LAST);
THISFILE←SCAN(SRCLINE,TO_VT_SKIP,DUMMY) END ;
IF TECOFILE ← INPUTCHAN > 50 THEN INPUTCHAN ← INPUTCHAN - 100 ;
INPUTSTR ← STRSCAN(LAST) ; LAST←LAST-2; RETURN(INPUTSTR) ;
END "SWICHBACK" ;
INTERNAL SIMPLE PROCEDURE SWICHF(STRING FILENAME) ;
BEGIN "SWICHF"
INTEGER CHAN ; BOOLEAN MANEXT ;
IFC TENEX THENC STRING ELSEC INTEGER ENDC FIR, EXT, PPN ; TES 10/25/73 ;
IFC TENEX THENC DEFINE PUB=""".PUB""",PUG=""".PUG""",PUZ=""".PUZ""" ; ELSEC TES 10/25/73;
DEFINE PUB = "'606542000000",
PUG = "'606547000000",
PUZ = "'606572000000";
ENDC
IF (CHAN ← GETCHAN) < 0 THEN
BEGIN WARN("=","No channel for reading "&FILENAME) ; RETURN END ;
CHANLS[CHAN] ← -1 ; EOF ← 0 ; OPEN(CHAN, "DSK", 0, 2, 0, 150, BRC, EOF) ;
MANEXT ← FALSE ;
FIR ← CVFIL(FILENAME, EXT, PPN) ;
IF LAST=2 THEN
BEGIN "PRIMARY FILE"
MANEXT ← EXT=0 ;
END "PRIMARY FILE" ;
DO BEGIN
IF MANEXT THEN FLAG ← NOT XLOOKUP(CHAN,FIR,PUB,0,PPN)
ELSE LOOKUP(CHAN,FILENAME,FLAG);
IF FLAG THEN IF MANEXT THEN MANEXT ← FALSE ELSE
BEGIN
OUTSTR("No file named `"&FILENAME&"'--read file:") ;
FILENAME←INCHWL ;
END ;
END
UNTIL ¬FLAG ;
SWICH(NULL, CHAN, 0) ;
IFC TENEX THENC IF EQU(EXT[1 FOR 4],PUG) OR EQU(EXT[1 FOR 4],PUZ) THEN
ELSEC IF EXT=PUG OR EXT=PUZ THEN ENDC
TECOFILE ← 0
ELSE BEGIN INPUT(INPUTCHAN, NO_CHARS) ; TECOFILE ← BRC≥0 END ;
PAGEMARKS ← PAGEWAS ← 1 ; SRCPAGE ← "1" ; SRCLINE ← IF TECOFILE THEN "0" ELSE "00000" ;
IF TECOFILE THEN
BEGIN COMMENT IF TVEDIT FILE, SKIP PAGE 1 ;
IF EQU("COMMENT ⊗", INPUT(INPUTCHAN,TO_TERQ_CR)[1 TO 9]) THEN
BEGIN
DO INPUT(INPUTCHAN, TO_TB_FF_SKIP) UNTIL BRC=FF ;
SRCPAGE ← "2" ; PAGEMARKS ← PAGEWAS ← 2 ;
END
ELSE BEGIN CLOSIN(INPUTCHAN) ; COMMENT NOT TVEDIT -- RESTART INPUT ;
IF MANEXT THEN XLOOKUP(CHAN,FIR,PUB,0,PPN) ELSE
LOOKUP(CHAN,FILENAME,FLAG);
END END ;
THISFILE ← FILENAME ;
IF NOT PUBSTD THEN
BEGIN
IF LAST =4 THEN BEGIN OUTSTR("PUB: ") ; MAINFILE←THISFILE ; END
ELSE OUTSTR(CRLF & SPS(LAST)) ;
OUTSTR(THISFILE&SP&SRCPAGE) ; SWDBACK ← FALSE ;
END ;
END "SWICHF" ;
INTERNAL BOOLEAN SIMPLE PROCEDURE SYMLOOK(STRING NAME) ;
BEGIN "SYMLOOK" comment same as LOOKSYM, but if hash table full, expands it and does linear search ;
comment don't search if it's already here;
IF SYMBOL>0 AND EQU(SYM[SYMBOL],NAME) OR LOOKSYM(NAME) THEN RETURN(TRUE) ;
IF SYMBOL>0 THEN RETURN(FALSE) ; comment it's not there, and table's not full;
FOR SYMBOL ← SYMNO STEP 1 WHILE SYMBOL≤XSYMNO AND FULSTR(SYM[SYMBOL]) AND ¬EQU(SYM[SYMBOL],NAME) DO ;
IF SYMBOL > XSYMNO THEN
BEGIN
SGROW(SYM, SYMIDA, XSYMNO, 1000, "Symbol Table Full") ; SMAKEBE(SYMIDA, SYM) ;
ZEROSTRINGS(1000, SYM[XSYMNO-999]) ;
GROW(NUMBER, NUMBIDA, DUMMY, 1000, NULL) ; MAKEBE(NUMBIDA, NUMBER) ;
IF XSYMNO≥TWO(13) THEN WARN(NULL,"Symbol Table Enormopotamus. I give up.") ;
FOR SYMBOL ← XSYMNO-999 THRU XSYMNO DO SYM[SYMBOL] ← NULL ;
DUMMY←XSYMNO+1; SYMBOL ← XSYMNO - 999 ; RETURN(FALSE) ;
END
ELSE RETURN(FULSTR(SYM[SYMBOL])) ;
END "SYMLOOK" ;
INTERNAL INTEGER SIMPLE PROCEDURE SYMNUM(STRING NAME) ;
BEGIN "SYMNUM" comment looks up a symbol, and if not there, enters it. returns subscript;
IF ¬SYMLOOK(NAME) THEN ENTERSYM(NAME, 0) ;
RETURN(SYMBOL) ;
END "SYMNUM" ;
INTERNAL BOOLEAN SIMPLE PROCEDURE SIMLOOK(STRING NAME) ;
comment, SIMilar to SYMLOOK, but sets SYMTYPE and SYMIX ;
IF SYMLOOK(NAME) THEN
BEGIN
BYTEWD ← NUMBER[SYMBOL] ;
SYMTYPE ← LDB(TYPEWD(BYTEWD)) ; SYMIX ← LDB(IXWD(BYTEWD)) ;
RETURN(TRUE) ;
END
ELSE RETURN(FALSE) ;
INTERNAL INTEGER SIMPLE PROCEDURE SIMNUM(STRING NAME) ;
BEGIN "SIMNUM" comment, SIMilar to SYMNUM, but uses SIMLOOK instead of SYMLOOK ;
IF ¬SIMLOOK(NAME) THEN ENTERSYM(NAME, SYMTYPE←SYMIX←0) ;
RETURN(SYMBOL) ;
END "SIMNUM" ;
INTERNAL INTEGER SIMPLE PROCEDURE WRITEON(BOOLEAN BINARY; STRING FILENAME) ;
BEGIN "WRITEON"
INTEGER CH ;
IF (CH ← GETCHAN) < 0 THEN RETURN(WARN("=","No channel for writing "&FILENAME));
K ← 0 ; OPEN(CH, "DSK", IF BINARY THEN 8 ELSE 0, 0, 2, DUMMY, DUMMY, K) ;
ENTER(CH, FILENAME, DUMMY←0) ;
IF DUMMY THEN WARN("=","ENTER failed for "&FILENAME);
RETURN(CH) ;
END "WRITEON" ;
INTEGER SIMPLE PROCEDURE LOG2(INTEGER BINARY) ;
BEGIN "LOG2"
INTEGER I ; I ← 0 ;
WHILE BINARY > 1 DO BEGIN I ← I + 1 ; BINARY ← BINARY DIV 2 END ;
RETURN(I) ;
END "LOG2" ;
INTEGER SVSHED ; comment, value of SHED before Alphabetizing began ;
BOOLEAN SIMPLE PROCEDURE STRLSS(INTEGER XI, YI) ;
BEGIN "STRLSS"
INTEGER XL, YL, MINL, L ; STRING X, Y ;
X ← SSTK[SVSHED + XI] ; Y ← SSTK[SVSHED + YI] ;
XL ← LENGTH(X) ; YL ← LENGTH(Y) ; MINL ← XL MIN YL ;
START_CODE "STRCOM"
LABEL NEXC, SAME, DIFF ;
MOVE 2, X ; MOVE 3, Y ; SKIPN 4, MINL ; JRST SAME ;
NEXC: ILDB 5, 2 ; LDB 5, UPCAS5 ; ILDB 6, 3 ; LDB 6, UPCAS6 ;
CAME 5, 6 ; JRST DIFF ; SOJG 4, NEXC ;
SAME: COMMENT SAME FOR FIRST MINL CHARACTERS ;
MOVE 5, XL ; MOVE 6, YL ; CAME 5, 6 ; JRST DIFF ;
COMMENT AND SAME LENGTH: ; MOVE 5, XI ; MOVE 6, YI ;
DIFF: CAML 5, 6 ; TDZA 1,1 ; MOVEI 1, -1 ; MOVEM 1, L ;
END ;
RETURN(L) ;
END "STRLSS" ;
PROCEDURE QUICKERSORT(INTEGER J, BASE) ;
BEGIN "QUICKERSORT" comment, Ascending SORT for ALFIZE ;
INTEGER I, K, Q, M, P, T, X ; INTEGER ARRAY UT,LT[1:LOG2(J+2)+1] ;
COMMENT Algorithm 271 (R. S. Scowen) CACM 8,11 (Nov. 1965) pp 669-670 ;
DEFINE A(L) = "ITBL[BASE+L]" ;
LABEL N, L, MM, PP ;
I ← M ← 1 ;
N: IF J-I > 1 THEN
BEGIN
P ← (J+I) DIV 2 ; T ← A(P) ; A(P) ← A(I) ; Q ← J ;
FOR K ← I + 1 THRU Q DO
BEGIN
IF STRLSS(T, A(K)) THEN
BEGIN
FOR Q ← Q DOWN K DO
BEGIN
IF STRLSS(A(Q), T) THEN
BEGIN
A(K) ↔ A(Q) ; Q ← Q - 1 ;
GO TO L ;
END ;
END ;
Q ← K - 1 ;
GO TO MM ;
END ;
L:
END ;
MM:
A(I) ← A(Q) ; A(Q) ← T ;
IF Q+Q > I+J THEN BEGIN LT[M]←I; UT[M]←Q-1; I←Q+1 END
ELSE BEGIN LT[M]←Q+1; UT[M]←J; J←Q-1 END ;
M ← M + 1 ;
GO TO N ;
END
ELSE IF I≥J THEN GO TO PP
ELSE BEGIN
IF STRLSS(A(J),A(I)) THEN A(I)↔A(J) ;
PP: M ← M - 1 ;
IF M > 0 THEN BEGIN I←LT[M]; J←UT[M]; GO TO N END ;
END ;
END "QUICKERSORT" ;
INTERNAL SIMPLE PROCEDURE DAPART ; IF ON THEN
BEGIN "DAPART"
DBREAK ; GLINEM ← 0 ; COMMENT ← TES 4/25/73 ; IF GROUPM=0 THEN RETURN ;
IF MOLESIDA THEN DPB(0,BELOWM(OLX)) ; GROUPM←0 ;
END "DAPART" ;
INTERNAL SIMPLE PROCEDURE MAKEPAGE(INTEGER HIGH, WIDE) ;
BEGIN "MAKEPAGE"
IDASSIGN("FRAMEIDA←CREATE(0,PFREC)", THISFRAME) ;
HIGHF ← HIGH; WIDEF ← WIDE;
END "MAKEPAGE" ;
INTERNAL SIMPLE PROCEDURE MAKEAREA(INTEGER ITSIX) ;
BEGIN "MAKEAREA"
INTEGER C, L, CS, LS, NCH, OCH ;
IF FULWIDE(ITSIX) THEN
BEGIN Comment Make frame width ;
OCH ← CHARCT(ITSIX) ; CHARCT(ITSIX) ← NCH ← IF FRAMEIDA THEN WIDEF ELSE FWIDE ;
COLWID(ITSIX) ← (COLWID(ITSIX) * NCH) DIV OCH ;
END ;
IF FULHIGH(ITSIX) THEN LINECT(ITSIX) ← IF FRAMEIDA THEN HIGHF ELSE FHIGH ;
L←OPEN_ACTIVE(ITSIX)←CREATE(0, AREC) ;
IF NULLAREAS THEN BEGIN IDASSIGN(AREAIDA←NULLAREAS,THISAREA) ; INA←LHRH(L,INA) END ;
IDASSIGN(AREAIDA ← L, THISAREA) ;
DEFA ← ITSIX ; STATA ← 0 ; INA ← LHRH(0, NULLAREAS) ; NULLAREAS ← AREAIDA ;
IDASSIGN("AAA←CREATE2(1, CS←COLCT(ITSIX)*2, 0, LS←LINECT(ITSIX)+((LINECT(ITSIX) DIV 2) MAX 8) ) ", AA) ;
ZEROWORDS(CS*(LS+1), AA[1,0]) ;
COMMENT FOR C ← 1 THRU CS DO FOR L ← 0 THRU LS DO AA[C,L] ← 0 ;
END "MAKEAREA" ;
FORWARD RECURSIVE PROCEDURE ASSUREAREA ;
INTERNAL SIMPLE PROCEDURE SEND(INTEGER PORTIX; STRING MESSAGE) ;
BEGIN "SEND"
INTEGER CH ;
IF 0≤ (CH ← PORCH(PORTIX)) THEN OUT(CH,MESSAGE)
ELSE IF CH=-1 THEN
BEGIN ASSUREAREA ; CH←FOOTSTR(AREAIXM); SSTK[CH]←SSTK[CH]&MESSAGE END
ELSE WARN(NULL,"Can't send to a passed PORTION:"&MESSAGE) ;
END "SEND" ;
INTERNAL RECURSIVE PROCEDURE STATEMENT ;
BEGIN "STATEMENT"
INTEGER LVL ; BOOLEAN VALID ;
LVL ← BLNMS ;
DO VALID ← CHUNK(VALID) UNTIL BLNMS≤LVL ;
END "STATEMENT" ;
STRING SIMPLE PROCEDURE ALFIZE(STRING FILENAME, LEFTRIGHT) ;
BEGIN "ALFIZE"
INTEGER SVIHIGH, SVSHIGH, CHAN, LEFT, RIGHT, N, I ; STRING S, KEY ;
SVSHED ← SHED ; SVIHIGH ← IHIGH ; SVSHIGH ← SHIGH ;
IF (CHAN←GETCHAN)<0 THEN RETURN(WARN(NULL,"No Channel to Alphabetize "&FILENAME)) ;
EOF ← 0 ; OPEN(CHAN, "DSK", 0, 2, 2, 150, BRC, EOF) ;
LOOKUP(CHAN, FILENAME, FLAG) ; IF FLAG THEN RETURN(WARN("=","No Generated file "&FILENAME)) ;
SETBREAK(LOCAL_TABLE, LEFTRIGHT&LF, NULL, "IS") ; LEFT ← LOP(LEFTRIGHT) ; RIGHT ← LOP(LEFTRIGHT) ; N ← 0 ;
DO BEGIN "SENDEE"
S ← INPUT(CHAN, TO_TB_FF_SKIP) ; IF EOF THEN DONE ; S ← S & TB ;
DO S ← S & INPUT(CHAN, LOCAL_TABLE) UNTIL BRC=LEFT ∨ BRC=LF ∨ EOF ;
IF BRC = LEFT THEN
BEGIN "KEY"
KEY ← NULL ; S ← S & LEFT ;
DO KEY ← KEY & INPUT(CHAN, LOCAL_TABLE) UNTIL BRC=RIGHT OR BRC=LF OR EOF ;
PUSHS(1,KEY) ; comment, Sort Key in SSTK ;
S ← S & KEY ;
IF BRC = RIGHT THEN
BEGIN
S ← S & RIGHT ;
DO S ← S & INPUT(CHAN, LOCAL_TABLE) UNTIL BRC = LF OR EOF ;
END ;
END "KEY" ;
PUTS(S&LF) ; comment, complete entry in STBL ;
N ← N + 1 ; PUTI(1, N) ; comment, Sort Tags in ITBL ;
END "SENDEE"
UNTIL EOF ;
QUICKERSORT(N, SVIHIGH) ;
CLOSIN(CHAN) ; FILENAME ← FILENAME[1 TO ∞-1] & "Z" ;
ENTER(CHAN, FILENAME, FLAG) ; comment, "---.PUZ" ;
IF FLAG THEN RETURN(WARN(NULL,"ENTER failed for Alphabetized File "&FILENAME)) ;
FOR I ← 1 THRU N DO OUT(CHAN, STBL[SVSHIGH + ITBL[SVIHIGH + I]]) ;
RELEASE(CHAN) ; SHED ← SVSHED ; IHIGH ← SVIHIGH ; SHIGH ← SVSHIGH ; RETURN(FILENAME) ;
END "ALFIZE" ;
INTERNAL SIMPLE PROCEDURE RECEIVE(INTEGER PORTIX; STRING ALPHABETIZE) ;
BEGIN "RECEIVE"
INTEGER CH ; STRING FIL ; LABEL TWICE ;
CASE (CH ← PORCH(PORTIX)) + 6 MIN 6 OF
BEGIN
ie -6 ; GO TO TWICE ;
ie -5 Only INSERTed ; IMPOSSIBLE("RECEIVE") ;
ie -4 ; TWICE: WARN(NULL,"Already RECEIVEd generated file for this PORTION") ;
ie -3 ; BEGIN "GENFILE"
FIL ← CVSTR(PORFIL(PORTIX)) & ".PUG" & JOBNO ;
IF FULSTR(ALPHABETIZE) THEN BEGIN FIL←ALFIZE(FIL,ALPHABETIZE) ; PORCH(PORTIX)←-6 END
ELSE PORCH(PORTIX) ← -4 ;
SWICHF(FIL) ; PAGESCAN(LAST) ← -PAGESCAN(LAST) ;
END "GENFILE" ;
ie -2 Never SENT ; BEGIN END ;
ie -1 ; BEGIN CH←FOOTSTR(AREAIXM); SWICH(SSTK[CH],-1,0); SSTK[CH]←NULL END ;
ie 0-15 ; IMPOSSIBLE("RECEIVE") ;
END ;
END "RECEIVE" ;
INTERNAL SIMPLE PROCEDURE PLACE(INTEGER NEWAREAIX) ;
COMMENT If No Place Area, AREAIXM=0. AREAIDA≠0 if STATUS= 0 or 1 ;
IF ON THEN
BEGIN "PLACE"
INTEGER FRM, ALLOW_FOR, MARGIX, FONTIX ;
IF IXTYPE(NEWAREAIX)≠AREATYPE THEN
BEGIN WARN("=","PLACE in non-area"); NEWAREAIX←IXTEXT END;
IF AREAIXM THEN
BEGIN TES 11/19/73 ;
TFONT(AREAIXM) ← THISFONT ;
OFONT(AREAIXM) ← OLDFONT ;
END ;
IF AREAIDA ∧ STATUS=1 THEN
BEGIN
COLA ← COL ; AA[COL,0] ← LHRH(COVERED,LINE) ; AA[PAL,0]←LHRH(COVERED,PINE) ; STATA←STATUS ;
XGENA ← XGENLINES; RKJ;
OVERA ← OVEREST ; TES 11/15/73;
IF AREAIXM=NEWAREAIX THEN RETURN
ELSE IF COL>COLS THEN BEGIN WARN("=","Can't PLACE inside footnotes!") ; RETURN END ;
END ;
IF XCRIBL AND AREAIXM NEQ NEWAREAIX THEN
BEGIN INTEGER DUMMY ;TES 11/15/73 ;
THISFONT ← TFONT(NEWAREAIX) ; OLDFONT ← OFONT(NEWAREAIX) ;
IF (DUMMY←FONTFIL[THISFONT])>0 THEN MAKEBE(DUMMY, CW) ;
END ;
AREAIXM←NEWAREAIX ;
IF (AREAIDA ← OPEN_ACTIVE(AREAIXM)) = 0 THEN MAKEAREA(AREAIXM)
ELSE BEGIN MAKEBE(AREAIDA, THISAREA) ; IDASSIGN(AAA, AA) ; END ;
IF (MARGIX ← MARGINS(AREAIXM)) = 0 THEN BEGIN LMARG ← 0 ; RMARG ← COLWID(AREAIXM) END
ELSE BEGIN LMARG ← LMARGX(MARGIX) ; RMARG ← RMARGX(MARGIX) END ;
ALLOW_FOR ← 2 * COLWID(AREAIXM) ;
IF ALLOW_FOR > LENGTH(OWL) THEN OWL ← OWL&SPS(ALLOW_FOR - LENGTH(OWL)) ;
COLS ← COLCT(AREAIXM) ; LINES ← LINECT(AREAIXM) ; STATUS ← STATA ;
IF STATUS=1 THEN
BEGIN "IT'S OPEN"
COL ← COLA ; PAL ← (COL+COLS-1) MOD (2*COLS) + 1 ; ie, Leg↔Foot;
LINE ← AA[COL,0] ; COVERED ← LH(LINE) ; LINE ← RH(LINE) ; PINE ← RH("AA[PAL,0]") ;
XGENLINES ← XGENA; RKJ;
OVEREST ← OVERA ; TES 11/15/73 ;
END "IT'S OPEN"
ELSE COL←PAL←LINE←COVERED←PINE←XGENLINES←OVEREST←0 ; RKJ ADDED XGENLINES;
TES ADDED OVEREST 11/15/73;
END "PLACE" ;
INTEGER PROCEDURE FIND_CHR(INTEGER CHR) ; COMMENT ADDED 2/20/73 TES ;
BEGIN "FIND_CHR"
INTEGER I, B ;
FOR I ← LENGTH(DEFN_BRC)-LDEFN_BRC STEP -1 UNTIL 1 DO
IF DEFN_BRC[I FOR 1] = CHR THEN
BEGIN B ← I ; DONE END ;
RETURN(B) ;
END "FIND_CHR" ;
INTERNAL SIMPLE PROCEDURE TURN(INTEGER CHR,FUN,ONOFF) ;
BEGIN "TURN"
INTEGER CODE, X, M, STDCHR ; BOOLEAN HADCHR, DEFD ; LABEL FIN ;
DEFD ← FALSE ; CODE ← LDB(SPCODE(CHR)) ; STDCHR ← LDB(SPCHAR(FUN)) ;
IF CHR=TB THEN
BEGIN
DPB(TABTAB ← IF ONOFF THEN FUN ELSE 0, SPCODE(CHR)) ;
GO TO FIN ;
END
ELSE IF ¬CODE THEN HADCHR ← FALSE
ELSE IF CODE=STDCHR AND ONOFF THEN GO TO FIN COMMENT ALREADY ON ;
ELSE IF ¬ONOFF ∨ ¬STDCHR THEN
BEGIN COMMENT REMOVE CHARACTER FROM BREAK TABLE STRING ;
HADCHR ← TRUE ; X ← LENGTH(TEXT_BRC) ;
START_CODE "FINDIT"
LABEL NEXC, DUN ;
MOVE 1, TEXT_BRC ; SKIPN 2, X ; JRST DUN ;
NEXC: ILDB 3,1 ; CAMN 3, CHR ; JRST DUN ; SOJG 2, NEXC ;
DUN: MOVEM 2, M ;
END ;
TEXT_BRC ← TEXT_BRC[1 TO X-M] & TEXT_BRC[X-M+2 TO X] ;
END ;
IF ONOFF THEN
BEGIN "ON" COMMENT REV. 2/20/73 TES ;
IF STDCHR ∧ STDCHR < LBRACK THEN TEXT_BRC ← TEXT_BRC & CHR ;
IF FUN="{" ∧ ¬FIND_CHR(CHR) THEN
BEGIN
DEFN_BRC ← CHR & DEFN_BRC ;
DEFD ← TRUE ;
END ;
DPB(STDCHR, SPCODE(CHR)) ;
END "ON"
ELSE BEGIN "OFF" COMMENT REV. 2/20/73 TES ;
INTEGER I ;
IF FUN = "{" ∧ (I ← FIND_CHR(CHR)) THEN
BEGIN
DEFN_BRC ← DEFN_BRC[1 TO I-1] & DEFN_BRC[I+1 TO ∞] ;
DEFD ← TRUE ;
END ;
IF HADCHR THEN DPB(0, SPCODE(CHR)) ;
END "OFF" ;
SETBREAK(TEXT_TBL, TEXT_BRC&SIG_BRC, NULL, "IS") ;
IF DEFD THEN SETBREAK(DEFN_TABLE, DEFN_BRC, NULL, "IS") ;
FIN:
IF ONOFF ≤ 0 THEN ISTK[PUSHI(TURNWDS, TURNTYPE) - 1] ←
CHR LSH 7 LOR (IF CHR=TB THEN CODE ELSE CHARSP[CODE FOR 1]) ;
END "TURN" ;
INTERNAL SIMPLE PROCEDURE BEGINBLOCK(BOOLEAN MIDPGPH; INTEGER ECASE ; STRING NAME) ;
BEGIN "BEGINBLOCK"
INTEGER MIX, I, X ;
IF ECASE = 0 THEN STARTS ← STARTS + 1 comment START...END ;
ELSE IF ECASE=-1 THEN ENDCASE←1 comment, ONCE merging with BEGIN ;
ELSE BEGIN "NOT CLUMP"
DBREAK ; DEPTH ← DEPTH + 1 ; MIX ← PUSHI(MODEWDS, MODETYPE) ;
ARRBLT(ISTK[MIX-MODEWDS], BREAKM, MODEWDS) ;
PUSHI(28, TABTYPE) ; I ← 0 ;
DO ISTK[MIX←MIX+1] ← X ← TABSORT[I←I+1] UNTIL X=TWO(33) ;
ISTK[MIX+1] ← ISTK[IHED] ; OLDIHED ← IHED;TES 11/15/73; IHED ← MIX + 1 ;
IF MIDPGPH THEN
BEGIN "SAVE FILL PARAMS"
X ← MIDWDS + 1 ; PUSHI(X, MIDTYPE) ;
ILBF ← CVASC(LBF) ; ARRBLT(ISTK[IHED-X], THISTYPE, X-1) ;
ISTK[IHED-1]←PUSHS(1, THISWD) ; NOPGPH ← TRUE ; PLBL←BRKPLBL←-TWO(13) ;
END "SAVE FILL PARAMS" ;
ENDCASE ← ECASE ; STARTS ← 0 ;
END "NOT CLUMP" ;
IF BLNMS=MAXBLNMS THEN WARN(NULL, "DEEP BLOCK NEST/POSSIBLY INFINITE RECURSION");
IF NAME ≠ ALTMODE THEN BLKNAMES[BLNMS←BLNMS+1] ← NAME ; comment not for ONCE! ;
END "BEGINBLOCK" ;
INTERNAL BOOLEAN SIMPLE PROCEDURE FINDINSET(INTEGER HM) ;
BEGIN "FINDINSET"
INTEGER ARE ;
LLSCAN(LEADRESPS, NEXT_RESP, "(ARE ← CLUE(LLTHIS)) ≥ HM" ) ;
RETURN(LLTHIS ∧ ARE = HM) ;
END "FINDINSET" ;
INTERNAL INTEGER SIMPLE PROCEDURE FINDSIGNAL(INTEGER SIGASC) ;
BEGIN "FINDSIGNAL"
INTEGER CHR ;
CHR ← SIGASC LSH -29 ;
LLSCAN(SIGNALD[CHR], NEXT_RESP, "SIGASC = SIGNAL(LLTHIS)" ) ;
RETURN(LLTHIS) ;
END "FINDSIGNAL" ;
INTERNAL INTEGER SIMPLE PROCEDURE FINDTRAN(INTEGER UASYMB, VARI) ;
BEGIN "FINDTRAN"
LLSCAN(WAITRESP, NEXT_RESP, "CLUE(LLTHIS) = UASYMB ∧ (VARI=0 ∨ VARIETY(LLTHIS)=VARI)" ) ;
RETURN(LLTHIS) ;
END "FINDTRAN" ;
INTERNAL SIMPLE PROCEDURE COMPMAXIMS ;
BEGIN "COPYMAXIMS"
FMAXIM ← (RMARG-RIGHTIM)-LMARG ;
NMAXIM ← COLWID(IF AREAIXM THEN AREAIXM ELSE IXTEXT)-LMARG ;
MAXIM ← IF FILL THEN FMAXIM ELSE NMAXIM ;
END "COPYMAXIMS" ;
INTERNAL SIMPLE PROCEDURE BIND(INTEGER LOC, NEWIX) ;
BEGIN "BIND"
IF LOC = SYMTEXT THEN IXTEXT ← NEWIX
ELSE IF LOC = SYMPAGE THEN BEGIN IXPAGE ← NEWIX ; PATPAGE ← PATT_STRS(IXPAGE) END ;
DPB(NEWIX, IXN(LOC)) ; IF LDB(TYPEN(LOC)) ≥ 11 THEN DPB(LOC, BIXNUM(NEWIX)) ;
END "BIND" ;
INTERNAL RECURSIVE BOOLEAN PROCEDURE ENDBLOCK ;
IF BLNMS<0 ∧ LAST>2 THEN BEGIN WARN("=","Extra END ignored"); BLNMS←0; RETURN(FALSE) END ELSE
BEGIN "ENDBLOCK"
INTEGER TYP, OLD, MIX, I, X, L1, L2, PASSED, NARROWED ; STRING S ;
DBREAK ; NARROWED ← PASSED ← FALSE ;
DO COMMENT Skip through ISTK restoring former state and terminating INDENT etc. ;
BEGIN "ISTK ENTRY"
TYP ← IXTYPE(IHED) ;
CASE TYP - 12 OF
BEGIN COMMENT BY TYPE ;
[AREATYPE-12] IF ¬DISD(IHED) THEN BEGIN CLOSEAREA(IHED,TRUE) ; NUMBER[LDB(BIXNUM(IHED))]←0 END;
[UNITTYPE-12] IF ¬DISD(IHED) THEN BEGIN CLOSEUNIT(IHED,TRUE) ; NUMBER[LDB(BIXNUM(IHED))]←0 END;
[MACROTYPE-12] BEGIN SSTK[BODY(IHED)]←NULL;TES 11/15/73; NUMBER[LDB(BIXNUM(IHED))] ← 0 END;
[RESPTYPE-12] BEGIN "POP RESP"
X ← CLUE(IHED) ; I ← VARIETY(IHED) ; OLD ← OLD_RESP(IHED) ;
SSTK[BODY(IHED)] ← NULL ; TES 11/15/73 ;
CASE I-1 MIN 2 OF
BEGIN "BY VARIETY"
ie 0 ... Phrase ;
TES 11/15/73 removed this case ;
ie 1 ... Inset ;
IF FINDINSET(X) THEN
IF ¬OLD THEN LLSKIP(LEADRESPS, NEXT_RESP)
ELSE BEGIN
NEXT_RESP(OLD) ← LLPOST ;
IF LLPREV<0 THEN LEADRESPS←OLD ELSE NEXT_RESP(LLPREV) ← OLD ;
END ;
ie 2 ... Signal ;
BEGIN "SIGNAL"
X ← SIGNAL(IHED) ; L1 ← X LSH -29 ;
IF FINDSIGNAL(X) THEN
IF ¬OLD THEN BEGIN
S ← NULL ;
WHILE FULSTR(SIG_BRC) ∧ (L2←LOP(SIG_BRC))≠L1 DO S←S&L2;
SIG_BRC ← S & SIG_BRC ;
LLSKIP("SIGNALD[L1]", NEXT_RESP) ; COMMENT JAN 8 1973 ;
END
ELSE BEGIN
NEXT_RESP(OLD) ← LLPOST ;
IF LLPREV<0 THEN SIGNALD[L1]←OLD ELSE NEXT_RESP(LLPREV) ← OLD ;
END ;
END "SIGNAL" ;
ie 3, 4 ... After, Before ;
IF FINDTRAN(X,I) THEN
IF ¬OLD THEN LLSKIP(WAITRESP, NEXT_RESP)
ELSE BEGIN
NEXT_RESP(OLD) ← LLPOST ;
IF LLPREV<0 THEN WAITRESP←OLD ELSE NEXT_RESP(LLPREV) ← OLD ;
END ;
END "BY VARIETY" ;
END "POP RESP" ;
[MARGTYPE-12] IF OLD←AREAX(IHED) THEN
BEGIN NARROWED ← TRUE ; MARGINS(OLD) ← X ← OLD_MARGX(IHED) ;
LMARG ← IF X THEN LMARGX(X) ELSE 0 ;
RMARG ← IF X THEN RMARGX(X) ELSE COLWID(OLD) ;
END ;
[TURNTYPE-12] IF (OLD←ISTK[IHED-1])≥0 THEN TURN(OLD LSH -7 , OLD LAND '177 , 1 ) ;
[MODETYPE-12] BEGIN
I ← GROUPM ; OLD ← AREAIXM ; X ← GLINEM ; TES 11/15/73 REMOVED J ← THISFONT ;
ARRBLT(BREAKM, ISTK[IHED-MODEWDS], MODEWDS) ; OLD ↔ AREAIXM ;
TES 11/14/73 removed IF J ≠ THISFONT THEN SELECTFONT(THISFONT);
IF I THEN IF ¬GROUPM THEN DAPART
ELSE IF GLINEM=0 THEN GLINEM ← X ;
COMMENT ADDED THIS ↑ LINE 2/20/73 ;
IF ¬PASSED ∧ NARROWED THEN NOPGPH ← 1 ;
JUSTIFY ← FILL ∧ ADJUST ∨ JUSTJUST ;
PLACE(IF OLD THEN OLD ELSE IXTEXT);
COMPMAXIMS ;
END ;
[NUMTYPE-12] BEGIN
OLD ← OLD_NUMBER(IHED) ;
NUMBER[X ← LDB(SYMBOLWD(OLD))] ← OLD ;
IF X = SYMPAGE THEN BEGIN IXPAGE ← LDB(IXN(X)) ; PATPAGE ← PATT_STRS(IXPAGE) END
ELSE IF X = SYMTEXT THEN IXTEXT ← LDB(IXN(X)) ;
END ;
[TABTYPE-12] BEGIN
MIX ← IXOLD(IHED) ; I ← 0 ;
DO TABSORT[I←I+1] ← X ← ISTK[MIX←MIX+1] UNTIL X=TWO(33) ;
END ;
[MIDTYPE-12] BEGIN
IF LENGTH(INPUTSTR)>1 THEN WARN("Imbalance","Unbalanced Response|Footnote! "&SOMEINPUT) ;
THISWD←SSTK[ISTK[IHED-1]] ; OLD←PLBL ;
ARRBLT(THISTYPE,ISTK[X←IXOLD(IHED)+1],IHED-X-1) ;
LBF ← CVSTR(ILBF) ;
WHILE FULSTR(LBF) ∧ LBF[∞ FOR 1]=0 DO LBF←LBF[1 TO ∞-1] ;
IF OLD ≠ -TWO(13) THEN
BEGIN COMMENT UNDEFINED PAGE LABELS -- PASS UP TO OUTER BLOCK ;
X ← OLD ;
DO BEGIN L1←X ; X←IF X<0 THEN NUMBER[-X] ELSE ITBL[X] END UNTIL X=-TWO(13) ;
IF L1<0 THEN NUMBER[-L1] ← PLBL ELSE ITBL[L1] ← PLBL ;
PLBL ← OLD ;
END ;
INPUTSTR←NULL ; IF THATISFULL THEN RDENTITY ELSE INPUTSTR←SWICHBACK ; PASSED←TRUE ;
END ;
[FONTYPE-12] IF (OLD←AREAX(IHED)) AND XCRIBL THEN TES 11/15/73 ;
BEGIN
FONTS(OLD) ← OUTERX(IHED) ;
TFONT(OLD) ← THISFONTX(IHED) ;
OFONT(OLD) ← OLDFONTX(IHED) ;
IF OLD = AREAIXM THEN
BEGIN
THISFONT ← TFONT(OLD) ;
OLDFONT ← OFONT(OLD) ;
IDASSIGN("FONTFIL[THISFONT]", CW) ;
END ;
END
END ; COMMENT BY TYPE ;
IHED ← IXOLD(IHED) ;
END "ISTK ENTRY"
UNTIL TYP=MODETYPE ∨ IHED=0 ;
DEPTH ← DEPTH - 1 ;
RETURN(PASSED) ;
END "ENDBLOCK" ;
RECURSIVE PROCEDURE TOEND ;
BEGIN "TOEND"
BOOLEAN VALID ;
VALID ← TRUE ;
DO VALID ← CHUNK(VALID) UNTIL MYEND ;
MYEND ← FALSE ;
END "TOEND" ;
INTERNAL SIMPLE PROCEDURE ANYEND(BOOLEAN CHECK) ;
BEGIN "ANYEND"
STRING BLOCKNAME ;
BLOCKNAME ← IF BLNMS<0 THEN "!MISSING!" ELSE BLKNAMES[BLNMS] ;
BLNMS ← (BLNMS MAX 0) - 1 ;
IF CHECK ∧ THATISCON THEN
BEGIN
PASS ;
LOPP(THISWD) ;
IF ¬ITSV(BLOCKNAME) THEN WARN("Mismatched BEGIN-END","BEGIN """&BLOCKNAME&""" but END """&THISWD&"""") ;
END
ELSE IF FULSTR(BLOCKNAME) THEN WARN("Mismatched BEGIN-END","BEGIN """&BLOCKNAME&""" but END <blank>") ;
END "ANYEND" ;
INTERNAL RECURSIVE PROCEDURE BEGINEND ;
BEGIN ANYEND(TRUE) ; IF ENDBLOCK THEN WARN("=","Missed END in Response|Footnote") ELSE PASS END ;
INTERNAL RECURSIVE PROCEDURE ONCEEND ;
IF ENDBLOCK THEN WARN("=","Missing END in Response|Footnote") ELSE BEGINEND ;
INTERNAL RECURSIVE PROCEDURE STARTEND ;
BEGIN ANYEND(TRUE) ; STARTS ← STARTS - 1 ; PASS ; END ;
INTERNAL RECURSIVE PROCEDURE RESPOND(INTEGER IX) ;
IF ON THEN
BEGIN "RESPOND"
INTEGER ARGS ; STRING COM_ENT ;
ARGS ← IF VARIETY(IX) = 2 THEN NUMARGS(IX) ELSE 0 ;
IF VARIETY(IX) < 3 ∧ IX ≠ SIGNALD[FF] THEN
BEGIN "AT"
SWICH(IF IX=SIGNALD[CR] THEN SSTK[BODY(IX)] ELSE ALTMODE&SSTK[BODY(IX)]&RCBRAK, -1, ARGS) ;
RETURN ;
END "AT" ;
GENSYM←GENSYM+1 ; COM_ENT ← "!?@"&CVS(GENSYM) ;
BEGINBLOCK( TRUE, 3 , COM_ENT ) ;
SWICH(SSTK[BODY(IX)]&(CRLF&TB&TB&"END """)&COM_ENT&""";;", -1, ARGS) ;
PASS ; TOEND ;
END "RESPOND" ;
INTERNAL RECURSIVE PROCEDURE RESPEND ;
BEGIN ANYEND(TRUE) ; PASS ; IF ENDBLOCK THEN MYEND←TRUE ELSE WARN("=","Extra END") ; END ;
INTERNAL SIMPLE PROCEDURE OPENFRAME ;
BEGIN "OPENFRAME"
MAKEPAGE(FHIGH,FWIDE);
OLXX ← OLMAX ; comment Total of all areas now declared ; OLX ← 0 ;
IDASSIGN("OWLSF←OWLSIDA←CREATE(0,OLXX)", OWLS);
IDASSIGN("MOLESF←MOLESIDA←CREATE(0,OLXX)", MOLES);
IDASSIGN("SHORTF←SHORTIDA←CREATE(0,OLXX)", SHORT);
END "OPENFRAME" ;
INTERNAL SIMPLE PROCEDURE OPENPAGE ;
DO BEGIN OPENFRAME ; IDASSIGN(OLDPGIDA ← FRAMEIDA, OLDPAGE) ;
PAGEVAL ← PATT_VAL(PATPAGE) ;
IF FINDTRAN(SYMPAGE, 4) THEN RESPOND(LLTHIS) ;
END UNTIL FRAMEIDA ;
SIMPLE PROCEDURE REMNULLS ;
BEGIN "REMNULLS"
INTEGER L, R, I ;
L ← LH(INA) ; R ← RH(INA) ;
IF L ∨ R THEN
BEGIN
I ← AREAIDA ;
IF L THEN BEGIN IDASSIGN(AREAIDA←L,THISAREA); DPB(R, H2(INA)) ; END ELSE NULLAREAS ← R ;
IF R THEN BEGIN IDASSIGN(AREAIDA←R,THISAREA); DPB(L, H1(INA)) ; END ;
IDASSIGN(AREAIDA ← I, THISAREA) ;
END
ELSE NULLAREAS ← 0 ;
END "REMNULLS" ;
INTERNAL RECURSIVE PROCEDURE OPENAREA(INTEGER ITSIX) ;
BEGIN "OPENAREA"
INTEGER X, PREV, NEX ;
IF FRAMEIDA=0 THEN OPENPAGE ; PLACE(ITSIX) ; IF STATUS=1 THEN RETURN ; REMNULLS ;
INA ← FRAMEIDA ;
PREV ← 0 ; NEX ← ARF ; X ← AREAIDA ; COMMENT KEEP AREAS SORTED BY LEFT EDGE ;
IF CHAR1(ITSIX) > 1 THEN WHILE NEX DO
BEGIN
IF NEX=X THEN
BEGIN COMMENT PREVENT INEXPLICABLE ENDLESS LOOP 2/27/73 TES;
WARN("CAN'T REOPEN", "CAN'T REOPEN CLOSED AREA " &
SYM[LDB(BIXNUM(ITSIX))] ) ;
RETURN ;
END ;
IDASSIGN(AREAIDA←NEX, THISAREA) ;
IF DEFA THEN IF CHAR1("DEFA") ≥ CHAR1(ITSIX) THEN DONE ELSE BEGIN END
ELSE BEGIN IDASSIGN(AAA,AA) ; IF AA[1,0]≥CHAR1(ITSIX) THEN DONE ; END ;
PREV ← AREAIDA ; NEX ← ARA ;
END ;
IF PREV THEN
BEGIN TES AND DCS REVISED 9/24/73@SU, 10/25/73@PARC ;
IDASSIGN(AREAIDA←PREV, THISAREA) ; TES ADDED THIS ;
ARA ← X ;
END
ELSE ARF ← X ;
IDASSIGN(AREAIDA←X, THISAREA) ; ARA ← NEX ;
STATA ← STATUS←1 ; COL ← 1 ; PAL ← COLS + 1 ;
IF FINDTRAN(LDB(BIXNUM(ITSIX)), 4) THEN RESPOND(LLTHIS) ; comment BEFORE areaname ... ;
END "OPENAREA" ;
INTERNAL RECURSIVE PROCEDURE CLOSET(INTEGER ITSIX; BOOLEAN CLOSEIT, DISDECLAREIT) ;
BEGIN "CLOSET"
IF DISDECLAREIT THEN DBREAK ;
IF FINDTRAN(LDB(BIXNUM(ITSIX)), 3) THEN
IF CLOSEIT ∧ ITSIX≠IXPAGE ∧ comment AFTER ;
(IXTYPE(ITSIX)=AREATYPE ∨ FULSTR("CTR_VAL(""PATT_STRS(ITSIX)"")")) THEN RESPOND(LLTHIS) ;
IF DISDECLAREIT THEN DISD(ITSIX) ← -1 ;
END "CLOSET" ;
INTERNAL RECURSIVE PROCEDURE CLOSEAREA(INTEGER ITSIX; BOOLEAN DISDECLAREIT) ;
BEGIN "CLOSEAREA"
INTEGER SAVAR, C, WC, NC, CC, LEFC ; BOOLEAN NORESP ;
NORESP ← ITSIX < 0 ; ITSIX ← ABS(ITSIX) ;
IF DISDECLAREIT THEN OLMAX ← OLMAX - LINECT(ITSIX)*COLCT(ITSIX) ;
IF OPEN_ACTIVE(ITSIX) = 0 THEN IF DISDECLAREIT THEN CLOSET(ITSIX, FALSE, TRUE)
ELSE BEGIN END
ELSE BEGIN SAVAR←AREAIXM; PLACE(ITSIX); IF STATUS=0 THEN REMNULLS ; STATA ← STATUS←2;
ULLA ← LINE1(ITSIX) ; AA[1,0] ← LEFC ← CHAR1(ITSIX) ;
IF (NC ← COLCT(ITSIX)) > 1 THEN
BEGIN
WC ← COLWID(ITSIX) ; CC ← CHARCT(ITSIX) ;
FOR C ← 2 THRU NC DO AA[C,0] ← LEFC + ((C-1)*(CC-WC)) DIV (NC-1) ;
END ;
LINECA ← LINECT(ITSIX) ; COLCA ← NC ;
IF ¬NORESP THEN CLOSET(ITSIX, TRUE, DISDECLAREIT) ;
IF DISDECLAREIT THEN BEGIN STATA ← STATUS←3 ; DEFA ← 0 END ;
OPEN_ACTIVE(ITSIX) ← AREAIDA ← 0 ;
IF SAVAR ∧ ¬DISDECLAREIT ∧ SAVAR ≠ ITSIX THEN PLACE(SAVAR) ELSE BEGIN AREAIXM←0; STATUS←-1 END ;
END ;
END "CLOSEAREA" ;
INTERNAL RECURSIVE PROCEDURE CLOSEUNIT(INTEGER ITSIX; BOOLEAN DISDECLAREIT) ;
BEGIN "CLOSEUNIT"
INTEGER STRS, PP ;
CLOSET(ITSIX, TRUE, DISDECLAREIT) ;
IF DISDECLAREIT THEN
BEGIN
IF (PP ← PARENT(ITSIX)) THEN
BEGIN
LLSCAN("SON(PP)", BROTHER, LLTHIS=ITSIX) ;
LLSKIP("SON(PP) ", BROTHER) ;
END ;
STRS ← PATT_STRS(ITSIX) ;
PATT_VAL(STRS)←PREFIX(STRS)←INFIX(STRS)←SUFFIX(STRS)←CTR_VAL(STRS)←NULL ;
IF STRS=SHED THEN SHED←SHED-5 ;
END ;
END "CLOSEUNIT" ;
INTERNAL SIMPLE PROCEDURE DISDECLARE(INTEGER SYMB, OLDTYPE, OLDIX) ;
IF ON THEN
CASE OLDTYPE OF
BEGIN
[LOCALTYPE] BEGIN SSTK[OLDIX]←NULL; IF IX=SHED THEN SHED←SHED-1 END ;
[INTERNTYPE] WARN("=",SYM[SYMB]&" Redeclared") ;
[AREATYPE] CLOSEAREA(OLDIX,TRUE);
[UNITTYPE] CLOSEUNIT(OLDIX,TRUE) ;
[14]
END ;
INTERNAL INTEGER SIMPLE PROCEDURE DECLARE(INTEGER LOC, NEWTYPE) ;
IF ON THEN
BEGIN "DECLARE"
INTEGER NEWDEPTH, OLDDEPTH ; LABEL PURGE ;
BYTEWD ← NUMBER[LOC] ;
NEWDEPTH ← CASE NEWTYPE OF (0,1,DEPTH,0,DEPTH,0,0,0,0,0,1,DEPTH,DEPTH,DEPTH,DEPTH) ;
IF LOC = SYMTEXT ∧ NEWTYPE ≠ AREATYPE ∨ LOC = SYMPAGE ∧ NEWTYPE ≠ UNITTYPE THEN
BEGIN
WARN("=",SYM[LOC] & " may only be type " & (IF LOC=SYMTEXT THEN "AREA" ELSE "UNIT")) ;
GO TO PURGE ;
END ;
IF LDB(TYPEWD(BYTEWD)) THEN
IF (OLDDEPTH ← LDB(DEPTHWD(BYTEWD))) < 1 THEN
BEGIN
WARN("=","YOU MAY NOT REDECLARE RESERVED WORD " & SYM[LOC]) ;
PURGE: LOC ← SYMNUM("(Purged)" & SYM[LOC]) ;
END
ELSE IF OLDDEPTH < NEWDEPTH THEN
BEGIN
PUSHI(NUMWDS, NUMTYPE) ;
OLD_NUMBER(IHED) ← BYTEWD ;
END
ELSE IF OLDDEPTH = 1 THEN
BEGIN
WARN("=","YOU MAY NOT REDECLARE" & SYM[LOC] & ", A GLOBAL VARIABLE OR PORTION") ;
GO TO PURGE ;
END
ELSE IF OLDDEPTH=NEWDEPTH THEN
DISDECLARE(LOC, LDB(TYPEWD(BYTEWD)), LDB(IXWD(BYTEWD)))
ELSE WARN("=","GLOBAL " & SYM[LOC] & " REDECLARING LOCAL") ;
NUMBER[LOC] ← (NEWDEPTH ROT -5) LOR (LOC LSH 18) LOR (NEWTYPE LSH 14) ;
RETURN(LOC) ;
END "DECLARE" ;
INTERNAL STRING SIMPLE PROCEDURE VASSIGN(INTEGER VSYMB, VTYPE, VIX; STRING VAL) ;
BEGIN "VASSIGN" comment, NAME←VAL ;
SIMPLE PROCEDURE RDONLY(STRING IV) ; WARN("=","The value of "&IV&" is read-only") ;
IF ON THEN CASE VTYPE OF
BEGIN COMMENT BY TYPE ;
[0] BIND(VSYMB←DECLARE(VSYMB, GLOBALTYPE), PUTS(VAL)) ; ie Undeclared identifier ;
[GLOBALTYPE] STBL[VIX] ← VAL ;
[LOCALTYPE] SSTK[VIX] ← VAL ;
[INTERNTYPE] CASE VIX OF
BEGIN COMMENT INTERNAL ;
ie 0 ... LINES ; RDONLY("LINES") ;
ie 1 ... COLUMNS; RDONLY("COLUMNS") ;
ie 2 ... ! ; ! ← VAL ;
ie 3 ... SPREAD ; SPREADM ← CVD(VAL) ;
ie 4 ... FILLING; RDONLY("FILLING") ;
ie 5 ... _SKIP_ ; MANUS_SKIP_ ← CVD(VAL) ;
ie 6 ... _SKIPL_; DPB(CVD(VAL), H1(MANUS_SKIP_)) ;
ie 7 ... _SKIPR_; DPB(CVD(VAL), H2(MANUS_SKIP_)) ;
ie 8 ... NULL ; RDONLY("NULL") ;
ie 9 ... ∞ ; RDONLY("∞") ;
ie 10... FOOTSEP; FOOTSEP ← VAL ;
ie 11... TRUE ; RDONLY("TRUE") ;
ie 12... FALSE ; RDONLY("FALSE") ;
ie 13... INDENT1; FIRSTIM ← CVD(VAL) ;
ie 14... INDENT2; RESTIM ← CVD(VAL) ;
ie 15... INDENT3; BEGIN RIGHTIM ← CVD(VAL) ; COMPMAXIMS END ;
ie 16... LMARG ; BEGIN LMARG ← CVD(VAL) MAX 0 MIN
COLWID(IF AREAIXM THEN AREAIXM ELSE IXTEXT)-1 ; COMPMAXIMS END ;
ie 17... RMARG ; BEGIN RMARG ← CVD(VAL) MAX 1 MIN
COLWID(IF AREAIXM THEN AREAIXM ELSE IXTEXT) ; COMPMAXIMS END ;
ie 18... CHAR ; RDONLY("CHAR") ;
ie 19... CHARS ; RDONLY("CHARS") ;
ie 20... LINE ; RDONLY("LINE") ;
ie 21... COLUMN ; RDONLY("COLUMN") ;
ie 22... TOPLINE; RDONLY("TOPLINE") ;
ie 23... XCRIBL ; RDONLY("XCRIBL") ;
ie 24... CHARW ; CHARW ← CVD(VAL) ;
ie 25... XGENLINES; XGENLINES ← CVD(VAL) ;
ie 26... UNDERLINE ; VUNDERLINE ← VAL ; TES 10/22/73 ;
ie 27... THISDEVICE ; RDONLY("DEVICE") ; TES 11/15/73
ie 28... THISFONT ; RDONLY("THISFONT") ; TES 11/15/73 ;
END ; COMMENT INTERNAL ;
[MANTYPE] WARN("Improper use of `←'","← after reserved word "&SYM[VSYMB]&" -- assignment ignored") ;
[PORTYPE] WARN("=","← after PORTION NAME "&SYM[VSYMB]) ;
[PUNITTYPE] PATT_VAL("PATT_STRS(VIX)") ← VAL ;
[AREATYPE] WARN("=","← after Area NAME "&SYM[VSYMB]) ;
[UNITTYPE] CTR_VAL("PATT_STRS(VIX)") ← VAL
END ; COMMENT BY TYPE ;
RETURN(VAL) ;
END "VASSIGN" ;
INTERNAL SIMPLE PROCEDURE ASSIGN(STRING NAME, VAL) ;
VASSIGN(SIMNUM(NAME), 0, SYMIX, VAL) ;
INTERNAL SIMPLE PROCEDURE NOPORTION ;
BEGIN "NOPORTION"
STRING IFIL ; INTEGER PIX ;
WARN("=","No PORTION Declaration Found") ;
IFIL ← "PUI"&CVS(INTERS←INTERS+1) ; THISPORT ← PIX ← PUTI(4, -2) ;
PORINT(PIX) ← CVASC(IFIL) ; PORSEQ(SEQPORT) ← PIX ; PORSEQ(SEQPORT←PIX) ← 0 ;
PORTS ← PORTS + 1 ; INTER ← WRITEON(TRUE, IFIL & ".PUI") ; SINTER ← WRITEON(FALSE, IFIL & "S.PUI") ;
END "NOPORTION" ;
STRING SIMPLE PROCEDURE CVALF(INTEGER ALFABET, VAL) ;
BEGIN "CVALF" COMMENT handles 1aAiI conversions ;
STRING S, A ; INTEGER I ;
PRELOAD_WITH NULL, "i", "ii", "iii", "iv", "v", "vi", "vii", "viii", "ix",
NULL, "x", "xx", "xxx", "xl", "l", "lx", "lxx", "lxxx", "xc",
NULL, "c", "cc", "ccc", "cd", "d", "dc", "dcc", "dccc", "cm" ;
OWN STRING ARRAY LOWROMAN[0:2, 0:9] ;
PRELOAD_WITH NULL, "I", "II", "III", "IV", "V", "VI", "VII", "VIII", "IX",
NULL, "X", "XX", "XXX", "XL", "L", "LX", "LXX", "LXXX", "XC",
NULL, "C", "CC", "CCC", "CD", "D", "DC", "DCC", "DCCC", "CM" ;
OWN STRING ARRAY UPROMAN[0:2, 0:9] ;
DEFINE BEG = "WHILE VAL DO BEGIN", OOPS = "WARN(""="",""I only know roman numerals upto 1000, sorry"")" ;
IF VAL = 0 THEN RETURN("0") ;
IF VAL<0 THEN BEGIN S ← "-" ; VAL ← ABS(VAL) END ELSE S ← NULL ;
A ← NULL ; I ← -1 ;
CASE ALFABET - 1 OF
BEGIN
ie 1 ... "1" ; A ← CVS(VAL) ;
ie 2 ... "i" ; IF VAL < 1000 THEN BEG A ← LOWROMAN[I←I+1, VAL MOD 10]&A ;
VAL← VAL DIV 10 END ELSE OOPS ;
ie 3 ... "I" ; IF VAL < 1000 THEN BEG A ← UPROMAN[I←I+1, VAL MOD 10]&A ;
VAL← VAL DIV 10 END ELSE OOPS ;
ie 4 ... "a" ; BEG A ← ("a" + (VAL-1) MOD 26)&A ; VAL ← VAL DIV 26 END ;
ie 5 ... "A" ; BEG A ← ("A" + (VAL-1) MOD 26)&A ; VAL ← VAL DIV 26 END ;
END ;
RETURN(S & A) ;
END "CVALF" ;
INTEGER SIMPLE PROCEDURE CHRSALF(INTEGER INT, ALFABET) ;
BEGIN "CHRSALF"
INTEGER LABS, LSIGN ; STRING STR ; PRELOAD_WITH [2]3,2,[5]1,[2]0 ; OWN INTEGER ARRAY L[0:9] ;
LSIGN ← IF INT < 0 THEN 1 ELSE 0 ; INT ← ABS(INT) ; STR ← CVS(INT) ;
CASE ALFABET DIV 2 OF
BEGIN
ie 1 ... "1" ; LABS ← LENGTH(STR) ;
ie 2 ... i,I ; LABS ← 4*LENGTH(STR) - L[STR-"0"] ; comment, Believe-it-or-Not ;
ie 3 ... a,A ; LABS ← LENGTH(CVALF(ALFABET, INT)) ;
END ;
RETURN(LABS + LSIGN) ;
END "CHRSALF" ;
SIMPLE PROCEDURE FIXFRAME(INTEGER FRIDA) ;
BEGIN "FIXFRAME"
IF AREAIDA ∧ STATUS=1 THEN PLACE(AREAIXM) ; COMMENT BE SURE LINE,PINE STORED IN AA ;
MOLES[0] ← OLX ;
IDASSIGN(FRAMEIDA ← FRIDA, THISFRAME) ;
IDASSIGN("OWLSIDA ← OWLSF", OWLS) ;
IDASSIGN("MOLESIDA ← MOLESF", MOLES) ;
IDASSIGN("SHORTIDA ← SHORTF", SHORT) ;
OLX ← MOLES[0] ; AREAIDA ← 0 ;
END "FIXFRAME" ;
INTERNAL PROCEDURE FINPAGE ;
BEGIN "FINPAGE" COMMENT ***T EMPO RA RY V ERS I ON -- No Boxes **** ;
INTEGER A, CS, LS, C, L, X, LB, LBPAGE, LINK, LINENO, FOOTLINE1, F, OWLINE ;
INTEGER NULINE, NUPINE, NUINE, NLFOOT, NPFOOT, NFOOT, NAREA ;
IF EXNEXTPAGE THEN BEGIN WARN("=","Response to PAGE change called NEXT PAGE again.") ; RETURN END ;
EXNEXTPAGE ← TRUE ;
BEGIN "PAGEOUT"
COMMENT PASS 1 OUTPUT FORMAT FOR EACH PAGE :
Height Width
For each area:
UpperLine NumCols NumLines
For each column:
LeftChar
For each non-null line: LineNo SHORTM Index of PUInS.PUI line
0
-10
;
IF OLDPGIDA ≠ FRAMEIDA THEN BEGIN WARN("=","FRAME≠PAGE at end of page"); FIXFRAME(OLDPGIDA) END ;
IF AREAIDA ∧ AREAIXM ∧ STATUS=1 THEN CLOSEAREA(AREAIXM, FALSE) ;
IF (A ← ARF) THEN
BEGIN "NONEMPTY"
INTEGER ARRAY XTRALINES[1:HIGHF]; RKJ TO FIXUP "TOPLINES" OF AREAS;
IF INTER ≤ 0 THEN NOPORTION ;
LS←0;
WHILE A DO BEGIN "COLLECTXGENS"
IDASSIGN(AREAIDA←A, THISAREA) ; A ← ARA ; IDASSIGN(AAA, AA) ;
IF STATA THEN LS ← LS + (XTRALINES[ULLA MAX 1] ← XGENA);
END "COLLECTXGENS";
A←ARF;
WORDOUT(INTER, HIGHF+LS) ; WORDOUT(INTER, WIDEF) ;
WHILE A DO BEGIN "AFTER AREA RESPONSES"
IDASSIGN(AREAIDA←A, THISAREA) ; A ← ARA ; IDASSIGN(AAA, AA) ;
IF (X ← DEFA) ∧ STATA=1 ∧ FINDTRAN(LDB(BIXNUM(X)), 3) THEN RESPOND(LLTHIS) ;
END "AFTER AREA RESPONSES" ;
A ← ARF ;
WHILE A DO BEGIN "CLOSE ALL AREAS"
IDASSIGN(AREAIDA←A, THISAREA) ; A ← ARA ; IDASSIGN(AAA, AA) ;
IF STATA = 1 THEN CLOSEAREA(-DEFA, FALSE) ;
END "CLOSE ALL AREAS" ;
A ← ARF ;
WHILE A DO
BEGIN "AREAOUT"
IDASSIGN(AREAIDA←A, THISAREA) ; NAREA ← 0 ; IDASSIGN(AAA, AA) ;
IF STATA > 1 THEN
BEGIN "AREAUSED"
IF GRPOLX ∧ (STATUS←STATA)=2 ∧ (X ← DEFA) THEN
BEGIN COMMENT SET UP GROUP OVERFLOW INFO ;
FIXFRAME(NEWPGIDA) ; OPENAREA(X) ; NAREA ← AREAIDA ;
IDASSIGN(AAA, NAA) ; NLFOOT←NPFOOT←NULINE←NUPINE←0 ;
FIXFRAME(OLDPGIDA) ; IDASSIGN(AREAIDA←A, THISAREA) ;
IDASSIGN(AAA, AA) ;
END ;
CS ← COLCA ; LS ← LINECA + XGENA ; RKJ ADDED XGENA;
F←0; RKJ;
FOR C←1 THRU ULLA-1 DO F←F+XTRALINES[C]; RKJ SEE IF ANY AREAS ABOVE THIS ONE HAVE "XTRALINES";
WORDOUT(INTER, ULLA+F) ; RKJ ADDED F; WORDOUT(INTER, CS) ; WORDOUT(INTER, LS) ;
FOR C ← 1 THRU CS DO
BEGIN "AREACOL" WORDOUT(INTER, AA[C,0]) ; FOOTLINE1 ← LS - RH("AA[CS+C,0]") ;
FOR F ← 0, CS DO FOR L ← 1 THRU LS DO IF (X ← AA[F+C, L]) THEN
IF GRPOLX = 0 ∨ X < GRPOLX ∨ X > GRPTOP THEN
BEGIN "AREALINE" LINENO ← IF F=0 THEN L ELSE FOOTLINE1 + L ;
IF (LB ← LDB(LABELM(X))) THEN
BEGIN "A PAGE LABEL"
LBPAGE ← 2 ROT -2 LOR PUTS(PAGEVAL&(IF XCRIBL THEN ALTMODE&CVS(XLENGTH(PAGEVAL)) ELSE NULL)) ;
WHILE LB ≠ -TWO(13) DO
IF (LINK ← LB) < 0 THEN
BEGIN
LB←NUMBER[-LINK] ;
NUMBER[-LINK] ← LBPAGE ;
END
ELSE BEGIN LB←ITBL[LINK] ; ITBL[LINK]←LBPAGE END ;
END "A PAGE LABEL" ;
IF OWLINE ← OWLS[X] THEN BEGIN WORDOUT(INTER, LINENO) ;
WORDOUT(INTER, SHORT[X]) ; WORDOUT(INTER, OWLINE) END ;
END "AREALINE"
ELSE BEGIN "GRP OVERFLOW"
NUINE ← IF F THEN NUPINE ← NUPINE + 1 ELSE NULINE ← NULINE + 1 ;
NFOOT ← IF LDB(FOOTM(X)) = 0 THEN 0
ELSE IF F THEN NPFOOT←NPFOOT+1 ELSE NLFOOT←NLFOOT+1 ;
NAA[F+1, NUINE] ← NOLX ← NOLX + 1 ; NOWLS[NOLX] ← OWLS[X] ;
IF NFOOT THEN DPB(NFOOT, FOOTM(X)) ; NMOLES[NOLX] ← MOLES[X] ;
NSHORT[NOLX] ← SHORT[X] ;
END "GRP OVERFLOW" ;
WORDOUT(INTER, 0) ;
END "AREACOL" ;
END "AREAUSED" ;
A ← ARA ;
GOAWAY(WHATIS(AA)) ; GOAWAY(AREAIDA) ;
IF NAREA THEN
BEGIN
NAA[1, 0] ← NULINE ; NAA[CS+1, 0] ← NUPINE ;
IDASSIGN(AREAIDA←NAREA, THISAREA) ; COLA ← 1 ; AREAIDA ← 0 ;
END ;
END "AREAOUT" ;
WORDOUT(INTER, -10) ;
END "NONEMPTY" ;
GOAWAY(MOLESIDA) ; GOAWAY(SHORTIDA) ; GOAWAY(-1 LSH 18 + OWLSIDA) ;
MOLESIDA ← SHORTIDA ← OWLSIDA ← GROUPM ← GLINEM ← 0 ;
GOAWAY(FRAMEIDA) ; FRAMEIDA ← OLDPGIDA ← AREAIDA ← 0 ; STATUS ← -1 ;
END "PAGEOUT" ;
IF GRPOLX THEN GRPOLX ← 0 ;
EXNEXTPAGE ← FALSE ;
OVEREST ← 0; comment short font kludge ;
END "FINPAGE" ;
INTERNAL RECURSIVE PROCEDURE USTEP(INTEGER USYMB, UIX) ;
BEGIN "USTEP"
INTEGER PS, PARIX, PARTYPE, SONIX, SONPS, IVAL, SVTY, SVIX, SVSY, SVTHAT ;
INTEGER I;
STRING PARVAL, CVAL, PVAL, SVWD ;
IF UIX>0 ∧ ¬IN_LINE(UIX) THEN DBREAK ;
IF UIX>0 ∧ FULSTR("CTR_VAL(""PATT_STRS(UIX)"")") ∧ FINDTRAN(USYMB, 3) THEN RESPOND(LLTHIS) ;
IF UIX = IXPAGE AND OLDPGIDA THEN FINPAGE ELSE UIX ← ABS(UIX) ;
PS ← PATT_STRS(UIX) ; CVAL ← CTR_VAL(PS) ;
CTR_VAL(PS) ← CVAL ←
CVS(IVAL←IF NULSTR(CVAL) THEN CTR_INIT(UIX)-TWO(14) ELSE CVD(CVAL)+CTR_STEP(UIX)-TWO(6)) ;
PARVAL ← IF PATT_PARENT(UIX) ∧ (PARIX ← PARENT(UIX)) THEN
EVALV("(a parent unit)", PARIX, PUNITTYPE) ELSE NULL ;
IF PATT_ALF(UIX) THEN
PVAL ← ! ← PREFIX(PS)&PARVAL&INFIX(PS)&CVALF(PATT_ALF(UIX),IVAL)&SUFFIX(PS)
ELSE BEGIN
SVTY←THISTYPE ; SVIX←IX ; SVSY←SYMB ; SVWD←THISWD ; SVTHAT←THATISFULL ;
SWICH(PREFIX(PS), -1, 0) ; PASS ; PVAL ← E(NULL, NULL) ;
PASS ; IF ITS(;) THEN PASS ;
IF ¬ITS(!!!) THEN WARN("=","Unbalanced COUNT Template") ;
SWICHBACK ;
THISTYPE←SVTY ; IX←SVIX ; SYMB←SVSY ; THISWD←SVWD ;
IF SVTHAT THEN RDENTITY ELSE EMPTYTHAT;
END ;
IF LENGTH(CVAL) > CTR_CHRS(UIX) THEN
BEGIN
WARN("Counter underestimated","Underestimated counter "&SYM[USYMB]&" -- reached "&CVAL) ;
CTR_CHRS(UIX) ← LENGTH(CVAL) ;
END ;
IF LENGTH(PVAL) > PATT_CHRS(UIX) THEN
BEGIN
IF PATT_STRS(UIX) THEN WARN("Pattern underestimate",
"Underestimated unit "&SYM[USYMB]&": -- reached "&PVAL) ;
PATT_CHRS(UIX) ← LENGTH(PVAL) ;
END ;
PATT_VAL(PS) ← PVAL ; SONIX ← SON(UIX) ;
WHILE SONIX > 0 DO
BEGIN
SONPS ← PATT_STRS(SONIX) ;
IF SONIX≠IXPAGE ∧ FULSTR("CTR_VAL(SONPS)") ∧ FINDTRAN(LDB(BIXNUM(SONIX)),3) THEN RESPOND(LLTHIS) ;
CTR_VAL(SONPS) ← PATT_VAL(SONPS) ← NULL ;
IF SONIX = IXPAGE THEN USTEP(SYMPAGE, SONIX ← -SONIX) ;
DO SONIX ← IF SONIX>0 ∧ (K←SON(SONIX)) THEN K ELSE IF (K←BROTHER(ABS SONIX)) THEN K
ELSE -PARENT(ABS SONIX) UNTIL SONIX>0 ∨ SONIX=-UIX ;
END ;
IF UIX ≠ IXPAGE ∧ FINDTRAN(USYMB, 4) THEN RESPOND(LLTHIS) ;
IF UIX = IXPAGE THEN PAGEVAL ← PATT_VAL(PATPAGE) ;
! ← PVAL ; C! ← CVAL ; comment RESPOND or USTEP(..PAGE..) might have changed it ;
END "USTEP" ;
INTERNAL SIMPLE PROCEDURE NEXTPAGE ;
BEGIN
INTEGER SAVEAREA ;
SAVEAREA ← IF AREAIXM THEN LDB(BIXNUM(AREAIXM)) ELSE SYMTEXT ;
USTEP(SYMPAGE, IXPAGE) ;
PLACE(LDB(IXN(SAVEAREA))) ;
END ;
SIMPLE PROCEDURE OWT(STRING C) ;
BEGIN "OWT"
IF NULSTR(C) THEN BEGIN OWLS[OLX] ← 0 ; RETURN END ;
IF INTER ≤ 0 THEN NOPORTION ;
OWLS[OLX] ← OWLSEQ ← OWLSEQ + 1 ;
OUT(SINTER, CVSR(OWLSEQ) & C) ;
END "OWT" ;
INTERNAL PROCEDURE CREUNIT(INTEGER INLINE, PFROM, PTO, PBY, PIN;
STRING PPRINTING; INTEGER USYMB) ;
BEGIN "CREUNIT"
INTEGER TEMP, LENPAT, PARENTCHARS, POSNALF, POSN!, PS, ALF, UIX, PINIX, PINPS, PCHARS ;
STRING S!, SPAR, SPAR! ;
USYMB ← DECLARE(USYMB, UNITTYPE) ; TEMP ← DECLARE(SYMNUM(SYM[USYMB]&"!"), PUNITTYPE) ;
UIX ← PUSHI(UNITWDS, UNITTYPE) ; PS ← PUSHS(5, NULL) ; PATT_STRS(UIX) ← PS ;
BIND(USYMB, UIX) ; DPB(UIX, IXN(TEMP)) ;
CTR_INIT(UIX) ← PFROM + TWO(14) ; CTR_STEP(UIX) ← PBY + TWO(6) ;
TES 10/25/73 ; IN_LINE(UIX) ← IF UIX=IXPAGE THEN 0 ELSE INLINE ;
PINIX ← IF PIN THEN LDB(IXN(PIN)) ELSE 0 ; PARENT(UIX) ← PINIX ;
IF PIN = 0 THEN PARENTCHARS ← PINPS ← 0
ELSE IF LDB(TYPEN(PIN)) = UNITTYPE THEN
BEGIN
PARENTCHARS ← PATT_CHRS(PINIX) ; PINPS ← PATT_STRS(PINIX) ;
BROTHER(UIX) ← SON(PINIX) ; SON(PINIX) ← UIX ;
END
ELSE BEGIN WARN("=","Undeclared Parent Unit "&SYMB) ; PINPS ← 0 ; PARENTCHARS ← 2 END ;
PCHARS ← LENGTH(CVS(PFROM)) MAX LENGTH(CVS(PTO)) ;
IF FULSTR(PPRINTING) ∧ PPRINTING=0 THEN
BEGIN "TEMPLATE"
PREFIX(PS) ← "!←" & PPRINTING[2 TO ∞] & ";!!!;;" ;
PATT_ALF(UIX) ← 0 ;
IF PIN≠0 ∧ PINPS=0 THEN TEMP ← PCHARS + PARENTCHARS comment lousy guess ;
ELSE BEGIN
S! ← ! ; CTR_VAL(PS) ← CVS(PTO - PBY) ; CTR_CHRS(UIX)←PATT_CHRS(UIX)←1000 ;
IF PINPS THEN BEGIN SPAR ← CTR_VAL(PINPS) ; SPAR! ← PATT_VAL(PINPS) ;
CTR_VAL(PINPS) ← "999999"[1 TO CTR_CHRS(PINIX)] ;
PATT_VAL(PINPS) ← ! ← "9999999999999999"[1 TO PARENTCHARS] ; END ;
USTEP(USYMB, -UIX) ; TEMP ← LENGTH(!) ;
! ← S! ; IF PINPS THEN BEGIN CTR_VAL(PINPS) ← SPAR ; PATT_VAL(PINPS) ← SPAR! END ;
END ;
END "TEMPLATE"
ELSE BEGIN "PATTERN"
STRING PATCOPY ; LABEL FALF ; INTEGER ARRAY PCH[1:LENGTH(PPRINTING)] ;
PRELOAD_WITH "1", "i", "I", "a", "A" ; OWN INTEGER ARRAY ALFS[1:5] ;
PATCOPY ← PPRINTING ; LENPAT ← 0 ; WHILE FULSTR(PATCOPY) DO PCH[LENPAT←LENPAT+1]←LOP(PATCOPY) ;
FOR POSNALF ← LENPAT DOWN 1 DO FOR ALF ← 1 THRU 5 DO IF ALFS[ALF]=PCH[POSNALF] THEN GO TO FALF;
WARN("=","No 1, i, I, a, or A in pattern for "&SYM[SYMB]) ;
POSNALF ← LENPAT + 1 ; PPRINTING ← PPRINTING & "1" ;
FALF: POSN! ← POSNALF - 1 ; WHILE POSN! ∧ PCH[POSN!]≠"!" DO POSN! ← POSN! - 1 ;
PATT_ALF(UIX) ← ALF ; PATT_PARENT(UIX) ← IF POSN! THEN 1 ELSE 0 ;
PREFIX(PS) ← PPRINTING[1 TO POSN!-1] ; INFIX(PS) ← PPRINTING[POSN!+1 TO POSNALF-1] ;
SUFFIX(PS) ← PPRINTING[POSNALF+1 TO ∞] ; PATT_VAL(PS) ← NULL ;
TEMP ← LENGTH(PREFIX(PS)) + PARENTCHARS + LENGTH(INFIX(PS)) +
(CHRSALF(PFROM,ALF) MAX CHRSALF(PTO,ALF)) + LENGTH(SUFFIX(PS));
END "PATTERN" ;
PATT_CHRS(UIX) ← TEMP ; CTR_CHRS(UIX) ← PCHARS ; PATT_VAL(PS)←CTR_VAL(PS)←NULL ;
END "CREUNIT" ;
RECURSIVE PROCEDURE ASSUREAREA ;
IF AREAIDA = 0 ∨ STATUS ≠ 1 THEN OPENAREA(IF AREAIXM THEN AREAIXM ELSE IXTEXT) ;
INTERNAL INTEGER SIMPLE PROCEDURE NEWBLANK(INTEGER MOLE) ;
BEGIN MOLES[OLX←OLX+1]←MOLE ; OWLS[OLX]←0 ; RETURN(OLX); END "NEWBLANK";
RECURSIVE BOOLEAN PROCEDURE MOVEGROUP(BOOLEAN OFFPAGE ; INTEGER TOCOL, TOLINE, EXTRA) ;
BEGIN "MOVEGROUP"
INTEGER SAVEAREA, LFOOT, PFOOT, FOOL, C, L, L1, L2, F, TC, TL, X ;
IF ¬OFFPAGE THEN
BEGIN TOCOL←TOCOL+1 ; IF COL≤COLS<TOCOL ∨ TOCOL>2*COLS THEN OFFPAGE←TRUE ELSE TOLINE←1 END ;
IF OFFPAGE THEN
BEGIN "OTHER PAGE"
SAVEAREA ← IF AREAIXM THEN LDB(BIXNUM(AREAIXM)) ELSE SYMTEXT ;
GRPTOP ← OLX ; GRPOLX ← GLINEM ; GLINEM ← 0 ; CLOSEAREA(AREAIXM, FALSE) ;
MOLES[0]←OLX ; OPENFRAME ; IDASSIGN(NEWPGIDA←FRAMEIDA, NEWPAGE) ;
IDASSIGN("MOLESF", NMOLES) ; IDASSIGN("SHORTF", NSHORT) ; SIDASSIGN("OWLSF", NOWLS) ;
NOLX ← OLX ; FIXFRAME(OLDPGIDA) ;
USTEP(SYMPAGE,IXPAGE) ; NMOLES[0]←NOLX ; NSHORT[0]←NOLX ;
FIXFRAME(NEWPGIDA) ; IDASSIGN(OLDPGIDA←NEWPGIDA, OLDPAGE) ;
F ← ARF ;
WHILE F DO
BEGIN
IDASSIGN(AREAIDA←F, THISAREA) ; F ← ARA ;
IF (X ← DEFA) THEN
BEGIN OLD_ACTIVE(X)←NEW_ACTIVE(X); NEW_ACTIVE(X)←0 END ;
END ;
NEWPGIDA ← 0 ; OPENAREA(LDB(IXN(SAVEAREA))) ;
IF TOCOL > COLS THEN COL ← COLS + 1 ;
IF FINDTRAN(SYMPAGE,4) THEN RESPOND(LLTHIS) ;
END "OTHER PAGE"
ELSE BEGIN "SAME PAGE"
GRPOLX ← GLINEM ; LFOOT ← 0 ; FOOL ← IF PAL>COL THEN PINE ELSE LINE ;
PFOOT ← IF FOOL=0 THEN 0 ELSE IF LDB(FOOTM("AA[PAL MAX COL,FOOL]"))=31 THEN 30 ELSE 0;
FOR C ← COL, PAL DO
BEGIN
L1 ← 1 ; L2 ← IF C = COL THEN LINE ELSE PINE ;
TC ← IF C=COL THEN TOCOL ELSE (TOCOL+COLS-1) MOD (2*COLS) + 1 ;
TL ← IF C=COL THEN TOLINE-1 ELSE RH("AA[TC,0]") ;
F ← IF C ≤ COLS THEN LFOOT ELSE PFOOT ;
FOR L ← L1 THRU L2 DO IF (X ← AA[C,L]) ≥ GRPOLX THEN
BEGIN
AA[TC, TL ← TL + 1] ← X ; AA[C, L] ← 0 ;
IF LDB(FOOTM(X)) THEN DPB(F←IF F=31 THEN 1 ELSE F+1, FOOTM(X)) ;
END ;
IF C= COL THEN BEGIN LINE ← TL ; COL ← TC END ELSE BEGIN PINE ← TL ; PAL ← TC END ;
END ;
GRPOLX ← 0 ;
END "SAME PAGE" ;
DAPART ; RETURN(TRUE) ;
END "MOVEGROUP" ;
INTERNAL RECURSIVE INTEGER PROCEDURE FIND_ROOM(INTEGER SOURCE,
EXTRA, FROMCOL, FROMLINE, MORECOMING) ;
BEGIN "FIND_ROOM"
INTEGER WANT, LEAD, I, C, L, SAVEAREA, KOLS ; LABEL FOUND, TRYHERE ;
ASSUREAREA ;
IF SOURCE≤0 THEN BEGIN WANT←EXTRA ; LEAD←-SOURCE END ELSE BEGIN WANT←1; LEAD←0 END;
IF WANT > LINES THEN BEGIN WARN("=","CAN'T FIT HERE"); RETURN(FALSE) END;
KOLS ← IF FROMCOL > COLS THEN 2*COLS ELSE COLS ;
TRYHERE:
FOR C ← FROMCOL THRU KOLS DO
IF (LINES-MORECOMING) - (L← IF C=FROMCOL THEN FROMLINE ELSE 0) + XGENLINES - PINE ≥
(IF L THEN WANT+LEAD ELSE WANT) THEN GO TO FOUND ;
IF GLINEM ∧ C≠FROMCOL ∧ MOVEGROUP(TRUE, 0,0,EXTRA) THEN BEGIN C←COL; L←LINE; GO FOUND END ;
IF TEXTAR(AREAIXM) THEN BEGIN
NEXTPAGE ; OPENAREA(AREAIXM) ;
IF FROMCOL>COLS ∧ COL≤COLS ∨ FROMCOL≤COLS ∧ COL>COLS THEN
BEGIN
IF FROMCOL>COLS THEN FOOTTOP ← 1 ; COMMENT THANKS RKJ ;
PAL ↔ COL ; LINE ↔ PINE ;
END ;
FROMCOL ← COL ; FROMLINE ← LINE; GO TO TRYHERE ; END
ELSE BEGIN WARN("=","Title area overflow") ;
FOR C ← 1 THRU COLS DO AA[C, 0] ← AA[COLS+C,0] ← 0 ;
PAL ← (C ← COL ← 1) + COLS ; L ← 0 ;
END ;
FOUND:
IF C=COL THEN LINE←L
ELSE IF GLINEM ∧ MOVEGROUP(FALSE, C, L, EXTRA) THEN BEGIN L ← LINE ; C ← COL END
ELSE BEGIN
COL ← C ; PAL ← (COL+COLS-1) MOD (2*COLS) + 1 ;
LINE ← L ; PINE ← RH("AA[PAL,0]") ;
END ;
IF OLX+WANT+LEAD > OLXX THEN GROWOWLS(WANT+LEAD+25) ;
IF LINE AND LEAD THEN
BEGIN
FOR I ← 1 THRU LEAD DO AA[COL, LINE+I] ← NEWBLANK(IF GROUPM ∨ I>1 THEN ABV_BLW ELSE BLW) ;
LINE ← LINE + LEAD ;
END ;
RETURN(L+1) ;
END "FIND_ROOM" ;
INTERNAL RECURSIVE PROCEDURE TOCOLUMN(INTEGER COLNO) ; IF ON THEN
BEGIN "TOCOLUMN"
ASSUREAREA ;
IF COLNO < COL ∨ (COLNO=COL ∧ LINE) OR TES 10/25/73; COLNO>COLS THEN NEXTPAGE ;
IF 1≤COLNO≤COLS THEN COL←COLNO ELSE
BEGIN TES 10/25/73;
WARN(NULL, "SKIP TO NONEXISTENT COLUMN "&CVS(COLNO));
COLNO ← 1 ;
END ;
LINE ← 0 ; IF COL>1 THEN OPENAREA(AREAIXM) ;
END "TOCOLUMN" ;
INTERNAL RECURSIVE PROCEDURE TOLINE(INTEGER LINENO) ; IF ON THEN
BEGIN "TOLINE"
ASSUREAREA ;
IF LINENO < LINE THEN
IF COL = COLS THEN
BEGIN NEXTPAGE ; IF LINENO>1 THEN OPENAREA(AREAIXM) END
ELSE BEGIN COL ← COL+1 ; LINE ← 0 ; END ;
IF LINENO=1 THEN LINE←1 ELSE FIND_ROOM(0, 0, COL, LINENO-1, 0) ;
END "TOLINE" ;
INTERNAL RECURSIVE PROCEDURE SKIPLINES(INTEGER HMLINES) ; IF ON THEN
BEGIN "SKIPLINES"
ASSUREAREA ;
IF HMLINES > 0 THEN
IF GROUPM=0 THEN FIND_ROOM(-HMLINES, 0, COL, LINE, 0)
ELSE BEGIN "GROUP SKIP"
INTEGER I ;
FIND_ROOM(0, HMLINES, COL, LINE, 0) ;
IF ¬GLINEM THEN GLINEM ← OLX + 1 ;
FOR I ← 1 THRU HMLINES DO AA[COL, LINE+I] ←
NEWBLANK(IF GLINEM=0 ∧ I=1 THEN ABV ELSE ABV_BLW) ;
LINE ← LINE + HMLINES ;
END "GROUP SKIP" ;
END "SKIPLINES" ;
INTERNAL RECURSIVE PROCEDURE PLACELINE(INTEGER CHARS,POSN,XPOSN,FAKE,
ABOVE,BELOW,LEADB,FIRSTLBL,JUSTIFY,MORECOMING) ;
BEGIN "PLACELINE"
INTEGER FOOTFLAG, NEEDS, TOPLINE, GR, ATOP, I, TOLBL, LBL, FOOTNUM, WASFRAME, WASCOL, WASOLX ;
COMMENT FOOTFLAG CHANGES RKJ 10-10-73;
STRING COWL, XREF, SOWL ;
IF ¬DEBUG THEN XREF ← ALTMODE
ELSE BEGIN
XREF ← ERRLINE&"/"&SRCPAGE&"["&MACLINE&"]" ;
FOR I ← 1 THRU MESGS DO XREF ← XREF & RUBOUT & MESSAGE[I] ;
MESGS←0 ; XREF ← XREF & ALTMODE ;
END ;
IFC VERSION=SAILVER OR VERSION=PARCVER
THENC IF XCRIBL THEN ABOVE←BELOW←0; comment scripts; ENDC
COWL ← XREF & (SOWL←OWL[1 TO CHARS] & CRLF) ;
ASSUREAREA ;
IF FOOTNUM ← FOOTTOP ∧ COL > COLS THEN
BEGIN comment First Footnote belonging to a line ;
GR ← GROUPM ; IF GROUPM=0 THEN GLINEM ← FOOTNUM ; GROUPM ← 1 ; FOOTTOP ← 0 ;
IF ATOP ← LINE=0 THEN ABOVE ← ABOVE + 1 ; comment assure room for FOOTSEP ;
END ;
FOOTFLAG ← COL ≤ COLS AND FULSTR("SSTK[FOOTSTR(AREAIXM)]");
IF FOOTFLAG THEN
MORECOMING←MORECOMING+2 ; RKJ 11/20/73 ;
WHILE ¬(TOPLINE ← FIND_ROOM(-LEADB,NEEDS←ABOVE+BELOW+1,COL,LINE,MORECOMING)) DO
BEGIN ABOVE←(ABOVE-1)MAX 0; BELOW←(BELOW-1)MAX 0 END;
IF XCRIBL AND (COL = 1 OR COL = COLS+1) THEN TES 11/19/73 COL 1 ONLY! ;
BEGIN "KLUDGE"
OVEREST←OVEREST+NEEDS*(STDCHARH-CHARH);
IF ABS(OVEREST)>STDCHARH THEN
BEGIN
XGENLINES←XGENLINES+OVEREST DIV STDCHARH;
OVEREST←OVEREST MOD STDCHARH;
END;
END "KLUDGE";
WASOLX ← OLX - (LINE + 1 - TOPLINE) ;
IF FOOTNUM OR FOOTTOP AND COL>COLS THEN COMMENT THANKS RKJ ;
BEGIN "FOOT1"
GROUPM ← GR ; IF GROUPM=0 THEN GLINEM ← 0 ;
IF ATOP THEN BEGIN ABOVE ← ABOVE - 1 ; NEEDS ← NEEDS - 1 END ;
IF LINE = 0 THEN BEGIN AA[COL, LINE←TOPLINE←LINE+1] ← OLX ← OLX + 1 ;
OWT(XREF&FOOTSEP[1 TO COLWID(AREAIXM)]&CRLF) ; MOLES[OLX] ← BLW ; END ;
END "FOOT1" ;
FOR I ← 1 THRU ABOVE DO AA[COL,LINE+I] ←
NEWBLANK(IF GROUPM ∨ TOPLINE<LINE+I THEN ABV_BLW ELSE BLW) ;
AA[COL, LINE+ABOVE+1] ← OLX ← OLX + 1 ;
OWT(COWL) ;
MOLES[OLX] ← (IF GROUPM ∨ TOPLINE<LINE+ABOVE+1 THEN ABV ELSE 0) LOR (IF GROUPM OR BELOW THEN BLW ELSE 0);
IF XCRIBL THEN I←MAXIM*CHARW + FAKE - XPOSN ELSE I←MAXIM - (POSN-FAKE);
IF JUSTIFY AND I > 0 THEN SHORT[OLX]←I ;
IF FIRSTLBL≠-TWO(13) THEN
BEGIN "PAGE LABELS"
LBL ← PLBL ; TOLBL ← 0 ;
WHILE LBL≠FIRSTLBL ∧ LBL≠-TWO(13) DO
LBL ← IF (TOLBL←LBL)>0 THEN ITBL[TOLBL] ELSE NUMBER[-TOLBL] ;
IF LBL=-TWO(13) THEN WARN("=","Page label not in Page Label L.L.!!!")
ELSE IF TOLBL=0 THEN PLBL ← -TWO(13)
ELSE IF TOLBL > 0 THEN ITBL[TOLBL] ← -TWO(13)
ELSE NUMBER[-TOLBL] ← -TWO(13) ;
BRKPLBL ← PLBL ;
DPB(IF FIRSTLBL<0 THEN PUTI(1,FIRSTLBL) ELSE FIRSTLBL, LABELM(OLX)) ;
END "PAGE LABELS" ;
FOR I ← ABOVE+2 THRU NEEDS DO AA[COL,LINE+I] ← NEWBLANK(IF GROUPM ∨ I<NEEDS THEN ABV_BLW ELSE BLW) ;
IF GROUPM∧¬GLINEM THEN BEGIN DPB(0,ABOVEM("GLINEM←AA[COL,IF COL>COLS THEN PINE ELSE TOPLINE]")) END;
LINE ← LINE + NEEDS ;
IF FOOTFLAG THEN comment, Footnotes ;
BEGIN "FOOTNOTES"
WHILE (FOOTNUM←IF PINE=0 THEN 1 ELSE LDB(FOOTM("AA[PAL,PINE]")) + 1) = 31 DO
BEGIN
WARN("=",">30 lines in col. "&COL&" want footnotes.") ;
FIND_ROOM(LINE, 1, COL+1, 0, 0) ;
END ;
IF FOOTNUM=32 THEN FOOTNUM ← 1 ; DPB(FOOTNUM, FOOTM(OLX)) ;
SEND(IXFOOT, CRLF&TB&TB& "END ""!FOOTNOTES"";;") ;
AA[COL,0] ← LHRH(COVERED, LINE) ; PINE ↔ LINE ; PAL ↔ COL ;
WASCOL ← COL ; WASFRAME ← FRAMEIDA ; BEGINBLOCK(TRUE, 3, "!FOOTNOTES") ; BREAKM ← 0 ;
FOOTTOP ← -1 ; WASOLX ← OLX ; RECEIVE(IXFOOT, NULL) ; PASS ; TOEND ; FOOTTOP ← 0 ;
AA[COL,0] ← LHRH(COVERED, LINE) ;
IF WASCOL ≠ COL ∨ WASFRAME ≠ FRAMEIDA THEN
BEGIN FOOTNUM ← 31 ; IF WASFRAME=FRAMEIDA THEN DPB(31, FOOTM(WASOLX)) END ;
DPB(FOOTNUM, FOOTM("AA[COL,LINE]")) ; PAL ↔ COL ; PINE ↔ LINE ;
END "FOOTNOTES" ;
END "PLACELINE" ;
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 - - - - - - - - - - ;
INTERNAL SIMPLE PROCEDURE FAMILYHAS(INTEGER FAMNUM; STRING MEMBERS) ;
BEGIN "FAMILYHAS"
INTEGER SPECIE, CHAR ;
SPECIE ← -1 ;
WHILE FULSTR(MEMBERS) DO
BEGIN
DPB(FAMNUM, FAMILY("CHAR ← LOP(MEMBERS)")) ;
DPB(SPECIE ← SPECIE+1, SPECIES(CHAR)) ;
END ;
END "FAMILYHAS" ;
EXTERNAL SIMPLE PROCEDURE MANUSCRIPT ;
COMMENT I N I T I A L I Z E A N D G O ! ! ! ! ! ;
COMMENT Set up the XGP stuff ;
CHARW ← 16 ; COMMENT fix later ;
WCW ← WHATIS(CW) ; COMMENT original font ;
THISFONT ← OLDFONT ← DEFAULTFONT ;
IFC TENEX THENC
JOBNO ← CVS(GJINF(J, I, J)) ;
CONDIR ← DIRST(I) ;
ENDC TES 10/25/73 ;
ON ← TRUE ; comment only false if code is to be parsed but not executed ;
WISTK←WHATIS(ISTK) ; WITBL←WHATIS(ITBL) ; WINEST←WHATIS(INEST) ;
WSSTK←SWHATIS(SSTK) ; WSTBL←SWHATIS(STBL) ; WSNEST←SWHATIS(SNEST) ;
WSYM←SWHATIS(SYM) ; WNUMBER←WHATIS(NUMBER) ; WOLDPAGE←WHATIS(OLDPAGE) ;
WNEWPAGE←WHATIS(NEWPAGE) ; WTHISFRAME←WHATIS(THISFRAME);
WMOLES←WHATIS(MOLES) ; WOWLS←WHATIS(OWLS) ; WNMOLES←WHATIS(NMOLES) ;
WNOWLS←WHATIS(NOWLS) ; WTHISAREA←WHATIS(THISAREA) ; WWAITBOX←WHATIS(WAITBOX) ;
WAVAILREC←WHATIS(AVAILREC) ; WAA←WHATIS(AA) ; WNAA←WHATIS(NAA) ;
WSHORT←WHATIS(SHORT) ; WNSHORT←WHATIS(NSHORT) ;
ITBLIDA ← RH("CREATE(0, ITSIZE)") ; ISTKIDA ← RH("CREATE(0, ISIZE)") ; INESTIDA ← RH("CREATE(0, SIZE)") ;
STBLIDA ← RH("SCREATE(0, STSIZE)") ; SSTKIDA ← RH("SCREATE(0, SSIZE)") ; SNESTIDA ← RH("SCREATE(0, SIZE)") ;
SYMIDA ← RH("SCREATE(-1, SYMNO)") ; NUMBIDA ← RH("CREATE(-1, SYMNO)") ;
MAKEBE(ITBLIDA, ITBL) ; MAKEBE(ISTKIDA, ISTK) ; MAKEBE(INESTIDA, INEST) ;
SMAKEBE(STBLIDA, STBL) ; SMAKEBE(SSTKIDA, SSTK) ; SMAKEBE(SNESTIDA, SNEST) ;
SMAKEBE(SYMIDA, SYM) ; MAKEBE(NUMBIDA, NUMBER) ;
SETSYM ; XSYMNO ← SYMNO ; comment Initialize the symbol table;
LAST ← IHED ← SHED ← IHIGH ← SHIGH ← 0 ; comment Tops of Stacks;
OLDPGIDA←NEWPGIDA←FRAMEIDA←MOLESIDA←SHORTIDA←OWLSIDA←AREAIDA←WBOXIDA←STATUS←AREAIXM←0 ;
DEPTH ← GENSYM ← 0 ; OLX ← -1 ; OLMAX ← 5 ; LEADRESPS ← WAITRESP ← 0 ;
FOR I ← 0 STEP 1 WHILE FULSTR(MANWD[I]) DO
BIND(DECLARE(SYMNUM(MANWD[I]), MANTYPE), I) ; comment reserved words ;
DEPTH ← 2 ; IXCOMMENT ← LDB(IXN("SYMNUM(""""COMMENT"""")")) ;
SYMTEXT ← SYMNUM("TEXT") ; IXEND←LDB(IXN("SYMNUM(""""END"""")"));
J ← 0 ;
FOR S ← CR, ALTMODE&"{", RUBOUT, "α", "β", "#", "\", "∂", "←", "→", "∞",
"↑", "↓", "]", "-", ".!?", SP, "_", "π", "∪", "∩", VT, "$", "%",
"⊗", "[", "&" DO
COMMENT 2D CHARS OF DIPHTHONGS COME NOT BEFORE [ IN LIST ↑ ;
BEGIN J←J+1; WHILE FULSTR(S) DO DPB(J, SPCHAR("LOP(S)")) ; END ;
AMSAND ← J ; LBRACK ← J-1 ; UNDERBAR ← 18 ; UARROW ← 12 ; DARROW ← 13 ;
LCURLY ← 2 ; DOLLAR ← 23 ; XCMDCHR ← 25 ;
FOR S ← SP, TB, FF, VT, CR, LF, 0 DO CHARTBL[S] ← CHARTBL[S] LOR TWO(6) ;
CHARSP ← CR & ALTMODE & RUBOUT & "αβ#\∂←→∞↑↓]-? _π∪∩" & VT & "$%⊗[&" ;
FOR J ← 0 THRU 127 DO BEGIN DPB(MISCQ, FAMILY(J)) ; DPB(0, SPECIES(J)) END ;
FAMILYHAS(LETTQ, "ABCDEFGHIJKLMNOPQRSTUVWXYZ!") ;
FAMILYHAS(LETTQ, "abcdefghijklmnopqrstuvwxyz_") ;
FAMILYHAS(DIGQ, "0123456789" ) ;
FAMILYHAS(EMPTYQ, '0 & ALTMODE & RUBOUT) ;
FAMILYHAS(TERQ, RCBRAK&";),]⊂" ) ;
FAMILYHAS(QUOTEQ, """'" ) ;
FAMILYHAS(DOLLARQ, "$" ) ;
FAMILYHAS(BROKQ, "[" ) ;
FAMILYHAS(MULQ, "*/%&" ) ;
DPB(LDB(SPECIES("""""/""""")), SPECIES("""""%""""")) ;
FAMILYHAS(ADDQ, "+-≡↑⊗" ) ;
FAMILYHAS(RELQ, "<>=≤≥≠" ) ;
FAMILYHAS(NOTQ, "¬" ) ;
FAMILYHAS(ANDQ, "∧" ) ;
FAMILYHAS(ORQ, "∨" ) ;
FAMILYHAS(MISCQ, " :←(∞@|ε" ) ;
FOR S ← "∧AND", "∨OR", "¬NOT", "/DIV", "≡EQV", "⊗XOR", "≡ABS", "⊗LENGTH", "≤LEQ", "≥GEQ", "≠NEQ" DO
BIND(DECLARE(SYMNUM(S[2 TO ∞]), INTERNTYPE), S+200) ; ie, equate with special character ;
J ← RUBOUT ;
FOR S ← ODDQ&0&"EVEN", ODDQ&1&"ODD",
BOUNDQ&0&"MAX", BOUNDQ&1&"MIN", MULQ&2&"MOD" DO
BEGIN
INTEGER TEMP ; COMMENT SAIL BUG -- THANKS RKJ ;
BIND(DECLARE(SYMNUM(S[3 TO ∞]), INTERNTYPE), (J←J+1)+200) ;
DPB(TEMP←S[1 FOR 1], FAMILY(J)) ;
DPB(TEMP←S[2 FOR 1], SPECIES(J)) ;
END ;
UPCAS3←(UPCASE(0)) LOR '3000000 ; COMMENT POINT 7, CHARTBL(3), 6 ;
UPCAS5←(UPCASE(0)) LOR '5000000 ; UPCAS6←(UPCASE(0)) LOR '6000000 ;
FOR J ← 0 THRU 127 DO DPB(J, UPCASE(J)) ;
FOR J ← "a" THRU "z" DO DPB(J-("a"-"A"), UPCASE(J)) ; DPB(J←"!", UPCASE("_")) ;
J ← -1 ;
FOR S ← "LINES", "COLUMNS", "!", "SPREAD", "FILLING", "!SKIP!", "!SKIPL!", "!SKIPR!",
"NULL", "!INF", "FOOTSEP", "TRUE", "FALSE",
"INDENT1", "INDENT2", "INDENT3", "LMARG", "RMARG",
"CHAR", "CHARS", "LINE", "COLUMN", "TOPLINE", "XCRIBL", "CHARW"
, "XGENLINES", "UNDERLINE", "THISDEVICE", "THISFONT" DO
BIND(DECLARE(SYMNUM(S), INTERNTYPE), J←J+1) ; comment Internal Variables;
PLBL←BRKPLBL←-TWO(13); NOPGPH ← TRUE ;
BIND(DECLARE(SYMNUM("FOOT"), PORTYPE), IXFOOT ← PUTI(4, -1)) ;
VUNDERLINE ← BAR ; TES 10/22/73 ;
ASSIGN("!CONTENTSW", CONTENTS) ; comment make RPG-switch available to macros;
ASSIGN("FILE", IFC TENEX THENC CVFIL(INFILE,S,S) TES 10/30/73;
ELSEC CVXSTR(CVFIL(INFILE,L,M)) ENDC) ;
! ← NULL ; K ← CALL(0, "DATE") ;
ASSIGN("MONTH", (STR1 ← MONTH[K DIV 31 MOD 12 + 1])[1 TO ∞-1]) ;
ASSIGN("DAY", STR2 ← CVS(K MOD 31 + 1)) ;
ASSIGN("YEAR", STR3 ← CVS(K DIV 31 DIV 12 + 1964)) ;
ASSIGN("DATE", STR1 & STR2 & ", " & STR3 );
K ← CALL(0,"TIMER")/3600 ; S ← CVS(K MOD 60) ; IF LENGTH(S)=1 THEN S ← "0"&S ;
ASSIGN("TIME", CVS(K DIV 60) & ":" & S) ;
SYMPAGE←SYMNUM("PAGE"); CREUNIT(0,1,18,1,0,"1",SYMPAGE); IXPAGE←LDB(IXN(SYMPAGE));
PATPAGE←PATT_STRS(IXPAGE); PAGEVAL ← NULL ;
INTERS ← PORTS ← THISPORT ← 0 ; PORTLL ← SEQPORT ← PUTI(4, -5) ; PORSEQ(SEQPORT) ← INTER ← -1 ;
INPUTCHAN ← -1 ; LIT_ENTITY ← LIT_TRAIL ← NULL ;
INPUTSTR ← CRLF & "99999/99" & TB & TB & "<<)]"&RCBRAK&"⊃>>;END""PAST EOF"";END""PASSED EOF"";" ;
TABSORT[1]←TWO(33); EXNEXTPAGE ← FALSE ; ENDCASE←STARTS←0 ; BLNMS←-1 ; AVAILREC[0] ← NULLAREAS ← 0 ;
EMPTYTHIS ; EMPTYTHAT ;
RESP_BODY ← DCLR_ID ← DCLR_LET ← FALSE ; OWLSEQ ← MESGS ← 0 ;
THISFILE ← "(NO FILE)" ; MAINFILE ← INFILE ; COMMENT RESET IN SWICHF ;
COMMAND_CHARACTER ← "." ;
S ← TEXT_BRC ← CRLF & ALTMODE & RUBOUT & VT & " -.!?" ;
WHILE FULSTR(S) DO DPB(LDB(SPCHAR("J ← LOP(S)")), SPCODE(J)) ;
DEFN_BRC ← RCBRAK&"$)⊂⊃∃" & LF & LETTS ; LDEFN_BRC ← LENGTH(DEFN_BRC) ;
SETBREAK(TO_VT_SKIP, VT, NULL, "IS") ;
SETBREAK(TO_COMMA_RPAR, ",)" & LF, CR, "IR") ;
COMMENT "|" IGNORED UNTIL 6 FEB 73;
SETBREAK(TO_TERQ_CR, RCBRAK&";),]⊂"&CRLF, NULL, "IR") ;
SETBREAK(TO_SEMI_SKIP, ";"&RCBRAK&""&LF, NULL, "IS") ;
SETBREAK(NO_CHARS, NULL, NULL, "XRL") ;
SETBREAK(ONE_CHAR, NULL, NULL, "XA") ;
SETBREAK(TO_TB_FF_SKIP, TB&FF, LF, "IS") ;
SETBREAK(TO_LF_TB_VT_SKIP, LF&TB&VT, FF, "ISL") ;
SETBREAK(TO_VISIBLE, SP&CR, NULL, "XR") ;
SETBREAK(ALPHA, LETTS&DIGS, NULL, "XR") ;
SETBREAK(DIGITA, DIGS, NULL, "XR") ;
SETBREAK(TO_QUOTE_APPD, """"&LF, NULL, "IA") ;
SETBREAK(TO_NON_SP, SP, NULL, "XR") ;
SETBREAK(TEXT_TBL, TEXT_BRC&SIG_BRC,NULL, "IS") ;
SETBREAK(TO_VBAR_SKIP, "|"&LF, CR, "IS") ;
SETBREAK(DEFN_TABLE, DEFN_BRC, NULL, "IS") ;
SETBREAK(TO_CR_SKIP, CRLF, NULL, "IS") ;
SWICH(CRLF & "9999/98" & TB & TB & "NEXT PAGE ; END ""!MANUSCRIPT"" ", -1, 0) ;
SWICHF(INFILE) ; comment main input file ;
SWICH("BEGIN ""!MANUSCRIPT"" ", -1, 0) ;
IFC VERSION=CMUVER THENC
LIBPPN ← "[A700PU00]";
SIMLOOK("!DEFONTA");
READFONT(DEFAULTFONT,"NGR25.KST[A730KS00]");
ENDC COMMENT RKJ 10-10-73;
IFC VERSION=SAILVER THENC
LIBPPN ← IF EQU(CVXSTR(CALL(0,"DSKPPN"))[3 TO 6], "2TES") THEN NULL ELSE "[1,3]" ;
ENDC;
PUBSTD ← TRUE ; COMMENT SUPPRESS PAGE NUMBER MONITORING ;
SWICHF("PUBSTD.DFS"&LIBPPN) ; comment standard modes and macros ;
SPREADM ← PREFMODE ;
PASS ; comment get scanner going ;
MANUSCRIPT ; NB NB NB NB T H I S D O E S P A S S O N E ;
COMMENT Write out Labels for Pass Two ;
L ← WRITEON(FALSE, "PULABL.PUI") ;
OUT(L, CVSR(XSYMNO MAX IHIGH) ) ;
FOR J ← 1 THRU XSYMNO DO
IF (BYTEWD ← NUMBER[J]) ≠ 0 ∧ (K← LDB(SYMBOLWD(BYTEWD))) = 0 ∨ K='17777 THEN
IF LDB(PLIGHTWD(BYTEWD)) = 2 THEN OUT(L, CVSR(0) & CVSR(J) & STBL[LDB(IXWD(BYTEWD))]&ALTMODE )
ELSE WARN("=","Undefined Label "&SYM[J]) ;
FOR J ← 1 THRU IHIGH DO IF LH(BYTEWD ← ITBL[J]) = '400000 THEN
OUT(L, CVSR(1) & CVSR(J) & STBL[LDB(IXWD(BYTEWD))] & ALTMODE) ;
RELEASE(L) ;
COMMENT Finish Last Page File and write out OUTFILE and Intermediate Sequence File ;
IF INTER ≥ 0 THEN BEGIN FOR DUMMY←1 THRU 5 DO WORDOUT(INTER,-20) ; RELEASE(INTER) ; RELEASE(SINTER) END ;
IF GENEXT THEN OUTFILE ← OUTFILE &
IFC VERSION=CMUVER THENC (IF XCRIBL THEN ".XGO" ELSE ".DOC") ENDC
IFC VERSION=SAILVER THENC ".DOC" ENDC
IFC VERSION=PARCVER THENC ".DOC" ENDC;
L ← WRITEON(FALSE,"PUPSEQ.PUI") ;
OUT(L, TMPFILE&ALTMODE&OUTFILE&ALTMODE&CVSR(DEBUG)&CVSR("ABS(DEVICE)")&DELINT&ALTMODE) ;
OUT(L, VUNDERLINE & ALTMODE) ; TES 10/22/73 ;
OUT(L,CVSR(CHARW));
SIMLOOK("!XGPLFTMAR"); OUT(L,EVALV("!XGPLFTMAR",SYMIX,SYMTYPE)&ALTMODE);
OUT(L,CVSR(BASELINE));
OUT(L,LF);
J ← PORSEQ(PORTLL) ;
OPEN(K ← GETCHAN, "DSK", 0,1,0,20, BRC, EOF) ;
WHILE J > 0 DO
BEGIN
IF PORINT(J) THEN OUT(L, CVSTR(PORINT(J)) & ALTMODE) ;
IF PORCH(J) = -5 ∨ PORSEQ(J) < 0 THEN WARN("=","INSERT Portion not found") ;
IF PORFIL(J) THEN FOR S ← ".PUG", ".PUZ" DO IF EQU(S,".PUG") ∨ PORCH(J)=-6 THEN
BEGIN COMMENT DELETE GENERATED FILES ;
LOOKUP(K, CVSTR(PORFIL(J)) & S & JOBNO, DUMMY) ;
IF DUMMY=0 THEN RENAME(K, NULL, 0, DUMMY) ;
END ;
J ← PORSEQ(J) ;
END ;
RELEASE(L) ; RELEASE(K) ;
IFC VERSION=SAILVER THENC
IF FULSTR(CMDFILE) AND XCRIBL THEN
BEGIN "WRITECMD"
L←WRITEON(FALSE,"QQXGP.RPG");
OUT(L,OUTFILE&"/NOHEADING/LMAR=");
SIMLOOK("!XGPLFTMAR"); OUT(L,EVALV("!XGPLFTMAR",SYMIX,SYMTYPE));
SIMLOOK("!XGPCOMMANDS"); OUT(L,EVALV("!XGPCOMMANDS",SYMIX,SYMTYPE));
OUT(L,CMDFILE&CRLF);
RELEASE(L)
END "WRITECMD"
ENDC;
OUTSTR(CRLF) ;
FOR J ← ITBLIDA, ISTKIDA, INESTIDA, NUMBIDA DO GOAWAY(J) ;
FOR J ← STBLIDA, SSTKIDA, SNESTIDA, SYMIDA DO GOAWAY(-1 LSH 18 + J) ;
FOR J ← 1 THRU 35 DO IF FONTFIL[J] ≠ 0 THEN GOAWAY(FONTFIL[J]) ;
MAKEBE(WCW,CW);
MAKEBE(WISTK, ISTK) ; MAKEBE(WITBL, ITBL) ; MAKEBE(WINEST, INEST) ;
SMAKEBE(WSSTK, SSTK) ; SMAKEBE(WSTBL, STBL) ; SMAKEBE(WSNEST, SNEST) ;
SMAKEBE(WSYM, SYM) ; MAKEBE(WNUMBER, NUMBER) ; MAKEBE(WOLDPAGE, OLDPAGE) ;
MAKEBE(WNEWPAGE, NEWPAGE) ; MAKEBE(WTHISFRAME,THISFRAME);
MAKEBE(WMOLES, MOLES) ; MAKEBE(WOWLS, OWLS) ; MAKEBE(WNMOLES, NMOLES) ;
MAKEBE(WSHORT, SHORT) ; MAKEBE(WNSHORT, NSHORT) ;
MAKEBE(WNOWLS, NOWLS) ; MAKEBE(WTHISAREA, THISAREA) ; MAKEBE(WWAITBOX, WAITBOX) ;
MAKEBE(WAVAILREC, AVAILREC) ; MAKEBE(WAA, AA) ; MAKEBE(WNAA, NAA) ;
END "VARIABLE BOUND ARRAY BLOCK" ;
IFC TENEX THENC TES 10/25/73 ;
BEGIN "PASS 2"
RUNPRG(IF EQU(CONDIR,"<PUB>") THEN "<PUB>PUB2.SAV" ELSE "<SUBSYS>PUB2.SAV", 1,0) ;
END "PASS 2"
ELSEC
IFC VERSION=CMUVER THENC
BEGIN "PASS 2"
INTEGER ARRAY PASSTWO[0:4];
PASSTWO[0] ← CVSIX(LIBDEV);
PASSTWO[1] ← CVFIL("PUB2"&LIBPPN,PASSTWO[2],PASSTWO[4]);
PASSTWO[3] ← 0;
START_CODE
MOVE 1,PASSTWO;
HRLI 1,1;
CALLI 1,'35;
JRST 4,0;
END;
END "PASS 2"
ELSEC
IFC VERSION=SAILVER THENC
BEGIN "PASS 2"
INTEGER SIMPLE PROCEDURE CORELOC(INTEGER ARRAY A) ; START_CODE MOVE 1,A ; END ;
INTEGER ARRAY PASSTWO[0:4] ;
EXTERNAL SIMPLE PROCEDURE K_OUT ; K_OUT ; COMMENT * * * * * * * * * * * ;
PASSTWO[0] ← CVSIX("DSK") ; PASSTWO[1] ← CVFIL("PUB2.DMP"&LIBPPN, PASSTWO[2], PASSTWO[4]) ;
PASSTWO[3] ← 1 ; COMMENT Do an RPGSTART so DEVICE will be taken from PUI file ;
CALL(CORELOC(PASSTWO), "SWAP") ;
END "PASS 2"
ELSEC
IFC VERSION=PARCVER THENC
BEGIN "PASS 2" RKJ NON-TENEX SAIL ;
INTEGER FH;
DEFINE JSYS="'104000000000",
RESET="JSYS '147", GTJFN="JSYS '20",
CFORK="JSYS '152", WFORK="JSYS '163",
HALTF="JSYS '170", GET="JSYS '200",
SFRKV="JSYS '201";
S←"<SUBSYS>PUB2.SAV "; TES 10/25/73 ;
START!CODE
RESET;
MOVSI 1,'200000;
CFORK; HALTF;
MOVEM 1,FH;
MOVSI 1,'100001;
MOVE 2,S;
GTJFN; HALTF;
HRL 1,FH;
GET;
MOVE 1,FH;
MOVEI 2,2;
SFRKV;
MOVE 1,FH;
WFORK;
RESET;
HALTF;
END;
END "PASS 2";
ENDC ENDC ENDC ENDC
END "PUB"