perm filename PTRAN.SAI[S,AIL]1 blob
sn#000833 filedate 1972-11-03 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00014 PAGES VERSION 10-4(49)
RECORD PAGE DESCRIPTION
00001 00001
00003 00002 HISTORY
00006 00003 Declarations
00010 00004 Initialization, Lookup, Entersym, Subequ
00014 00005 Pton, Printroom, Halword, Maksym
00017 00006 Assign, Classout
00022 00007 Searchit, Gword
00028 00008 Getword, Get_Good_Word, Compile, Map
00031 00009 Prodscan, Endcheck
00034 00010 Prodscan, Assemble
00038 00011 Prodscan
00047 00012 Ptran
00048 00013
00051 00014
00053 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,SAIL,REASON
025 401200000061 ⊗;
COMMENT ⊗
VERSION 10-4(49) 11-3-72 BY JRL GIVE CLASS TABLE OVERFLOW ERROR MESSAGE
VERSION 10-4(48) 7-31-72 BY DCS SLS CHANGE
VERSION 10-4(47) 7-18-72 BY KUT VANLEHN IS TO INCREASE EXNO
VERSION 10-4(46) 7-18-72 BY KURT VANLEHN IS AS BEFORE SYMNO ← 1290
VERSION 10-4(45) 7-18-72 BY KURT VANLEHN IS THE SAME AS LAST TIME: SYMNO ← 1258
VERSION 10-4(44) 7-18-72 BY KURT VANLEHN TO TRY A DIFFERENT SYMNO
VERSION 10-4(43) 7-18-72 BY KVL INCREASE SYMNO FROM 1200 TO 1282 (1283-1)
VERSION 10-4(42) 7-17-72 BY DCS SYMNO, EXNO GET LARGER
VERSION 10-4(41) 7-8-72
VERSION 10-4(40) 7-8-72 BY DCS FIX AN SLS THINGIE -- NUMTERM
VERSION 10-4(39) 5-23-72 BY DCS MODIFICATIONS TO SLS BASE STUFF
VERSION 10-4(33-38) 4-27-72 ALL SORTS OF THINGS
VERSION 10-4(28-33) 3-4-72
VERSION 10-4(8-27) 3-2-72 BY DCS EXEC @n ROUTINE
VERSION 10-4(7) 2-27-72 BY DCS ADD CLASSES⊂CLASSES SPECS, @TERMINAL∧@RESERVED
VERSION 10-4(6) 2-3-72 BY DCS MERGE WITH SLS VERSION, ADD SLS CONDITIONAL
VERSION 10(5) 1-24-72 BY DCS REMOVE SAILRUN FEATURE
VERSION 10(4) 1-14-72 BY DCS REPLACE CMDSCN.REL WITH SCNCMD.SAI
VERSION 10(3) 12-6-71 NON-TERMINALS INCLUDED IN ITEM DECLARATIONS
VERSION 10(2) 12-5-71 FIX BUG IN CLASS TABLES
VERSION 10(2) 12-5-71
VERSION 10(1) 12-5-71 PTRAN ISSUES ITEM DEFINITIONS FOR SSAIL
⊗;
COMMENT Declarations;
BEGIN "PTRAN"
DEFINE VERSION_NUMBER = "'401200000061";
REQUIRE VERSION_NUMBER VERSION;
Comment The Production Translator -- builds tables for the SAIL parser
to use. The tables are claimed to be a correct reflection of the input
file's requests, but no consistency or error checking is done;
DEFINE SRCEXT="NULL", RELEXT="NULL", LSTEXT="NULL",GOODSWT="NULL",
PROCESSOR="""PTRAN""", SRCMODE="0", RELMODE="0", LSTMODE="0";
DEFINE SWTSIZ="2";
REQUIRE "WNTSLS" SOURCE_FILE;
REQUIRE "SCNCMD[1,DCS]" SOURCE_FILE ;
REQUIRE 7000 STRING_SPACE;
DEFINE
⊃="COMMENT", SRC="1", SNK="2", SUB="3", BREAK="SRCBRK",
SAI="11",
EOF="SRCEOF", THROW="1", NORSCAN="2", SUPSPC="3", CR="'15",
LF="'12", CRLF="('15&'12)", DELIMNO="10",EXNO="385",
RESERVED="1", NONTERM="2", TERMINAL="3", CLASSID="4", EXROT="5",
ASSGN="6", BYTLEN="12", BYTENO="3", PRINTOCT="CVOS",
_ARROW="1", _GOTO="2", _ELSEGO="3", _EXEC="4", _SCAN="5",
_PUSHJ="6", _POPJ="7", _NOTREALLY="8",_BASE="9", _OLDBASE="10", _NODE="11",
_PRESUME="12",
SAFER="SAFE ", MAPNO="127", LININC="5", SYMNO="1290", CLSNO="72", PDNO="30",
NULSTR(A)="LENGTH(A)=0", PRINT="OUTSTR(",MSG="&CRLF)",
ERRIT(X)="BEGIN USERERR(0,1, ""PSEUDO OP ""&""X""&"" MISSING "");GO ERROREND END";
⊃ This macro decides whether numeric (fast) or symbolic (readable)
versions of things will be given to FAIL. Use MAKSYM for symbolic;
DEFINE PRINT_SYMBOL(X)="CVOS(NUMBER[X])";
INTEGER CURDELIM,DELIMSTACK,ON,LABCNT,ERRFLAG,COWNT,SUBCNT,SCANE,COMMAND,
CLASSTYPE,SYMBOL,NEXTFREE,FOUND,LINENO,BYTE,EXCNT,CLASSNO,Z,DPUSHJ,DPOPJ,DPRESUME,
COWNTC,R,II,OLDBASEFLAG, WHATKIND, NUMTERM;
STRING ALAB,LAB,WORD,HALSTR,TS,SYMMM,SAISTR;
SAFER INTEGER ARRAY FIRCLS[1:CLSNO], NUMCLS[1:CLSNO], NUMSYM[1:SYMNO],
NUMEX[1:EXNO], SYMD[0:MAPNO], DELIMS[1:DELIMNO],
PRODI[1:PDNO], TYPE, CLASS, CLASS2, NUMBER[-1:SYMNO];
SAFER STRING ARRAY PROD[1:PDNO],SYM[-1:SYMNO];
COMMENT Initialization, Lookup, Entersym, Subequ;
BOOLEAN PROCEDURE SUBEQU(STRING I,O);
RETURN(LENGTH(O)≥LENGTH(I) ∧ EQU(I,O[1 FOR LENGTH(I)]));
⊃ INITIALIZATION OF THE WORLD, BREAK TABLES,
I/O DEVICES, CONSTANTS.;
PROCEDURE INITIALIZATION;
BEGIN INTEGER T3;
SETBREAK(NORSCAN," "&LF,CR&'14,"IRN");
SETBREAK(SUPSPC," ",CR&'14,"XRN");
SETBREAK(THROW,LF&'14,NULL,"I");
NX_TFIL←FALSE; WANTBIN←TRUE;
COMMAND_SCAN;
OPEN(SUB,"DSK",0,0,2,0,T3,T3);
WHILE T3≠ ":" DO T3←LOP(BINFIL);
ENTER(SUB,BINFIL&"QQQ",T3);
IF (NOT WANTBIN) OR T3 THEN USERERR(0,0,"OUTPUT ENTRY ERROR");
IF SLS THEN BEGIN
OPEN(SAI,"DSK",0,0,2,0,T3,T3);
ENTER(SAI,BINFIL&"SAI",T3);
IF T3 THEN USERERR(0,0,"OUTPUT ENTRY ERROR");
OUT(SAI,"INTEGER ITEM "&CRLF);
SAISTR← "DEFINE "&CRLF
END;
TS←INPUT(SRC,THROW);
IF SUBEQU("COMMENT ⊗",TS) THEN
WHILE SRCBRK≠'14 DO TS←INPUT(SRC,THROW);
ON←EXCNT←BYTE←1;
ERRFLAG←DELIMSTACK←CURDELIM←COMMAND←EOF←0;
COWNT←IF SLS THEN 8 ELSE 0;
"START TOKEN NUMBERING AT FIRST ITEM NUMBER"
NEXTFREE←SYMNO;
SUBCNT←LINENO←LININC;
SYM[0]←" ";
HALSTR←" BYTE ("&CVS(BYTLEN)&") ";
END ;
INTEGER PROCEDURE LOOKUP(STRING A);
BEGIN "LOOKUP"
Comment uses Quadratic Search Algorithm as described in CACM ------;
INTEGER H,Q;
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 "LOOKUP";
⊃ Enter symbol in table. Always enters the word previously scanned by
GETWORD. "SYMBOL" is the index (from LOOKUP) into SYM, NUMBER, TYPE;
PROCEDURE ENTERSYM;
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;
SYM[SYMBOL]←WORD;
END "ENTERSYM";
COMMENT Pton, Printroom, Halword, Maksym;
⊃ Routines to write line of code to output file. Generates SOS line
numbers. REALOUTPUT=0 disables them. Many routines are used in place
of concatenation for speed;
PROCEDURE PTO_(STRING A);
BEGIN LINOUT(SNK,LINENO);LINENO←LINENO+1;OUT(SNK,A)END "PTO_";
PROCEDURE _PTO1(STRING A);
BEGIN OUT(SNK,A);OUT(SNK,CRLF);END "_PTO1";
PROCEDURE _PTO2(STRING A,B);
BEGIN OUT(SNK,A);_PTO1(B) END "_PTO2";
PROCEDURE _PTO3(STRING A,B,C);
BEGIN OUT(SNK,A); _PTO2(B,C) END "_PTO3";
PROCEDURE _PTO4(STRING A,B,C,D);
BEGIN OUT(SNK,A); _PTO3(B,C,D) END "_PTO4";
PROCEDURE PUTOUT(STRING A);
BEGIN PTO_(A); OUT(SNK,CRLF) END "PUTOUT";
PROCEDURE PTO2(STRING A,B);
BEGIN PTO_(A); _PTO1(B) END "PTO2";
PROCEDURE PTO3(STRING A,B,C);
BEGIN PTO_(A); _PTO2(B,C) END "PTO3";
PROCEDURE PTO4(STRING A,B,C,D);
BEGIN PTO_(A); _PTO3(B,C,D) END "PTO4";
PROCEDURE PRINTROOM;
BEGIN PUTOUT(NULL); PUTOUT(NULL) END;
PROCEDURE HALWORD(STRING A);
BEGIN "HALWORD"
IF BYTE=1 THEN PTO_(HALSTR);
OUT(SNK,A);
IF (BYTE←BYTE+1)≤BYTENO THEN
OUT(SNK,", ") ELSE
BEGIN OUT(SNK,CRLF); BYTE←1 END
END "HALWORD";
⊃ This procedure transforms an internal symbol into a symbolic one
for FAIL. It assures the symbols are ≤6 characters long, and that
they have the appropriate type (R, N, T) prefix;
PROCEDURE MAKSYM (INTEGER I);
BEGIN "MAKSYM"
STRING A; INTEGER T;
IF (A←SYM[I])="@" THEN T←LOP(A);
OUT(SNK,I←CASE TYPE[I] OF ("","R","N","T","C"));
OUT(SNK,A[1 TO 5]);
SYMMM←I&A;
END "MAKSYM";
COMMENT Assign, Classout;
⊃ Assign gives internal numbers to all symbols. It first assigns symbols
which are members of classes, so that the class-indexing EXEC stuff works.
Then it assigns numbers to all others. Finally it puts out "XXX←←nnnn" for
each symbol, telling FAIL what the values are;
PROCEDURE ASSIGN;
BEGIN "ASSIGN" INTEGER I,B;
STRING A;
PROCEDURE CLASSOUT (INTEGER Z);
FOR B←(IF SLS THEN 9 ELSE 1) STEP 1 UNTIL COWNT DO BEGIN "CLASSOUT"
I←NUMSYM[B];
PTO4(" ",PRINTOCT(IF Z THEN CLASS[I] ELSE CLASS2[I]),
" ;",SYM[I])
END "CLASSOUT";
PUTOUT (";CLASSES, BITS");
FOR B←1 STEP 1 UNTIL COWNTC DO
PUTOUT("; "&CVS(B)&" "&SYM[NUMCLS[B]]&" "&CVOS(
1 LSH (B-(IF B≤36 THEN 1 ELSE 37))));
PRINTROOM;
PRINTROOM;
PUTOUT ("; CLASS INDEX TABLE" );
PUTOUT ("CLSTAB: 0");
IF SLS THEN PUTOUT ("0↔0↔0↔0↔0↔0↔0↔0"); COMMENT NO TOKENS UNTIL 9;
CLASSOUT (TRUE);
PUTOUT((IF SLS THEN "↑" ELSE NULL)&"CLASSNO ← .-CLSTAB");
IF COWNTC>36 THEN BEGIN "ASG1"
PUTOUT("CLSTA2: 0");
CLASSOUT(FALSE);
END "ASG1";
⊃ NOW ASSIGN ALL OTHERS;
FOR I ← 1 STEP 1 UNTIL SYMNO DO BEGIN "ALLOTH"
IF LENGTH(SYM[I])∧NUMBER[I]=0∧0<TYPE[I]<ASSGN THEN BEGIN
COWNT ← COWNT + 1;
NUMBER [I] ← COWNT;
NUMSYM[COWNT]←I
END;
END "ALLOTH";
⊃ NOW OUTPUT SYMBOLIC ASSIGNMENTS;
PUTOUT ("; SYMBOLIC ASSIGNMENTS");
FOR B←(IF SLS THEN 9 ELSE 1) STEP 1 UNTIL COWNT DO
IF TYPE[I←NUMSYM[B]]=TERMINAL THEN
BEGIN
NUMTERM←NUMBER[I];
PTO_("↑");
MAKSYM(I);
_PTO4("←←",IF CLASS[I]∨CLASS2[I] THEN "CLASOP" ELSE "OPER",
"+",PRINTOCT(NUMBER[I]));
IF SLS THEN BEGIN
OUT(SAI," "&SYMMM&","&CRLF);
SAISTR←SAISTR&" OP"&SYMMM[2 TO ∞]&" = ""'"&PRINTOCT(NUMBER[I])&
""","&CRLF
END
END
ELSE BEGIN
NUMTERM←NUMBER[I];
PTO_(IF SLS THEN "↑" ELSE NULL);
MAKSYM(I);
_PTO2("←←",PRINTOCT(NUMBER[I]));
IF SLS THEN BEGIN
OUT(SAI," "&SYMMM&","&CRLF);
SAISTR←SAISTR&" OP"&SYMMM[2 TO ∞]&" = ""'"&PRINTOCT(NUMBER[I])&
""","&CRLF
END
END;
PRINTROOM;
LINOUT(SUB,SUBCNT←SUBCNT+LININC);
OUT(SUB," <SCAN TABLE>"&CRLF);
FOR B←1 STEP 1 UNTIL MAPNO DO
IF (I←SYMD[B])∧TYPE[I]=TERMINAL THEN BEGIN "TOUT2"
LINOUT(SUB,SUBCNT←SUBCNT+LININC);
OUT(SUB,CVS(B)&" "&CVS(NUMBER[I]));
OUT(SUB,(IF CLASS[I] ∨ CLASS2[I] THEN " C" ELSE " N")&CRLF);
END "TOUT2";
⊃ SYMBOL TABLE ENTRIES FOR ALL RESERVEDS;
LINOUT(SUB,SUBCNT←SUBCNT+LININC);
OUT(SUB," <RESERVED-WORDS>"&CRLF);
PUTOUT("; SYMBOL TABLE ENTRIES");
FOR I ← 1 STEP 1 UNTIL SYMNO DO
IF TYPE[I]=RESERVED THEN BEGIN "RES2"
PTO_("; ");
MAKSYM(I);
_PTO4(" ",PRINTOCT(NUMBER[I])," ",SYM[I]);
LINOUT(SUB,SUBCNT←SUBCNT+LININC);
OUT(SUB,SYM[I]&" "&PRINTOCT(NUMBER[I])&
" "&(IF CLASS[I] ∨ CLASS2[I] THEN "C" ELSE "N")&CRLF);
END "RES2";
PUTOUT(" LSTON(PRODS)");
RELEASE (SUB);
END "ASSIGN";
COMMENT Searchit, Gword;
⊃ Searchit Checks its argument for special features (EXEC, SCAN, ¬, etc.)
then looks it up if not special. FOUND, CLASSTYPE, and COMMAND are
set to reflect the result;
PROCEDURE SEARCHIT(STRING A);
BEGIN "SEARCHIT"
INTEGER CHAR,L,I;
COMMAND←CLASSTYPE←FOUND←0; CHAR←A;
IF (L←LENGTH(A))=1 ∧ (I←SYMD[CHAR]) THEN BEGIN "SRCH1"
SYMBOL←I; A←WORD←SYM[I]; FOUND←-1;
RETURN
END "SRCH1";
IF (L←LENGTH(A)>1) THEN
IF CHAR="@" THEN CLASSTYPE←1 ELSE
IF CHAR="→" THEN FOUND←_ARROW ELSE
IF CHAR="¬" THEN FOUND←_GOTO ELSE
IF CHAR="#" THEN FOUND←_ELSEGO ELSE
IF EQU(A,"EXEC") THEN FOUND←_EXEC ELSE
IF EQU(A,"SCAN") THEN FOUND←_SCAN ELSE
IF EQU(A,"PRESUME") THEN FOUND←_PRESUME ELSE
IF CHAR="↑" THEN FOUND←_PUSHJ ELSE
IF CHAR="↓" THEN FOUND←_POPJ ELSE
IF CHAR="<" THEN COMMAND←1 ELSE
IF CHAR="*" ∨ CHAR="⊗" THEN FOUND←_NOTREALLY ELSE
IF SLS THEN
IF SUBEQU("BASE",A) THEN FOUND←_BASE ELSE
IF EQU(A,"OLDBASE") THEN FOUND←_OLDBASE ELSE
IF EQU(A,"NODES") THEN FOUND←_NODE
;
IF ¬(FOUND ∨ COMMAND) THEN BEGIN "SRCH3"
IF L>1∧EQU(A[1 FOR 2],"SG") THEN RETURN;
FOUND←LOOKUP(A);
END "SRCH3";
END "SEARCHIT";
⊃ This is the procedure which looks at the source file, returning one
word at a time, using standard delimiters. It tries to type the word
as "COMMAND", "JUMPTYPE", "LABELTYPE", or "CLASSTYPE". The prefixes
expected for these types are < ¬ : @. At the end of a line, GETWORD
returns NULL. It does a symbol LOOKUP. If FOUND is nonzero, the symbol
was found or represents a special kind of thing (SCAN, EXEC, etc.) Symbol
contains the appropriate symbol table index if FOUND<0;
RECURSIVE STRING PROCEDURE GWORD;
BEGIN "GWORD"STRING A;
PROCEDURE PROCESS(INTEGER I);
BEGIN "PROCESS"
SEARCHIT(GWORD); ⊃ GET AN IDENTIFIER;
IF ¬FOUND ∨ TYPE[SYMBOL] ≠ ASSGN THEN BEGIN
PRINT "INVALID CONDITIONAL SWITCH" MSG;
Z←0
END ELSE Z←NUMBER[SYMBOL];
DELIMS[DELIMSTACK←DELIMSTACK+1]←CURDELIM;
CURDELIM←GWORD; ⊃ DELIMITER ;
ON←(IF (I∧Z∧ON) ∨ (¬I∧¬Z∧ON) THEN 1 ELSE 0);
IF ¬ON THEN BEGIN
DO BEGIN "GW1" A←GWORD END UNTIL LENGTH(A)=1 AND A=CURDELIM ;
CURDELIM←DELIMS[DELIMSTACK];DELIMSTACK←DELIMSTACK-1;
ON ← 1;
END
END "PROCESS";
WORD ← INPUT(SRC,SUPSPC);
IF BREAK=LF THEN BEGIN
WORD←INPUT(SRC,THROW);
RETURN(NULL);
END;
A←WORD ← INPUT(SRC,NORSCAN);
IF LENGTH(WORD)=6 AND EQU(WORD,"MUMBLE") THEN BEGIN
WHILE WORD≠";" ∧ EQU(WORD[∞ FOR 1],";")=0 DO
DO A←GWORD UNTIL LENGTH(A);
A←GWORD
END;
IF WORD="∞" THEN BEGIN
IF EQU(A,"∞∞") THEN BEGIN ⊃ LINE CONTINUATION;
A←GWORD;
RETURN(GWORD);
END ELSE
IF EQU(A,"∞ASG") THEN BEGIN ⊃ ASSIGN A COMPILATION VARB ;
SEARCHIT(GWORD); ⊃ IDENTIFIER ;
IF ¬ FOUND THEN BEGIN
ENTERSYM;
TYPE[SYMBOL]←ASSGN;
END;
IF TYPE[SYMBOL]≠ASSGN THEN PRINT "INVALID CONDITIONAL VARIABLE" MSG;
NUMBER[SYMBOL]←CVD(GWORD);
END ELSE
IF EQU(A,"∞IFE") THEN BEGIN
PROCESS (0);
RETURN (GWORD);
END ELSE
IF EQU(A,"∞IFN") THEN BEGIN
PROCESS (1);
RETURN (GWORD);
END;
END;
IF ON AND LENGTH(WORD)=1 ∧ WORD=CURDELIM THEN BEGIN "GW4"
CURDELIM←DELIMS[DELIMSTACK];DELIMSTACK←DELIMSTACK-1;
RETURN (GWORD);
END "GW4";
IF LENGTH(WORD)>1 ∧ WORD[LENGTH(WORD) FOR 1]=":" THEN BEGIN "GW5"
PTO2((LAB←WORD[1 FOR LENGTH(WORD)-1]),"←.+FTDEBUG");
LABCNT←0;ALAB←NULL;
RETURN(GWORD);
END "GW5";
RETURN (WORD);
END;
COMMENT Getword, Get_Good_Word, Compile, Map;
⊃ NOW FOR THE PROCEDURES WHICH ARE ACTUALLY USED BY THE POOR USERS;
STRING PROCEDURE GETWORD;
BEGIN "GETWORD"
WORD←GWORD;
IF LENGTH(WORD) THEN SEARCHIT(WORD);
RETURN (WORD);
END "GETWORD";
STRING PROCEDURE GET_GOOD_WORD;
BEGIN "GET_GOOD_WORD"
DO WORD←GETWORD UNTIL LENGTH(WORD);
RETURN(WORD);
END "GET_GOOD_WORD";
⊃ This makes (internal PTRAN) symbol tables of the simple variety;
PROCEDURE COMPILE (INTEGER A);
BEGIN "COMPILE"
STRING AA;
DO BEGIN "CMP1"
AA←GET_GOOD_WORD;
IF COMMAND=0 THEN BEGIN "CMP2"
IF FOUND<0∧TYPE[SYMBOL]≠0 THEN PRINT "DUPLICATE SYMBOL "&AA MSG;
IF FOUND>0 THEN PRINT "IMMORAL SYMBOL "&AA MSG;
IF ¬FOUND THEN ENTERSYM;
TYPE[SYMBOL]←A;
END; END UNTIL COMMAND;
END "COMPILE";
⊃ MAP inputs the symbol mapping information. Symbols like +, -, etc. are
given names which FAIL will accept;
PROCEDURE MAP;
BEGIN "MAP" STRING A;
DO BEGIN "MP1"
A←GET_GOOD_WORD;
IF COMMAND=0 THEN BEGIN "MP2"
GET_GOOD_WORD;
ENTERSYM;
SYMD[A]←SYMBOL
END "MP2";
END "MP1" UNTIL COMMAND;
END "MAP";
PROCEDURE LISTR(INTEGER ARRAY AA;INTEGER BB;STRING CC; INTEGER DD);
BEGIN "LISTR"
INTEGER I,J;
FOR J←1 STEP 1 UNTIL BB DO BEGIN "LS1"
I←AA[J];
PTO_(CC);
IF DD=1 THEN MAKSYM(I) ELSE
IF DD=2 THEN OUT(SNK,(SYM[I]&" ")[1 FOR 6]) ELSE
OUT(SNK,SYM[I]);
IF DD=0 THEN OUT(SNK,CRLF) ELSE _PTO1("/");
END "LS1"
END "LISTR";
COMMENT Prodscan, Endcheck;
⊃ PRODSCAN
This procedure scans the productions and creates the byte tables. It is
called with a valid "WORD". For each line, it:
1. Assembles all the words (and symbol entry #s) into "PROD" AND "PRODI"
keeping track of words like "EXEC", "SCAN" etc.
2. Puts out (right to left) code for the compare portion of the production.
3. Issues tree node descriptions based on BASE and NODE specs (SLS only).
4. Puts out calls to the executive routines.
5. Tries to match right with left parts and put out correct stack-restoring code.
6. Specifies number of SCANNER calls.
;
PROCEDURE PRODSCAN;
BEGIN "PRODSCAN" INTEGER FAILFLG,LEFTEND,RIGHTEND,EXECEND,SUCCEED,I,J,K,C,D,B,EXF;
STRING A; INTEGER EXTRA,ARSEEN,BASELOC,NODEND;
PROCEDURE ENDCHECK(INTEGER ILEV);
BEGIN "ENDCHECK"
⊃ This procedure sets the pointers to interesting places in the PROD list.
LEFTEND (→last left side token) and RIGHTEND (→last right side token)
are always set. Then if LEFTEND=RIGHTEND (no right part), the right
part is copied from the left part (no reduction occurs). Finally,
NODEND and/or EXECEND are set if requested and necessary;
IF ¬LEFTEND THEN LEFTEND←K; IF ¬RIGHTEND THEN RIGHTEND←K;
IF ¬ARSEEN∧LEFTEND=RIGHTEND THEN
FOR II ← 1 STEP 1 UNTIL LEFTEND DO BEGIN "CHECKARROW"
PROD[RIGHTEND←K←K+1] ← PROD[II];
PRODI[K] ← PRODI[II]
END "CHECKARROW";
IF ILEV>0∧¬NODEND THEN NODEND←K;
IF ILEV>1∧¬EXECEND THEN EXECEND←K
END "ENDCHECK";
COMMENT Prodscan, Assemble;
PROCEDURE ASSEMBLE;
BEGIN "ASSEMBLE"
LABEL MORE,BLAB;
EXF←1; A ← WORD;
DPUSHJ←DPOPJ←K←EXTRA←ARSEEN←FAILFLG←LEFTEND←RIGHTEND←EXECEND←SUCCEED←SCANE
←BASELOC←NODEND←OLDBASEFLAG←DPRESUME←0;
WHILE ¬NULSTR(A) DO BEGIN "ASS1"
IF FOUND>0 THEN CASE FOUND OF BEGIN "LOOK FOR SPECIALS"
[_ARROW]BEGIN "RIGHT ARROW"
ARSEEN←1;
LEFTEND←K;
GO MORE
END;
[_EXEC] BEGIN "EXEC SEEN"
EXF←0;
ENDCHECK(1); "SET {LEFT-,RIGHT-,NOD-}END IF NECESSARY"
GO MORE
END;
[_SCAN] BEGIN "SCAN SEEN"
EXF←SCANE←1;
ENDCHECK(2); "SET ALL IF NECESSARY"
GO MORE
END;
[_GOTO] BEGIN "¬ SEEN"
EXF←1;
ENDCHECK(2);
SUCCEED←K+1;
END;
[_ELSEGO]FAILFLG←K+1; "FAIL ADDRESS SEEN"
[_PUSHJ]BEGIN "↑ SEEN FOR A PRODUCTION PUSHJ"
ENDCHECK(2);
DPUSHJ ← K+1;
EXTRA←EXTRA+BYTENO;
END;
[_POPJ] BEGIN "↓↓ SEEN FOR A POPJ"
ENDCHECK(2);
DPOPJ ← 1;
END;
[_NOTREALLY]EXTRA←EXTRA-1;
[_BASE] BEGIN "BASE SEEN"
INTEGER I;
OLDBASEFLAG←FALSE;
BLAB: ENDCHECK(0); "SET LEFTEND, RIGHTEND IF NECESSARY"
BASELOC←K+1;
WHATKIND← IF ¬(I←A[5 FOR 1]) THEN 0 ELSE
(IF I="B" THEN '20 ELSE 1) LSH 7;
A←GETWORD; "THE BASE NODE NAME"
EXTRA←EXTRA+1
END;
[_OLDBASE] BEGIN "EXTEND OLD BASE"
OLDBASEFLAG←TRUE;
GO BLAB
END;
[_NODE] GO TO MORE;
[_PRESUME] BEGIN "PRESUME SEEN"
EXF←1;
ENDCHECK(2);
DPRESUME←1;
END
END "LOOK FOR SPECIALS";
K←K+1;
IF EXF=0 AND CLASSTYPE THEN EXTRA←EXTRA+1;
IF ¬EXF ∧ ¬FOUND ∧ ¬CLASSTYPE THEN BEGIN "ASS2"
ENTERSYM;
TYPE[SYMBOL]←EXROT;
NUMBER[SYMBOL]←EXCNT;
NUMEX[EXCNT]←SYMBOL;
EXCNT←EXCNT+1;
END "ASS2" ELSE
IF ¬FOUND AND ¬(CLASSTYPE∧"0"≤A[2 FOR 1]≤"9"∧(EXTRA←EXTRA-1)+10000) AND
EXECEND=0 ∧ ¬(LENGTH(A)≥2 ∧ EQU(A[1 FOR 2],"SG"))
THEN BEGIN "ASS3"
SYMBOL←1;
PRINT "UNDEFINED SYMBOL ? "&A MSG;
ERRFLAG←1;
END;
PROD[K]←A;
PRODI[K]←SYMBOL;
MORE: A←GETWORD;
END
END "ASSEMBLE";
INTEGER PROCEDURE INDEX(STRING S;INTEGER LIM);
BEGIN "INDEX"
INTEGER I;
FOR I←1 STEP 1 UNTIL LIM DO IF EQU(S,PROD[I]) THEN RETURN(I);
RETURN(0)
END "INDEX";
COMMENT Prodscan;
COMMENT MAIN BODY OF PRODSCAN; DEFINE B!="LEFTEND-B+1";
ASSEMBLE;
IF FALSE THEN BEGIN "HOOK" OUTSTR(LAB&ALAB) END "HOOK";
PRINTROOM;
IF LEFTEND=0 THEN BEGIN LEFTEND←1; PRINT "NO LEFT PART "&LAB MSG;ERRFLAG←1;END;
IF ¬(DPUSHJ OR DPOPJ) THEN
IF SUCCEED=0 THEN BEGIN SUCCEED←1; PRINT"NO SUCCESS LOCATION "&LAB MSG;ERRFLAG←1;END;
PTO3 ("IFN FTDEBUG < SIXBIT/",(LAB&ALAB)[1 TO 6],"/>");
ALAB←("A"-1)+(LABCNT←LABCNT+1);
PTO_(" XWD ");
IF FAILFLG THEN
OUT(SNK,PROD[FAILFLG][2 TO ∞]) ELSE
BEGIN
OUT(SNK,".+FTDEBUG+");
OUT(SNK,PRINTOCT((EXTRA+EXECEND+(1+2*BYTENO)) DIV BYTENO));
END;
_PTO2(", ",IF SUCCEED THEN PROD[SUCCEED][2 TO ∞] ELSE "0");
⊃ Now we process the left-half compares against the stack. These
are simply put out in reverse order of the scan order -- top seen first;
FOR J ←LEFTEND STEP -1 UNTIL 1 DO BEGIN "ASS4"
A←PROD[J]; C←PRODI[J];
IF LENGTH(A)≥2 ∧ EQU(A[1 FOR 2],"SG") THEN HALWORD("0") ELSE
BEGIN
A←PRINT_SYMBOL(C)&
(IF CLASS[C]+CLASS2[C] THEN "+BCARE" ELSE
IF TYPE[C] = CLASSID THEN
("+BCLASS"&(IF NUMBER[C]>36 THEN "+334" ELSE NULL))ELSE NULL);
IF J>1∧SUBEQU("⊗⊗",PROD[J-1]) THEN BEGIN
A←A&"+BINF"; J←J-1
END;
HALWORD(A)
END
END "ASS4";
⊃ Finish up the left half, specify # of right-half temporaries;
HALWORD(PRINTOCT(RIGHTEND-LEFTEND)&"+BDONE");
⊃ Specify the right-half -- index+BTEMP for matches, tokens for others;
FOR J←LEFTEND+1 STEP 1 UNTIL RIGHTEND DO
IF (B←INDEX(PROD[J],LEFTEND)) ∧ (B≤1∨PROD[B-1]≠"⊗")
THEN HALWORD(PRINTOCT(B!)&"+BTEMP") ELSE
HALWORD(PRINT_SYMBOL(PRODI[J]));
⊃ Process tree-building specifications. The word BASE (BASELOC in PROD array)
causes the next token to be used as the name of a new parse tree node (the
name is augmented by a code to distinguish it from, say, terminal symbols
with the same designations. The node name will more often be derived from
a terminal than from a non-terminal, but each terminal so used falls into
an equivalence class represented by a non-terminal (+, *, -, LAND all belong
in this sense to the non-terminal class Expression). The base node will be
represented in the output by BINF + (either the token number or BTEMP+index).
Then NODES appear (the actual word in the production line is ignored). Each
is represented by BTEMP+index, since all will be fetched from the left side.
BINF on will represent a variable number of actual results pointed to by the
parse entry for that index: the actual number will be calculated by the
parser. The nodes are represented in the output file by the file location
pointers found in the LPSAV stack. (NB all this is SLS stuff). There will
be one extra byte containing only BDONE to finish the node specifiers. Then
come the EXECS or whatever;
IF BASELOC THEN BEGIN "TREE PROCESS"
TS←IF OLDBASEFLAG THEN "BCLASS" ELSE "0";
IF B←INDEX(PROD[BASELOC],LEFTEND) THEN HALWORD(TS&"+BINF+BTEMP+"
&PRINTOCT(B!)) ELSE
HALWORD(TS&"+BINF+"&PRINT_SYMBOL(PRODI[BASELOC]));
A←NULL; I←0;
FOR J←BASELOC+1 STEP 1 UNTIL NODEND DO
IF SUBEQU("⊗⊗",PROD[J]) THEN A←"+BINF" ELSE BEGIN
B←INDEX(PROD[J],LEFTEND);
PROD[J]←PRINTOCT(B!)&A;
I←I+1;
A←NULL
END;
HALWORD(PRINTOCT(I LOR WHATKIND));
FOR J←BASELOC+1 STEP 1 UNTIL NODEND DO
IF (A←PROD[J])≠"⊗" THEN HALWORD(A);
END "TREE PROCESS";
⊃ Process EXEC routine calls. If the EXEC routine is typed according to some
class of tokens, search left hand side until the matching token is found.
Then put out the index of that token, then the base number of the class.
This base number is subtracted (by parser) from the token number and the
result passed to the EXEC. Then, no matter what, put out the EXEC routine
index number. If the ** (dispatch via parser) feature was used, the BCLASS
bit is turned on in the class number byte, indicating that the parser should
use the index to select one of the following EXECS. The BTEMP bit will appear
in the last indexed exec (followed by another ** in productions).
On 3-1-72 the syntax was extended by DCS to allow EXEC @4 ROUT, which means
that the explicit index 4 will be sent directly to the exec routine. In this
case, BTEMP is turned on in the byte with 4 in it -- the next byte is the
EXEC routine byte;
FOR J ← NODEND+1 STEP 1 UNTIL EXECEND DO
IF PROD[J]="@" THEN IF "0"≤PROD[J][2 FOR 1]≤"9" THEN
HALWORD(PROD[J][2 TO ∞]&"+BTEMP")
ELSE BEGIN "ASS10"
HALWORD(PRINTOCT(LEFTEND-INDEX(PROD[J],LEFTEND)+1)&"+BCLASS");
IF PROD[J+1] = "*" THEN BEGIN "ASS12"
HALWORD(PRINTOCT(FIRCLS[NUMBER[PRODI[J]]])&"+BCLASS");
FOR J←J+2 STEP 1 WHILE PROD[J+1]≠"*" DO
HALWORD(PRINTOCT(NUMBER[PRODI[J]]));
HALWORD(PRINTOCT(NUMBER[PRODI[J]])&"+BTEMP");
J ← J +1;
END "ASS12" ELSE HALWORD(PRINTOCT(FIRCLS[NUMBER[PRODI[J]]]))
END "ASS10" ELSE HALWORD(PRINTOCT(NUMBER[PRODI[J]]));
⊃ Issue SCANNER calls, then quit. If there is a PUSHJ to be done, include
BCLASS in the BDONE/SCANNER word. If a POPJ, include BTEMP;
HALWORD(
PRINTOCT(IF SCANE THEN 1 MAX CVD(PROD[EXECEND+1]) ELSE 0)
&"+BDONE"&(IF DPUSHJ THEN "+BCLASS" ELSE "")&
(IF DPOPJ THEN "+BTEMP" ELSE "")
&(IF DPRESUME THEN "+BPRESUME" ELSE ""));
WHILE BYTE ≠ 1 DO BEGIN "ASS15" HALWORD("0");END "ASS15";
IF DPUSHJ THEN PTO2(" ",(PROD[DPUSHJ][2 TO ∞]));
PRINTROOM;
END "PRODSCAN";
COMMENT Ptran;
⊃ THIS IS THE MAIN EXECUTION BLOCK;
ON_ETIME←FALSE; ⊃ SET UP TO OPEN COMMAND FILE;
WHILE TRUE DO BEGIN "EXECUTE"
LABEL PROGEND,ERROREND;
INTEGER I,CURCLS,FIRFLG;STRING A;
INITIALIZATION;
PUTOUT("LSTON(PDEFS)");
COWNTC←0;
WHILE COMMAND=0 DO A←GETWORD;
IF EQU(WORD,"<SYMBOLS>") THEN MAP;
IF EQU(WORD,"<TERMINALS>")=0 THEN ERRIT(<TERMINALS>)
ELSE COMPILE(TERMINAL);
IF EQU(WORD,"<RESERVED-WORDS>")=0 THEN ERRIT(<RESERVED-WORDS>)
ELSE COMPILE (RESERVED);
IF EQU(WORD,"<NON-TERMINAL-SYMBOLS>")=0 THEN ERRIT(<NON-TERMINAL-SYMBOLS>)
ELSE COMPILE(NONTERM);
IF EQU(WORD,"<CLASSES>") THEN
DO BEGIN "MAIN1"
A←GET_GOOD_WORD;
IF COMMAND = 0 THEN BEGIN "MAIN2"
INTEGER CBIT,OLDC,OLDCBIT,I,J,CTYPE;
PROCEDURE CLSIDASSIGN;
BEGIN "CLSIDASSIGN"
IF NUMBER [SYMBOL]=0 THEN BEGIN
NUMBER[SYMBOL]←COWNT←COWNT+1;
NUMSYM[COWNT]←SYMBOL
END;
IF FIRFLG THEN BEGIN
FIRCLS[COWNTC]←NUMBER[SYMBOL];
FIRFLG←0;
END;
IF COWNTC > 36 THEN
IF COWNTC > CLSNO THEN USERERR(0,0,"CLASS TABLE OVERFLOW")
ELSE
CLASS2[SYMBOL]←CLASS2[SYMBOL]LOR CBIT
ELSE
CLASS[SYMBOL]←CLASS[SYMBOL]LOR CBIT;
END "CLSIDASSIGN";
IF CLASSTYPE AND ¬FOUND THEN BEGIN "MAIN3"
ENTERSYM;
TYPE[SYMBOL]←CLASSID;
COWNTC←COWNTC+1; CBIT←1 LSH (COWNTC-(IF COWNTC≤36 THEN 1 ELSE 37));
FIRFLG←1;
NUMBER[SYMBOL]←COWNTC;
NUMCLS[COWNTC]←SYMBOL;
IF EQU(SYM[SYMBOL],"@RESERVED")∧(CTYPE←RESERVED)
∨ EQU(SYM[SYMBOL],"@TERMINAL")∧(CTYPE←TERMINAL)
THEN BEGIN "RESTER"
FOR SYMBOL←1 STEP 1 UNTIL SYMNO DO
IF TYPE[SYMBOL]=CTYPE THEN BEGIN
CLSIDASSIGN
END
END "RESTER"
END "MAIN3" ELSE IF CLASSTYPE ⊃ ∧FOUND; THEN BEGIN "MAIN35"
COMMENT CLASS⊂CLASS -- WHAT CLASS!;
OLDC←NUMBER[SYMBOL];
OLDCBIT←1 LSH (IF OLDC>36 THEN OLDC-37 ELSE OLDC-1);
"PUT ALL MEMBERS OF OLD CLASS INTO NEW CLASS TOO"
FOR I←1 STEP 1 UNTIL COWNT DO BEGIN
SYMBOL←NUMSYM[I];
IF OLDC≤36∧CLASS[SYMBOL]LAND OLDCBIT∨OLDC>36∧CLASS2[SYMBOL]LAND OLDCBIT
THEN IF COWNTC≤36 THEN CLASS[SYMBOL]←CLASS[SYMBOL] LOR CBIT
ELSE CLASS2[SYMBOL]←CLASS2[SYMBOL] LOR CBIT
END;
END "MAIN35"
ELSE IF FOUND THEN CLSIDASSIGN
ELSE BEGIN ERRFLAG←1;PRINT "UNDECLARED SYMBOL "&WORD MSG ;END;
END "MAIN2"
END "MAIN1" UNTIL COMMAND;
PRINTROOM;
ASSIGN;
PUTOUT ("PRBG%:");
IF EQU(WORD,"<PRODUCTIONS>")=0 THEN ERRIT(<PRODUCTIONS>) ELSE BEGIN
DO BEGIN "MAIN6"
A←GET_GOOD_WORD;
IF COMMAND=0 THEN PRODSCAN;
END UNTIL COMMAND;
END;
PRINTROOM;
PUTOUT("LSTON(SUBRS)");
PUTOUT("EXCTAB: ");
LISTR(NUMEX,EXCNT-1," SUBR ",0);
PUTOUT(" IFN FTDEBUG {");
PUTOUT("EXCNAM: SIXBIT/EXCNM/");
LISTR(NUMEX,EXCNT-1," SIXBIT/",2);
PUTOUT("SYMNAM: SIXBIT/SYMNM/");
LISTR(NUMSYM,COWNT," SIXBIT/",1);
PUTOUT("SYMNO← .-SYMNAM");
PUTOUT(" }");
PUTOUT("BEND PARSE");
IF ERRFLAG THEN
ERROREND: BEGIN
ERRFLAG←1; PRINT "ERROR RETURN" MSG END;
PROGEND:
IF ERRFLAG THEN DONE;
RELEASE(SUB);
IF SLS THEN BEGIN
OUT(SAI,"NOTANITEMATALL;"&CRLF&CRLF&SAISTR&CRLF&
"ENOUGH=""ENOUGH"";"&CRLF&
"DEFINE NUMTRM=""'"&CVOS(NUMTERM)&""";"&CRLF); RELEASE(SAI)
END;
END "EXECUTE";
END "PTRAN";