perm filename PROFIL.XAL[NEW,AIL]1 blob
sn#408220 filedate 1979-01-08 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00025 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002
C00007 00003 DEFINE DSCR="COMMENT "
C00012 00004 EXTERNAL INTEGER RPGSW
C00018 00005 LABEL NXTIME
C00022 00006 ELSE IF CMDBRK = "←" OR CMDBRK = "," THEN
C00025 00007 COMMENT Swinehart's scanner package (an old version)
C00030 00008 DEFINE OVERDEL="14", NOTATOM="13", STRSTOP="12", STRTEST="11"
C00033 00009 PROCEDURE DOLAND(REFERENCE INTEGER I INTEGER MASK)
C00035 00010 PROCEDURE ATOMINIT(
C00037 00011 SIMPLE STRING PROCEDURE NO!BANG(STRING S)
C00041 00012 RESERVED WORD SYMBOL TABLE
C00045 00013 PRELOADED ARRAYS FOR SYMBOL TABLE-- LOOKR
C00049 00014 FINITE STATE PARSER
C00050 00015 MAIN PROGRAM, EXECUTION STARTS HERE
C00054 00016 PROCEDURES SCAN1, SCAN2, TERP1, AND TERPRI
C00058 00017 PROCEDURES INDENT,UNDENT,SPRINT, PRINT1, & COUNTSTR
C00062 00018 PROCEDURES WIDTH,PRINTS, PRINTC, AND FINISH
C00068 00019 RECURSIVE PROCEDURE SCAN_STMT(INTEGER DOINDENT)
C00071 00020 ROUTINES FOR SIMPLE EX AND NON-EX STMTS AND PROC. DECLS
C00073 00021 ROUTINES FOR BLOCK AND CASE STATEMENTS
C00076 00022 DO,DONE,RETURN,FOR,FOREACH,WHILE,GOTO
C00078 00023 IF STATEMENT AND START_CODE, ALSO NULL STATEMENT, AND LET
C00083 00024 END OF THE VARIOUS STATEMENT ROUTINES
C00084 00025 THE REST OF THE MAIN PROGRAM
C00087 ENDMK
C⊗;
BEGIN "PROFILE"
COMMENT A PROGRAM TO PRODUCE PROGRAM PROFILES USING THE
LIST AND COUNTER FILES CREATED BY USING THE /K OPTION
OF SAIL;
IFC DECLARATION(GTJFN) THENC
DEFINE WANTBANGSW = "TRUE";
DEFINE DECSW = "FALSE";
DEFINE TENXSW="TRUE";
REQUIRE "
COMPILING TENEX VERSION
" MESSAGE;
ELSEC
IFCR DECLARATION(IFGLOBAL) THENC
DEFINE DECSW = "FALSE";
DEFINE TENXSW = "FALSE";
DEFINE WANTBANGSW = "FALSE";
REQUIRE "
COMPILING STANFORD AI VERSION
" MESSAGE;
ELSEC
DEFINE DECSW = "TRUE";
DEFINE TENXSW="FALSE";
DEFINE WANTBANGSW = "TRUE";
REQUIRE "
COMPILING DEC-SYSTEM 10 VERSION
" MESSAGE;
ENDC
ENDC
DEFINE SWTSIZ="12", GOODSWT="""BCFIKLNST""",NEXTCOUNTER="KOUNTR[IKNT←IKNT+1]",
SRCMODE="'17", LSTMODE="0", RELMODE="0", SRCEXT="""KNT""",LSTEXT="NULL",
RELEXT="""PFL""",PROCESSOR="""PROFILE""",EMRK="132",OFILE="BIN",TAB="'11",
FINDFF="4",FINDSEMI="5",FINDLF="6",FINDTAB="7",CMNTCODE="133";
REQUIRE 400 STRING_PDL; REQUIRE 600 SYSTEM_PDL;
STRING ARRAY NAMES[1:10];
INTEGER ARRAY STRT[1:11],INP[1:4];
INTEGER I,J,N,IFIL,NFIL,FL,CURCOUNT,Q,NTABS,NT,NLEN,OLEN,TYP1,TYP2,
NTYPE,OTYPE,NLINES,IKNT,NKNT,SEMICOL,FFLAG,PLVL,MXKTR,STPFLG,
CONIND,BLKIND,LASCOL,CTRCOL,MAXCOL,TI1,TI2,TI3,
SPAC1,SPAC2,SPACO,SPACT,SPACN,FIRSTSCAN,TIA,IGNCMT;
STRING HEAD1,HEADNG,TABS,NLINE,OLINE,STR1,STR2,STR1A,STR2A,BLANX,BFILL,
CONFIL,TS1,TS2,IGN;
DEFINE DSCR="COMMENT ";
DEFINE #=" "; #
DSCR SCNCMD.SAI -- a package for scanning CUSP-like commands.
DES This package provides a function COMMAND_SCAN, and a set
of variables and defined values with the following proerties:
PAR The following values must be DEFINEd:
SRCMODE, LSTMODE, RELMODE the data modes for the approp. files
(define them all, even if you don't use them)
SRCEXT, LSTEXT, RELEXT default extension names (they should
expand to string constants) for the appropriate files. Blank
will also be checked as a possible extension for source files.
PROCESSOR should expand to a string constant. QQprocessor.RPG
will be the RPG file looked up (at Stanford).
The following variables must be set:
ON_ETIME should be made 0 once only, to force opening of
the command file.
NX_TFIL should be made 0 to force COMMAND_SCAN to expect
a new FILE←FILE command next, instead of more source files.
WANTBIN should be made true if a `.REL' file is to be
opened if a file is specified for it.
WANTLST should be made true if a `.LST' file is to be
opened if a file is specified for it.
SOURCECOUNT, after the call on COMMAND_SCAN, may be changed,
either permanently or temporarily, to control input.
RES on returning from COMMAND_SCAN, the following are available:
WANTBIN, WANTLST -- true if a file was opened in the approp.
position, false if false coming in, or no file specified.
BINFIL, SRCFIL -- the file, extension, and PPN for the approp.
files (strings).
SRC, BIN, LST, CMD, DELCHNL (1-5) are channels reserved for
the obvious functions. You should use these names.
CMDTBL, LINTBL, RBRK (15-17) are break tables used by
COMMAND_SCAN. Use them if you wish, but don't expect
them to be there when you get back.
CRLF,DSCR, and BLANKS are the obvious macros. Redefine any but DSCR
if you wish.
SID Channels 1-5, Break Tables 15-17 are reserved by
COMMAND_SCAN. Do GETCHANs to obtain channels, or
be careful.
CAL call COMMAND_SCAN with no parameters. The first time, and
any time subsequently that it is called with NX_TFIL=0, it
will expect optional LST and REL specs, separated by comma,
followed by a left arrow in the command file, then one or
more source file names separated by commas, terminated by
a CRLF. Only one source file is read the first time. Subse-
quent calls on COMMAND_SCAN (without touching NX_TFIL) will
cause subsequent source files to be looked up--if no more exist
an error message will be printed. Set this to FALSE when you
want a brand new command. Set ON_ETIME once for every time
the entire program is restarted.
;
EXTERNAL INTEGER RPGSW;
INTEGER WANTBIN,WANTLST,SRCBRK,SRCEOF,CMDBRK,ON_ETIME,NX_TFIL;
INTEGER SOURCECOUNT,SWTP;
STRING BINFIL,SRCFIL,SWTSTR;
INTEGER ARRAY SWTVAL[1:SWTSIZ];
INTEGER ARRAY BUF[0:'377];
DEFINE CRLF="('15&'12)", BLANKS="("" "")";
INTEGER SRC,BIN,LST,CMND,DELCHNL;
DEFINE LINTBL="17", CMDTBL="16", RBRK="15";
PROCEDURE COMMAND_SCAN;
BEGIN "COMMAND SCAN"
INTEGER EOF,FG,TIA,TIB,TIC,TID,SPCFIL,TIE,TIF;
STRING CMNDFIL,LSTFIL,LINE,TSA,TSB,TSC,BKSTRNG,TSD,CMNDSTR;
IFCR NOT TENXSW THENC
SIMPLE INTEGER PROCEDURE TMPCORSTR
(INTEGER CODE; STRING FIL; REFERENCE STRING TEXT);
BEGIN COMMENT Performs TMPCOR function CODE on FIL, transfering TEXT.
Only functions 1 (read), 2 (read and delete), 3 (write) are legal.
Value returned is that returned in AC by the UUO, !SKIP! is
zero if no error, else !SKIP! is -1;
EXTERNAL INTEGER !SKIP!;
START!CODE LABEL FOOEY,WRLUP,WRBOT,WRCLR,NOTWRITE;
DEFINE P="'17",SP="'16",!="COMMENT";
MOVE 1,CODE; ! CHECK VALID CODES;
CAIL 1,1;
CAILE 1,3;
JRST FOOEY; ! YOU LOSE;
MOVE 2,BUF; ! FWA;
MOVEI 2,-1(2); ! FWA-1 FOR IOWD;
HRLI 2,-'400; ! COMPLETE THE IOWD;
PUSHJ P,CVSIX; ! CONVERT FIL TO SIXBIT IN AC1;
TRZ 1,-1; ! PUT ZEROES IN RIGHT HALF;
! FILE NAME AND IOWD NOW IN 1 AND 2;
MOVSI 5,'440700;
HRRI 5,1(2); ! BP TO BUF;
MOVE 3,CODE;
MOVE 4,-1(P);! PTR TO WD2;
CAIE 3,3;
MOVEM 5,(4); ! SET RESULT BP IF SOME SORT OF READ;
CAIE 3,3;
JRST NOTWRITE;
HRRZ 3,-1(4); ! LENGTH(TEXT);
CAILE 3,'400*5; ! CHECK MAX LENGTH;
JRST FOOEY;
MOVE 4,(4); ! COUNT IN 3, BP IN 4;
JRST WRBOT;
WRLUP: ILDB 6,4;
IDPB 6,5;
WRBOT: SOJGE 3,WRLUP;
TDZA 6,6; ! CLEAR REMAINDER OF LAST WORD;
WRCLR: IDPB 6,5;
TLNE 5,'760000;
JRST WRCLR;
NOTWRITE:MOVS 3,CODE;
HRRI 3,1; ! PARAM AC FOR TMPCOR;
SETZM !SKIP!;
CALLI 3,'44;
FOOEY: SETOB 3,!SKIP!;
SKIPGE 1,3;
MOVEI 3,0;! SET TO 0 IF NEGATIVE;
IMULI 3,5; ! CONVERT TO CHAR COUNT;
MOVE 2,CODE;
MOVE 4,-1(P);! PTR TO WD 2;
CAIE 2,3;
MOVEM 3,-1(4);! STORE CHAR COUNT IF SOME SORT OF READ;
SUB P,['3000003];
JRST @3(P);
END; END;
ENDC
PROCEDURE FILENAME(REFERENCE STRING DEVICE,FILE);
BEGIN "FILENAME"
PROCEDURE SWTGET;
BEGIN "SWTGET"
COMMENT mode "K" added by JFR 6-4-75;
SETBREAK(RBRK,"0123456789",NULL,"XAK");
TSC←SCAN(LINE,RBRK,CMDBRK);
SWTVAL[SWTP←SWTP+1]←CVD(TSC[1 TO ∞-1]);
TID←TSC[∞ FOR 1];
TSD←GOODSWT;
FOR TIE←1 STEP 1 WHILE (TIF←LOP(TSD))∧TID≠TIF DO;
SWTSTR←SWTSTR&TIE;
IF (CMDBRK←LINE)="/" ∨ CMDBRK=")" THEN CMDBRK←LOP(LINE)
END "SWTGET";
SPCFIL←FALSE;
FILE←SCAN(LINE,CMDTBL,CMDBRK) ;COMMENT GET A DEVICE OR FILENAME;
IF CMDBRK = ":" THEN BEGIN
DEVICE←FILE; SPCFIL←TRUE; COMMENT FILE SPECIFIED, NOT INVENTED;
FILE←SCAN(LINE,CMDTBL,CMDBRK)
END ELSE
IF EQU(FILE,"LPT") ∨ EQU(FILE,"LPT.") THEN DEVICE←"LPT" ELSE
DEVICE←"DSK";
IF CMDBRK="[" THEN BEGIN
SETBREAK(RBRK,"]",NULL,"IA");
FILE←FILE&"["&SCAN(LINE,RBRK,CMDBRK);
FILE←FILE&SCAN(LINE,CMDTBL,CMDBRK)
END;
WHILE CMDBRK="/" DO SWTGET;
IF CMDBRK="(" THEN BEGIN
DO SWTGET UNTIL CMDBRK=")";
CMDBRK←LOP(LINE)
END;
END "FILENAME";
LABEL NXTIME;
SWTP←0; SWTSTR←NULL;
IF NX_TFIL THEN GO TO NXTIME;
SETBREAK(CMDTBL,"←:,(!/["&'12,'15&" "&'11,"I");
SETBREAK(LINTBL,'12,'15,"INA"); SETBREAK(RBRK,"]",NULL,"IA");
RELEASE(BIN); RELEASE(LST);
COMMENT FIRST GET COMMAND DEVICE;
IF ¬RPGSW THEN OUTSTR(CRLF&"*");
TSA← IF RPGSW THEN "DSK" ELSE "TTY";
IF ¬ON_ETIME THEN BEGIN
EOF←0;
COMMENT TRY TMPCOR FIRST BEFORE FILE, USE LENGTH OF CMNDSTR
AS FLAG THAT COMMAND IS IN CMNDSTR RATHER THAN FILE;
CMNDSTR←NULL;
IFCR NOT TENXSW THENC
IF RPGSW THEN TMPCORSTR(2,PROCESSOR,CMNDSTR);
ENDC
IF NOT(LENGTH(CMNDSTR)) THEN BEGIN
OPEN(CMND←GETCHAN,TSA,0,1,1,100,CMDBRK,EOF←-1);
IF EOF THEN USERERR(0,0,"COMMAND DEVICE NOT AVAILABLE");
TSB←("000"&CVS(CALL(0,"PJOB")))[INF-2 FOR 3]&PROCESSOR&".TMP";
LOOKUP(CMND,TSB,FG);
IF FG THEN USERERR(0,0,"COMMAND FILE NOT FOUND");
END;
IF RPGSW AND NOT LENGTH(CMNDSTR) THEN BEGIN "DELETE COMMAND FILE"
OPEN(DELCHNL←GETCHAN,"DSK",0,2,0,100,TIA,TIA);
LOOKUP(DELCHNL,TSB,FG);
RENAME(DELCHNL,NULL,0,FG);
RELEASE(DELCHNL)
END "DELETE COMMAND FILE";
CMNDFIL←TSA&":"&(IF RPGSW THEN TSB ELSE NULL);
ON_ETIME←TRUE;
END;
LINE←NULL;
WHILE ¬EOF∧(LENGTH(LINE)≤1 ∨ LENGTH(LINE)<5∧
EQU (LINE,BLANKS[1 FOR LENGTH(LINE)-1]&'12)) DO
BEGIN COMMENT HANDLE TMPCOR VS. FILE;
IF LENGTH(CMNDSTR) THEN BEGIN
LINE←SCAN(CMNDSTR,LINTBL,CMDBRK);
EOF←NOT(LENGTH(CMNDSTR)) END
ELSE
LINE←INPUT(CMND,LINTBL); COMMENT GET RID OF BLANK LINES;
END;
IF EOF THEN TIA←CALL(0,"EXIT");
FILENAME(TSA,TSB);
IF CMDBRK = "!" THEN BEGIN "NEW_PROGRAM"
INTEGER ARRAY SWPTBL[1:5];
SWPTBL[1]←CVSIX(TSA);
SWPTBL[2]←CVFIL(TSB,SWPTBL[3],SWPTBL[5]);
IF ¬SPCFIL THEN SWPTBL[5]←CVSIX(" 1 3");
IF RPGSW THEN SWPTBL[4]←1;
START_CODE
MOVE '14,SWPTBL; MOVEM '14,TIA;
END;
CALL(TIA,IFC TENXSW OR DECSW THENC "RUN" ELSEC "SWAP" ENDC);
END "NEW_PROGRAM"
ELSE IF CMDBRK = "←" OR CMDBRK = "," THEN
IF SPCFIL ∨ LENGTH(TSB) THEN BEGIN "BINARY"
TIA←CVFIL(TSB,TIB,TIC);
IF TIB=0 THEN TSB←CV6STR(TIA)&"."&RELEXT;
TID←-1;
IF WANTBIN THEN BEGIN "OPNBIN"
OPEN(BIN←GETCHAN,TSA,RELMODE,0,2,0,TIC,TID);
IF TID THEN USERERR(0,0,RELEXT&" DEVICE NOT AVAILABLE");
ENTER(BIN,TSB,FG);
IF FG THEN USERERR(0,0,"CANT ENTER "&RELEXT&" FILE");
END "OPNBIN";
BINFIL←TSA&":"&TSB;
END "BINARY" ELSE WANTBIN←0 ELSE USERERR(0,0,PROCESSOR&
" COMMAND ERROR");
IF CMDBRK = "," THEN BEGIN "LISTING"
FILENAME(TSA,TSB);
TIA←CVFIL(TSB,TIB,TIC);
IF TIB = 0 THEN TSB←CV6STR(TIA)&"."&LSTEXT;
IF WANTLST THEN BEGIN
OPEN(LST←GETCHAN,TSA,LSTMODE,0,2,0,TIC,TIC);
ENTER(LST,TSB,FG);
IF FG THEN USERERR(0,0,"CAN'T ENTER "&LSTEXT&" FILE");
END;
LSTFIL←TSA&":"&TSB;
IF CMDBRK ≠ "←" THEN USERERR(0,0,PROCESSOR & " COMMAND ERROR");
END "LISTING" ELSE WANTLST←0;
FILENAME(TSA,TSB);
OPEN(SRC←GETCHAN,TSA,SRCMODE,2,0,SOURCECOUNT←200,SRCBRK,SRCEOF);
WHILE TRUE DO BEGIN "SOURCE FILE LOOP"
IF CMDBRK≠'12 AND CMDBRK≠"," THEN USERERR(0,0,PROCESSOR&
" COMMAND ERROR");
CLOSE(SRC);
TID←CVFIL(TSB,TIC,TIE);
TSC←CVXSTR(TID)&"."&SRCEXT&
(IF TIE THEN "["&(TSC←CVXSTR(TIE))[1 FOR 3]&","&TSC[4 FOR 3]&"]"
ELSE NULL);
FG←-1;
IF TIC=0 THEN LOOKUP(SRC,TSC,FG);
IF FG THEN LOOKUP(SRC,TSB,FG);
IF FG THEN USERERR(0,0,TSB &" FILE NOT FOUND");
SRCFIL←TSA&":"&TSB;
IF RPGSW THEN
OUTSTR(PROCESSOR&": "&(IF EQU(TSA,"DSK") THEN NULL ELSE TSA)&TSB&
'15&'12);
NX_TFIL←TRUE; RETURN;
NXTIME:
IF CMDBRK='12 THEN USERERR(0,0,"END OF FILE ON SOURCE FILE");
FILENAME(TSA,TSB);
END "SOURCE FILE LOOP";
END "COMMAND SCAN";
COMMENT Swinehart's scanner package (an old version);
DSCR SCNSER.SAI -- a package to provide SCANNER operations
DES This insert provides a token-scanning service more
extensive than the SAIL SCAN function can handle. It
can handle delimiters, identifiers, and string constants,
as well as filler characters, and characters which are
to be ignored completely. There is provision for extension
to handle numbers.
CAL Call ATOMINIT("DEL", "TS", "TC", "∂IGN", "IGN", SS, NUMF)
to parameterize the scanner. All characters in DEL will be
considered delimiters. The characters in TS are valid characters
for the start of an identifier. Those in TC are valid identifier
characters after the first. The characters in ∂IGN are fillers --
they are returned separately, and never appear in a token, but
will break an identifier scan. Those in IGN will be ignored on
input. SS is the string constant quote character -- otherwise,
string constants are scanned like SAIL scans them. NUMF is true
if numbers are to be handled (not implemented).
Call I←ATOM(@"TOSS",@"TOKEN") to scan from the input file
(ignoring line numbers). See Results below for exact returns.
RES The result of ATOM is a code -- the character code in ASCII
for a delimiter -- otherwise an integer >127 -- TOKENCODE for
identifiers (numbers currently returned in string form as IDs),
STRCONCODE for string constants, ILLEGALCODE for illegal characters,
EOFCODE when EOF is seen. TOSSED contains all those fill
(∂IGN) characters passed over before reaching the token. TOKEN
contains the character(s) of the token itself. TOKLEN (a local
variable, see below) contains the length of the token (for string
constants, the length of the string from the last LF to the end).
PAR The following will be local to the REQUIRing block:
SETBIT, SELSTR procedures, SCANTABLE(SCT) array,
TEMP, TEMP1, STEMP, STEMP1 variables, LETTER, LETDIG ... defs.
The following are also local, and possibly useful:
DOLAND, DOLOR, UPPERCASE routines (uses obvious on inspection),
RESCAN variable, if set, causes same token to be returned again
TOKLEN (see above), OVERDEL, NOTATOM, ... break tables (14-10),
TOKENCODE, STRCONCODE ... (see above) return codes.
The following should be set to affect the ATOM routine:
RESCAN -- set to rescan -- TOKEN and TOSSED will NOT be
set during a rescan -- only the return code is saved!!!!!
SID SCNCMD.SAI is required
Other side effects should be limited to changes to the variables
described above.
;
DEFINE OVERDEL="14", NOTATOM="13", STRSTOP="12", STRTEST="11";
DEFINE CHKLEN="10";
DEFINE LETTER="1", LETDIG="2", DIGIT="4", PARTOFNUMBER="8",
STRINGSTART="16", DELIM="32", IGNORE="64",
∂IGNORE="128", ILLEGAL="256",LOWERCASE="512";
DEFINE TOKENCODE="128", STRCONCODE="129", ILLEGALCODE="130",
EOFCODE="131";
COMMENT These values go into the scan table, which controls all,
iff default is indicated by the user
;
#
PRELOAD_WITH
ILLEGAL, Comment 0;
[8] DELIM, Comment ↓ α β ∧ ¬ ε π λ;
∂IGNORE, Comment TAB;
DELIM, Comment LF;
IGNORE, Comment VT;
DELIM, Comment FF;
IGNORE, Comment CR;
[10] DELIM, Comment ∞ ∂ ⊂ ⊃ ∪ ∩ ∀ ∃ ⊗ ↔ ;
LETDIG LOR LETTER, Comment UNDERLINE;
[7] DELIM, Comment → ~ ≠ ≤ ≥ ≡ ∨ ;
∂IGNORE, Comment SPACE;
LETDIG LOR LETTER, Comment ! -- SAME AS _;
STRINGSTART, Comment " ;
[13] DELIM, Comment # # $ % & ' ( ) * + - . /;
[10] DIGIT LOR
LETDIG LOR PARTOFNUMBER, Comment 0-9;
[7] DELIM, Comment : SEMIC < = > ? @ ;
[26] LETDIG LOR LETTER, Comment A-Z;
[6] DELIM, Comment [ \ ] ↑ ← ` ;
[26] LETDIG LOR LETTER
LOR LOWERCASE, Comment a-z;
[2] DELIM, Comment { | ;
ILLEGAL, Comment ALTMODE;
DELIM, Comment } ;
ILLEGAL; Comment DELETE;
#
SAFE INTEGER ARRAY SCANTABLE[0:127];
DEFINE SCT="SCANTABLE";
INTEGER TEMP,TEMP1,RESCAN,TOKLEN;
STRING STEMP,STEMP1;
PROCEDURE DOLAND(REFERENCE INTEGER I; INTEGER MASK);
I←I LAND MASK;
PROCEDURE DOLOR(REFERENCE INTEGER I; INTEGER MASK);
I←I LOR MASK;
PROCEDURE CLEAR(INTEGER MASK);
BEGIN "CLEAR"
TEMP1←-1 XOR MASK;
FOR TEMP←0 STEP 1 UNTIL 127 DO
DOLAND(SCT[TEMP],TEMP1);
END "CLEAR";
PROCEDURE SETBIT(STRING S;INTEGER MASK);
IF S≠'177 THEN BEGIN "SETBIT"
CLEAR(MASK);
WHILE TEMP←LOP(S) DO DOLOR(SCT[TEMP],MASK)
END "SETBIT";
STRING PROCEDURE SELSTR(INTEGER MASK);
BEGIN "SELSTR"
STEMP←NULL;
FOR TEMP←0 STEP 1 UNTIL 127 DO
IF SCT[TEMP] LAND MASK THEN STEMP←STEMP&TEMP;
RETURN(STEMP)
END "SELSTR";
STRING PROCEDURE UPPERCASE(STRING S);
BEGIN "UPPERCASE"
STEMP←NULL;
WHILE LENGTH(S) DO STEMP←STEMP&
(IF LOWERCASE LAND (TEMP1←SCT[TEMP←LOP(S)]) THEN
(TEMP1 LSH -18) ELSE TEMP);
RETURN(STEMP)
END "UPPERCASE";
PROCEDURE ATOMINIT(
STRING DELIMITER_STRING,
TOKEN_START,
TOKEN_CONTINUE,
∂IGNORE_STRING,
IGNORE_STRING;
INTEGER STRING_START,
NUMBER_FLAG );
BEGIN "ATOMINIT"
FOR TEMP←"a" STEP 1 UNTIL "z" DO
DOLOR(SCT[TEMP],(TEMP-"a"+"A") LSH 18);
SETBIT(DELIMITER_STRING,DELIM);
SETBIT(TOKEN_START,LETTER);
SETBIT(TOKEN_CONTINUE,LETDIG);
IF STRING_START≠'177 THEN BEGIN
CLEAR(STRINGSTART);
DOLOR(SCT[STRING_START],STRINGSTART)
END ELSE STRING_START←"""";
SETBIT(IGNORE_STRING,IGNORE);
SETBIT(∂IGNORE_STRING,∂IGNORE);
STEMP1←SELSTR(IGNORE); "ALWAYS IGNORED COMPLETELY"
SETBREAK(OVERDEL,SELSTR(∂IGNORE)&STEMP1,STEMP1,"XNR");
SETBREAK(NOTATOM,SELSTR(LETDIG)&STEMP1,STEMP1,"XNR");
SETBREAK(STRSTOP,STRING_START,NULL,"INA");
SETBREAK(STRTEST,NULL,NULL,"XNR");
SETBREAK(CHKLEN,'12,'15,"I");
RESCAN←FALSE;
END "ATOMINIT";
SIMPLE STRING PROCEDURE NO!BANG(STRING S);
BEGIN INTEGER C; STRING T;
T ← NULL;
WHILE (C ← LOP(S)) DO T ← T & (IF C="!" THEN "_" ELSE C);
RETURN(T);
END;
IFCR WANTBANGSW THENC
SIMPLE STRING PROCEDURE YES!BANG(STRING Y);
BEGIN "YES!BANG"
STRING Q; INTEGER TEMP;
Q ← NULL;
WHILE LENGTH(Y) DO
IF (TEMP ← LOP(Y)) = ("X"-'100) THEN
Q ← Q & "!"
ELSE
Q ← Q & TEMP;
RETURN(Q);
END "YES!BANG";
ELSEC
DEFINE YES!BANG(S) = "S";
ENDC
INTEGER PROCEDURE ATOM(REFERENCE STRING TOSSED,TOKEN);
BEGIN "ATOM"
INTEGER RET;
IF RESCAN THEN BEGIN
RESCAN←FALSE;
RETURN(RET)
END;
SOURCECOUNT←200; TOKLEN←1;
TOSSED←INPUT(SRC,OVERDEL); "BLANKS AND SUCH"
IF SRCEOF THEN RETURN(RET←EOFCODE);
TEMP←SCT[SRCBRK]; "SCANNER TABLE BITS"
IF TEMP LAND LETTER THEN BEGIN "TOKEN"
TOKEN←NO!BANG(INPUT(SRC,NOTATOM)); "GET IDENTIFIER"
TOKLEN←LENGTH(TOKEN);
RETURN(RET←TOKENCODE)
END "TOKEN";
IF TEMP LAND STRINGSTART THEN BEGIN "STRCON"
TOKEN←NULL;
DO BEGIN "GET STRING"
SOURCECOUNT←1;
TOKEN←TOKEN&INPUT(SRC,0); "PICK UP STRINGSTART"
SOURCECOUNT←200;
DO TOKEN←TOKEN&
INPUT(SRC,STRSTOP) UNTIL SRCBRK; "GO UNTIL STRINGSTART"
INPUT(SRC,STRTEST); "CHECK FOR 2 STRINGSTARTS";
END "GET STRING" UNTIL ¬(SCT[SRCBRK] LAND STRINGSTART);
STEMP1←TOKEN; "COMPUTE TOKLEN"
DO STEMP←SCAN(STEMP1,CHKLEN,TEMP) UNTIL TEMP≠'12;
TOKLEN←LENGTH(STEMP); IF TOKLEN≠LENGTH(TOKEN) THEN TOKLEN←-TOKLEN;
RETURN(RET←STRCONCODE)
END "STRCON";
"MUST NOW BE EITHER DELIMITER OR ILLEGAL"
SOURCECOUNT←1; TEMP1←SRCBRK;
TOKEN←INPUT(SRC,0); "GET THE CHARACTER"
"HACK HERE TO ALLOW := FOR ←"
IF TOKEN = ":" THEN
BEGIN
STRING TOSS2;
TOSS2 ← INPUT(SRC,OVERDEL);
IF SRCBRK = "=" THEN
BEGIN
TOKEN ← "←";
TOSS2 ← INPUT(SRC,0);
RETURN(RET←"←");
END;
END;
IF TEMP LAND ILLEGAL THEN RETURN(RET←ILLEGALCODE)
ELSE RETURN(RET←TEMP1)
END "ATOM";
DSCR END OF SCNSER
;
COMMENT RESERVED WORD SYMBOL TABLE
THE ARRAY STAB CONTAINS THE NAMES OF ALL THE IMPORTANT RESERVED WORDS
(THOSE NEEDED TO DISTINGUISH DECLARATIONS AND OTHER NON-EXECUTABLE
STATEMENTS FROM EXECUTABLE STATEMENTS, THUS "PUT" IS NOT IN THE TABLE
BECAUSE IT MERELY INDICATES AN EXECUTABLE STATEMENT, MUCH AS ANY
OTHER IDENTIFIER NOT FOLLOWED BY A COLON).
THE ARRAY LETS CONTAINS THE NAMES OF ALL USER DEFINED RESERVED WORDS
(BY MEANS OF "LET" DECLARATIONS).
THE PROCEDURE LOOKR LOOKS UP A SYMBOL AS FOLLOWS:
1. IF ANY "LET" DECLARATIONS HAVE BEEN SEEN (THE NUMBER SEEN
IS KEPT IN THE INTEGER NLETS) THEN LOOKR
DOES A LINEAR SEARCH THROUGH THE LETS ARRAY FOR THE
SYMBOL. IF THE SYMBOL IS FOUND, THE "VALUE" OF THE SYMBOL RETURNED
IS THE CORRESPONDING ELEMENT OF THE ARRAY LETVAL. THUS, IF
LETS[3] WAS THE SYMBOL, LETVAL[3] WOULD BE RETURNED.
2. OTHERWISE WE USE THE ASCII CODE FOR THE FIRST LETTER OF THE
SYMBOL AS AN INDEX INTO THE ARRAY XFERTAB. AN XFERTAB ENTRY
CONTAINS TWO INTEGERS PACKED IN A SINGLE WORD. THEY
ARE THE INDEX OF THE FIRST ELEMENT OF THE ARRAY STAB WHICH STARTS
WITH THE CORRESPONDING LETTER, AND THE INDEX OF THE LAST ELEMENT
OF THE ARRAY STAB WHICH STARTS WITH THE SAME LETTER.
IF THERE IS NO ENTRY IN STAB STARTING WITH A GIVEN LETTER
THEN THE ENTRIES IN XFERTAB FOR THAT LETTER ARE BOTH 0.
IF THERE IS ONLY ONE ENTRY IN STAB STARTING WITH A GIVEN LETTER
THEN (FOR SOME UNEXPLAINED REASON) THE ENDING INDEX IS ZERO
INSTEAD OF BEING THE SAME AS THE STARTING INDEX. IF THE
STARTING INDEX IS NON-ZERO LOOKR DOES A LINEAR SEARCH FROM
THAT POSITION IN STAB TO THE ENDING POSITION IN STAB. IF
THE SYMBOL IS FOUND THE CORRESPONDING ENTRY IN SVAL IS RETURNED.
THUS, IF THE DESIRED SYMBOL IS STAB[5], THEN SVAL[5] WILL
BE RETURNED.
3. IF THE SYMBOL IS NOT FOUND THEN IT IS NOT A CRUCIAL RESERVED
WORD AND THE VALUE 0 IS RETURNED.
;
COMMENT PRELOADED ARRAYS FOR SYMBOL TABLE-- LOOKR;
PRELOAD_WITH
"ASSIGNC", "ARRAY", "BEGIN", "BOOLEAN", "CASE",
"CLEANUP", "CONTEXT", "CONTINUE", "DEFINE", "DO",
"DONE", "END", "ELSE", "EXTERNAL", "FOR",
"FOREACH", "FORTRAN", "FORWARD", "GLOBAL", "GO",
"GOTO", "IF", "INTEGER", "INTERNAL", "ITEM",
"ITEMVAR", "LABEL", "LET", "LIST", "LONG",
"MATCHING", "MESSAGE", "NEEDNEXT", "OF", "OWN",
"PRELOAD_WITH", "PRESET_WITH", "PROCEDURE", "QUICK_CODE", "REAL",
"RECURSIVE", "REQUIRE", "RETURN", "RECORD_CLASS", "RECORD_POINTER",
"SAFE", "SET", "SHORT", "SIMPLE", "START_CODE",
"STRING", "UNTIL", "WHILE";
STRING ARRAY STAB[1:53];
PRELOAD_WITH [65]0,
'0102, '0304, '0510, '1113, '1416, '1722, '2325, 0, '2632, 0,
0, '3336, '3740, '4100, '4243, '4446, '4700, '5055, '5663, 0,
'6400, 0, '6500;
SAFE INTEGER ARRAY XFERTAB[0:127];
COMMENT RESERVED WORDS ARE CLASSIFIED AS FOLLOWS:
1- "FORWARD" AND "FORTRAN"
2- "EXTERNAL"
3- NECESSARILY DETERMINES A NON-EXECUTABLE STATEMENT
4- A TYPE, THIS MIGHT BE A PROCEDURE DECL.
5- "PROCEDURE"
6- "NEEDNEXT"
7- "BEGIN"
8- "CASE"
9- "DO"
10- "DONE","RETURN","CONTINUE"
11- "FOR","FOREACH"
12- "WHILE"
13- "GO","GOTO"
14- "IF"
15- "QUICK_CODE","START_CODE"
16- "END"
17- "ELSE"
18- "UNTIL"
19- "OF"
20- "LET"
21- "RECORD_CLASS"
22- "RECORD_POINTER"
;
PRELOAD_WITH
3, 3, 7, 4, 8, 3, 4, 10, 3, 9,
10, 16, 17, 2, 11, 11, 1, 1, 4, 13,
13, 14, 4, 4, 4, 4, 3, 20, 4, 4,
4, 4, 6, 19, 3, 3, 3, 5, 15, 4,
4, 3, 10, 21, 22, 3, 4, 4, 4, 15,
4, 18, 12;
INTEGER ARRAY SVAL[1:53];
INTEGER ARRAY LETVAL[1:20];
STRING ARRAY LETS[1:20],RPSTR[1:40];
INTEGER NLETS,NRPC;
INTEGER PROCEDURE LOOKR;
BEGIN INTEGER I,I1,I2;
IF NLETS >0 THEN
BEGIN FOR I← 1 STEP 1 UNTIL NLETS DO
IF EQU(STR1,LETS[I]) THEN RETURN (LETVAL[I]);
END;
I1←(I2←XFERTAB[STR1]) LSH (-6);
IF I1=0 THEN RETURN(0);
I2←I2 LAND '77;
IF I2=0 THEN RETURN(IF EQU(STR1,STAB[I1]) THEN SVAL[I1] ELSE 0);
FOR I←I1 STEP 1 UNTIL I2 DO
IF EQU(STR1,STAB[I]) THEN RETURN(SVAL[I]);
RETURN(0);
END "LOOKR";
COMMENT FINITE STATE PARSER
IN THE FOLLOWING TRANSITION TABLE, THE POSITIVE ENTRIES INDICATE
STATE TRANSITIONS AND THE NEGATIVE ONES INDICATE EXITS AS FOLLOWS:
(-2) EXECUTABLE STATEMENT
(-3) NON-EXECUTABLE STATEMENT
(-4) FORWARD OR EXTERNAL PROCEDURE DECL.
(-5) ACTUAL PROCEDURE DECL.
(-6) ERROR
;
PRELOAD_WITH
-2,-4,2,-3,3,-5,4,[6] -6, COMMENT ROW 1 BEGINNING OF STATEMENT;
-3,-4,-6,-3,2,-4,-6,[6] -6, COMMENT ROW 2 SEEN "EXTERNAL" LOOKING FOR "PROCEDURE";
-3,-4,2,-3,3,-5,-6,[6] -6, COMMENT ROW 3 SEEN TYPE LOOKING FOR "PROCEDURE";
[11] -6,-11,-12;
INTEGER ARRAY XITION[1:4,0:12];
COMMENT MAIN PROGRAM, EXECUTION STARTS HERE;
SCANTABLE['177]←DELIM;
ATOMINIT(",+-|¬()[]/↑←↔∧∨&≤≥<>≠=*⊗≡∩∪%αβ;:{}ε"&'14&'177,
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!_∂$0123456789@.'⊂⊃",
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!_∂$0123456789@.'⊂⊃",
'11&'12&'40,
'177,
"""",
0);
COMMENT THE FOLLOWING IS NECESSARY SINCE SAIL DOES NOT ALWAYS CLEAR
THE LOW ORDER BIT IN THE LIST FILE;
FOR I←1 STEP 1 UNTIL 18 DO BREAKSET(I,NULL,"P");
SETBREAK(FINDFF,'14&'12,'15,"IPS");
SETBREAK(FINDSEMI,";",NULL,"IPA");
SETBREAK(FINDLF,'12,'15,"IPS");
SETBREAK(FINDTAB,'11,NULL,"IPS");
ON_ETIME←0;
HEAD1←" PROGRAM PROFILE ";
NT←0;
SETFORMAT(8,0);
BLANX←" "&
" ";
TABS←" "&
" ";
WHILE TRUE DO
BEGIN "SUPERLOOP"
NX_TFIL←0;
WANTBIN←TRUE;
WANTLST←FALSE;
SOURCECOUNT←100;
COMMENT FIRST OPEN COUNTER FILE AND LISTING FILE;
COMMAND_SCAN;
COMMENT THE FOLLOWING SWITCHES ARE IMPLEMENTED:
/nB INDENT n SPACES FOR BLOCKS (default 4)
/nC INDENT n SPACES FOR CONTINUATIONS (default 2)
/F FILL OUT EVERY 4th LINE WITH . . .
/I IGNORE COMMENTS OTHER THAN STRING CONSTANTS
/nK MAKE COUNTER ARRAY OF SIZE n (default 200)
/nL MAXIMUM LINE LENGTH OF n (default 120)
/N DON'T FILL OUT EVERY 4th LINE WITH . . .
/S STOP (EXIT PROGRAM) AFTER THIS PROFILE
/T TELETYPE MODE = /1C/2B/80L/F
;
MXKTR←200;
CONIND←2;BLKIND←4;
IGNCMT←STPFLG←0;
FFLAG←1;
MAXCOL← 120;
I←1;
WHILE LENGTH(SWTSTR)>0 DO
BEGIN TEMP←LOP(SWTSTR);
CASE TEMP-1 OF
BEGIN
BLKIND←SWTVAL[I];
CONIND←SWTVAL[I];
FFLAG←1;
IGNCMT←1;
MXKTR←SWTVAL[I];
MAXCOL←SWTVAL[I];
FFLAG←0;
STPFLG←1;
BEGIN
CONIND←1; BLKIND←2; MAXCOL←80; FFLAG←1;
END;
USERERR(0,0,"ILLEGAL SWITCH")
END;
I←I+1;
END;
CONFIL←BLANX[1 FOR CONIND];
CTRCOL← (MAXCOL LAND '777777777770) -8;
LASCOL← CTRCOL-9;
BEGIN "KNTLOOP"
INTEGER ARRAY KOUNTR[1:MXKTR];
COMMENT PROCEDURES SCAN1, SCAN2, TERP1, AND TERPRI;
RECURSIVE PROCEDURE SCAN2;
BEGIN
SPAC2←0;
TYP2←ATOM(IGN,STR2A);
WHILE TYP2='177 DO
BEGIN TYP2←ATOM(IGN,STR2A);
IF TYP2=2 THEN TYP2←ATOM(IGN,STR2A)
ELSE IF TYP2=3 THEN TYP2←EMRK
ELSE USERERR(0,0,"ILLEGAL CHAR <'"&CVOS(TYP2)&"> AFTER '177
FILE= "&NAMES[IFIL]&"
OLINE= "&OLINE&"
NLINE= "&NLINE&"
NEXT 2 TOKENS= "&STR1A&STR2A);
END;
IF TYP2=EOFCODE THEN
BEGIN TYP2←TOKENCODE; STR2←"END";
STR2A←"END (supplied by scanner)";SPAC2←1;
RETURN;
END;
IF TYP2=TOKENCODE THEN
BEGIN SPAC2←1;
STR2←UPPERCASE(STR2A);
IF EQU(STR2,"COMMENT") THEN
BEGIN
DO
STR2A←STR2A&INPUT(SRC,FINDSEMI)
UNTIL SRCBRK;
TYP2←CMNTCODE;
END;
END
ELSE BEGIN IF TYP2=STRCONCODE THEN SPAC2←1; STR2←STR2A; END;
IF TYP2='14 THEN
BEGIN
SOURCECOUNT←200; TS1←INPUT(SRC,FINDLF);
TS2←NULL;
WHILE (TS1[∞ FOR 1]≠"-")∧(LENGTH(TS1)>0) DO
BEGIN TS2←TS1[∞ FOR 1]& TS2;
TS1←TS1[1 TO ∞-1];
END;
TI1← INTSCAN(TS2,TI2);
TS1←INPUT(SRC,FINDLF); "READ THE SECOND HEADING LINE"
IF (TI1=1)∧¬FIRSTSCAN THEN
BEGIN STR2A← '15&'14;
TYP2←CMNTCODE;
END
ELSE SCAN2;
END;
END "SCAN2";
PROCEDURE SCAN1;
BEGIN
SPAC1←SPAC2;
STR1←STR2;
STR1A←STR2A;
TYP1←TYP2;
SCAN2;
END "SCAN1";
PROCEDURE TERP1;
BEGIN INTEGER L2;
STRING FILL;
IF NLEN=0 THEN SPACO←0 ELSE IF SPACN THEN
BEGIN TIA←LOP(NLINE); NLEN←NLEN-1; SPACN←0 END;
IF LENGTH(OLINE)=0 THEN RETURN;
L2←(OLEN+8) LAND '777777777770;
OUT(OFILE,YES!BANG(BFILL&OLINE&TAB));
IF (OTYPE≠0) THEN
BEGIN
FILL← IF (FFLAG≠0)∧((NLINES LAND 3)=0) THEN " . ." ELSE TAB;
WHILE L2<CTRCOL DO
BEGIN OUT(OFILE,YES!BANG(FILL));
L2←L2+8;
END;
IF CURCOUNT<0 THEN USERERR(0,1,"DRYROT: negative count.
FILE= "&NAMES[IFIL]&"
OLINE= "&OLINE&"
NLINE= "&NLINE&"
NEXT 2 TOKENS= "&STR1A&STR2A);
OUT(OFILE,CVS(CURCOUNT)&CRLF);
OTYPE←0;
END
ELSE OUT(OFILE,CRLF);
OLINE←NULL;
NLINES←NLINES+1;
END "TERP1";
PROCEDURE TERPRI;
BEGIN
TERP1;
TI3←NT % 8;
BFILL←TABS[1 FOR TI3]&BLANX[1 FOR NT-8*TI3];
OLEN←NT;
END "TERPRI";
COMMENT PROCEDURES INDENT,UNDENT,SPRINT, PRINT1, & COUNTSTR;
PROCEDURE INDENT(INTEGER NCOLS);
BEGIN
NT← NT+NCOLS;
IF NT≥LASCOL-1 THEN
BEGIN SETFORMAT(0,0);
USERERR(0,0,"NESTING TOO DEEP FOR PRINTING. CHANGE INDENTION COUNTS
FOR BLOCKS AND CONTINUATIONS FROM /"&CVS(BLKIND)&"B/"&CVS(CONIND)&"C");
END;
TERPRI;
END;
PROCEDURE UNDENT(INTEGER NCOLS);
BEGIN
NT← NT-NCOLS;
TERPRI;
END;
PROCEDURE SPRINT;
BEGIN
IF NLEN=0 THEN RETURN;
OLINE←OLINE&NLINE;
OLEN←OLEN+NLEN;
OTYPE← OTYPE LOR NTYPE;
NLINE←NULL;
SPACN←0;
NLEN←0;
END;
PROCEDURE PRINT1;
BEGIN INTEGER L1;
IF SPAC1 ∧ SPACO THEN
BEGIN STR1A←" "&STR1A; SPACT←1;
IF NLEN=0 THEN SPACN←1;
END ELSE SPACT←0;
L1←LENGTH(STR1A);
IF OLEN+NLEN+L1<LASCOL THEN
BEGIN NLINE←NLINE&STR1A;
NLEN←NLEN+L1;
END
ELSE BEGIN TERPRI;
IF SPACN ∧ (NLEN=0) THEN
BEGIN SPACN←SPACT←0; TIA←LOP(STR1A); L1←L1-1 END;
IF OLEN+NLEN+L1<LASCOL THEN
BEGIN NLEN←NLEN+L1;
NLINE←NLINE&STR1A;
END
ELSE BEGIN OLINE←NLINE;
OTYPE←NTYPE;
OLEN←OLEN+NLEN;
TERPRI; IF SPACT THEN BEGIN TIA←LOP(STR1A); L1←L1-1 END;
WHILE L1+NT+CONIND > LASCOL DO
BEGIN OLINE←CONFIL& STR1A[1 FOR LASCOL-NT-CONIND];
OTYPE←NTYPE;
OLEN← LASCOL;
TERPRI;
STR1A←STR1A[LASCOL-NT-CONIND+ 1 TO ∞];
L1←LENGTH(STR1A);
END;
NLINE←CONFIL&STR1A;
NLEN←L1+CONIND;
END;
END;
SPACO←SPAC1;
END "PRINT1";
DEFINE PASSCOMMENT= "WHILE (TYP1=STRCONCODE)∨(TYP1=CMNTCODE) DO
BEGIN NTYPE←0; IF TYP1=STRCONCODE THEN PRINTS ELSE
PRINTC; SPRINT;SCAN1; END",
CHECKSEMI= "IF TYP1="";"" THEN
BEGIN PRINT1;SPACO←1;SCAN1;SEMICOL←1;
END ELSE SEMICOL←0; SPRINT";
DEFINE PASSTOKEN=
"BEGIN IF TYP1=STRCONCODE THEN PRINTS ELSE
IF TYP1=CMNTCODE THEN PRINTC ELSE
BEGIN IF TYP1=EMRK THEN COUNTSTR; PRINT1 END;
SCAN1;
END";
PROCEDURE COUNTSTR;
BEGIN
INTEGER I,J;
GETFORMAT(I,J);
SETFORMAT(0,0);
STR1A←"<<"&CVS(NEXTCOUNTER)&">>"; SPAC1←0;
SETFORMAT(I,J);
END;
COMMENT PROCEDURES WIDTH,PRINTS, PRINTC, AND FINISH;
INTEGER PROCEDURE WIDTH(STRING ST1; INTEGER STCOL);
BEGIN COMMENT RETURN THE FINAL COLUMN IF STRING
ST1 IS PRINTED STARTING IN COLUMN STCOL;
INTEGER L1,BRK; STRING ST2;
L1←STCOL;
WHILE LENGTH(ST1)>0 DO
BEGIN
ST2←SCAN(ST1,FINDTAB,BRK);
L1←L1+LENGTH(ST2);
IF BRK=TAB THEN L1←8+(L1 LAND '777777777770);
END;
RETURN(L1);
END;
PROCEDURE PRINTS;
BEGIN
INTEGER L1,BRK,T1,L2;
STRING ST1;
IF SPAC1 ∧ SPACO THEN
BEGIN STR1A←" "&STR1A; SPACT←1; IF NLEN=0 THEN SPACN←1 END
ELSE SPACT←0;
ST1←SCAN(STR1A,FINDLF,BRK);
L1←WIDTH(ST1,NLEN+OLEN);
IF L1≤LASCOL THEN
BEGIN NLINE←NLINE&ST1;
NLEN←L1-OLEN;
END
ELSE BEGIN
TERPRI; IF SPACN ∧ (NLEN=0) THEN
BEGIN TIA←LOP(ST1); SPACT←SPACN←0 END;
L1←WIDTH(ST1,NLEN+OLEN);
IF L1≤LASCOL THEN
BEGIN
NLINE←NLINE&ST1; NLEN←L1-OLEN;
END
ELSE
BEGIN OLINE←NLINE; OTYPE←NTYPE;
NLINE←NULL;
OLEN←OLEN+NLEN; TERPRI;
IF SPACT THEN BEGIN TIA←LOP(ST1); SPACT←0 END;
L1←WIDTH(ST1,OLEN+CONIND);
IF L1≤LASCOL THEN
BEGIN NLINE←CONFIL&ST1; NLEN← L1-OLEN;
END
ELSE BEGIN L2←WIDTH(ST1,0);
IF L2≤LASCOL THEN
BEGIN T1←LASCOL-L2;
WHILE (L2←WIDTH(ST1,T1))>LASCOL DO
T1←T1-1;
OLEN←L2;
BFILL←BLANX[1 FOR T1];
OLINE←ST1; TERPRI;
END
ELSE
BEGIN COMMENT JESUS THAT'S A LONG STRING;
WHILE(T1← LENGTH(ST1))>0 DO
BEGIN
WHILE (L1←WIDTH(ST1[1 FOR T1],OLEN+CONIND))>LASCOL-2 DO
T1←T1-1;
NLINE←CONFIL&ST1[1 FOR T1]; NLEN← L1-OLEN;
ST1←ST1[T1+1 TO ∞];
IF LENGTH(ST1)>0 THEN
BEGIN NLINE←NLINE&"""&"; NLEN←NLEN+2; SPRINT;
TERPRI; ST1←CONFIL&""""&ST1;
END;
END;
END;
END;
END;
END;
COMMENT BY HOOK OR CROOK WE GOT THE FIRST LINE OF THE STRING OUT.
NOW DO THE REST;
WHILE LENGTH(STR1A)>0 DO
BEGIN SPRINT; TERP1; ST1←SCAN(STR1A,FINDLF,BRK);
BFILL←NULL; OLEN←0;
L1←WIDTH(ST1,0);
IF L1≤LASCOL THEN
BEGIN NLINE←ST1;
NLEN←L1; L1←0;
END
ELSE
WHILE(T1← LENGTH(ST1))>0 DO
BEGIN
WHILE (L1←WIDTH(ST1[1 FOR T1],0))>LASCOL-2 DO
T1←T1-1;
NLINE←ST1[1 FOR T1]; NLEN← L1;
ST1←ST1[T1+1 TO ∞];
IF LENGTH(ST1)>0 THEN
BEGIN NLINE←NLINE&"""&"; NLEN←NLEN+2; SPRINT;
TERPRI; ST1←CONFIL&""""&ST1;
END;
END;
END;
SPACO←SPAC1;
END "PRINTS";
PROCEDURE PRINTC;
BEGIN
STRING ST1;
INTEGER BRK;
IF (LENGTH(STR1A)=2)∧EQU(STR1A,'15&'14) THEN
BEGIN TERPRI; OUT(OFILE,YES!BANG(STR1A)); RETURN;
END;
IF IGNCMT THEN RETURN;
TERPRI;
ST1←SCAN(STR1A,FINDLF,BRK);
NTYPE←0;
OLINE←ST1;
WHILE LENGTH(STR1A)>0 DO
BEGIN ST1←SCAN(STR1A,FINDFF,BRK);
IF BRK='14 THEN
BEGIN
SOURCECOUNT←200; TS1←SCAN(STR1A,FINDLF,BRK);
TS2←NULL;
WHILE (TS1[∞ FOR 1]≠"-")∧(LENGTH(TS1)>0) DO
BEGIN TS2←TS1[∞ FOR 1]& TS2;
TS1←TS1[1 TO ∞-1];
END;
TI1← INTSCAN(TS2,TI2);
TS1←SCAN(STR1A,FINDLF,BRK);
IF (TI1=1) THEN
BEGIN TERP1; OUT(OFILE,'15&'14);
OLEN←0;
END
END
ELSE
BEGIN
TERP1; OLEN←0; BFILL←NULL;
OLINE←ST1;
END;
END;
TERPRI;
END "PRINTC";
PROCEDURE FINISH;
BEGIN
NTYPE←1;
WHILE (TYP1≠";")∧((TYP1≠TOKENCODE)∨ (¬EQU(STR1,"UNTIL")∧
¬EQU(STR1,"END")∧(¬EQU(STR1,"ELSE")∨(TYP2=EMRK)))) DO
PASSTOKEN;
CHECKSEMI;
END;
RECURSIVE PROCEDURE SCAN_STMT(INTEGER DOINDENT);
COMMENT THIS IS THE MAIN PROCEDURE. IT WILL SCAN A SINGLE STATEMENT
AND WRITE IT OUT TO THE LIST FILE. IF THE STATEMENT ENDS
WITH A SEMICOLON, THE VARIABLE SEMICOL WILL BE SET TO 1 ELSE
0;
BEGIN "SCAN_STMT"
INTEGER S1,S2; LABEL KP; INTEGER NQ;
WHILE (TYP1=STRCONCODE)∨(TYP1=CMNTCODE)∨
((TYP1=TOKENCODE)∧(TYP2=":")) DO
BEGIN "SCNLBL" COMMENT FIRST HANDLE LABELS AND COMMENTS;
IF (TYP1=STRCONCODE) THEN
BEGIN NTYPE←0;
PRINTS; SPRINT;
END
ELSE IF TYP1=CMNTCODE THEN
BEGIN PRINTC; SPRINT END
ELSE
BEGIN FOR S1←1 STEP 1 UNTIL NRPC DO
IF EQU(STR1,RPSTR[S1]) THEN DONE "SCNLBL";
TERPRI;
NTYPE←1; CURCOUNT←NEXTCOUNTER;
PRINT1; SCAN1;
PRINT1; SPRINT; TERPRI;
END;
SCAN1;
END;
COMMENT FIRST DETERMINE WHETHER THIS IS A NULL STATEMENT (SOME NULL
STATEMENTS ARE CAUGHT BELOW BY THE "PARSER";
IF TYP1=";" THEN
BEGIN PRINT1;SPACO←1;NTYPE←1;SCAN1;SPRINT;SEMICOL←1; RETURN;
END;
COMMENT DETERMINE THE STATEMENT TYPE BY A FINITE STATE "PARSER";
NQ←1;
KP: J←LOOKR;
IF J≤6 THEN
BEGIN Q←NQ;
WHILE Q>0 DO
BEGIN PRINT1; SCAN1;
IF J>12 THEN USERERR(0,0,"ERROR IN STMT TYPING
FILE= "&NAMES[IFIL]&"
OLINE= "&OLINE&"
NLINE= "&NLINE&"
NEXT 2 TOKENS= "&STR1A&STR2A);
Q←XITION[Q,J];
J←LOOKR;
END;
J← -Q;
END;
CASE J OF
BEGIN "BIGSW"
COMMENT ROUTINES FOR SIMPLE EX AND NON-EX STMTS AND PROC. DECLS;
[0] USERERR(0,1,"DRYROT:CASE INDEX = 0 IN SCAN_STMT");
[1] USERERR(0,1,"DRYROT:CASE INDEX = 1 IN SCAN_STMT");
COMMENT -- A GARDEN VARIETY EXECUTABLE STATEMENT;
[2] FINISH;
COMMENT -- A GARDEN VARIETY NON-EXECUTABLE STATEMENT;
[3] BEGIN "NONEX"
NTYPE←0;
WHILE TYP1≠";" DO
PASSTOKEN;
PRINT1;SPACO←1;SCAN1;SEMICOL←1;SPRINT;
END;
COMMENT -- A FORWARD OR EXTERNAL PROCEDURE DECLARATION;
[4] BEGIN "FPROC"
TERPRI;
NTYPE←0;
PLVL←0;
WHILE (PLVL>0)∨(TYP1≠";") DO
BEGIN PRINT1;
IF TYP1="(" THEN PLVL←PLVL+1
ELSE IF TYP2=")" THEN PLVL←PLVL-1;
SCAN1;
END;
PRINT1; SPACO←1;
SPRINT; SEMICOL←1;
SCAN1;
END;
COMMENT -- AN ACTUAL REAL-LIFE PROCEDURE DECLARATION;
[5] BEGIN "PROC"
TERPRI;
NTYPE←0;
PLVL←0;
WHILE (PLVL>0)∨(TYP1≠";") DO
BEGIN PRINT1;
IF TYP1="(" THEN PLVL←PLVL+1
ELSE IF TYP2=")" THEN PLVL←PLVL-1;
SCAN1;
END;
PRINT1; SPACO←1;
SCAN1;
SPRINT;
INDENT(CONIND);
S1←CURCOUNT;
CURCOUNT←NEXTCOUNTER;
SCAN_STMT(1);
UNDENT(CONIND);
CURCOUNT←S1;
END;
COMMENT -- ERROR;
[6] USERERR(0,0,"ERROR IN STMT TYPING
OLINE= "&OLINE&"
NLINE= "&NLINE&"
NEXT 2 TOKENS= "&STR1A&STR2A);
COMMENT ROUTINES FOR BLOCK AND CASE STATEMENTS;
COMMENT -- BEGIN, A BLOCK OR COMPOUND STATEMENT;
[7] BEGIN "BLOCK" INTEGER OLDNLETS,OLDNRPC;
TERPRI;
NTYPE←1;
PRINT1; SPRINT; SCAN1;
PASSCOMMENT;
IF DOINDENT THEN INDENT(BLKIND);
OLDNLETS←NLETS; OLDNRPC←NRPC;
WHILE (TYP1≠TOKENCODE)∨¬EQU(STR1,"END") DO
SCAN_STMT(1);
NLETS←OLDNLETS; NRPC←OLDNRPC;
IF DOINDENT THEN UNDENT(BLKIND) ELSE TERPRI;
PRINT1; SPRINT; SCAN1;
PASSCOMMENT;
CHECKSEMI;
TERPRI;
END;
COMMENT -- CASE STATEMENT;
[8] BEGIN "CASE"
NTYPE←1;
S1←0;
TERPRI;
WHILE (TYP1≠TOKENCODE)∨¬EQU(STR1,"OF")∨(TYP2=EMRK) DO
PASSTOKEN;
PRINT1; SPRINT; INDENT(CONIND);
SCAN1; NTYPE←0;
PASSCOMMENT; IF ¬EQU(STR1,"BEGIN") THEN USERERR(0,0,"NO BEGIN AFTER CASE
FILE= "&NAMES[IFIL]&"
OLINE= "&OLINE&"
NLINE= "&NLINE&"
NEXT 2 TOKENS= "&STR1A&STR2A);
PRINT1;SPRINT; SCAN1; INDENT(CONIND);
DO
BEGIN "CASE1"
TERPRI; SEMICOL←0;
CURCOUNT←NEXTCOUNTER;
PASSCOMMENT;
WHILE TYP1="[" DO
BEGIN DO
BEGIN PRINT1; SCAN1;
END
UNTIL TYP1="]";
PRINT1; SCAN1
END;
SCAN_STMT(1);
S1←S1+CURCOUNT;
END
UNTIL SEMICOL=0;
PASSCOMMENT; IF ¬EQU(STR1,"END") THEN USERERR(0,0,"NO END AFTER CASE
FILE= "&NAMES[IFIL]&"
OLINE= "&OLINE&"
NLINE= "&NLINE&"
NEXT 2 TOKENS= "&STR1A&STR2A);
UNDENT(CONIND); PRINT1; NTYPE←0;
SCAN1;
CHECKSEMI;
UNDENT(CONIND); CURCOUNT←S1;
END;
COMMENT DO,DONE,RETURN,FOR,FOREACH,WHILE,GOTO;
COMMENT -- DO STATEMENT;
[9] BEGIN "DOSTMT"
TERPRI; PRINT1; NTYPE←1; SPRINT;
INDENT(CONIND);
CURCOUNT←NEXTCOUNTER;
SCAN1;
SCAN_STMT(1);
PASSCOMMENT;
UNDENT(CONIND);
IF ¬EQU(STR1,"UNTIL") THEN USERERR(0,0,"NO UNTIL AFTER DO
FILE= "&NAMES[IFIL]&"
OLINE= "&OLINE&"
NLINE= "&NLINE&"
NEXT 2 TOKENS= "&STR1A&STR2A);
PRINT1; SCAN1;
FINISH;
TERPRI;
CURCOUNT←NEXTCOUNTER;
END;
COMMENT -- DONE, CONTINUE, RETURN STATEMENTS;
[10] BEGIN "DONE"
FINISH;
TERPRI;
CURCOUNT←0;
END;
COMMENT -- FOR, AND FOREACH STATEMENTS;
[11] BEGIN "FORST"
TERPRI;
NTYPE←1;
WHILE ¬EQU(STR1,"DO") DO
PASSTOKEN;
PRINT1; SPRINT;
INDENT(CONIND); CURCOUNT←NEXTCOUNTER;
SCAN1;
SCAN_STMT(1);
UNDENT(CONIND); CURCOUNT←NEXTCOUNTER;
END;
COMMENT -- WHILE STATEMENT;
[12] BEGIN "WHILE"
TERPRI;
CURCOUNT←NEXTCOUNTER;
NTYPE←1;
WHILE ¬EQU(STR1,"DO") DO
PASSTOKEN;
PRINT1; SPRINT;
INDENT(CONIND); CURCOUNT←NEXTCOUNTER;
SCAN1;
SCAN_STMT(1);
UNDENT(CONIND); CURCOUNT←NEXTCOUNTER;
END;
COMMENT -- GO TO STATEMENT;
[13] BEGIN "GOTO"
FINISH;
TERPRI;
CURCOUNT←0;
END;
COMMENT IF STATEMENT AND START_CODE, ALSO NULL STATEMENT, AND LET;
COMMENT -- IF STATEMENT;
[14] BEGIN "IFSTMT"
TERPRI;
S1←CURCOUNT;
NTYPE←1;
WHILE (TYP1≠TOKENCODE)∨¬EQU(STR1,"THEN")∨(TYP2=EMRK) DO
PASSTOKEN;
PRINT1; SPRINT; SCAN1;
INDENT(CONIND); CURCOUNT←NEXTCOUNTER;
S2←S1-CURCOUNT;
SCAN_STMT(1); S1←CURCOUNT;
PASSCOMMENT;
IF (SEMICOL=0) ∧EQU(STR1,"ELSE") THEN
BEGIN UNDENT(CONIND); CURCOUNT←S2;
PRINT1; SPRINT; SCAN1;
INDENT(CONIND); SCAN_STMT(1);
S2←CURCOUNT;
END;
UNDENT(CONIND);
CURCOUNT←S1+S2;
END;
COMMENT -- START_CODE AND QUICK_CODE;
[15] BEGIN "CODE"
TERPRI;
PRINT1; NTYPE←1; SPRINT; SCAN1; PASSCOMMENT;
IF DOINDENT THEN INDENT(BLKIND) ELSE TERPRI;
NTYPE←0;
WHILE ¬EQU(STR1,"END") DO
BEGIN PRINT1;
IF TYP1=";" THEN
BEGIN SCAN1; PASSCOMMENT;
SPRINT; TERPRI;
END
ELSE SCAN1;
END;
IF DOINDENT THEN UNDENT(BLKIND) ELSE TERPRI;
PRINT1; SPRINT; SCAN1; PASSCOMMENT;
CHECKSEMI;
TERPRI;
END;
COMMENT -- NULL STATEMENT NOT ENDING IN SEMICOLON;
COMMENT -- THREE COPIES ARE NEEDED;
COMMENT -- COPY FOR END;
[16] BEGIN "NULL1"
STRING TSA;
TSA←STR1A; STR1A←" "; SPAC1←0;
PRINT1;STR1A←TSA; SPAC1←1;
NTYPE←1; SPRINT;
SEMICOL←0;
END;
COMMENT -- COPY FOR ELSE;
[17] BEGIN "NULL2"
STRING TSA;
TSA←STR1A; STR1A←" "; SPAC1←0;
PRINT1;STR1A←TSA; SPAC1←1;
NTYPE←1; SPRINT;
SEMICOL←0;
END;
COMMENT -- COPY FOR UNTIL;
[18] BEGIN "NULL3"
STRING TSA;
TSA←STR1A; STR1A←" "; SPAC1←0;
PRINT1;STR1A←TSA; SPAC1←1;
NTYPE←1; SPRINT;
SEMICOL←0;
END "NULL3";
COMMENT -- ERROR;
[19] BEGIN
USERERR(0,0,"ILLEGAL USE OF OF
OLINE= "&OLINE&"
NLINE= "&NLINE&"
NEXT 2 TOKENS= "&STR1A&STR2A);
END;
COMMENT -- LET STATEMENT;
[20] BEGIN "LET"
STRING TSA;
INTEGER J1;
NTYPE←0;
WHILE TYP1≠";" DO
BEGIN PRINT1; SCAN1; TSA← STR1; PRINT1; SCAN1;
IF TYP1≠ "=" THEN
USERERR(0,0,"BAD LET STATEMENT
FILE= "&NAMES[IFIL]&"
OLINE= "&OLINE&"
NLINE= "&NLINE&"
NEXT 2 TOKENS= "&STR1A&STR2A);
PRINT1;
SCAN1; J1← LOOKR;
IF J1≠0 THEN
BEGIN NLETS← NLETS+1;
IF NLETS>20 THEN USERERR(0,0,"TOO MANY LET STMTS");
LETS[NLETS]← TSA;
LETVAL[NLETS]← J1;
END;
PRINT1;
SCAN1;
END;
PRINT1; SPACO←1; SCAN1; SEMICOL←1; SPRINT;
END;
[21] BEGIN "RECORDCLASS"
IF (NRPC←NRPC+1)>40 THEN USERERR(0,0,"TOO MANY RECORD CLASSES");
RPSTR[NRPC]←STR2;
TERPRI; NTYPE←0; PLVL←0;
WHILE (PLVL>0) OR (TYP1 NEQ ";") DO
BEGIN PRINT1;
IF TYP1="(" THEN PLVL←PLVL+1
ELSE IF TYP1=")" THEN PLVL←PLVL-1;
SCAN1 END;
PRINT1; SPACO←1; SPRINT; SEMICOL←1; SCAN1; END;
[22] BEGIN "RPTR"
COMMENT must scan past parenthesized class list, then reenter parser
loop in order to allow for record!pointer procedures;
DO BEGIN PRINT1; SCAN1 END UNTIL TYP1=")"; PRINT1; SCAN1;
NQ←3; GOTO KP END "RPTR"
COMMENT END OF THE VARIOUS STATEMENT ROUTINES;
END;
END "SCAN_STMT";
COMMENT THE REST OF THE MAIN PROGRAM;
LABEL MLO; COMMENT PUT THERE TO LOCATE LOOP IN DDT;
NFIL←NKNT←IKNT←0;
COMMENT NOW READ IN THE COUNTER FILE;
WHILE TRUE DO
BEGIN
ARRYIN(SRC,INP[1],4);
IF SRCEOF THEN DONE;
N←INP[4];
N←-(N%262144);
NAMES[NFIL←NFIL+1]←CVXSTR(INP[1]);
STRT[NFIL]←NKNT←NKNT+1;
IF NKNT+N>MXKTR THEN USERERR(0,0,
"TOO MANY COUNTERS, USE THE /#K SWITCH (YOU HAVE AT LEAST "&CVS(NKNT+N)&" COUNTERS)");
ARRYIN(SRC,KOUNTR[NKNT],N);
NKNT←NKNT+N-1;
END;
STRT[NFIL+1]←NKNT+1;
RELEASE(SRC);
COMMENT NOW READ IN THE LIST FILES AND PRODUCE THE
PROFILES. THE LIST FILE NAMES ARE FOUND IN THE COUNTER
BLOCK HEADERS WRITTEN OUT TO THE DISK AFTER EXECUTION;
OPEN(SRC←GETCHAN,"DSK",0,2,0,SOURCECOUNT,SRCBRK,SRCEOF);
MLO: FOR IFIL←1 STEP 1 UNTIL NFIL DO
BEGIN "SRCLOOP"
IKNT←STRT[IFIL]-1;
FL←-1; LOOKUP(SRC,NAMES[IFIL]&
IFCR DECSW THENC ".CRF" ELSEC ".LST" ENDC ,FL);
IF FL THEN USERERR(0,0,"CAN'T FIND FILE-"&NAMES[IFIL]&
IFCR DECSW THENC ".CRF" ELSEC ".LST" ENDC);
HEADNG←HEAD1&NAMES[IFIL];
OUT(OFILE,'14&'15&YES!BANG(HEADNG)&'15&'12&'12);
NLINES←0;
FIRSTSCAN←1; SCAN1;
FIRSTSCAN←0; SCAN1;
PASSCOMMENT;
IF EQU(STR1,"ENTRY") THEN
BEGIN CURCOUNT←0; NTYPE←0;
WHILE TYP1≠";" DO
BEGIN PRINT1; SCAN1 END;
PRINT1;SPACO←1; SCAN1;
SPRINT;
END
ELSE CURCOUNT←1;
TERPRI;
SCAN_STMT(0);
TERPRI;
CLOSE(SRC);
IF IKNT≠(I←STRT[IFIL+1]-1) THEN
USERERR(0,1,CVS(ABS(IKNT-I))&(IF IKNT<I THEN
" TOO FEW" ELSE " TOO MANY")&" COUNTERS FOUND FOR-"&
NAMES[IFIL]);
END "SRCLOOP";
RELEASE(SRC);
RELEASE(OFILE);
IF STPFLG THEN DONE;
END "KNTLOOP";
END "SUPERLOOP";
OUTSTR("
THAT'S ALL FOLKS
");
END "PROFILE";