perm filename PTRAN.SAI[X,AIL]3 blob sn#076452 filedate 1973-12-09 generic text, type T, neo UTF8
COMMENT ⊗   VALID 00014 PAGES VERSION 10-4(55)
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  401200000067  ⊗;


COMMENT ⊗
VERSION 10-4(55) 12-9-73 BY RHT REQUIRE SCNCMD W/O A PPN
VERSION 10-4(54) 12-2-73 BY JRL SUPPRESS LINOUTS VIA A MACRO HACK
VERSION 10-4(53) 9-23-73 BY HJS ALLOW SPACES AFTER ∞∞
VERSION 10-4(52) 8-17-73 BY JRL REMOVE DUPLICATE DEFINITION OF SRC
VERSION 10-4(51) 7-27-73 BY JRL TEMPORARILY LET DEFINE=REDEFINE TO AVOID ERRMSGS
VERSION 10-4(50) 7-15-73 BY JRL INCREASE EXNO TO 400
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 = "'401200000067";
  LET DEFINE = REDEFINE;
  DEFINE VERSION_NUMBER = "'401200000062";
 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="""PTR""", RELEXT="NULL", LSTEXT="NULL",GOODSWT="NULL",
	PROCESSOR="""PTRAN""", SRCMODE="0", RELMODE="0", LSTMODE="0";
DEFINE SWTSIZ="2";
REQUIRE "WNTSLS" SOURCE_FILE;
REQUIRE "SCNCMD.SAI" SOURCE_FILE ;
REQUIRE 7000 STRING_SPACE;
DEFINE
⊃="COMMENT",    SNK="2",      SUB="3",     BREAK="SRCBRK",  SAI="11",
 EOF="SRCEOF",  THROW="1",   NORSCAN="2",  SUPSPC="3",  THROW2="4",
 CR="'15",	TAB = "'11", 
 LF="'12",      CRLF="('15&'12)",	   DELIMNO="10",EXNO="400",
 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])";

⊃ Currently (11-73) SOS style line numbers are not desired. If in the
  future they are once again desired, remove the following macro definition;

DEFINE LINOUT(A,B)="";


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," "&TAB&LF,CR&'14,"IRN");
	SETBREAK(SUPSPC," "&TAB,CR&'14,"XRN");
	SETBREAK(THROW,LF&'14,NULL,"I");
	SETBREAK(THROW2,LF&'14,NULL,"IRN");

	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;
			INPUT(SRC,THROW2);
			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";