Trailing-Edge
-
PDP-10 Archives
-
decus_20tap1_198111
-
decus/20-0002/ptran.sai
There is 1 other file named ptran.sai in the archive. Click here to see a list.
00100 COMMENT HISTORY
00200 AUTHOR,SAIL,REASON
00300 025 401200000070 ;
00400
00500
00600 COMMENT
00700 VERSION 10-4(56) 1-11-74 BY RHT INCREASE EXNO FROM 400 TO 450
00800 VERSION 10-4(55) 12-9-73 BY RHT REQUIRE SCNCMD W/O A PPN
00900 VERSION 10-4(54) 12-2-73 BY JRL SUPPRESS LINOUTS VIA A MACRO HACK
01000 VERSION 10-4(53) 9-23-73 BY HJS ALLOW SPACES AFTER
01100 VERSION 10-4(52) 8-17-73 BY JRL REMOVE DUPLICATE DEFINITION OF SRC
01200 VERSION 10-4(51) 7-27-73 BY JRL TEMPORARILY LET DEFINE=REDEFINE TO AVOID ERRMSGS
01300 VERSION 10-4(50) 7-15-73 BY JRL INCREASE EXNO TO 400
01400 VERSION 10-4(49) 11-3-72 BY JRL GIVE CLASS TABLE OVERFLOW ERROR MESSAGE
01500 VERSION 10-4(48) 7-31-72 BY DCS SLS CHANGE
01600 VERSION 10-4(47) 7-18-72 BY KUT VANLEHN IS TO INCREASE EXNO
01700 VERSION 10-4(46) 7-18-72 BY KURT VANLEHN IS AS BEFORE SYMNO _ 1290
01800 VERSION 10-4(45) 7-18-72 BY KURT VANLEHN IS THE SAME AS LAST TIME: SYMNO _ 1258
01900 VERSION 10-4(44) 7-18-72 BY KURT VANLEHN TO TRY A DIFFERENT SYMNO
02000 VERSION 10-4(43) 7-18-72 BY KVL INCREASE SYMNO FROM 1200 TO 1282 (1283-1)
02100 VERSION 10-4(42) 7-17-72 BY DCS SYMNO, EXNO GET LARGER
02200 VERSION 10-4(41) 7-8-72
02300 VERSION 10-4(40) 7-8-72 BY DCS FIX AN SLS THINGIE -- NUMTERM
02400 VERSION 10-4(39) 5-23-72 BY DCS MODIFICATIONS TO SLS BASE STUFF
02500 VERSION 10-4(33-38) 4-27-72 ALL SORTS OF THINGS
02600 VERSION 10-4(28-33) 3-4-72
02700 VERSION 10-4(8-27) 3-2-72 BY DCS EXEC @n ROUTINE
02800 VERSION 10-4(7) 2-27-72 BY DCS ADD CLASSESCLASSES SPECS, @TERMINAL@RESERVED
02900 VERSION 10-4(6) 2-3-72 BY DCS MERGE WITH SLS VERSION, ADD SLS CONDITIONAL
03000 VERSION 10(5) 1-24-72 BY DCS REMOVE SAILRUN FEATURE
03100 VERSION 10(4) 1-14-72 BY DCS REPLACE CMDSCN.REL WITH SCNCMD.SAI
03200 VERSION 10(3) 12-6-71 NON-TERMINALS INCLUDED IN ITEM DECLARATIONS
03300 VERSION 10(2) 12-5-71 FIX BUG IN CLASS TABLES
03400 VERSION 10(2) 12-5-71
03500 VERSION 10(1) 12-5-71 PTRAN ISSUES ITEM DEFINITIONS FOR SSAIL
03600
03700 ;
03800
00100 COMMENT Declarations;
00200
00300 BEGIN "PTRAN"
00400 DEFINE VERSIONNUMBER = "'401200000070";
00500 LET DEFINE = REDEFINE;
00600 DEFINE VERSIONNUMBER = "'401200000062";
00700 REQUIRE VERSIONNUMBER VERSION;
00800 Comment The Production Translator -- builds tables for the SAIL parser
00900 to use. The tables are claimed to be a correct reflection of the input
01000 file's requests, but no consistency or error checking is done;
01100
01200 DEFINE SRCEXT="""PTR""", RELEXT="NULL", LSTEXT="NULL",GOODSWT="NULL",
01300 PROCESSOR="""PTRAN""", SRCMODE="0", RELMODE="0", LSTMODE="0";
01400 DEFINE SWTSIZ="2";
01500 REQUIRE "WNTSLS" SOURCEFILE;
01600 REQUIRE "SCNCMD.SAI" SOURCEFILE ;
01700 REQUIRE 7000 STRINGSPACE;
01800 DEFINE
01900 ="COMMENT", SNK="2", SUB="3", BREAK="SRCBRK", SAI="11",
02000 EOF="SRCEOF", THROW="1", NORSCAN="2", SUPSPC="3", THROW2="4",
02100 CR="'15", TAB = "'11",
02200 LF="'12", CRLF="('15&'12)", DELIMNO="10",EXNO="450",
02300 RESERVED="1", NONTERM="2", TERMINAL="3", CLASSID="4", EXROT="5",
02400 ASSGN="6", BYTLEN="12", BYTENO="3", PRINTOCT="CVOS",
02500 ARROW="1", GOTO="2", ELSEGO="3", EXEC="4", SCAN="5",
02600 PUSHJ="6", POPJ="7", NOTREALLY="8",BASE="9", OLDBASE="10", NODE="11",
02700 PRESUME="12",
02800 SAFER="SAFE ", MAPNO="127", LININC="5", SYMNO="1290", CLSNO="72", PDNO="30",
02900 NULSTR(A)="LENGTH(A)=0", PRINT="OUTSTR(",MSG="&CRLF)",
03000 ERRIT(X)="BEGIN USERERR(0,1, ""PSEUDO OP ""&""X""&"" MISSING "");GO ERROREND END";
03100
03200 This macro decides whether numeric (fast) or symbolic (readable)
03300 versions of things will be given to FAIL. Use MAKSYM for symbolic;
03400 DEFINE PRINTSYMBOL(X)="CVOS(NUMBER[X])";
03500
03600 Currently (11-73) SOS style line numbers are not desired. If in the
03700 future they are once again desired, remove the following macro definition;
03800
03900 DEFINE LINOUT(A,B)="";
04000
04100
04200 INTEGER CURDELIM,DELIMSTACK,ON,LABCNT,ERRFLAG,COWNT,SUBCNT,SCANE,COMMAND,
04300 CLASSTYPE,SYMBOL,NEXTFREE,FOUND,LINENO,BYTE,EXCNT,CLASSNO,Z,DPUSHJ,DPOPJ,DPRESUME,
04400 COWNTC,R,II,OLDBASEFLAG, WHATKIND, NUMTERM;
04500 STRING ALAB,LAB,WORD,HALSTR,TS,SYMMM,SAISTR;
04600
04700 SAFER INTEGER ARRAY FIRCLS[1:CLSNO], NUMCLS[1:CLSNO], NUMSYM[1:SYMNO],
04800 NUMEX[1:EXNO], SYMD[0:MAPNO], DELIMS[1:DELIMNO],
04900 PRODI[1:PDNO], TYPE, CLASS, CLASS2, NUMBER[-1:SYMNO];
05000
05100 SAFER STRING ARRAY PROD[1:PDNO],SYM[-1:SYMNO];
05200
00100 COMMENT Initialization, Lookup, Entersym, Subequ;
00200
00300 BOOLEAN PROCEDURE SUBEQU(STRING I,O);
00400 RETURN(LENGTH(O) LENGTH(I) EQU(I,O[1 FOR LENGTH(I)]));
00500
00600 INITIALIZATION OF THE WORLD, BREAK TABLES,
00700 I/O DEVICES, CONSTANTS.;
00800
00900 PROCEDURE INITIALIZATION;
01000 BEGIN INTEGER T3;
01100 SETBREAK(NORSCAN," "&TAB&LF,CR&'14,"IRN");
01200 SETBREAK(SUPSPC," "&TAB,CR&'14,"XRN");
01300 SETBREAK(THROW,LF&'14,NULL,"IN");
01400 SETBREAK(THROW2,LF&'14,NULL,"IRN");
01500
01600 NXTFIL_FALSE; WANTBIN_TRUE;
01700 COMMANDSCAN;
01800 OPEN(SUB,"DSK",0,0,2,0,T3,T3);
01900 WHILE T3 ":" DO T3_LOP(BINFIL);
02000 ENTER(SUB,BINFIL&"QQQ",T3);
02100 IF (NOT WANTBIN) OR T3 THEN USERERR(0,0,"OUTPUT ENTRY ERROR");
02200 IF SLS THEN BEGIN
02300 OPEN(SAI,"DSK",0,0,2,0,T3,T3);
02400 ENTER(SAI,BINFIL&"SAI",T3);
02500 IF T3 THEN USERERR(0,0,"OUTPUT ENTRY ERROR");
02600 OUT(SAI,"INTEGER ITEM "&CRLF);
02700 SAISTR_ "DEFINE "&CRLF
02800 END;
02900 TS_INPUT(SRC,THROW);
03000 IF SUBEQU("COMMENT ",TS) THEN
03100 WHILE SRCBRK'14 DO TS_INPUT(SRC,THROW);
03200
03300
03400 ON_EXCNT_BYTE_1;
03500 ERRFLAG_DELIMSTACK_CURDELIM_COMMAND_EOF_0;
03600 COWNT_IF SLS THEN 8 ELSE 0;
03700 "START TOKEN NUMBERING AT FIRST ITEM NUMBER"
03800 NEXTFREE_SYMNO;
03900 SUBCNT_LINENO_LININC;
04000 SYM[0]_" ";
04100 HALSTR_" BYTE ("&CVS(BYTLEN)&") ";
04200
04300 END ;
04400
04500
04600 INTEGER PROCEDURE LOOKUP(STRING A);
04700 BEGIN "LOOKUP"
04800 Comment uses Quadratic Search Algorithm as described in CACM ------;
04900 INTEGER H,Q;
05000 DEFINE SCON="10";
05100
05200 H_CVASC(A) +LENGTH(A) LSH 6;
05300 R_SYMBOL_(H_ABS(H(H LSH 2))) MOD (SYMNO+1);
05400
05500 IF EQU(SYM[SYMBOL],A) THEN RETURN(-1);
05600 IF NULSTR(SYM[SYMBOL]) THEN RETURN(0);
05700
05800 Q_H%(SYMNO+1) MOD (SYMNO+1);
05900 IF (H_Q+SCON) SYMNO THEN H_H-SYMNO;
06000
06100 WHILE (IF (SYMBOL_SYMBOL+H)>SYMNO
06200 THEN SYMBOL_SYMBOL-(SYMNO+1) ELSE SYMBOL) R DO
06300 BEGIN "LK1"
06400 IF EQU(SYM[SYMBOL],A) THEN RETURN(-1);
06500 IF NULSTR(SYM[SYMBOL]) THEN RETURN(0);
06600 IF (H_H+Q)>SYMNO THEN H_H-(SYMNO+1);
06700 END "LK1";
06800 SYMBOL_-1; RETURN(0);
06900 END "LOOKUP";
07000
07100
07200 Enter symbol in table. Always enters the word previously scanned by
07300 GETWORD. "SYMBOL" is the index (from LOOKUP) into SYM, NUMBER, TYPE;
07400
07500 PROCEDURE ENTERSYM;
07600 BEGIN "ENTERSYM"
07700 IF LENGTH(SYM[SYMBOL]) SYMBOL<0 THEN
07800 BEGIN
07900 ERRFLAG_1;
08000 IF SYMBOL 0 THEN PRINT "DUPLICATE SYMBOL "&WORD MSG
08100 ELSE PRINT "SYMBOL TABLE FULL" MSG
08200 END;
08300 SYM[SYMBOL]_WORD;
08400 END "ENTERSYM";
08500
08600
00100 COMMENT Pton, Printroom, Halword, Maksym;
00200
00300 Routines to write line of code to output file. Generates SOS line
00400 numbers. REALOUTPUT=0 disables them. Many routines are used in place
00500 of concatenation for speed;
00600
00700 PROCEDURE PTO(STRING A);
00800 BEGIN LINOUT(SNK,LINENO);LINENO_LINENO+1;OUT(SNK,A) END "PTO";
00900 PROCEDURE PTO1(STRING A);
01000 BEGIN OUT(SNK,A);OUT(SNK,CRLF);END "PTO1";
01100 PROCEDURE PTO2(STRING A,B);
01200 BEGIN OUT(SNK,A);PTO1(B) END "PTO2";
01300 PROCEDURE PTO3(STRING A,B,C);
01400 BEGIN OUT(SNK,A); PTO2(B,C) END "PTO3";
01500 PROCEDURE PTO4(STRING A,B,C,D);
01600 BEGIN OUT(SNK,A); PTO3(B,C,D) END "PTO4";
01700 PROCEDURE PUTOUT(STRING A);
01800 BEGIN PTO(A); OUT(SNK,CRLF) END "PUTOUT";
01900 PROCEDURE PTO2(STRING A,B);
02000 BEGIN PTO(A); PTO1(B) END "PTO2";
02100 PROCEDURE PTO3(STRING A,B,C);
02200 BEGIN PTO(A); PTO2(B,C) END "PTO3";
02300 PROCEDURE PTO4(STRING A,B,C,D);
02400 BEGIN PTO(A); PTO3(B,C,D) END "PTO4";
02500
02600
02700 PROCEDURE PRINTROOM;
02800 BEGIN PUTOUT(NULL); PUTOUT(NULL) END;
02900
03000 PROCEDURE HALWORD(STRING A);
03100 BEGIN "HALWORD"
03200 IF BYTE=1 THEN PTO(HALSTR);
03300 OUT(SNK,A);
03400 IF (BYTE_BYTE+1) BYTENO THEN
03500 OUT(SNK,", ") ELSE
03600 BEGIN OUT(SNK,CRLF); BYTE_1 END
03700 END "HALWORD";
03800
03900 This procedure transforms an internal symbol into a symbolic one
04000 for FAIL. It assures the symbols are 6 characters long, and that
04100 they have the appropriate type (R, N, T) prefix;
04200
04300 PROCEDURE MAKSYM (INTEGER I);
04400 BEGIN "MAKSYM"
04500 STRING A; INTEGER T;
04600 IF (A_SYM[I])="@" THEN T_LOP(A);
04700 OUT(SNK,I_CASE TYPE[I] OF ("","R","N","T","C"));
04800 OUT(SNK,A[1 TO 5]);
04900 SYMMM_I&A;
05000 END "MAKSYM";
05100
00100 COMMENT Assign, Classout;
00200
00300 Assign gives internal numbers to all symbols. It first assigns symbols
00400 which are members of classes, so that the class-indexing EXEC stuff works.
00500 Then it assigns numbers to all others. Finally it puts out "XXX__nnnn" for
00600 each symbol, telling FAIL what the values are;
00700
00800 PROCEDURE ASSIGN;
00900 BEGIN "ASSIGN" INTEGER I,B;
01000 STRING A;
01100
01200 PROCEDURE CLASSOUT (INTEGER Z);
01300 FOR B_(IF SLS THEN 9 ELSE 1) STEP 1 UNTIL COWNT DO BEGIN "CLASSOUT"
01400 I_NUMSYM[B];
01500 PTO4(" ",PRINTOCT(IF Z THEN CLASS[I] ELSE CLASS2[I]),
01600 " ;",SYM[I])
01700 END "CLASSOUT";
01800
01900 PUTOUT (";CLASSES, BITS");
02000 FOR B_1 STEP 1 UNTIL COWNTC DO
02100 PUTOUT("; "&CVS(B)&" "&SYM[NUMCLS[B]]&" "&CVOS(
02200 1 LSH (B-(IF B 36 THEN 1 ELSE 37))));
02300 PRINTROOM;
02400 PRINTROOM;
02500
02600 PUTOUT ("; CLASS INDEX TABLE" );
02700 PUTOUT ("CLSTAB: 0");
02800 IF SLS THEN PUTOUT ("00000000"); COMMENT NO TOKENS UNTIL 9;
02900 CLASSOUT (TRUE);
03000 PUTOUT((IF SLS THEN "^" ELSE NULL)&"CLASSNO _ .-CLSTAB");
03100 IF COWNTC>36 THEN BEGIN "ASG1"
03200 PUTOUT("CLSTA2: 0");
03300 CLASSOUT(FALSE);
03400 END "ASG1";
03500
03600 NOW ASSIGN ALL OTHERS;
03700
03800 FOR I _ 1 STEP 1 UNTIL SYMNO DO BEGIN "ALLOTH"
03900 IF LENGTH(SYM[I])NUMBER[I]=00<TYPE[I]<ASSGN THEN BEGIN
04000 COWNT _ COWNT + 1;
04100 NUMBER [I] _ COWNT;
04200 NUMSYM[COWNT]_I
04300 END;
04400 END "ALLOTH";
04500
04600 NOW OUTPUT SYMBOLIC ASSIGNMENTS;
04700
04800 PUTOUT ("; SYMBOLIC ASSIGNMENTS");
04900 FOR B_(IF SLS THEN 9 ELSE 1) STEP 1 UNTIL COWNT DO
05000 IF TYPE[I_NUMSYM[B]]=TERMINAL THEN
05100 BEGIN
05200 NUMTERM_NUMBER[I];
05300 PTO("^");
05400 MAKSYM(I);
05500 PTO4("__",IF CLASS[I] CLASS2[I] THEN "CLASOP" ELSE "OPER",
05600 "+",PRINTOCT(NUMBER[I]));
05700 IF SLS THEN BEGIN
05800 OUT(SAI," "&SYMMM&","&CRLF);
05900 SAISTR_SAISTR&" OP"&SYMMM[2 TO ]&" = ""'"&PRINTOCT(NUMBER[I])&
06000 ""","&CRLF
06100 END
06200 END
06300 ELSE BEGIN
06400 NUMTERM_NUMBER[I];
06500 PTO(IF SLS THEN "^" ELSE NULL);
06600 MAKSYM(I);
06700 PTO2("__",PRINTOCT(NUMBER[I]));
06800 IF SLS THEN BEGIN
06900 OUT(SAI," "&SYMMM&","&CRLF);
07000 SAISTR_SAISTR&" OP"&SYMMM[2 TO ]&" = ""'"&PRINTOCT(NUMBER[I])&
07100 ""","&CRLF
07200 END
07300 END;
07400
07500 PRINTROOM;
07600
07700 LINOUT(SUB,SUBCNT_SUBCNT+LININC);
07800 OUT(SUB," <SCAN TABLE>"&CRLF);
07900 FOR B_1 STEP 1 UNTIL MAPNO DO
08000 IF (I_SYMD[B])TYPE[I]=TERMINAL THEN BEGIN "TOUT2"
08100 LINOUT(SUB,SUBCNT_SUBCNT+LININC);
08200 OUT(SUB,CVS(B)&" "&CVS(NUMBER[I]));
08300 OUT(SUB,(IF CLASS[I] CLASS2[I] THEN " C" ELSE " N")&CRLF);
08400 END "TOUT2";
08500
08600 SYMBOL TABLE ENTRIES FOR ALL RESERVEDS;
08700
08800 LINOUT(SUB,SUBCNT_SUBCNT+LININC);
08900 OUT(SUB," <RESERVED-WORDS>"&CRLF);
09000 PUTOUT("; SYMBOL TABLE ENTRIES");
09100
09200 FOR I _ 1 STEP 1 UNTIL SYMNO DO
09300 IF TYPE[I]=RESERVED THEN BEGIN "RES2"
09400 PTO("; ");
09500 MAKSYM(I);
09600 PTO4(" ",PRINTOCT(NUMBER[I])," ",SYM[I]);
09700 LINOUT(SUB,SUBCNT_SUBCNT+LININC);
09800 OUT(SUB,SYM[I]&" "&PRINTOCT(NUMBER[I])&
09900 " "&(IF CLASS[I] CLASS2[I] THEN "C" ELSE "N")&CRLF);
10000 END "RES2";
10100 PUTOUT(" LSTON(PRODS)");
10200 RELEASE (SUB);
10300 END "ASSIGN";
10400
00100 COMMENT Searchit, Gword;
00200
00300 Searchit Checks its argument for special features (EXEC, SCAN, , etc.)
00400 then looks it up if not special. FOUND, CLASSTYPE, and COMMAND are
00500 set to reflect the result;
00600
00700 PROCEDURE SEARCHIT(STRING A);
00800 BEGIN "SEARCHIT"
00900 INTEGER CHAR,L,I;
01000 COMMAND_CLASSTYPE_FOUND_0; CHAR_A;
01100 IF (L_LENGTH(A))=1 (I_SYMD[CHAR]) THEN BEGIN "SRCH1"
01200 SYMBOL_I; A_WORD_SYM[I]; FOUND_-1;
01300 RETURN
01400 END "SRCH1";
01500 IF (L_LENGTH(A)>1) THEN
01600 IF CHAR="@" THEN CLASSTYPE_1 ELSE
01700 IF CHAR="" THEN FOUND_ARROW ELSE
01800 IF CHAR="" THEN FOUND_GOTO ELSE
01900 IF CHAR="#" THEN FOUND_ELSEGO ELSE
02000 IF EQU(A,"EXEC") THEN FOUND_EXEC ELSE
02100 IF EQU(A,"SCAN") THEN FOUND_SCAN ELSE
02200 IF EQU(A,"PRESUME") THEN FOUND_PRESUME ELSE
02300 IF CHAR="^" THEN FOUND_PUSHJ ELSE
02400 IF CHAR="" THEN FOUND_POPJ ELSE
02500 IF CHAR="<" THEN COMMAND_1 ELSE
02600 IF CHAR="*" CHAR="" THEN FOUND_NOTREALLY ELSE
02700 IF SLS THEN
02800 IF SUBEQU("BASE",A) THEN FOUND_BASE ELSE
02900 IF EQU(A,"OLDBASE") THEN FOUND_OLDBASE ELSE
03000 IF EQU(A,"NODES") THEN FOUND_NODE
03100 ;
03200 IF (FOUND COMMAND) THEN BEGIN "SRCH3"
03300 IF L>1EQU(A[1 FOR 2],"SG") THEN RETURN;
03400 FOUND_LOOKUP(A);
03500 END "SRCH3";
03600 END "SEARCHIT";
03700
03800 This is the procedure which looks at the source file, returning one
03900 word at a time, using standard delimiters. It tries to type the word
04000 as "COMMAND", "JUMPTYPE", "LABELTYPE", or "CLASSTYPE". The prefixes
04100 expected for these types are < : @. At the end of a line, GETWORD
04200 returns NULL. It does a symbol LOOKUP. If FOUND is nonzero, the symbol
04300 was found or represents a special kind of thing (SCAN, EXEC, etc.) Symbol
04400 contains the appropriate symbol table index if FOUND<0;
04500
04600 RECURSIVE STRING PROCEDURE GWORD;
04700 BEGIN "GWORD"STRING A;
04800
04900 PROCEDURE PROCESS(INTEGER I);
05000 BEGIN "PROCESS"
05100 SEARCHIT(GWORD); GET AN IDENTIFIER;
05200 IF FOUND TYPE[SYMBOL] ASSGN THEN BEGIN
05300 PRINT "INVALID CONDITIONAL SWITCH" MSG;
05400 Z_0
05500 END ELSE Z_NUMBER[SYMBOL];
05600 DELIMS[DELIMSTACK_DELIMSTACK+1]_CURDELIM;
05700 CURDELIM_GWORD; DELIMITER ;
05800 ON_(IF (IZON) (IZON) THEN 1 ELSE 0);
05900 IF ON THEN BEGIN
06000 DO BEGIN "GW1" A_GWORD END UNTIL LENGTH(A)=1 AND A=CURDELIM ;
06100 CURDELIM_DELIMS[DELIMSTACK];DELIMSTACK_DELIMSTACK-1;
06200 ON _ 1;
06300 END
06400 END "PROCESS";
06500
06600 WORD _ INPUT(SRC,SUPSPC);
06700 IF BREAK=LF THEN BEGIN
06800 WORD_INPUT(SRC,THROW);
06900 RETURN(NULL);
07000 END;
07100 A_WORD _ INPUT(SRC,NORSCAN);
07200
07300 IF LENGTH(WORD)=6 AND EQU(WORD,"MUMBLE") THEN BEGIN
07400 WHILE WORD";" EQU(WORD[ FOR 1],";")=0 DO
07500 DO A_GWORD UNTIL LENGTH(A);
07600 A_GWORD
07700 END;
07800
07900 IF WORD="" THEN BEGIN
08000 IF EQU(A,"") THEN BEGIN LINE CONTINUATION;
08100 INPUT(SRC,THROW2);
08200 A_GWORD;
08300 RETURN(GWORD);
08400 END ELSE
08500 IF EQU(A,"ASG") THEN BEGIN ASSIGN A COMPILATION VARB ;
08600 SEARCHIT(GWORD); IDENTIFIER ;
08700 IF FOUND THEN BEGIN
08800 ENTERSYM;
08900 TYPE[SYMBOL]_ASSGN;
09000 END;
09100 IF TYPE[SYMBOL]ASSGN THEN PRINT "INVALID CONDITIONAL VARIABLE" MSG;
09200 NUMBER[SYMBOL]_CVD(GWORD);
09300 END ELSE
09400 IF EQU(A,"IFE") THEN BEGIN
09500 PROCESS (0);
09600 RETURN (GWORD);
09700 END ELSE
09800 IF EQU(A,"IFN") THEN BEGIN
09900 PROCESS (1);
10000 RETURN (GWORD);
10100 END;
10200 END;
10300 IF ON AND LENGTH(WORD)=1 WORD=CURDELIM THEN BEGIN "GW4"
10400 CURDELIM_DELIMS[DELIMSTACK];DELIMSTACK_DELIMSTACK-1;
10500 RETURN (GWORD);
10600 END "GW4";
10700 IF LENGTH(WORD)>1 WORD[LENGTH(WORD) FOR 1]=":" THEN BEGIN "GW5"
10800 PTO2((LAB_WORD[1 FOR LENGTH(WORD)-1]),"_.+FTDEBUG");
10900 LABCNT_0;ALAB_NULL;
11000 RETURN(GWORD);
11100 END "GW5";
11200 RETURN (WORD);
11300 END;
11400
00100 COMMENT Getword, GetGoodWord, Compile, Map;
00200
00300 NOW FOR THE PROCEDURES WHICH ARE ACTUALLY USED BY THE POOR USERS;
00400
00500 STRING PROCEDURE GETWORD;
00600 BEGIN "GETWORD"
00700 WORD_GWORD;
00800 IF LENGTH(WORD) THEN SEARCHIT(WORD);
00900 RETURN (WORD);
01000 END "GETWORD";
01100
01200 STRING PROCEDURE GETGOODWORD;
01300 BEGIN "GETGOODWORD"
01400 DO WORD_GETWORD UNTIL LENGTH(WORD);
01500 RETURN(WORD);
01600 END "GETGOODWORD";
01700
01800
01900 This makes (internal PTRAN) symbol tables of the simple variety;
02000
02100 PROCEDURE COMPILE (INTEGER A);
02200 BEGIN "COMPILE"
02300 STRING AA;
02400 DO BEGIN "CMP1"
02500 AA_GETGOODWORD;
02600 IF COMMAND=0 THEN BEGIN "CMP2"
02700 IF FOUND<0TYPE[SYMBOL]0 THEN PRINT "DUPLICATE SYMBOL "&AA MSG;
02800 IF FOUND>0 THEN PRINT "IMMORAL SYMBOL "&AA MSG;
02900 IF FOUND THEN ENTERSYM;
03000 TYPE[SYMBOL]_A;
03100 END; END UNTIL COMMAND;
03200 END "COMPILE";
03300
03400 MAP inputs the symbol mapping information. Symbols like +, -, etc. are
03500 given names which FAIL will accept;
03600
03700 PROCEDURE MAP;
03800 BEGIN "MAP" STRING A;
03900 DO BEGIN "MP1"
04000 A_GETGOODWORD;
04100 IF COMMAND=0 THEN BEGIN "MP2"
04200 GETGOODWORD;
04300 ENTERSYM;
04400 SYMD[A]_SYMBOL
04500 END "MP2";
04600 END "MP1" UNTIL COMMAND;
04700 END "MAP";
04800
04900 PROCEDURE LISTR(INTEGER ARRAY AA;INTEGER BB;STRING CC; INTEGER DD);
05000 BEGIN "LISTR"
05100 INTEGER I,J;
05200 FOR J_1 STEP 1 UNTIL BB DO BEGIN "LS1"
05300 I_AA[J];
05400 PTO(CC);
05500 IF DD=1 THEN MAKSYM(I) ELSE
05600 IF DD=2 THEN OUT(SNK,(SYM[I]&" ")[1 FOR 6]) ELSE
05700 OUT(SNK,SYM[I]);
05800 IF DD=0 THEN OUT(SNK,CRLF) ELSE PTO1("/");
05900 END "LS1"
06000 END "LISTR";
06100
00100 COMMENT Prodscan, Endcheck;
00200
00300 PRODSCAN
00400 This procedure scans the productions and creates the byte tables. It is
00500 called with a valid "WORD". For each line, it:
00600 1. Assembles all the words (and symbol entry #s) into "PROD" AND "PRODI"
00700 keeping track of words like "EXEC", "SCAN" etc.
00800 2. Puts out (right to left) code for the compare portion of the production.
00900 3. Issues tree node descriptions based on BASE and NODE specs (SLS only).
01000 4. Puts out calls to the executive routines.
01100 5. Tries to match right with left parts and put out correct stack-restoring code.
01200 6. Specifies number of SCANNER calls.
01300 ;
01400
01500 PROCEDURE PRODSCAN;
01600 BEGIN "PRODSCAN" INTEGER FAILFLG,LEFTEND,RIGHTEND,EXECEND,SUCCEED,I,J,K,C,D,B,EXF;
01700 STRING A; INTEGER EXTRA,ARSEEN,BASELOC,NODEND;
01800
01900 PROCEDURE ENDCHECK(INTEGER ILEV);
02000 BEGIN "ENDCHECK"
02100 This procedure sets the pointers to interesting places in the PROD list.
02200 LEFTEND (last left side token) and RIGHTEND (last right side token)
02300 are always set. Then if LEFTEND=RIGHTEND (no right part), the right
02400 part is copied from the left part (no reduction occurs). Finally,
02500 NODEND and/or EXECEND are set if requested and necessary;
02600
02700 IF LEFTEND THEN LEFTEND_K; IF RIGHTEND THEN RIGHTEND_K;
02800 IF ARSEENLEFTEND=RIGHTEND THEN
02900 FOR II _ 1 STEP 1 UNTIL LEFTEND DO BEGIN "CHECKARROW"
03000 PROD[RIGHTEND_K_K+1] _ PROD[II];
03100 PRODI[K] _ PRODI[II]
03200 END "CHECKARROW";
03300
03400 IF ILEV>0NODEND THEN NODEND_K;
03500 IF ILEV>1EXECEND THEN EXECEND_K
03600 END "ENDCHECK";
03700
00100 COMMENT Prodscan, Assemble;
00200
00300 PROCEDURE ASSEMBLE;
00400 BEGIN "ASSEMBLE"
00500 LABEL MORE,BLAB;
00600 EXF_1; A _ WORD;
00700 DPUSHJ_DPOPJ_K_EXTRA_ARSEEN_FAILFLG_LEFTEND_RIGHTEND_EXECEND_SUCCEED_SCANE
00800 _BASELOC_NODEND_OLDBASEFLAG_DPRESUME_0;
00900 WHILE NULSTR(A) DO BEGIN "ASS1"
01000
01100 IF FOUND>0 THEN CASE FOUND OF BEGIN "LOOK FOR SPECIALS"
01200 [ARROW]BEGIN "RIGHT ARROW"
01300 ARSEEN_1;
01400 LEFTEND_K;
01500 GO MORE
01600 END;
01700 [EXEC] BEGIN "EXEC SEEN"
01800 EXF_0;
01900 ENDCHECK(1); "SET {LEFT-,RIGHT-,NOD-}END IF NECESSARY"
02000 GO MORE
02100 END;
02200 [SCAN] BEGIN "SCAN SEEN"
02300 EXF_SCANE_1;
02400 ENDCHECK(2); "SET ALL IF NECESSARY"
02500 GO MORE
02600 END;
02700 [GOTO] BEGIN " SEEN"
02800 EXF_1;
02900 ENDCHECK(2);
03000 SUCCEED_K+1;
03100 END;
03200 [ELSEGO]FAILFLG_K+1; "FAIL ADDRESS SEEN"
03300 [PUSHJ]BEGIN "^ SEEN FOR A PRODUCTION PUSHJ"
03400 ENDCHECK(2);
03500 DPUSHJ _ K+1;
03600 EXTRA_EXTRA+BYTENO;
03700 END;
03800 [POPJ] BEGIN " SEEN FOR A POPJ"
03900 ENDCHECK(2);
04000 DPOPJ _ 1;
04100 END;
04200 [NOTREALLY]EXTRA_EXTRA-1;
04300 [BASE] BEGIN "BASE SEEN"
04500 OLDBASEFLAG_FALSE;
04600 BLAB: ENDCHECK(0); "SET LEFTEND, RIGHTEND IF NECESSARY"
04700 BASELOC_K+1;
04750 BEGIN
04755 COMMENT DUMMY BLOCK TO HAVE VARIABLE I. NEEDED NOW
04760 THAT WE CHECK LABEL DEFINITIONS IN TERMS OF BLOCKS;
04765 INTEGER I;
04800 WHATKIND_ IF (I_A[5 FOR 1]) THEN 0 ELSE
04900 (IF I="B" THEN '20 ELSE 1) LSH 7;
04905 END;
05000 A_GETWORD; "THE BASE NODE NAME"
05100 EXTRA_EXTRA+1
05200 END;
05300 [OLDBASE] BEGIN "EXTEND OLD BASE"
05400 OLDBASEFLAG_TRUE;
05500 GO BLAB
05600 END;
05700 [NODE] GO TO MORE;
05800 [PRESUME] BEGIN "PRESUME SEEN"
05900 EXF_1;
06000 ENDCHECK(2);
06100 DPRESUME_1;
06200 END
06300 END "LOOK FOR SPECIALS";
06400
06500 K_K+1;
06600 IF EXF=0 AND CLASSTYPE THEN EXTRA_EXTRA+1;
06700 IF EXF FOUND CLASSTYPE THEN BEGIN "ASS2"
06800 ENTERSYM;
06900 TYPE[SYMBOL]_EXROT;
07000 NUMBER[SYMBOL]_EXCNT;
07100 NUMEX[EXCNT]_SYMBOL;
07200 EXCNT_EXCNT+1;
07300 END "ASS2" ELSE
07400 IF FOUND AND (CLASSTYPE"0" A[2 FOR 1] "9"(EXTRA_EXTRA-1)+10000) AND
07500 EXECEND=0 (LENGTH(A) 2 EQU(A[1 FOR 2],"SG"))
07600 THEN BEGIN "ASS3"
07700 SYMBOL_1;
07800 PRINT "UNDEFINED SYMBOL ? "&A MSG;
07900 ERRFLAG_1;
08000 END;
08100 PROD[K]_A;
08200 PRODI[K]_SYMBOL;
08300
08400 MORE: A_GETWORD;
08500
08600 END
08700 END "ASSEMBLE";
08800
08900
09000 INTEGER PROCEDURE INDEX(STRING S;INTEGER LIM);
09100 BEGIN "INDEX"
09200 INTEGER I;
09300 FOR I_1 STEP 1 UNTIL LIM DO IF EQU(S,PROD[I]) THEN RETURN(I);
09400 RETURN(0)
09500 END "INDEX";
09600
00100 COMMENT Prodscan;
00200
00300 COMMENT MAIN BODY OF PRODSCAN; DEFINE B!="LEFTEND-B+1";
00400 ASSEMBLE;
00500 IF FALSE THEN BEGIN "HOOK" OUTSTR(LAB&ALAB) END "HOOK";
00600 PRINTROOM;
00700 IF LEFTEND=0 THEN BEGIN LEFTEND_1; PRINT "NO LEFT PART "&LAB MSG;ERRFLAG_1;END;
00800 IF (DPUSHJ OR DPOPJ) THEN
00900 IF SUCCEED=0 THEN BEGIN SUCCEED_1; PRINT"NO SUCCESS LOCATION "&LAB MSG;ERRFLAG_1;END;
01000
01100 PTO3 ("IFN FTDEBUG < SIXBIT/",(LAB&ALAB)[1 TO 6],"/>");
01200 ALAB_("A"-1)+(LABCNT_LABCNT+1);
01300 PTO(" XWD ");
01400 IF FAILFLG THEN
01500 OUT(SNK,PROD[FAILFLG][2 TO ]) ELSE
01600 BEGIN
01700 OUT(SNK,".+FTDEBUG+");
01800 OUT(SNK,PRINTOCT((EXTRA+EXECEND+(1+2*BYTENO)) DIV BYTENO));
01900 END;
02000 PTO2(", ",IF SUCCEED THEN PROD[SUCCEED][2 TO ] ELSE "0");
02100
02200 Now we process the left-half compares against the stack. These
02300 are simply put out in reverse order of the scan order -- top seen first;
02400
02500 FOR J _LEFTEND STEP -1 UNTIL 1 DO BEGIN "ASS4"
02600 A_PROD[J]; C_PRODI[J];
02700 IF LENGTH(A) 2 EQU(A[1 FOR 2],"SG") THEN HALWORD("0") ELSE
02800 BEGIN
02900 A_PRINTSYMBOL(C)&
03000 (IF CLASS[C]+CLASS2[C] THEN "+BCARE" ELSE
03100 IF TYPE[C] = CLASSID THEN
03200 ("+BCLASS"&(IF NUMBER[C]>36 THEN "+334" ELSE NULL))ELSE NULL);
03300 IF J>1SUBEQU("",PROD[J-1]) THEN BEGIN
03400 A_A&"+BINF"; J_J-1
03500 END;
03600 HALWORD(A)
03700 END
03800 END "ASS4";
03900
04000 Finish up the left half, specify # of right-half temporaries;
04100 HALWORD(PRINTOCT(RIGHTEND-LEFTEND)&"+BDONE");
04200
04300 Specify the right-half -- index+BTEMP for matches, tokens for others;
04400
04500
04600 FOR J_LEFTEND+1 STEP 1 UNTIL RIGHTEND DO
04700 IF (B_INDEX(PROD[J],LEFTEND)) (B 1 PROD[B-1]"")
04800 THEN HALWORD(PRINTOCT(B!)&"+BTEMP") ELSE
04900 HALWORD(PRINTSYMBOL(PRODI[J]));
05000
05100 Process tree-building specifications. The word BASE (BASELOC in PROD array)
05200 causes the next token to be used as the name of a new parse tree node (the
05300 name is augmented by a code to distinguish it from, say, terminal symbols
05400 with the same designations. The node name will more often be derived from
05500 a terminal than from a non-terminal, but each terminal so used falls into
05600 an equivalence class represented by a non-terminal (+, *, -, LAND all belong
05700 in this sense to the non-terminal class Expression). The base node will be
05800 represented in the output by BINF + (either the token number or BTEMP+index).
05900 Then NODES appear (the actual word in the production line is ignored). Each
06000 is represented by BTEMP+index, since all will be fetched from the left side.
06100 BINF on will represent a variable number of actual results pointed to by the
06200 parse entry for that index: the actual number will be calculated by the
06300 parser. The nodes are represented in the output file by the file location
06400 pointers found in the LPSAV stack. (NB all this is SLS stuff). There will
06500 be one extra byte containing only BDONE to finish the node specifiers. Then
06600 come the EXECS or whatever;
06700
06800 IF BASELOC THEN BEGIN "TREE PROCESS"
06900 TS_IF OLDBASEFLAG THEN "BCLASS" ELSE "0";
07000 IF B_INDEX(PROD[BASELOC],LEFTEND) THEN HALWORD(TS&"+BINF+BTEMP+"
07100 &PRINTOCT(B!)) ELSE
07200 HALWORD(TS&"+BINF+"&PRINTSYMBOL(PRODI[BASELOC]));
07300 A_NULL; I_0;
07400 FOR J_BASELOC+1 STEP 1 UNTIL NODEND DO
07500 IF SUBEQU("",PROD[J]) THEN A_"+BINF" ELSE BEGIN
07600 B_INDEX(PROD[J],LEFTEND);
07700 PROD[J]_PRINTOCT(B!)&A;
07800 I_I+1;
07900 A_NULL
08000 END;
08100 HALWORD(PRINTOCT(I LOR WHATKIND));
08200 FOR J_BASELOC+1 STEP 1 UNTIL NODEND DO
08300 IF (A_PROD[J])"" THEN HALWORD(A);
08400 END "TREE PROCESS";
08500
08600 Process EXEC routine calls. If the EXEC routine is typed according to some
08700 class of tokens, search left hand side until the matching token is found.
08800 Then put out the index of that token, then the base number of the class.
08900 This base number is subtracted (by parser) from the token number and the
09000 result passed to the EXEC. Then, no matter what, put out the EXEC routine
09100 index number. If the ** (dispatch via parser) feature was used, the BCLASS
09200 bit is turned on in the class number byte, indicating that the parser should
09300 use the index to select one of the following EXECS. The BTEMP bit will appear
09400 in the last indexed exec (followed by another ** in productions).
09500 On 3-1-72 the syntax was extended by DCS to allow EXEC @4 ROUT, which means
09600 that the explicit index 4 will be sent directly to the exec routine. In this
09700 case, BTEMP is turned on in the byte with 4 in it -- the next byte is the
09800 EXEC routine byte;
09900
10000 FOR J _ NODEND+1 STEP 1 UNTIL EXECEND DO
10100 IF PROD[J]="@" THEN IF "0" PROD[J][2 FOR 1] "9" THEN
10200 HALWORD(PROD[J][2 TO ]&"+BTEMP")
10300 ELSE BEGIN "ASS10"
10400 HALWORD(PRINTOCT(LEFTEND-INDEX(PROD[J],LEFTEND)+1)&"+BCLASS");
10500 IF PROD[J+1] = "*" THEN BEGIN "ASS12"
10600 HALWORD(PRINTOCT(FIRCLS[NUMBER[PRODI[J]]])&"+BCLASS");
10700 FOR J_J+2 STEP 1 WHILE PROD[J+1]"*" DO
10800 HALWORD(PRINTOCT(NUMBER[PRODI[J]]));
10900 HALWORD(PRINTOCT(NUMBER[PRODI[J]])&"+BTEMP");
11000 J _ J +1;
11100 END "ASS12" ELSE HALWORD(PRINTOCT(FIRCLS[NUMBER[PRODI[J]]]))
11200 END "ASS10" ELSE HALWORD(PRINTOCT(NUMBER[PRODI[J]]));
11300
11400
11500 Issue SCANNER calls, then quit. If there is a PUSHJ to be done, include
11600 BCLASS in the BDONE/SCANNER word. If a POPJ, include BTEMP;
11700 HALWORD(
11800 PRINTOCT(IF SCANE THEN 1 MAX CVD(PROD[EXECEND+1]) ELSE 0)
11900 &"+BDONE"&(IF DPUSHJ THEN "+BCLASS" ELSE "")&
12000 (IF DPOPJ THEN "+BTEMP" ELSE "")
12100 &(IF DPRESUME THEN "+BPRESUME" ELSE ""));
12200 WHILE BYTE 1 DO BEGIN "ASS15" HALWORD("0");END "ASS15";
12300 IF DPUSHJ THEN PTO2(" ",(PROD[DPUSHJ][2 TO ]));
12400 PRINTROOM;
12500
12600 END "PRODSCAN";
12700
00100 COMMENT Ptran;
00200
00300 THIS IS THE MAIN EXECUTION BLOCK;
00400
00500 ONETIME_FALSE; SET UP TO OPEN COMMAND FILE;
00600 WHILE TRUE DO BEGIN "EXECUTE"
00700 LABEL PROGEND,ERROREND;
00800 INTEGER I,CURCLS,FIRFLG;STRING A;
00900
01000 INITIALIZATION;
01100 PUTOUT("LSTON(PDEFS)");
01200 COWNTC_0;
01300 WHILE COMMAND=0 DO A_GETWORD;
01400
01500 IF EQU(WORD,"<SYMBOLS>") THEN MAP;
01600 IF EQU(WORD,"<TERMINALS>")=0 THEN ERRIT(<TERMINALS>)
01700 ELSE COMPILE(TERMINAL);
01800 IF EQU(WORD,"<RESERVED-WORDS>")=0 THEN ERRIT(<RESERVED-WORDS>)
01900 ELSE COMPILE (RESERVED);
02000 IF EQU(WORD,"<NON-TERMINAL-SYMBOLS>")=0 THEN ERRIT(<NON-TERMINAL-SYMBOLS>)
02100 ELSE COMPILE(NONTERM);
02200
00100
00200 IF EQU(WORD,"<CLASSES>") THEN
00300 DO BEGIN "MAIN1"
00400 A_GETGOODWORD;
00500 IF COMMAND = 0 THEN BEGIN "MAIN2"
00600 INTEGER CBIT,OLDC,OLDCBIT,I,J,CTYPE;
00700 PROCEDURE CLSIDASSIGN;
00800 BEGIN "CLSIDASSIGN"
00900 IF NUMBER [SYMBOL]=0 THEN BEGIN
01000 NUMBER[SYMBOL]_COWNT_COWNT+1;
01100 NUMSYM[COWNT]_SYMBOL
01200 END;
01300 IF FIRFLG THEN BEGIN
01400 FIRCLS[COWNTC]_NUMBER[SYMBOL];
01500 FIRFLG_0;
01600 END;
01700 IF COWNTC > 36 THEN
01800 IF COWNTC > CLSNO THEN USERERR(0,0,"CLASS TABLE OVERFLOW")
01900 ELSE
02000 CLASS2[SYMBOL]_CLASS2[SYMBOL]LOR CBIT
02100 ELSE
02200 CLASS[SYMBOL]_CLASS[SYMBOL]LOR CBIT;
02300 END "CLSIDASSIGN";
02400
02500 IF CLASSTYPE AND FOUND THEN BEGIN "MAIN3"
02600 ENTERSYM;
02700 TYPE[SYMBOL]_CLASSID;
02800 COWNTC_COWNTC+1; CBIT_1 LSH (COWNTC-(IF COWNTC 36 THEN 1 ELSE 37));
02900 FIRFLG_1;
03000 NUMBER[SYMBOL]_COWNTC;
03100 NUMCLS[COWNTC]_SYMBOL;
03200 IF EQU(SYM[SYMBOL],"@RESERVED")(CTYPE_RESERVED)
03300 EQU(SYM[SYMBOL],"@TERMINAL")(CTYPE_TERMINAL)
03400 THEN BEGIN "RESTER"
03500 FOR SYMBOL_1 STEP 1 UNTIL SYMNO DO
03600 IF TYPE[SYMBOL]=CTYPE THEN BEGIN
03700 CLSIDASSIGN
03800 END
03900 END "RESTER"
04000 END "MAIN3" ELSE IF CLASSTYPE FOUND; THEN BEGIN "MAIN35"
04100 COMMENT CLASSCLASS -- WHAT CLASS!;
04200 OLDC_NUMBER[SYMBOL];
04300 OLDCBIT_1 LSH (IF OLDC>36 THEN OLDC-37 ELSE OLDC-1);
04400
04500 "PUT ALL MEMBERS OF OLD CLASS INTO NEW CLASS TOO"
04600 FOR I_1 STEP 1 UNTIL COWNT DO BEGIN
04700 SYMBOL_NUMSYM[I];
04800 IF OLDC 36CLASS[SYMBOL]LAND OLDCBIT OLDC>36CLASS2[SYMBOL]LAND OLDCBIT
04900 THEN IF COWNTC 36 THEN CLASS[SYMBOL]_CLASS[SYMBOL] LOR CBIT
05000 ELSE CLASS2[SYMBOL]_CLASS2[SYMBOL] LOR CBIT
05100 END;
05200
05300 END "MAIN35"
05400 ELSE IF FOUND THEN CLSIDASSIGN
05500 ELSE BEGIN ERRFLAG_1;PRINT "UNDECLARED SYMBOL "&WORD MSG ;END;
05600 END "MAIN2"
05700 END "MAIN1" UNTIL COMMAND;
05800
00100
00200 PRINTROOM;
00300 ASSIGN;
00400 PUTOUT ("PRBG%:");
00500
00600 IF EQU(WORD,"<PRODUCTIONS>")=0 THEN ERRIT(<PRODUCTIONS>) ELSE BEGIN
00700 DO BEGIN "MAIN6"
00800 A_GETGOODWORD;
00900 IF COMMAND=0 THEN PRODSCAN;
01000 END UNTIL COMMAND;
01100 END;
01200 PRINTROOM;
01300 PUTOUT("LSTON(SUBRS)");
01400 PUTOUT("EXCTAB: ");
01500 LISTR(NUMEX,EXCNT-1," SUBR ",0);
01600 PUTOUT(" IFN FTDEBUG {");
01700 PUTOUT("EXCNAM: SIXBIT/EXCNM/");
01800 LISTR(NUMEX,EXCNT-1," SIXBIT/",2);
01900 PUTOUT("SYMNAM: SIXBIT/SYMNM/");
02000 LISTR(NUMSYM,COWNT," SIXBIT/",1);
02100 PUTOUT("SYMNO_ .-SYMNAM");
02200 PUTOUT(" }");
02300 PUTOUT("BEND PARSE");
02400 IF ERRFLAG THEN
02500 ERROREND: BEGIN
02600 ERRFLAG_1; PRINT "ERROR RETURN" MSG END;
02700 PROGEND:
02800 IF ERRFLAG THEN DONE;
02900 RELEASE(SUB);
03000 IF SLS THEN BEGIN
03100 OUT(SAI,"NOTANITEMATALL;"&CRLF&CRLF&SAISTR&CRLF&
03200 "ENOUGH=""ENOUGH"";"&CRLF&
03300 "DEFINE NUMTRM=""'"&CVOS(NUMTERM)&""";"&CRLF); RELEASE(SAI)
03400 END;
03500 END "EXECUTE";
03600 END "PTRAN";