/* SERVICE CLASS>QUICK,PRINT>HOLD // EXEC PLC //GO.SYSIN DD * *PL/C ID>:RONALD MAK:,NOHDRPG,PAGES>125,LINES>6000,TIME>[0,30] /* F O R T R A N M C O M P I L E R */ /* FFFFF OOOOO RRRR TTTTT RRRR A N N M M */ /* F O O R R T R R A A NN N MM MM */ /* F O O R R T R R A A N N N M M M */ /* FFFFF O O RRRR T RRRR A A N NN M M M */ /* F O O R R T R R AAAAA N N M M */ /* F O O R R T R R A A N N M M */ /* F OOOOO R R T R R A A N N M M */ /* */ /* */ /* CCC OOOOO M M PPPP III L EEEEE RRRR */ /* C C O O MM MM P P I L E R R */ /* C O O M M M P P I L E R R */ /* C O O M M M PPPP I L EEE -R-- */ /* C O O M M P I L E R R */ /* C C O O M M P I L E R R */ /* CCC OOOOO M M P III LLLLL EEEEE R - */ /* BY */ /* RONALD MAK */ /* COMPUTER SCIENCE 293 */ /* PROFESSOR BREDT */ /* STANFORD UNIVERSITY */ /* AUGUST 1975 */ 1 [NOFLOW] 10 ^^ , , 32 , 8 , 20,8,o [NOSIZE] 21 ^^ , , 32 , 8 , 20,8,o [NOFIXEDOVERFLOW] 19 ^^ , , 32 , 8 , 20,8,o [NOSTRINGRANGE] 37 ^^ , , 32 , 8 , 20,8,o [NOSUBSCRIPTRANGE] 58 ^^ , , 32 , 8 , 20,8,o FORTRAN 9 ^^ , , 32 , 8 , 20,8,o PROCEDURE OPTIONS[MAIN]; /* *************************************************************** */ /* *************************************************************** */ /* *************************************************************** */ /* 1. I N I T I A L I Z A T I O N S */ /* IN THIS SECTION, WE FIRST DECLARE AND INITIALIZE */ /* COMPILER PARAMETERS AS PART OF (LOADING( THE COMPILER. */ /* THESE PARAMETERS DETERMINE LIMITS FOR CERTAIN BASIC */ /* COUNTERS AND ARRAY AND TABLE SIZES. */ /* THEN, WITHIN THE COMPILER PROPER [(MAIN=BLOCK(], */ /* WE DECLARE AND INITIALIZE THE NUMEROUS OTHER GLOBAL */ /* VARIABLES, ARRAYS, AND TABLES. */ /* *************************************************************** */ /* *************************************************************** */ /* *************************************************************** */ /* --------------------------------------------------------------- */ /* 1.1 COMPILER PARAMETERS */ /* --------------------------------------------------------------- */ DECLARE MAXPROGS /* MAX. NO. OF PROGRAMS PER JOB */ FIXED BINARY; DECLARE /* TABLE SIZES */ [HEADLISTSIZE, NAMTABSIZE, RW=HEADLISTSIZE, RWTABSIZE, SN=HEADLISTSIZE, SNTABSIZE] FIXED BINARY; DECLARE /* COMPILER LIMITS PER PROGRAM */ [MAXCARDS, /* MAX. NO. OF NONCOMMENT CARDS */ MAXGCOUNT, /* MAX. NO. OF STMT GROUPS */ MAXREFS, /* MAX. NO. OF REFERENCING STMTS */ MAXSN, /* MAX. NO. OF STMT NO. REFERENCES */ MAXDIM, /* MAX. NO. OF DIMENSIONS PER ARRAY */ MAXARGS, /* MAX. NO. OF ARGUMENTS PER CALL */ MAXLEVEL, /* MAX. LEVEL OF STMT GROUP NESTING */ MAXDOLEVEL, /* MAX. LEVEL OF DO NESTING */ MAXCASELEVEL] /* MAX. LEVEL OF CASE"DO=EVENT NESTING */ FIXED BINARY; DECLARE /* NAMED CONSTANTS */ TRUE BIT[1] INITIAL[:1:B], FALSE BIT[1] INITIAL[:0:B], MAXINTEGER FIXED[31,0] BINARY INITIAL[2147483647], NULL FIXED BINARY INITIAL[-32767]; MAXPROGS > 4; HEADLISTSIZE > 5; NAMTABSIZE > 10; RW=HEADLISTSIZE > 25; RWTABSIZE > 51; SN=HEADLISTSIZE > 8; SNTABSIZE > 16; MAXCARDS > 35; MAXGCOUNT > 8; MAXREFS > 8; MAXSN > 16; MAXDIM > 2; MAXARGS > 4; MAXLEVEL > 4; MAXDOLEVEL > 4; MAXCASELEVEL > 4; 1 MAIN=BLOCK 12 ^^ , , 32 , 8 , 20,8,o BEGIN; /* --------------------------------------------------------------- */ /* 1.2 GLOBAL VARIABLES, ARRAYS, AND TABLES */ /* --------------------------------------------------------------- */ DECLARE /* BASIC SCANNER VARIABLES */ [TOKEN, /* ENCODING FOR THE LAST TOKEN SCANNED */ TYPE, /* ENCODING FOR THE TYPE OF CHARACTER */ CARD=PTR] /* POINTER INTO THE BUFFERED CARD IMAGE */ FIXED BINARY; DECLARE /* BASIC TYPE AND TOKEN CODES */ [DIGIT, LETTER, BLANK, DOT, LPAREN, PLUS, STAR, RPAREN, SEMICOLON, MINUS, SLASH, COMMA, QUOTE, EQUALS, STAR2, STMTEND, ILLEGAL] FIXED BINARY; DECLARE /* CLASS CODES */ [INTEGER=NO, REAL=NO, SIMPLE=VAR, ARRAY=VAR, FUNCTION=NAME, SUBROUTINE=NAME, CHAR=NAME, ID] FIXED BINARY; DECLARE /* MODE CODES */ [INTEGER, RREAL, LOGICAL] FIXED BINARY; DECLARE /* RESERVED WORD CODES */ [RW=EQ, RW=NE, RW=LT, RW=LE, RW=GT, RW=GE, RW=AND, RW=OR, RW=NOT, RW=TRUE, RW=FALSE, RW=ASSEMBLER, RW=CALL, RW=CASE, RW=CAUSE, RW=COMMON, RW=CONTINUE, RW=DATA, RW=DIMENSION, RW=DO, RW=ELSE, RW=END, RW=ENTER, RW=EVENT, RW=EXIT, RW=FIN, RW=FOR, RW=FORMAT, RW=FORTRAN, RW=FUNCTION, RW=GO, RW=GOTO, RW=IF, RW=INTEGER, RW=ITERATE, RW=LOGICAL, RW=NEXT, RW=PRINT, RW=READ, RW=REAL, RW=RETURN, RW=STOP, RW=SUBROUTINE, RW=THEN, RW=TO, RW=UNTIL, RW=WHILE, RW=WRITE, RW=OF, RW=CHARACTER, RW=EXTERNAL] FIXED BINARY; DECLARE /* CURRENT COMPILATION STATUS */ [CURCLASS, CURMODE, /* CLASS AND MODE */ CASE=LEVEL, /* CASE " DO=EVENT NESTING LEVEL */ DOLEVEL, HIDOLEVEL, /* DO LOOP NESTING LEVEL */ CURLEV] /* STMT GROUP NESTING LEVEL */ FIXED BINARY; DECLARE /* COUNTERS GALORE */ [JOB=COUNT, PROG=COUNT, CARD=COUNT, LABEL=COUNT, GRP=COUNT, CASE=COUNT, FOR=COUNT, GO=COUNT, DUM=ARG=COUNT, SPC=COUNT, /* SUBPROGRAM CALLS */ TEMP=COUNT] /* TEMPORARY VARIABLES */ FIXED[31,0] BINARY; DECLARE /* TABLE INDEXES AND TABLE TOPS */ [XNAMTAB, TOP=NAMTAB, XRWTAB, TOP=REFSTMT, TOP=REFSN, XSNTAB, TOP=SNTAB, XSPTAB, TOP=SPTAB, XBUF] FIXED BINARY; DECLARE /* INTEGER AND REAL PROGRAM CONSTANTS */ INUMBER FIXED[31,0] BINARY, RNUMBER FLOAT BINARY; DECLARE STMT=NO /* STATEMENT NUMBER */ FIXED[31,0] BINARY; DECLARE /* MISCELLANEOUS */ [I, /* PL/1 DO LOOP INDEX */ SEQ, /* SEQ. NO. ON FORTRAN LISTING */ SEQASM, /* SEQ. NO. ON ASSEMBLY LISTING */ SAVEXSP, /* SAVES VALUE OF XSPTAB */ FTNMODE] /* MODE OF FUNCTION SUBPROGRAM */ FIXED BINARY; DECLARE /* FLAGS */ [ENDBATCH, ENDJOB, ENDPROG, ELSESTMT, ENDSTMT, FINSTMT, IFSTMT, CLASSDEC, MODEDEC, FOUND, DEFINED, UNDEFINED, CONTINUATION, /* IS CARD A CONTINUATION CARD+ */ CASE, NOTCASE, /* STMT NO. REF:D BY CASE " DO=EVENT+ */ FUNCTION, /* FUNCTION SUBPROGRAM+ */ TYPE=OK, /* OK TO HAVE A TYPE STMT+ */ ARITHMETIC] /* ARITHMETIC EXPRESSION+ */ BIT[1]; DECLARE /* SCANNER ELEMENTS */ CHARR /* CHARACTER SCANNED */ CHARACTER[1], SYMBOL /* SPECIAL SYMBOL */ CHARACTER[2] VARYING, SAVEWORD /* THE (UNTAGGED( WORD */ CHARACTER[6] VARYING, SUBPROGNAME /* SUBPROGRAM NAME [UNTAGGED] */ CHARACTER[6] VARYING, WORD /* SCANNED RESERVED WORD OR IDENTIFIER */ CHARACTER[10] VARYING, NOTHING /* THE (BLANK( CARD */ CHARACTER[72] INITIAL[: :], CARD /* BUFFERED SOURCE PROGRAM CARD */ CHARACTER[73]; DECLARE /* LISTING ELEMENTS */ STR=PROG=COUNT /* STRING VERSION OF PROG=COUNT */ CHARACTER[2], STR=SEQ /* STRING VERSION OF SEQ " SEQASM */ CHARACTER[3], WHEN /* DATE AND TIME */ CHARACTER[26]; DECLARE [LABEL=FLD, /* LABEL FIELD OF ASSEMBLER INSTRUCTION */ SAVEAREA] /* SAVE AREA FOR PROGRAM:S REGISTERS */ CHARACTER[8]; DECLARE BUFFER[1 23 ^^ , , 32 , 8 , 20,8,oMAXCARDS] /* PROGRAM CARD BUFFER */ CHARACTER[73]; DECLARE CURCOUNT[0 25 ^^ , , 32 , 8 , 20,8,oMAXLEVEL] /* STACKED CURRENT GRP=COUNT */ FIXED BINARY; DECLARE DUM=ARGS[1 25 ^^ , , 32 , 8 , 20,8,oMAXARGS] /* DUMMY ARGUMENT LIST */ CHARACTER[8] VARYING; DECLARE /* STACKED EXIT LABELS FOR CASE " DO=EVENT STMTS */ CASE=LABELS[1 28 ^^ , , 32 , 8 , 20,8,oMAXCASELEVEL] CHARACTER[8]; DECLARE /* IS DO=EVENT LOOP COMPLETED+ */ CASE=CLOSED[1 28 ^^ , , 32 , 8 , 20,8,oMAXCASELEVEL] BIT[1]; DECLARE /* BRANCH-TO LABELS FOR NEXT AND EXIT STMTS */ [NEXT=LABELS[1 29 ^^ , , 32 , 8 , 20,8,oMAXDOLEVEL], EXIT=LABELS[1 56 ^^ , , 32 , 8 , 20,8,oMAXDOLEVEL]] CHARACTER[8]; /* RESERVED WORD TABLE */ DECLARE RW=HEADLIST[0 28 ^^ , , 32 , 8 , 20,8,oRW=HEADLISTSIZE] FIXED BINARY; DECLARE 01 RWTAB[1001 30 ^^ , , 32 , 8 , 20,8,o 1000( SUPPLIED :], MISLPARN INITIAL[:([( SUPPLIED :], MISOPRND INITIAL[:DUMMY VAR SUPPLIED :], MISOPRTR INITIAL[:(<( SUPPLIED :], MISPSTMT INITIAL[:MISPLACED STATEMENT :], MISPTYPE INITIAL[:MISPLACED TYPE STMT :], MISRPARN INITIAL[:(]( SUPPLIED :], MISRWDOF INITIAL[:(OF( SUPPLIED :], MISRWDTO INITIAL[:(TO( SUPPLIED :], MXMDINTG INITIAL[:CONVERSN TO INTEGER :], MXMDLOGC INITIAL[:EXPR NOT LOGICAL :], MXMDREAL INITIAL[:CONVERSION TO REAL :], NFTNDEFN INITIAL[:NOT FTN DEFINITION :], NOTARITH INITIAL[:EXPR NOT ARITHMETIC :], NOTIMPLM INITIAL[:STMT NOT IMPLEMENTED:], NUMSUBSC INITIAL[:NO. OF SUBSCRIPTS :], OVFNAMTB INITIAL[:NAME TABLE OVERFLOW :], OVFREFTB INITIAL[:REFTAB OVERFLOW :], OVFSNTAB INITIAL[:SNTAB OVERFLOW :], SUBPNAME INITIAL[:INVALID SUBPROG NAME:], UNXPPEND INITIAL[:UNEXPTD END OF PROG :], UNXPSEND INITIAL[:UNEXPTD END OF STMT :]] CHARACTER[20]; /* BASIC TYPE AND TOKEN CODES */ DIGIT > -2; LETTER > -1; BLANK > 1; DOT > 2; LPAREN > 3; PLUS > 4; STAR > 5; RPAREN > 6; SEMICOLON > 7; MINUS > 8; SLASH > 9; COMMA > 10; QUOTE > 11; EQUALS > 12; STAR2 > 13; STMTEND > 10001; ILLEGAL > -NULL; /* IDENTIFIER CLASS CODES */ INTEGER=NO > 101; REAL=NO > 102; SIMPLE=VAR > 103; ARRAY=VAR > 104; FUNCTION=NAME > 106; SUBROUTINE=NAME > 107; CHAR=NAME > 108; ID > 109; /* MODE CODES */ INTEGER > 501; RREAL > 502; LOGICAL > 503; /* RESERVED WORD CODES */ RW=EQ > 1001; RW=NE > 1002; RW=LT > 1003; RW=LE > 1004; RW=GT > 1005; RW=GE > 1006; RW=AND > 1007; RW=OR > 1008; RW=NOT > 1009; RW=TRUE > 1010; RW=FALSE > 1011; RW=ASSEMBLER > 1012; RW=CALL > 1013; RW=CASE > 1014; RW=CAUSE > 1015; RW=COMMON > 1016; RW=CONTINUE > 1017; RW=DATA > 1018; RW=DIMENSION > 1019; RW=DO > 1020; RW=ELSE > 1021; RW=END > 1022; RW=ENTER > 1023; RW=EVENT > 1024; RW=EXIT > 1025; RW=FIN > 1026; RW=FOR > 1027; RW=FORMAT > 1028; RW=FORTRAN > 1029; RW=FUNCTION > 1030; RW=GO > 1031; RW=GOTO > 1032; RW=IF > 1033; RW=INTEGER > 1034; RW=ITERATE > 1035; RW=LOGICAL > 1036; RW=NEXT > 1037; RW=PRINT > 1038; RW=READ > 1039; RW=REAL > 1040; RW=RETURN > 1041; RW=STOP > 1042; RW=SUBROUTINE > 1043; RW=THEN > 1044; RW=TO > 1045; RW=UNTIL > 1046; RW=WHILE > 1047; RW=WRITE > 1048; RW=OF > 1049; RW=CHARACTER > 1050; RW=EXTERNAL > 1051; DEFINED, CASE > TRUE; UNDEFINED, NOTCASE > FALSE; INUMBER, RNUMBER > 0; CALL BATCH; /* AND AWAY WE GO */ 1 /* *************************************************************** */ /* *************************************************************** */ /* *************************************************************** */ /* 2. P A R S I N G A N D S E M A N T I C S */ /* SINCE FORTRAN HAS A RELATIVELY SIMPLE STRUCTURE, */ /* THE PARSING AND SEMANTIC ROUTINES ARE COMBINED. MUCH */ /* OF THE SEMANTIC OPERATIONS INVOLVE TABLE MAINTENANCE */ /* [SECTION 4] AND CODE GENERATION [SECTION 5]. */ /* THREE MAJOR LEVELS OF HIERARCHY ARE EVIDENT IN */ /* THIS SECTION. */ /* AT THE HIGHEST LEVEL ARE PROCEDURES TO PROCESS A */ /* BATCH, TO PROCESS THE JOBS WHICH COMPOSE A BATCH, TO */ /* PROCESS THE PROGRAMS WHICH COMPOSE A JOB, AND TO */ /* PROCESS THE STATEMENTS WHICH COMPOSE A PROGRAM. */ /* AT THE SECOND LEVEL ARE PROCEDURES TO PROCESS THE */ /* INDIVIDUAL FORTRAN M STATEMENTS. THESE STATEMENTS ARE */ /* PARSED TOP-DOWN WITH RECURSIVE DESCENT AND NO BACKUP. */ /* FINALLY, AT THE LOWEST LEVEL ARE THE PROCEDURES */ /* WHICH PROCESS THE LOGICAL AND ARITHMETIC EXPRESSIONS */ /* CONTAINED IN MANY STATEMENTS. ARITHMETIC EXPRESSIONS */ /* ARE CONSIDERED TO BE PART OF LOGICAL EXPRESSIONS. */ /* ALSO IN THIS SECTION ARE PROCEDURES WHICH STORE */ /* AND LIST THE SOURCE PROGRAM. */ /* *************************************************************** */ /* *************************************************************** */ /* *************************************************************** */ /* --------------------------------------------------------------- */ /* 2.1 BATCH, JOBS, PROGRAMS, STATEMENTS */ /* --------------------------------------------------------------- */ BATCH 7 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* DRIVER FOR A BATCH */ CALL INITIALIZE=TABLES; ENDBATCH > FALSE; JOB=COUNT > 0; /* LOOP ONCE PER JOB */ DO WHILE [_ENDBATCH]; GET EDIT [CARD] [COLUMN[1], A[73]]; /* FIRST CARD OF JOB */ ON ENDFILE[SYSIN] BEGIN; CALL ERR[ENDOFILE]; STOP; END; JOB=COUNT > JOB=COUNT < 1; SEQASM > 0; CALL JOB; END; END BATCH; JOB 5 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* DRIVER FOR A JOB */ /* SCAN FOR A CONTROL CARD */ DO WHILE [ [SUBSTR[CARD, 1, 9] _> :$FORTRANM:] & [SUBSTR[CARD, 1, 4] _> :$END:] & [SUBSTR[CARD, 1, 5] _> :$EXIT:] ]; GET EDIT [CARD] [COLUMN[1], A[73]]; ON ENDFILE[SYSIN] BEGIN; CALL ERR[ENDOFILE]; STOP; END; PUT SKIP EDIT [:*** :, CARD] [A, A]; END; PROG=COUNT > 0; TOP=SPTAB > 1; FUNCTION > FALSE; ENDJOB > [SUBSTR[CARD, 1, 4] > :$END:]; ENDBATCH > [SUBSTR[CARD, 1, 5] > :$EXIT:]; /* LOOP ONCE PER PROGRAM */ DO WHILE [ _[ENDJOB " ENDBATCH] ]; IF PROG=COUNT > MAXPROGS THEN DO; CALL ERR[MANYPROG]; CALL CRASH; ENDJOB > TRUE; CALL FINALE; RETURN; /* ERROR RETURN */ END; IF PROG=COUNT \ 0 THEN DO; PUT SKIP EDIT[:&END :, JOB=COUNT, PROG=COUNT] [A, [2]F[3]]; CALL SN=REF=ERRORS; END; PROG=COUNT > PROG=COUNT < 1; PUT STRING[STR=PROG=COUNT] EDIT [PROG=COUNT] [F[2]]; IF PROG=COUNT ) 10 THEN SUBSTR[STR=PROG=COUNT, 1, 1] > :0: ; SAVEAREA > :SAVEA$: "" STR=PROG=COUNT; LABEL=COUNT > 0; LABEL=FLD > : :; CALL FILL=BUFFER; /* INPUT, STORE, AND LIST PROGRAM */ CALL RESET=TABLES; IF PROG=COUNT > 1 THEN CALL MAIN=PROGRAM; ELSE CALL SUBPROGRAM; END; CALL FINALE; CALL SN=REF=ERRORS; CALL SUBPROG=ERRORS; END JOB; MAIN=PROGRAM 14 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* DRIVER FOR A MAIN PROGRAM */ CALL MAIN=PROLOGUE; XBUF, SEQASM > 0; CALL NEXT=CARD; /* GET FIRST PROGRAM CARD */ CALL PROGRAM; CALL EPILOGUE; END MAIN=PROGRAM; SUBPROGRAM 12 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* DRIVER FOR A SUBPROGRAM */ DECLARE LABEL1 CHARACTER[8]; LABEL1 > GEN=LABEL; /* LABEL FOR THE RETURN ROUTINE */ XBUF, SEQASM > 1; CARD > BUFFER[1]; /* SHOULD BE FUNCTION OR SUBROUTINE STMT */ CARD=PTR > 6; CALL GET=CHAR; CALL GET=TOKEN; IF [TOKEN _> RW=FUNCTION] & [TOKEN _> RW=SUBROUTINE] THEN DO; CALL ERR[INVFTSUB]; CALL FLUSH=STATEMENT; CALL PROGRAM; END; ELSE DO; PUT PAGE EDIT [:&START:, JOB=COUNT, PROG=COUNT] [A, [2]F[3]]; CALL FUNCTION=SUBROUTINE=STMT; CALL PROGRAM; /* A FUNCTION SHOULD HAVE A VALUE. IF NOT, DEFAULT TO 0 */ IF FUNCTION THEN DO; ACTIVE[SAVEXSP] > FALSE; IF _VALUE=FLAG[SAVEXSP] THEN DO; CALL ERR[FTNVALUE]; IF FTNMODE > RREAL THEN CALL OUT[:SER F0,F0:]; ELSE CALL OUT[:SR R0,R0:]; END; END; /* RETURN ROUTINE */ LABEL=FLD > LABEL1; DO I > 1 TO DUM=ARG=COUNT; CALL OUT[:L R4,: "" CVS=I[ 4*[I-1] ] "" :[R1]: ]; CALL OUT[:MVC 0[4,R4],: "" DUM=ARGS[I]]; END; CALL OUT[:L R13,: "" SAVEAREA "" :<4:]; CALL OUT[:LM R14,R15,12[R13]:]; CALL OUT[:LM R4,R9,36[R13]:]; CALL OUT[:MVI 12[R13],X::FF:::]; CALL OUT[:BR R14:]; CALL EPILOGUE; END; END SUBPROGRAM; PROGRAM 9 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* DRIVER FOR A PROGRAM */ ENDPROG, CLASSDEC, MODEDEC > FALSE; ELSESTMT, ENDSTMT, IFSTMT > FALSE; TYPE=OK > TRUE; GRP=COUNT, CASE=COUNT, FOR=COUNT, GO=COUNT, SPC=COUNT > 0; CURCOUNT[0] > 0; CURLEV, DOLEVEL, HIDOLEVEL, CASE=LEVEL > 0; TEMP=COUNT > 3; CURCLASS > NULL; IF CONTINUATION THEN CALL ERR[INVCONTN]; /* FIRST CARD SHOULDN:T BE CONTINUATION */ /* LOOP ONCE PER STATEMENT */ DO WHILE [_ENDPROG]; CALL STATEMENT=ROUTINE; END; IF _ENDSTMT THEN CALL ERR[MISENDST]; END PROGRAM; STATEMENT=ROUTINE 19 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* PROCESSES A FORTRAN SOURCE STATEMENT */ DECLARE STMT=NO=FLD CHARACTER[5]; CARD > BUFFER[XBUF]; /* GET THE NEXT STATEMENT */ SEQASM > SEQASM < 1; CALL COMMENT=LINE[ :[: "" CVS=I3[SEQASM] "" :] : "" SUBSTR[CARD, 1, 72] ]; /* IS THERE A STATEMENT NUMBER+ */ IF SUBSTR[CARD, 1, 5] > : : THEN STMT=NO > 0; ELSE CALL STMT=NO=ROUTINE; /* PREPARE TO PROCESS THE STATEMENT */ CARD=PTR > 6; CALL GET=CHAR; CALL GET=TOKEN; CALL STATEMENT; /* DID THE STATEMENT END PROPERLY+ */ IF _ELSESTMT & [TOKEN _> STMTEND] THEN DO; CALL ERR[INVSTEND]; CALL NEXT=CARD; END; END STATEMENT=ROUTINE; STATEMENT 11 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* PROCESSES A STATEMENT */ /* ALREADY SEEN THE END STATEMENT+ IF SO, FLUSH */ IF ENDSTMT THEN DO; CALL FIND=PROGRAM=END; RETURN; END; /* TYPE STATEMENT+ */ IF [TOKEN > RW=DIMENSION] " [TOKEN > RW=INTEGER] " [TOKEN > RW=LOGICAL] " [TOKEN > RW=REAL] " [TOKEN > RW=EXTERNAL] " [TOKEN > RW=CHARACTER] THEN DO; IF TYPE=OK THEN DO; IF [TOKEN > RW=EXTERNAL] " [TOKEN > RW=CHARACTER] THEN CALL EXTERNAL=CHARACTER=STMT; ELSE CALL TYPE=STATEMENT; RETURN; END; ELSE DO; /* SORRY, NO LONGER HAVE HAVE A TYPE STMT */ CALL ERR[MISPTYPE]; RETURN; /* ERROR RETURN */ END; END; ELSE TYPE=OK > FALSE; /* ASSIGNMENT STATEMENT+ */ IF [TOKEN \> SIMPLE=VAR] & [TOKEN )> FUNCTION=NAME] THEN DO; CALL ASSIGNMENT=STMT; RETURN; END; IF TOKEN > CHAR=NAME THEN GO TO NOT=IMPLEMENTED; IF TOKEN > STMTEND THEN RETURN; /* VALID STATEMENT OTHERWISE+ */ IF [TOKEN ) RW=CALL] " [TOKEN \ RW=WRITE] THEN GO TO BAD=STATEMENT; /* CALL THE APPROPRIATE STATEMENT ROUTINE */ BEGIN; DECLARE L[RW=CALL 25 ^^ , , 32 , 8 , 20,8,o RW=WRITE] LABEL; ELSESTMT, FINSTMT > FALSE; GO TO L[TOKEN]; L[1013] 19 ^^ , , 32 , 8 , 20,8,o CALL CALL=STMT; RETURN; L[1014] 19 ^^ , , 32 , 8 , 20,8,o CALL CASE=STMT; RETURN; L[1015] 19 ^^ , , 32 , 8 , 20,8,o CALL CAUSE=STMT; RETURN; L[1017] 19 ^^ , , 32 , 8 , 20,8,o CALL CONTINUE=STMT; RETURN; L[1020] 19 ^^ , , 32 , 8 , 20,8,o CALL DO=STMT; RETURN; L[1021] 19 ^^ , , 32 , 8 , 20,8,o CALL ELSE=STMT; RETURN; L[1022] 19 ^^ , , 32 , 8 , 20,8,o CALL END=STMT; RETURN; L[1025] 19 ^^ , , 32 , 8 , 20,8,o CALL EXIT=NEXT=STMT; RETURN; L[1026] 19 ^^ , , 32 , 8 , 20,8,o CALL FIN=STMT; RETURN; L[1031] 19 ^^ , , 32 , 8 , 20,8,o CALL GO=STMT; RETURN; L[1032] 19 ^^ , , 32 , 8 , 20,8,o CALL GOTO=STMT; RETURN; L[1033] 19 ^^ , , 32 , 8 , 20,8,o CALL IF=STMT; RETURN; L[1037] 19 ^^ , , 32 , 8 , 20,8,o CALL EXIT=NEXT=STMT; RETURN; L[1038] 19 ^^ , , 32 , 8 , 20,8,o CALL PRINT=STMT; RETURN; L[1041] 19 ^^ , , 32 , 8 , 20,8,o CALL RETURN=STMT; RETURN; L[1042] 19 ^^ , , 32 , 8 , 20,8,o CALL STOP=STMT; RETURN; L[1016] 19 ^^ , , 32 , 8 , 20,8,o L[1018] 29 ^^ , , 32 , 8 , 20,8,o L[1023] 39 ^^ , , 32 , 8 , 20,8,o L[1028] 19 ^^ , , 32 , 8 , 20,8,o L[1039] 29 ^^ , , 32 , 8 , 20,8,o L[1048] 39 ^^ , , 32 , 8 , 20,8,o GO TO NOT=IMPLEMENTED; L[1012] 19 ^^ , , 32 , 8 , 20,8,o L[1024] 29 ^^ , , 32 , 8 , 20,8,o L[1029] 39 ^^ , , 32 , 8 , 20,8,o L[1035] 49 ^^ , , 32 , 8 , 20,8,o L[1044] 19 ^^ , , 32 , 8 , 20,8,o L[1045] 29 ^^ , , 32 , 8 , 20,8,o L[1046] 39 ^^ , , 32 , 8 , 20,8,o L[1047] 49 ^^ , , 32 , 8 , 20,8,o L[1049] 59 ^^ , , 32 , 8 , 20,8,o GO TO BAD=STATEMENT; END; NOT=IMPLEMENTED 22 ^^ , , 32 , 8 , 20,8,o CALL ERR[NOTIMPLM]; CALL FLUSH=STATEMENT; RETURN; BAD=STATEMENT 20 ^^ , , 32 , 8 , 20,8,o CALL ERR[INVKEYWD]; CALL FLUSH=STATEMENT; RETURN; END STATEMENT; STMT=NO=ROUTINE 17 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES STATEMENT NUMBERS [IN COLUMNS 1 THROUGH 5] */ DECLARE SNFLD CHARACTER[6]; DECLARE [PTR1, PTR2] FIXED BINARY; /* BRACKET THE NUMBER WITH PTR1 AND PTR2 */ SNFLD > SUBSTR[CARD, 1, 5]; PTR1 > VERIFY[SNFLD, : :]; PTR2 > VERIFY[SUBSTR[SNFLD, PTR1], :0123456789:] < PTR1 - 1; IF [SUBSTR[SNFLD,PTR2] _> : :] " [PTR2 > PTR1] THEN CALL ERR[INVSTNUM]; ELSE DO; GET STRING[SNFLD] LIST [STMT=NO]; INUMBER > STMT=NO; CALL SNTAB=SEARCH; IF FOUND THEN DO; IF SN=DEFINED[XSNTAB] THEN CALL ERR[INVSTNUM]; /* MULTIPLE DEFINITION */ ELSE DO; /* IF REFERENCED BY A CASE " DO=EVENT STATEMENT, */ /* CLOSE THE PREVIOUS STATEMENT GROUP BEFORE */ /* BEGINNING A NEW ONE. */ IF SN=CASE[XSNTAB] THEN DO; IF CASE=CLOSED[CASE=LEVEL] & [SN=GLEVEL[XSNTAB] > CURLEV] THEN DO; CALL OUT[:B : "" CASE=LABELS[CASE=LEVEL]]; CURLEV > CURLEV - 1; CALL GRP=IN; END; ELSE CALL ERR[INVSTNUM]; END; SN=DEFINED[XSNTAB] > DEFINED; LABEL=FLD > :S: "" CVS=I7[STMT=NO]; END; END; ELSE DO; /* NOT FOUND */ CALL SNTAB=INSERT[DEFINED, NOTCASE]; LABEL=FLD > :S: "" CVS=I7[STMT=NO]; END; END; END STMT=NO=ROUTINE; /* --------------------------------------------------------------- */ /* 2.2 STORE AND LIST THE SOURCE PROGRAM */ /* --------------------------------------------------------------- */ FILL=BUFFER 13 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* READ, LIST, AND STORE THE FORTRAN PROGRAM STATEMENTS */ DECLARE SEQ FIXED BINARY; DECLARE [CONTINUE, COMMENT] BIT[1]; DECLARE INCARD CHARACTER[80]; CALL GET=TIME; CALL HEADING; XBUF, SEQ > 0; CONTINUE > TRUE; /* LOOP ONCE PER CARD */ DO WHILE [CONTINUE]; GET EDIT [INCARD] [COLUMN[1], A[80]]; ON ENDFILE[SYSIN] BEGIN; CALL ERR[ENDOFILE]; INCARD > :$EXIT:; /* FORCE END OF BATCH */ END; IF SUBSTR[INCARD, 1, 1] _> :$: THEN DO; /* COMMENT CARD+ */ COMMENT > [SUBSTR[INCARD, 1, 1] > :C:] " [SUBSTR[INCARD, 1, 72] > NOTHING]; /* DON:T STORE SOMMENT CARDS */ IF _COMMENT THEN DO; /* CONTINUATION CARD+ */ CONTINUATION > [SUBSTR[INCARD, 6, 1] _> : :] & [SUBSTR[INCARD, 6, 1] _> :0:]; IF XBUF > MAXCARDS - 1 THEN DO; CALL ERR[MANYCARD]; CALL CRASH; CONTINUE > FALSE; END; ELSE DO; /* STORE CARD WITH (;( ATTACHED */ XBUF > XBUF < 1; BUFFER[XBUF] > SUBSTR[INCARD, 1, 72] "" :;: ; END; END; ELSE CONTINUATION > FALSE; /* COMMENT AND CONTINUATION CARDS DON:T GET SEQUENCE */ /* NUMBERS ON THE PROGRAM LISTING. */ IF COMMENT " CONTINUATION THEN STR=SEQ > : :; ELSE DO; SEQ > SEQ < 1; STR=SEQ > CVS=I3[SEQ]; END; PUT SKIP EDIT [STR=SEQ, INCARD] [A[5], A]; ON ENDPAGE[SYSPRINT] CALL HEADING; END; ELSE DO; /* CONTROL CARD */ CARD=COUNT > XBUF < 1; BUFFER[CARD=COUNT] > SUBSTR[INCARD, 1, 72]; CONTINUE > FALSE; END; END; XBUF > 0; END FILL=BUFFER; GET=TIME 10 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* GETS THE DATE AND TIME */ DECLARE MONTHS[1 23 ^^ , , 32 , 8 , 20,8,o12] CHARACTER[4] INITIAL[:JAN:, :FEB:, :MAR:, :APR:, :MAY:, :JUN:, :JUL:, :AUG:, :SEP:, :OCT:, :NOV:, :DEC:]; DECLARE DATE=INFO CHARACTER[6]; DECLARE TIME=INFO CHARACTER[9]; DECLARE MONTH FIXED BINARY; /* DATE AND TIME ARE PL/1 BUILT-IN FUNCTIONS */ DATE=INFO > DATE; TIME=INFO > TIME; GET STRING[DATE=INFO] EDIT [MONTH] [X[2], F[2]]; WHEN > SUBSTR[DATE=INFO, 5, 2] "" : : "" MONTHS[MONTH] "" SUBSTR[DATE=INFO, 1, 2] "" : @ : "" SUBSTR[TIME=INFO, 1, 2] "" : 42 ^^ , , 32 , 8 , 20,8,o: "" SUBSTR[TIME=INFO, 3, 2] "" : 42 ^^ , , 32 , 8 , 20,8,o: "" SUBSTR[TIME=INFO, 5, 2] "" :.: "" SUBSTR[TIME=INFO, 7, 3]; END GET=TIME; HEADING 9 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PRINTS THE LISTING PAGE HEADER */ PUT PAGE EDIT [:FORTRAN M [AUG 75] --- JOB :, JOB=COUNT, :, PROGRAM :, PROG=COUNT, : --- :, WHEN] [A, F[2], A, F[2], A, A]; PUT SKIP[2] LIST [:SEQ .... 35 ^^ , , 32 , 8 , 20,8,o. 37 ^^ , , 32 , 8 , 20,8,o..1.... 45 ^^ , , 32 , 8 , 20,8,o....2.... 55 ^^ , , 32 , 8 , 20,8,o....3.... 65 ^^ , , 32 , 8 , 20,8,o: "" :....4.... 34 ^^ , , 32 , 8 , 20,8,o....5.... 44 ^^ , , 32 , 8 , 20,8,o....6.... 54 ^^ , , 32 , 8 , 20,8,o....7. 61 ^^ , , 32 , 8 , 20,8,o.......8:]; PUT SKIP; END HEADING; /* --------------------------------------------------------------- */ /* 2.3 FORTRAN M STATEMENTS */ /* --------------------------------------------------------------- */ ASSIGNMENT=STMT 17 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES ASSIGNMENT STATEMENTS */ DECLARE DESTINATION /* THE ASSIGNMENT DESTINATION */ CHARACTER[8] VARYING; DECLARE DESTMODE /* MODE OF DESTINATION */ FIXED BINARY; DECLARE FTNDEST /* DESTINATION A FUNCTION NAME+ */ BIT[1]; DESTMODE > MODE[XNAMTAB]; FTNDEST > FALSE; IF [TOKEN > SIMPLE=VAR] " [TOKEN > FUNCTION=NAME] THEN DO; /* CAN:T CHANGE THE VALUE OF A DO LOOP INDEX VARIABLE */ IF DO=INDEX[XNAMTAB] THEN CALL ERR[INDEXODO]; ELSE IF TOKEN > FUNCTION=NAME THEN DO; FTNDEST > TRUE; CALL SPTAB=ROUTINE; IF ACTIVE[XSPTAB] THEN DO; DESTINATION > WORD; VALUE=FLAG[XSPTAB] > TRUE; END; ELSE CALL ERR[NFTNDEFN]; /* THE FUNCTION IS NOT BEING DEFINED */ END; ELSE DESTINATION > WORD; END; ELSE IF TOKEN > ARRAY=VAR THEN DO; CALL ARRAY=ELMT[:R9:]; DESTINATION > :0[R9]: ; END; CALL GET=TOKEN; IF TOKEN > EQUALS THEN CALL GET=TOKEN; ELSE CALL ERR[MISEQUAL]; CALL EXPRESSION; /* PROCESS THE RIGHT-HAND SIDE */ /* CURMODE AND ARITHMETIC REFER TO THE RIGHT-HAND SIDE */ IF DESTMODE > INTEGER THEN DO; IF CURMODE > INTEGER THEN DO; CALL OUT[:ST R3,: "" DESTINATION]; CALL POP[INTEGER]; END; ELSE DO; CALL FLOATTOFIX[:F2:, :R4:]; /* MODE CONVERSION */ CALL POP[RREAL]; CALL OUT[:ST R4,: "" DESTINATION]; END; END; ELSE IF DESTMODE > RREAL THEN DO; IF CURMODE > RREAL THEN DO; CALL OUT[:STE F2,: "" DESTINATION]; CALL POP[RREAL]; END; ELSE DO; CALL FIXTOFLOAT[:R3:, :F4:]; /* MODE CONVERSION */ CALL POP[INTEGER]; CALL OUT[:STE F4,: "" DESTINATION]; END; END; ELSE DO; /* LOGICAL DESTINATION */ IF _ARITHMETIC THEN DO; CALL OUT[:ST R3,: "" DESTINATION]; CALL POP[INTEGER]; END; ELSE IF CURMODE > INTEGER THEN DO; CALL ERR[MXMDLOGC]; CALL OUT[:SR R3,R3:]; /* DEFAULT TO .FALSE. */ CALL OUT[:ST R3,: "" DESTINATION]; CALL POP[INTEGER]; END; ELSE DO; CALL ERR[MXMDLOGC]; CALL POP[RREAL]; CALL OUT[:SR R4,R4:]; /* DEFAULT TO .FALSE. */ CALL OUT[:ST R4,: "" DESTINATION]; END; END; IF FTNDEST THEN DO; IF DESTMODE > RREAL THEN CALL OUT[:LE F0,: "" DESTINATION]; ELSE CALL OUT[:L R0,: "" DESTINATION]; END; END ASSIGNMENT=STMT; CALL=STMT 11 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES THE SUBROUTINE CALL STATEMENT */ CLASSDEC, MODEDEC > TRUE; CURCLASS > SUBROUTINE=NAME; CURMODE > NULL; /* GET THE SUBROUTINE NAME */ CALL GET=TOKEN; IF TOKEN > ID THEN CALL NAMTAB=INSERT; ELSE IF TOKEN _> SUBROUTINE=NAME THEN DO; CALL ERR[SUBPNAME]; CALL FLUSH=STATEMENT; RETURN; END; CLASSDEC, MODEDEC > FALSE; CALL SUBPROGRAM=CALL; CALL OUT[:NOP 0:]; END CALL=STMT; CASE=STMT 11 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* PROCESSES THE CASE STATEMENT */ DECLARE [LABEL1, CLABEL] CHARACTER[8]; GET=SN 13 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES STATEMENT NUMBERS FROM THE LIST */ IF [TOKEN > INTEGER=NO] & [INUMBER \ 0] & [INUMBER ) 100000] THEN DO; CALL SNTAB=SEARCH; IF FOUND THEN CALL ERR[INVSTNUM]; ELSE DO; CALL SNTAB=INSERT[UNDEFINED, CASE]; CALL REFSN=INSERT; CALL OUT[:DC A[S: "" CVS=I7[INUMBER] "" :]:]; CALL GET=TOKEN; END; END; ELSE CALL ERR[INVSTNUM]; END GET=SN; IF CASE=LEVEL > MAXCASELEVEL THEN DO; CALL ERR[MANYCLEV]; CALL CRASH; RETURN; /* ERROR RETURN */ END; LABEL1 > GEN=LABEL; CASE=COUNT > CASE=COUNT < 1; CLABEL > :C: "" CVS=I7[CASE=COUNT]; CASE=LEVEL > CASE=LEVEL < 1; CASE=LABELS[CASE=LEVEL] > LABEL1; CASE=CLOSED[CASE=LEVEL] > TRUE; CALL REFSTMT=INSERT; CALL GET=TOKEN; IF TOKEN > LPAREN THEN CALL GET=TOKEN; ELSE CALL ERR[MISLPARN]; /* PROCESS THE EXPRESSION */ CALL EXPRESSION; IF _ARITHMETIC THEN DO; CALL ERR[NOTARITH]; CALL FLUSH=STATEMENT; RETURN; /* ERROR RETURN */ END; IF CURMODE > INTEGER THEN DO; CALL OUT[:LPR R4,R3:]; CALL POP[INTEGER]; END; ELSE DO; CALL ERR[MXMDINTG]; CALL FLOATTOFIX[:F2:, :R4:]; /* MODE CONVERSION */ CALL POP[RREAL]; CALL OUT[:LPR R4,R4:]; END; CALL OUT[:SLA R4,2:]; CALL OUT[:L R4,: "" CLABEL "" :[R4]:]; CALL OUT[:BR R4:]; LABEL=FLD > CLABEL; CALL OUT[:DC A[: "" LABEL1 "" :]:]; IF TOKEN > RPAREN THEN CALL GET=TOKEN; ELSE CALL ERR[MISRPARN]; IF TOKEN > RW=OF THEN CALL GET=TOKEN; ELSE CALL ERR[MISRWDOF]; IF TOKEN > LPAREN THEN CALL GET=TOKEN; ELSE CALL ERR[MISLPARN]; /* PROCESS THE STATEMENT NUMBER LIST */ CALL GET=SN; DO WHILE [TOKEN > COMMA]; CALL GET=TOKEN; CALL GET=SN; END; IF TOKEN > RPAREN THEN CALL GET=TOKEN; ELSE CALL ERR[MISRPARN]; IF TOKEN _> STMTEND THEN CALL ERR[INVSTEND]; /* PROCESS THE RANGE */ DO WHILE [ _[FINSTMT " ENDPROG] ]; CALL STATEMENT=ROUTINE; END; IF ENDPROG THEN CALL ERR[UNXPPEND]; LABEL=FLD > LABEL1; CALL OUT[:NOP 0:]; CASE=LEVEL > CASE=LEVEL - 1; END CASE=STMT; CAUSE=STMT 12 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES THE CAUSE STATEMENT */ DECLARE OK BIT[1]; /* WAS THERE A DO=EVENT STATEMENT+ */ IF CASE=LEVEL ) 1 THEN DO; OK > FALSE; END; ELSE DO; OK > TRUE; /* PROCESS THE STATEMENT NUMBER */ CALL GET=TOKEN; IF [TOKEN > INTEGER=NO] & [INUMBER \ 0] & [INUMBER ) 100000] THEN DO; CALL SNTAB=SEARCH; IF _FOUND THEN DO; OK > FALSE; CALL ERR[INVSTNUM]; END; END; ELSE DO; CALL ERR[INVSTNUM]; OK > FALSE; END; END; IF OK THEN DO; CALL REFSTMT=INSERT; CALL REFSN=INSERT; CALL OUT[:B S: "" CVS=I7[INUMBER]]; CALL GET=TOKEN; END; ELSE DO; CALL ERR[MISPSTMT]; CALL FLUSH=STATEMENT; END; END CAUSE=STMT; CONTINUE=STMT 15 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* ISSUES A NOP FOR THE CONTINUE STATEMENT */ CALL OUT[:NOP 0:]; CALL GET=TOKEN; END CONTINUE=STMT; DO=STMT 9 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* DRIVER FOR THE DO STATEMENTS */ DECLARE TARGET /* STMT NO. OF TARGET STATEMENT */ FIXED[31,0] BINARY; DECLARE IFSTATE BIT[1]; IF DOLEVEL > MAXDOLEVEL THEN DO; CALL ERR[MANYDLEV]; CALL CRASH; RETURN; END; /* PRESERVE VALUE OF IFSTMT [IF AND DO CAN:T OVERLAP] */ IFSTATE > IFSTMT; IFSTMT > FALSE; CALL GRP=IN; DOLEVEL > DOLEVEL < 1; HIDOLEVEL > MAX[HIDOLEVEL, DOLEVEL]; /* PROCESS THE STATEMENT NUMBER OF THE TARGET STATEMENT */ CALL GET=TOKEN; IF TOKEN > INTEGER=NO THEN DO; CALL SNTAB=SEARCH; IF FOUND THEN DO; CALL ERR[INVSTNUM]; CALL FLUSH=STATEMENT; RETURN; END; ELSE DO; CALL SNTAB=INSERT[UNDEFINED, NOTCASE]; CALL REFSTMT=INSERT; CALL REFSN=INSERT; END; TARGET > INUMBER; CALL GET=TOKEN; END; ELSE DO; CALL ERR[INVSTNUM]; CALL FLUSH=STATEMENT; RETURN; END; /* CALL APPROPRIATE ROUTINE FOR DO STATEMENT */ IF TOKEN > SIMPLE=VAR THEN DO; IF MODE[XNAMTAB] > INTEGER THEN CALL INTEGER=DO[TARGET]; ELSE IF MODE[XNAMTAB] > RREAL THEN CALL REAL=DO[TARGET]; ELSE DO; CALL ERR[INVDOSTM]; WORD > :INTG$VAR:; CALL INTEGER=DO[TARGET]; END; END; ELSE IF [TOKEN > RW=WHILE] " [TOKEN > RW=UNTIL] THEN CALL DO=WHILE=UNTIL[TARGET]; ELSE IF TOKEN > RW=ITERATE THEN CALL DO=ITERATE[TARGET]; ELSE IF TOKEN > RW=EVENT THEN CALL DO=EVENT[TARGET]; ELSE IF TOKEN > RW=FOR THEN CALL DO=FOR[TARGET]; ELSE DO; CALL ERR[INVDOSTM]; CALL FLUSH=STATEMENT; END; CURLEV > CURLEV - 1; DOLEVEL > DOLEVEL - 1; IFSTMT > IFSTATE; /* RESTORE IFSTMT */ STMT=NO > 0; END DO=STMT; INTEGER=DO 12 ^^ , , 32 , 8 , 20,8,o PROCEDURE [TARGET] RECURSIVE; /* PROCESSES THE EXTENDED [INTEGER] STANDARD DO STATEMENT */ DECLARE TARGET /* STMT NO. OF TARGET STATEMENT */ FIXED[31,0] BINARY; DECLARE SAVEX /* SAVES XNAMTAB OF THE INDEX VARIABLE */ FIXED BINARY; DECLARE /* SAVE AREA FOR DO STATEMENT */ DOSAVE CHARACTER[ 8], DOSAVE4 CHARACTER[10]; DECLARE INDEX=VAR CHARACTER[8]; DECLARE [LABEL1, LABEL2, LABEL3, LABEL4, LABEL5] CHARACTER[8]; DO=EXPR 14 ^^ , , 32 , 8 , 20,8,o PROCEDURE [MEM, REG]; /* PROCESSES THE EXPRESSIONS FOR THE INITIAL, TEST, AND */ /* INCREMENT VALUES */ DECLARE [MEM, /* MEMORY LOCATION */ REG] /* REGISTER TO HOLD VALUE */ CHARACTER[*]; CALL EXPRESSION; IF CURMODE > INTEGER THEN DO; CALL OUT[:ST R3,: "" MEM]; IF REG _> :: THEN CALL OUT[:LR : "" REG "" :,R3:]; CALL POP[INTEGER]; END; ELSE DO; CALL ERR[MXMDINTG]; CALL FLOATTOFIX[:F2:, :R7:]; /* MODE CONVERSION */ CALL POP[RREAL]; CALL OUT[:ST R7,: "" MEM]; IF REG _> :: THEN CALL OUT[:LR : "" REG "" :,R7:]; END; END DO=EXPR; LABEL1 > GEN=LABEL; LABEL2 > GEN=LABEL; LABEL3 > GEN=LABEL; LABEL4 > GEN=LABEL; LABEL5 > GEN=LABEL; NEXT=LABELS[DOLEVEL] > LABEL5; EXIT=LABELS[DOLEVEL] > LABEL4; DOSAVE > :D: "" CVS=I7[DOLEVEL]; DOSAVE4 > DOSAVE "" :<4:; INDEX=VAR > WORD; SAVEX > XNAMTAB; DO=INDEX[SAVEX] > TRUE; CALL GET=TOKEN; IF TOKEN > EQUALS THEN CALL GET=TOKEN; ELSE CALL ERR[MISEQUAL]; /* PROCESS THE EXPRESSIONS */ CALL DO=EXPR[INDEX=VAR, :R6:]; /* INITIAL VALUE */ IF TOKEN > COMMA THEN CALL GET=TOKEN; ELSE CALL ERR[MISCOMMA]; CALL DO=EXPR[DOSAVE, ::]; /* TEST VALUE */ IF TOKEN > COMMA THEN DO; CALL GET=TOKEN; CALL DO=EXPR[DOSAVE4, :R7:]; /* INCREMENT VALUE */ END; ELSE DO; CALL OUT[:LA R7,1:]; /* DEFAULT INCREMENT IS 1 */ CALL OUT[:ST R7,: "" DOSAVE4]; END; /* PRELIMINARY CODE */ LABEL=FLD > LABEL1; CALL OUT[:LTR R7,R7:]; CALL OUT[:BM : "" LABEL2]; CALL OUT[:C R6,: "" DOSAVE]; CALL OUT[:BH : "" LABEL4]; CALL OUT[:B : "" LABEL3]; LABEL=FLD > LABEL2; CALL OUT[:C R6,: "" DOSAVE]; CALL OUT[:BL : "" LABEL4]; LABEL=FLD > LABEL3; CALL OUT[:NOP 0:]; IF TOKEN _> STMTEND THEN CALL ERR[INVSTEND]; /* PROCESS THE RANGE */ DO WHILE [ [STMT=NO _> TARGET] & _ENDPROG ]; CALL STATEMENT=ROUTINE; END; IF ENDPROG THEN CALL ERR[UNXPPEND]; /* FINAL CODE */ LABEL=FLD > LABEL5; CALL OUT[:L R6,: "" INDEX=VAR]; CALL OUT[:L R7,: "" DOSAVE4]; CALL OUT[:AR R6,R7:]; CALL OUT[:ST R6,: "" INDEX=VAR]; CALL OUT[:B : "" LABEL1]; LABEL=FLD > LABEL4; CALL OUT[:NOP 0:]; DO=INDEX[SAVEX] > FALSE; END INTEGER=DO; REAL=DO 9 ^^ , , 32 , 8 , 20,8,o PROCEDURE [TARGET] RECURSIVE; DECLARE TARGET /* STMT NO. OF THE TARGET STATEMENT */ FIXED[31,0] BINARY; CALL ERR[NOTIMPLM]; CALL FLUSH=STATEMENT; END REAL=DO; DO=EVENT 10 ^^ , , 32 , 8 , 20,8,o PROCEDURE [TARGET] RECURSIVE; /* PROCESSES THE DO EVENT STATEMENT */ DECLARE TARGET /* STMT NO. OF THE TARGET STATEMENT */ FIXED[31,0] BINARY; DECLARE [LABEL1, LABEL2] CHARACTER[8]; GET=SN 13 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES STATEMENT NUMBERS FROM THE LIST */ IF [TOKEN > INTEGER=NO] & [INUMBER \ 0] & [INUMBER ) 100000] THEN DO; CALL SNTAB=SEARCH; IF FOUND THEN CALL ERR[INVSTNUM]; ELSE DO; CALL SNTAB=INSERT[UNDEFINED, CASE]; CALL REFSN=INSERT; END; CALL GET=TOKEN; END; ELSE CALL ERR[INVSTNUM]; END GET=SN; IF CASE=LEVEL > MAXCASELEVEL THEN DO; CALL ERR[MANYCLEV]; CALL CRASH; RETURN; /* ERROR RETURN */ END; LABEL1 > GEN=LABEL; LABEL2 > GEN=LABEL; NEXT=LABELS[DOLEVEL] > LABEL1; EXIT=LABELS[DOLEVEL] > LABEL2; CASE=LEVEL > CASE=LEVEL < 1; CASE=LABELS[CASE=LEVEL] > LABEL2; CASE=CLOSED[CASE=LEVEL] > FALSE; CALL GET=TOKEN; IF TOKEN > LPAREN THEN CALL GET=TOKEN; ELSE CALL ERR[MISLPARN]; /* PROCESS THE STATEMENT NUMBER LIST */ CALL GET=SN; DO WHILE [TOKEN > COMMA]; CALL GET=TOKEN; CALL GET=SN; END; IF TOKEN > RPAREN THEN CALL GET=TOKEN; ELSE CALL ERR[MISRPARN]; IF TOKEN _> STMTEND THEN CALL ERR[INVSTEND]; LABEL=FLD > LABEL1; CALL OUT[:NOP 0:]; /* PROCESS THE RANGE */ DO WHILE [ [STMT=NO _> TARGET] & _ENDPROG ]; CALL STATEMENT=ROUTINE; END; IF ENDPROG THEN CALL ERR[UNXPPEND]; CALL OUT[:B : "" LABEL1]; CASE=CLOSED[CASE=LEVEL] > TRUE; /* PROCESS THE EVENT GROUPS */ DO WHILE [ _[FINSTMT " ENDPROG] ]; CALL STATEMENT=ROUTINE; END; IF ENDPROG THEN CALL ERR[UNXPPEND]; LABEL=FLD > LABEL2; CALL OUT[:NOP 0:]; CASE=LEVEL > CASE=LEVEL - 1; FINSTMT > FALSE; END DO=EVENT; DO=FOR 8 ^^ , , 32 , 8 , 20,8,o PROCEDURE [TARGET] RECURSIVE; /* PROCESS THE DO FOR STATEMENT */ DECLARE TARGET /* STMT NO. OF THE TARGET STATEMENT */ FIXED[31,0] BINARY; DECLARE [SAVEMODE, /* SAVES MODE OF INDEX VARIABLE */ SAVEX, /* SAVES XNAMTAB OF INDEX VARIABLE */ C=COUNT] /* COUNT OF CONSTANTS IN LIST */ FIXED BINARY; DECLARE /* SAVE AREA FOR DO STATEMENT */ DOSAVE CHARACTER[ 8], DOSAVE4 CHARACTER[10]; DECLARE INDEX=VAR CHARACTER[8] VARYING; DECLARE [LABEL1, LABEL2, LABEL3, LABEL4, FLABEL] CHARACTER[8]; GET=CONST 16 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* EXTRACTS CONSTANTS FROM THE LIST */ DECLARE NEGATIVE BIT[1]; NEGATIVE > FALSE; IF TOKEN > MINUS THEN DO; NEGATIVE > TRUE; CALL GET=TOKEN; END; ELSE IF TOKEN > PLUS THEN CALL GET=TOKEN; IF TOKEN > INTEGER=NO THEN DO; C=COUNT > C=COUNT < 1; IF SAVEMODE > RREAL THEN INUMBER > RNUMBER; IF NEGATIVE THEN INUMBER > -INUMBER; CALL OUT[:DC F::: "" CVS=I[INUMBER] "" ::::]; END; ELSE IF TOKEN > REAL=NO THEN DO; C=COUNT > C=COUNT < 1; IF SAVEMODE > INTEGER THEN RNUMBER > INUMBER; IF NEGATIVE THEN RNUMBER > -RNUMBER; CALL OUT[:DC E::: "" CVS=R[RNUMBER] "" ::::]; END; ELSE CALL ERR[ILLGTOKN]; CALL GET=TOKEN; END GET=CONST; LABEL1 > GEN=LABEL; LABEL2 > GEN=LABEL; LABEL3 > GEN=LABEL; LABEL4 > GEN=LABEL; NEXT=LABELS[DOLEVEL] > LABEL3; EXIT=LABELS[DOLEVEL] > LABEL4; FOR=COUNT > FOR=COUNT < 1; FLABEL > :F: "" CVS=I7[FOR=COUNT]; DOSAVE > :D: "" CVS=I7[DOLEVEL]; DOSAVE4 > DOSAVE "" :<4:; CALL OUT[:B : "" LABEL1]; /* GET THE INDEX VARIABLE */ CALL GET=TOKEN; IF TOKEN > SIMPLE=VAR THEN DO; INDEX=VAR > WORD; SAVEX > XNAMTAB; SAVEMODE > MODE[SAVEX]; DO=INDEX[SAVEX] > TRUE; IF SAVEMODE > LOGICAL THEN DO; CALL ERR[INVDOSTM]; CALL FLUSH=STATEMENT; RETURN; END; END; ELSE DO; CALL ERR[INVDOSTM]; CALL FLUSH=STATEMENT; RETURN; END; CALL GET=TOKEN; IF TOKEN > EQUALS THEN CALL GET=TOKEN; ELSE CALL ERR[MISEQUAL]; /* PROCESS THE CONSTANTS LIST */ C=COUNT > 0; CALL GET=CONST; DO WHILE [TOKEN > COMMA]; CALL GET=TOKEN; CALL GET=CONST; END; LABEL=FLD > FLABEL; CALL OUT[:DC F::: "" CVS=I[C=COUNT] "" ::::]; /* PRELIMINARY CODE */ LABEL=FLD > LABEL1; CALL OUT[:LA R6,: "" FLABEL "" CVS=I[-4*C=COUNT]]; CALL OUT[:L R7,: "" FLABEL]; LABEL=FLD > LABEL2; CALL OUT[:ST R6,: "" DOSAVE]; CALL OUT[:ST R7,: "" DOSAVE4]; IF SAVEMODE > INTEGER THEN DO; CALL OUT[:L R6,0[R6]:]; CALL OUT[:ST R6,: "" INDEX=VAR]; END; ELSE DO; CALL OUT[:LE F6,0[R6]:]; CALL OUT[:STE F6,: "" INDEX=VAR]; END; IF TOKEN _> STMTEND THEN CALL ERR[INVSTEND]; /* PROCESS THE RANGE */ DO WHILE [ [STMT=NO _> TARGET] & _ENDPROG ]; CALL STATEMENT=ROUTINE; END; IF ENDPROG THEN CALL ERR[UNXPPEND]; /* FINAL CODE */ LABEL=FLD > LABEL3; CALL OUT[:L R6,: "" DOSAVE]; CALL OUT[:LA R6,4[R6]:]; CALL OUT[:L R7,: "" DOSAVE4]; CALL OUT[:BCT R7,: "" LABEL2]; LABEL=FLD > LABEL4; CALL OUT[:NOP 0:]; DO=INDEX[SAVEX] > FALSE; END DO=FOR; DO=ITERATE 12 ^^ , , 32 , 8 , 20,8,o PROCEDURE [TARGET] RECURSIVE; /* PROCESSES THE DO ITERATE STATEMENT */ DECLARE TARGET /* STMT NO. OF THE TARGET STATEMENT */ FIXED[31,0] BINARY; DECLARE [LABEL1, LABEL2] CHARACTER[8]; LABEL1 > GEN=LABEL; LABEL2 > GEN=LABEL; NEXT=LABELS[DOLEVEL] > LABEL1; EXIT=LABELS[DOLEVEL] > LABEL2; CALL GET=TOKEN; LABEL=FLD > LABEL1; CALL OUT[:NOP 0:]; IF TOKEN _> STMTEND THEN CALL ERR[INVSTEND]; /* PROCESS THE RANGE */ DO WHILE [ [STMT=NO _> TARGET] & _ENDPROG ]; CALL STATEMENT=ROUTINE; END; IF ENDPROG THEN CALL ERR[UNXPPEND]; CALL OUT[:B : "" LABEL1]; LABEL=FLD > LABEL2; CALL OUT[:NOP 0:]; END DO=ITERATE; DO=WHILE=UNTIL 16 ^^ , , 32 , 8 , 20,8,o PROCEDURE [TARGET] RECURSIVE; /* PROCESSES THE DO WHILE AND DO UNTIL STATEMENTS */ DECLARE TARGET /* STMT NO. OF THE TARGET STATEMENT */ FIXED[31,0] BINARY; DECLARE UNTIL=LOOP BIT[1]; DECLARE [LABEL1, LABEL2, LABEL3] CHARACTER[8]; UNTIL=LOOP > [TOKEN > RW=UNTIL]; /* CODE TO BRANCH AROUND CONDITION TEST BEFORE FIRST ITERATION */ IF UNTIL=LOOP THEN DO; LABEL2 > GEN=LABEL; CALL OUT[:B : "" LABEL2]; END; LABEL1 > GEN=LABEL; LABEL3 > GEN=LABEL; NEXT=LABELS[DOLEVEL] > LABEL1; EXIT=LABELS[DOLEVEL] > LABEL3; CALL GET=TOKEN; IF TOKEN > LPAREN THEN CALL GET=TOKEN; ELSE CALL ERR[MISLPARN]; LABEL=FLD > LABEL1; /* PROCESS THE LOGICAL EXPRESSION */ CALL EXPRESSION; IF ARITHMETIC THEN CALL LOGIC=ERR; IF TOKEN > RPAREN THEN CALL GET=TOKEN; ELSE CALL ERR[MISRPARN]; CALL OUT[:LR R4,R3:]; CALL POP[INTEGER]; CALL OUT[:C R4,>F::1:::]; /* CODE FOR EXIT ON TRUE FOR UNTIL LOOP; */ /* EXIT ON FALSE FOR WHILE LOOP */ IF UNTIL=LOOP THEN DO; CALL OUT[:BE : "" LABEL3]; LABEL=FLD > LABEL2; CALL OUT[:NOP 0:]; END; ELSE CALL OUT[:BNE : "" LABEL3]; IF TOKEN _> STMTEND THEN CALL ERR[INVSTEND]; /* PROCESS THE RANGE */ DO WHILE [ [STMT=NO _> TARGET] & _ENDPROG ]; CALL STATEMENT=ROUTINE; END; IF ENDPROG THEN CALL ERR[UNXPPEND]; CALL OUT[:B : "" LABEL1]; LABEL=FLD > LABEL3; CALL OUT[:NOP 0:]; END DO=WHILE=UNTIL; ELSE=STMT 11 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES THE ELSE STATEMENT */ ELSESTMT > TRUE; /* WAS THERE AN IF STATEMENT+ */ IF IFSTMT THEN CALL GET=TOKEN; ELSE DO; CALL ERR[MISPSTMT]; CALL FLUSH=STATEMENT; END; CALL GET=TOKEN; END ELSE=STMT; END=STMT 10 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES THE END STATEMENT */ ENDPROG, ENDSTMT > TRUE; CALL GET=TOKEN; END END=STMT; EXIT=NEXT=STMT 16 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES THE EXIT AND NEXT STATEMETNS */ DECLARE NEXTSTMT BIT[1]; NEXTSTMT > [TOKEN > RW=NEXT]; /* GET THE LEVEL NUMBER, IF ANY */ INUMBER > 0; /* DEFAULT LEVEL IS 0 */ CALL GET=TOKEN; IF [TOKEN > INTEGER=NO] & [ [INUMBER ) 0] " [DOLEVEL-INUMBER )> 0] ] THEN CALL ERR[INVEXNXT]; ELSE DO; IF NEXTSTMT THEN CALL OUT[:B : "" NEXT=LABELS[DOLEVEL-INUMBER]]; ELSE CALL OUT[:B : "" EXIT=LABELS[DOLEVEL-INUMBER]]; END; IF TOKEN > INTEGER=NO THEN CALL GET=TOKEN; END EXIT=NEXT=STMT; EXTERNAL=CHARACTER=STMT 25 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES THE EXTERNAL AND CHARACTER TYPE STATEMENTS */ DECLARE EXTSTMT BIT[1]; GET=ID 13 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* EXTRACTS IDENTIFIERS FROM THE LIST */ IF TOKEN > ID THEN DO; CALL NAMTAB=INSERT; FUNCTION=SUBROUTINE=STMT 26 ^^ , , 32 , 8 , 20,8,o PROCEDURE; IF EXTSTMT THEN DO; CALL SPTAB=ROUTINE; ACTIVE[XSPTAB] > FALSE; END; END; ELSE CALL ERR[INVIDENT]; CALL GET=TOKEN; END GET=ID; CLASSDEC > TRUE; EXTSTMT > [TOKEN > RW=EXTERNAL]; IF EXTSTMT THEN CURCLASS > FUNCTION=NAME; ELSE DO; CURCLASS > CHAR=NAME; MODEDEC > TRUE; CURMODE > NULL; END; /* PROCESS THE IDENTIFIER LIST */ CALL GET=TOKEN; CALL GET=ID; DO WHILE [TOKEN > COMMA]; CALL GET=TOKEN; CALL GET=ID; END; CLASSDEC, MODEDEC > FALSE; END EXTERNAL=CHARACTER=STMT; FIN=STMT 10 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES THE FIN STATEMENT */ /* WAS THERE AN IF, CASE, OR DO=EVENT STATEMENT+ */ IF _IFSTMT & [CASE=LEVEL ) 1] THEN CALL ERR[MISPSTMT]; FINSTMT > TRUE; CALL GET=TOKEN; END FIN=STMT; /* PROCESSES THE FUNCTION AND SUBROUTINE STATEMENTS */ DECLARE I FIXED BINARY; GET=ARG 14 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES DUMMY ARGUMENTS IN THE LIST */ IF DUM=ARG=COUNT > MAXARGS THEN DO; CALL ERR[MANYARGS]; CALL SKIP=SUBSCRIPTLIST; END; ELSE DO; IF TOKEN > SIMPLE=VAR THEN ARGUMENT[XNAMTAB] > TRUE; ELSE DO; CALL ERR[INVIDENT]; WORD > :XXXX$VAR: ; END; DUM=ARG=COUNT > DUM=ARG=COUNT < 1; DUM=ARGS[DUM=ARG=COUNT] > WORD; CALL OUT[:L R4,: "" CVS=I[ 4*[DUM=ARG=COUNT - 1] ] "" :[R1]:]; CALL OUT[:MVC : "" WORD "" :,0[R4]:]; CALL GET=TOKEN; END; END GET=ARG; FUNCTION > [TOKEN > RW=FUNCTION]; CLASSDEC > TRUE; /* GET THE SUBPROGRAM NAME */ CALL GET=TOKEN; IF TOKEN _> ID THEN DO; CALL ERR[SUBPNAME]; WORD > :ENTRY$: ; END; IF FUNCTION THEN DO; MODEDEC > FALSE; CURCLASS > FUNCTION=NAME; END; ELSE DO; MODEDEC > TRUE; CURMODE > NULL; CURCLASS > SUBROUTINE=NAME; END; CALL NAMTAB=INSERT; CALL SPTAB=ROUTINE; /* CHECK FOR MULTIPLE DEFINITION */ IF SP=DEFINED[XSPTAB] THEN CALL ERR[SUBPNAME]; ELSE SP=DEFINED[XSPTAB] > DEFINED; IF FUNCTION THEN DO; ACTIVE[XSPTAB] > TRUE; VALUE=FLAG[XSPTAB] > FALSE; SAVEXSP > XSPTAB; FTNMODE > MODE[XNAMTAB]; END; CLASSDEC, MODEDEC > FALSE; CALL SUBPROGRAM=PROLOGUE; CALL COMMENT=LINE[ :[: "" CVS=I3[SEQASM] "" :] : "" SUBSTR[CARD, 1, 72] ]; IF SUBSTR[CARD, 1, 6] _> : : THEN CALL ERR[INVFTSUB]; CALL GET=TOKEN; IF TOKEN > LPAREN THEN CALL GET=TOKEN; ELSE CALL ERR[MISLPARN]; /* PROCESS THE DUMMY ARGUMENT LIST */ DUM=ARG=COUNT > 0; CALL GET=ARG; DO WHILE [TOKEN > COMMA]; CALL GET=TOKEN; CALL GET=ARG; END; IF TOKEN > RPAREN THEN CALL GET=TOKEN; ELSE CALL ERR[MISRPARN]; IF TOKEN _> STMTEND THEN DO; CALL ERR[INVSTEND]; CALL NEXT=CARD; END; END FUNCTION=SUBROUTINE=STMT; GO=STMT 9 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* DRIVER FOR THE GO TO STATEMENT */ CALL GET=TOKEN; IF TOKEN _> RW=TO THEN CALL ERR[MISRWDTO]; CALL GOTO=STMT; END GO=STMT; GOTO=STMT 11 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES THE UNCONDITIONAL GO TO STATEMENT */ CALL GET=TOKEN; IF [TOKEN > INTEGER=NO] & [INUMBER \ 0] & [INUMBER ) 100000] THEN DO; /* FOUND A STATEMENT NUMBER */ CALL SNTAB=SEARCH; IF _FOUND THEN CALL SNTAB=INSERT[UNDEFINED, NOTCASE]; CALL REFSTMT=INSERT; CALL REFSN=INSERT; CALL OUT[:B S: "" CVS=I7[INUMBER]]; CALL GET=TOKEN; END; ELSE IF TOKEN > LPAREN THEN CALL COMPUTED=GOTO=STMT; ELSE DO; CALL ERR[INVGOSTM]; CALL FLUSH=STATEMENT; END; END GOTO=STMT; COMPUTED=GOTO=STMT 20 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES THE COMPUTED GO TO STATEMENT */ DECLARE [LABEL1, LABEL2, GLABEL] CHARACTER[8]; GET=SN 13 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES STATEMENT NUMBERS FROM THE LIST */ IF [TOKEN > INTEGER=NO] & [INUMBER \ 0] & [INUMBER ) 100000] THEN DO; CALL SNTAB=SEARCH; IF _FOUND THEN CALL SNTAB=INSERT[UNDEFINED, NOTCASE]; CALL REFSN=INSERT; CALL OUT[:DC A[S: "" CVS=I7[INUMBER] "" :]:]; CALL GET=TOKEN; END; ELSE CALL ERR[INVSTNUM]; END GET=SN; LABEL1 > GEN=LABEL; LABEL2 > GEN=LABEL; GO=COUNT > GO=COUNT < 1; GLABEL > :G: "" CVS=I7[GO=COUNT]; CALL REFSTMT=INSERT; CALL OUT[:B : "" LABEL1]; LABEL=FLD > GLABEL; CALL OUT[:DC A[: "" LABEL2 "" :]:]; /* PROCESS THE STATEMENT NUMBER LIST */ CALL GET=TOKEN; CALL GET=SN; DO WHILE [TOKEN > COMMA]; CALL GET=TOKEN; CALL GET=SN; END; IF TOKEN > RPAREN THEN CALL GET=TOKEN; ELSE CALL ERR[MISRPARN]; IF TOKEN > COMMA THEN CALL GET=TOKEN; ELSE CALL ERR[MISCOMMA]; LABEL=FLD > LABEL1; /* PROCESS THE EXPRESSION */ CALL EXPRESSION; IF _ARITHMETIC THEN DO; CALL ERR[NOTARITH]; CALL FLUSH=STATEMENT; RETURN; END; IF CURMODE > INTEGER THEN DO; CALL OUT[:LPR R4,R3:]; CALL POP[INTEGER]; END; ELSE DO; CALL ERR[MXMDINTG]; CALL FLOATTOFIX[:F2:, :R4:]; CALL POP[RREAL]; CALL OUT[:LPR R4,R4:]; END; CALL OUT[:SLA R4,2:]; CALL OUT[:L R4,: "" GLABEL "" :[R4]:]; CALL OUT[:BR R4:]; LABEL=FLD > LABEL2; CALL OUT[:NOP 0:]; END COMPUTED=GOTO=STMT; IF=STMT 9 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* DRIVER FOR THE IF STATEMENTS */ IFSTMT > TRUE; CALL GET=TOKEN; IF TOKEN > LPAREN THEN CALL GET=TOKEN; ELSE CALL ERR[MISLPARN]; CALL EXPRESSION; IF TOKEN > RPAREN THEN CALL GET=TOKEN; ELSE CALL ERR[MISRPARN]; IF ARITHMETIC THEN CALL ARITH=IF; ELSE CALL LOGIC=IF; IFSTMT > FALSE; END IF=STMT; ARITH=IF 10 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* PROCESS THE ARITHMETIC IF STATEMENT */ DECLARE [SNNEG, SNZERO, SNPOS] /* THE THREE STMT NOS. */ FIXED[31,0] BINARY; DECLARE OK BIT[1]; GET=SN 13 ^^ , , 32 , 8 , 20,8,o PROCEDURE [SN]; /* PROCESSES STATEMENT NUMBERS FROM THE LIST */ DECLARE SN FIXED[31,0] BINARY; IF [TOKEN > INTEGER=NO] & [INUMBER \ 0] & [INUMBER ) 100000] THEN DO; CALL SNTAB=SEARCH; IF _FOUND THEN CALL SNTAB=INSERT[UNDEFINED, NOTCASE]; CALL REFSN=INSERT; SN > INUMBER; CALL GET=TOKEN; END; ELSE DO; OK > FALSE; CALL ERR[INVSTNUM]; END; END GET=SN; OK > TRUE; CALL REFSTMT=INSERT; CALL GET=SN[SNNEG]; /* (NEGATIVE( STMT NO. */ IF TOKEN > COMMA THEN CALL GET=TOKEN; ELSE CALL ERR[MISCOMMA]; CALL GET=SN[SNZERO]; /* (ZERO( STMT NO. */ IF TOKEN > COMMA THEN CALL GET=TOKEN; ELSE CALL ERR[MISCOMMA]; CALL GET=SN[SNPOS]; /* (POSITIVE( STMT NO. */ IF OK THEN DO; /* CODE TO TEST ALGEBRAIC SIGN OF EXPRESSION VALUE */ IF CURMODE > INTEGER THEN DO; CALL OUT[:LR R4,R3:]; CALL POP[INTEGER]; CALL OUT[:LTR R4,R4:]; END; ELSE DO; CALL OUT[:LER F4,F2:]; CALL POP[RREAL]; CALL OUT[:LTER F4,F4:]; END; CALL OUT[:BM S: "" CVS=I7[SNNEG]]; CALL OUT[:BZ S: "" CVS=I7[SNZERO]]; CALL OUT[:BP S: "" CVS=I7[SNPOS]]; END; ELSE DO; CALL ERR[INVIFSTM]; CALL POP[CURMODE]; CALL FLUSH=STATEMENT; END; END ARITH=IF; LOGIC=IF 10 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* PROCESSES THE LOGICAL IF STATEMENT */ IF TOKEN > RW=THEN THEN CALL IF=THEN=ELSE; ELSE BEGIN; DECLARE LABEL1 CHARACTER[8]; LABEL1 > GEN=LABEL; CALL OUT[:LR R4,R3:]; CALL POP[INTEGER]; CALL OUT[:C R4,>F::1:::]; CALL OUT[:BNE : "" LABEL1]; /* PROCESS THE STATEMENT AT THE RIGHT */ IF TOKEN > STMTEND THEN CALL ERR[UNXPSEND]; ELSE CALL STATEMENT; IF ENDPROG THEN CALL ERR[UNXPPEND]; LABEL=FLD > LABEL1; CALL OUT[:NOP 0:]; END; END LOGIC=IF; IF=THEN=ELSE 14 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* PROCESSES THE IF=THEN=ELSE STATEMENT */ DECLARE LABEL1 CHARACTER[8]; LABEL1 > GEN=LABEL; CALL GRP=IN; CALL OUT[:LR R4,R3:]; CALL POP[INTEGER]; CALL OUT[:C R4,>F::1:::]; CALL OUT[:BNE : "" LABEL1]; /* DOES THE NEXT STMT START ON THE SAME CARD OR ON A NEW ONE+ */ CALL GET=TOKEN; IF TOKEN > STMTEND THEN CALL STATEMENT=ROUTINE; ELSE CALL STATEMENT; /* PROCESS THE (THEN( STATEMENT GROUP */ DO WHILE [ _[FINSTMT " ELSESTMT " ENDPROG] ]; CALL STATEMENT=ROUTINE; END; CURLEV > CURLEV - 1; IF FINSTMT " ENDPROG THEN DO; /* NO (ELSE( STMT GRP */ IF ENDPROG THEN CALL ERR[UNXPPEND]; LABEL=FLD > LABEL1; CALL OUT[:NOP 0:]; FINSTMT > FALSE; END; ELSE BEGIN; /* PROCESS THE (ELSE( STMT GRP */ DECLARE LABEL2 CHARACTER[8]; LABEL2 > GEN=LABEL; CALL GRP=IN; CALL OUT[:B : "" LABEL2]; LABEL=FLD > LABEL1; CALL OUT[:NOP 0:]; /* NEXT STMT ON SAME CARD OR NEW CARD+ */ IF TOKEN > STMTEND THEN CALL STATEMENT=ROUTINE; ELSE CALL STATEMENT; DO WHILE [ _[FINSTMT " ENDPROG] ]; CALL STATEMENT=ROUTINE; END; CURLEV > CURLEV - 1; IF ENDPROG THEN CALL ERR[UNXPPEND]; LABEL=FLD > LABEL2; CALL OUT[:NOP 0:]; FINSTMT > FALSE; END; FINSTMT > FALSE; END IF=THEN=ELSE; PRINT=STMT 12 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* CONVERTS THE PRINT STATEMENT INTO THE PRINTOUT MACRO CALL */ DECLARE TEXT CHARACTER[60] VARYING; TEXT > :PRINTOUT : ; CALL GET=TOKEN; /* LOOP ONCE PER IDENTIFIER */ DO WHILE [TOKEN > COMMA]; CALL GET=TOKEN; TEXT > TEXT "" WORD "" :,: ; CALL GET=TOKEN; END; CALL OUT[ SUBSTR[TEXT, 1, LENGTH[TEXT]-1] ]; END PRINT=STMT; RETURN=STMT 13 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES THE RETURN STATEMENT BY GENERATING A BRANCH TO THE */ /* SUBPROGRAM RETURN ROUTINE */ IF PROG=COUNT \ 1 THEN CALL OUT[:B L: "" CVS=I7[1]]; ELSE CALL ERR[MISPSTMT]; CALL GET=TOKEN; END RETURN=STMT; STOP=STMT 11 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES THE STOP STATEMENT BY GENERATING CODE TO RETURN */ /* CONTROL TO THE MONITOR */ IF PROG=COUNT > 1 THEN DO; CALL OUT[:L R13,: "" SAVEAREA "" :<4:]; CALL OUT[:LM R14,R12,12[R13]:]; CALL OUT[:MVI 12[R13],X::FF:::]; CALL OUT[:BR R14:]; END; ELSE CALL ERR[MISPSTMT]; CALL GET=TOKEN; END STOP=STMT; TYPE=STATEMENT 16 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES THE FOLLOWING TYPE STATEMENTS 46 ^^ , , 32 , 8 , 20,8,o INTEGER, LOGICAL, */ /* REAL, AND DIMENSION */ DECLARE DIM=COUNT FIXED BINARY; DECLARE DIMSTMT BIT[1]; GET=ID 13 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES IDENTIFIERS FROM THE LIST */ IF [TOKEN > ID] " [ FOUND & ARGUMENT[XNAMTAB] ] THEN DO; IF TOKEN > ID THEN CALL NAMTAB=INSERT; ELSE IF MODEDEC THEN MODE[XNAMTAB] > CURMODE; DIM=COUNT > 0; CALL GET=TOKEN; IF TOKEN > LPAREN THEN DO; /* IT HAS ARRAY BOUNDS */ CALL GET=TOKEN; CALL GET=BOUND; /* LOOP ONCE PER BOUND */ DO WHILE [TOKEN > COMMA]; CALL GET=TOKEN; CALL GET=BOUND; END; IF TOKEN > RPAREN THEN CALL GET=TOKEN; ELSE CALL ERR[MISRPARN]; CLASS[XNAMTAB] > ARRAY=VAR; END; /* ALL IDS IN A DIMENSION STMT MUST HAVE BOUNDS */ IF DIMSTMT & [DIM=COUNT > 0] THEN CALL ERR[NUMSUBSC]; NODIM[XNAMTAB] > DIM=COUNT; END; ELSE DO; CALL ERR[INVIDENT]; CALL GET=TOKEN; IF TOKEN > LPAREN THEN CALL SKIP=SUBSCRIPTLIST; END; END GET=ID; GET=BOUND 16 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES ARRAY BOUNDS */ IF DIM=COUNT > MAXDIM THEN DO; CALL ERR[NUMSUBSC]; CALL SKIP=SUBSCRIPTLIST; END; ELSE DO; DIM=COUNT > DIM=COUNT < 1; IF [TOKEN > INTEGER=NO] & [INUMBER \ 0] THEN DIMENSION[XNAMTAB, DIM=COUNT] > INUMBER; ELSE DO; /* ON ERROR, THE DEFAULT BOUND IS 1 */ CALL ERR[INVSUBSC]; DIMENSION[XNAMTAB, DIM=COUNT] > 1; END; CALL GET=TOKEN; END; END GET=BOUND; DIMSTMT > [TOKEN > RW=DIMENSION]; IF DIMSTMT THEN DO; CLASSDEC > TRUE; CURCLASS > ARRAY=VAR; END; ELSE DO; MODEDEC > TRUE; IF TOKEN > RW=INTEGER THEN CURMODE > INTEGER; ELSE IF TOKEN > RW=REAL THEN CURMODE > RREAL; ELSE CURMODE > LOGICAL; END; /* PROCESS THE IDENTIFIER LIST */ CALL GET=TOKEN; CALL GET=ID; DO WHILE [TOKEN > COMMA]; CALL GET=TOKEN; CALL GET=ID; END; CLASSDEC, MODEDEC > FALSE; END TYPE=STATEMENT; SUBPROGRAM=CALL 17 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* PROCESSES A FUNCTION OR SUBROUTINE SUBPROGRAM CALL */ DECLARE ACT=ARGS[1 25 ^^ , , 32 , 8 , 20,8,oMAXARGS] /* ACTUAL ARGUMENT LIST */ CHARACTER[8]; DECLARE SAVENAME /* SAVES THE SUBPROGRAM NAME */ CHARACTER[6] VARYING; DECLARE [I, ACT=ARG=COUNT] FIXED BINARY; DECLARE [TEMPLOC, ALABEL, LABEL1] CHARACTER[8]; DECLARE OK BIT[1]; GET=ARG 14 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* PROCESSES ACTUAL ARGUMENTS IN THE LIST */ IF ACT=ARG=COUNT > MAXARGS THEN DO; CALL ERR[MANYARGS]; CALL FLUSH=STATEMENT; OK > FALSE; END; ELSE DO; ACT=ARG=COUNT > ACT=ARG=COUNT < 1; IF [TOKEN > SIMPLE=VAR] " [TOKEN > ARRAY=VAR] THEN DO; /* CALL BY REFERENCE */ ACT=ARGS[ACT=ARG=COUNT] > WORD; CALL GET=TOKEN; END; ELSE DO; /* CALL BY VALUE VIA A TEMPORARY LOC. */ TEMP=COUNT > TEMP=COUNT < 1; TEMPLOC > :T: "" CVS=I7[TEMP=COUNT]; ACT=ARGS[ACT=ARG=COUNT] > TEMPLOC; CALL EXPRESSION; IF _ARITHMETIC " [CURMODE > INTEGER] THEN CALL OUT[:ST R3,: "" TEMPLOC]; ELSE CALL OUT[:STE F2,: "" TEMPLOC]; CALL POP[CURMODE]; END; END; END GET=ARG; CALL SPTAB=ROUTINE; SAVENAME > SUBPROGNAME; CALL GET=TOKEN; IF TOKEN > LPAREN THEN CALL GET=TOKEN; ELSE RETURN; /* ARGUMENTLESS CALL */ /* PROCESS THE ACTUAL ARGUMENT LIST */ ACT=ARG=COUNT > 0; OK > TRUE; CALL GET=ARG; IF _OK THEN RETURN; /* ERROR RETURN */ DO WHILE [TOKEN > COMMA]; CALL GET=TOKEN; CALL GET=ARG; END; IF _OK THEN RETURN; /* ERROR RETURN */ IF TOKEN > RPAREN THEN CALL GET=TOKEN; ELSE CALL ERR[MISRPARN]; /* CODE FOR THE CALLING SEQUENCE */ LABEL1 > GEN=LABEL; SPC=COUNT > SPC=COUNT < 1; ALABEL > :A: "" CVS=I7[SPC=COUNT]; CALL OUT[:LA R1,: "" ALABEL]; CALL OUT[:LA R14,: "" LABEL1]; CALL OUT[:LA R15,: "" SAVENAME]; CALL OUT[:BR R15:]; /* CODE FOR THE ARGUMENT LIST */ LABEL=FLD > ALABEL; DO I > 1 TO ACT=ARG=COUNT; CALL OUT[:DC A[: "" ACT=ARGS[I] "" :]: ]; END; LABEL=FLD > LABEL1; /* RETURN-TO LABEL */ END SUBPROGRAM=CALL; /* --------------------------------------------------------------- */ /* 2.4 LOGICAL AND ARITHMETIC EXPRESSIONS */ /* --------------------------------------------------------------- */ EXPRESSION 12 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* DRIVER FOR AN EXPRESSION */ CURMODE > NULL; CALL LOGIC=EXPR; END EXPRESSION; LOGIC=EXPR 12 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* PROCESSES )DISJUNCTION.1\ .OR. )DISJUNCTION.2\ */ CALL DISJUNCTION; /* )DISJUNCTION.1\ */ IF TOKEN > RW=OR THEN DO; IF ARITHMETIC THEN CALL LOGIC=ERR; DO WHILE [TOKEN > RW=OR]; CALL GET=TOKEN; CURMODE > NULL; CALL DISJUNCTION; /* )DISJUNCTION.2\ */ IF ARITHMETIC THEN CALL LOGIC=ERR; CALL OUT[:O R3,STACK[R10]:]; CALL OUT[:S R10,>F::4:::]; END; END; END LOGIC=EXPR; DISJUNCTION 13 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* PROCESSES )CONJUNCTION.1\ .AND. )CONJUNCTION.2\ */ CALL CONJUNCTION; /* )CONJUNCTION.1\ */ IF TOKEN > RW=AND THEN DO; IF ARITHMETIC THEN CALL LOGIC=ERR; DO WHILE [TOKEN > RW=AND]; CALL GET=TOKEN; CURMODE > NULL; CALL CONJUNCTION; /* )CONJUNCTION.2\ */ IF ARITHMETIC THEN CALL LOGIC=ERR; CALL OUT[:N R3,STACK[R10]:]; CALL OUT[:S R10,>F::4:::]; END; END; END DISJUNCTION; CONJUNCTION 13 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* PROCESSES )REL.EXPR.\ OR .NOT. )REL.EXPR.\ */ DECLARE NEGATE BIT[1]; /* IS THERE A UNARY .NOT.+ */ IF TOKEN > RW=NOT THEN DO; NEGATE > TRUE; CALL GET=TOKEN; END; ELSE NEGATE > FALSE; CALL REL=EXPR; /* NEGATE THE VALUE OF THE EXPRESSION IF NECESSARY */ IF NEGATE THEN DO; IF ARITHMETIC THEN CALL LOGIC=ERR; CALL OUT[:X R3,>F::1:::]; END; END CONJUNCTION; REL=EXPR 10 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* PROCESSES )ARITH.EXPR.1\ )REL.OP.\ )ARITH.EXPR.2\ */ CALL ARITH=EXPR; /* )ARITH.EXPR.1\ */ IF [TOKEN \> RW=EQ] & [TOKEN )> RW=GE] THEN BEGIN; DECLARE SAVEOP FIXED BINARY; DECLARE [LABEL1, LABEL2] CHARACTER[8]; DECLARE BRANCHES[RW=EQ 34 ^^ , , 32 , 8 , 20,8,oRW=GE] CHARACTER[6] INITIAL [:BE:, :BNE:, :BH:, :BNL:, :BL:, :BNH:]; LABEL1 > GEN=LABEL; LABEL2 > GEN=LABEL; SAVEOP > TOKEN; CALL GET=TOKEN; CALL ARITH=EXPR; /* )ARITH.EXPR.2\ */ IF CURMODE > INTEGER THEN DO; CALL OUT[:C R3,STACK[R10]:]; CALL OUT[BRANCHES[SAVEOP] "" LABEL1]; CALL OUT[:SR R3,R3:]; CALL OUT[:B : "" LABEL2]; LABEL=FLD > LABEL1; CALL OUT[:LA R3,1:]; LABEL=FLD > LABEL2; CALL OUT[:S R10,>F::4:::]; END; ELSE DO; CALL OUT[:CE F2,STACK[R10]:]; CALL OUT[BRANCHES[SAVEOP] "" LABEL1]; CALL OUT[:SR R4,R4:]; CALL OUT[:B : "" LABEL2]; LABEL=FLD > LABEL1; CALL OUT[:LA R4,1:]; LABEL=FLD > LABEL2; CALL OUT[:S R10,>F::4:::]; CALL OUT[:LE F2,STACK[R10]:]; CALL OUT[:ST R3,STACK[R10]:]; CALL OUT[:LR R3,R4:]; END; ARITHMETIC > FALSE; END; END REL=EXPR; ARITH=EXPR 12 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* PROCESSES )ADDEND.1\ <"- )ADDEND.2\ */ DECLARE SAVEOP FIXED BINARY; DECLARE CONTINUE BIT[1]; ARITHMETIC > TRUE; CALL ADDEND; /* )ADDEND.1\ */ CONTINUE > TRUE; /* LOOP SO LONG AS THERE:S A <"- SIGN */ DO WHILE [CONTINUE]; IF [TOKEN > PLUS] " [TOKEN > MINUS] THEN DO; SAVEOP > TOKEN; CALL GET=TOKEN; CALL ADDEND; /* )ADDEND.2\ */ END; ELSE IF [ [TOKEN \> INTEGER=NO] & [TOKEN )> ARRAY=VAR] ] " [TOKEN > LPAREN] THEN DO; CALL ERR[MISOPRTR]; CALL ADDEND; /* )ADDEND.2\ */ SAVEOP > PLUS; END; ELSE CONTINUE > FALSE; IF CONTINUE THEN DO; /* GENERATE CODE FOR AN ADDITION */ IF SAVEOP > PLUS THEN DO; IF CURMODE > INTEGER THEN CALL OUT[:A R3,STACK[R10]:]; ELSE CALL OUT[:AE F2,STACK[R10]:]; END; ELSE DO; /* GENERATE CODE FOR A SUBTRACTION */ IF CURMODE > INTEGER THEN DO; CALL OUT[:LR R4,R3:]; CALL OUT[:L R3,STACK[R10]:]; CALL OUT[:SR R3,R4:]; END; ELSE DO; CALL OUT[:LER F4,F2:]; CALL OUT[:LE F2,STACK[R10]:]; CALL OUT[:SER F2,F4:]; END; END; CALL OUT[:S R10,>F::4:::]; END; END; END ARITH=EXPR; ADDEND 8 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* PROCESSES )FACTOR.1\ *"/ )FACTOR.2\ */ DECLARE SAVEOP FIXED BINARY; CALL FACTOR; /* )FACTOR.1\ */ /* LOOP SO LONG AS THERE:S A *"/ SIGN */ DO WHILE [ [TOKEN > STAR] " [TOKEN > SLASH] ]; SAVEOP > TOKEN; CALL GET=TOKEN; CALL FACTOR; /* )FACTOR.2\ */ IF SAVEOP > STAR THEN DO; /* GENERATE CODE FOR A MULTIPLICATION */ IF CURMODE > INTEGER THEN CALL OUT[:M R2,STACK[R10]:]; ELSE CALL OUT[:ME F2,STACK[R10]:]; END; ELSE DO; /* GENERATE CODE FOR A DIVISION */ IF CURMODE > INTEGER THEN DO; CALL OUT[:LR R4,R3:]; CALL OUT[:L R3,STACK[R10]:]; CALL OUT[:M R2,>F::1:::]; CALL OUT[:DR R2,R4:]; END; ELSE DO; CALL OUT[:LER F4,F2:]; CALL OUT[:LE F2,STACK[R10]:]; CALL OUT[:DER F2,F4:]; END; END; CALL OUT[:S R10,>F::4:::]; END; END ADDEND; FACTOR 8 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* PROCESSES )OPERAND.1\ ** )OPERAND.2\ */ DECLARE SAVEMODE /* SAVES MODE OF )OPERAND.1\ [BASE] */ FIXED BINARY; DECLARE [LABEL1, LABEL2] CHARACTER[8]; CALL OPERAND; /* )OPERAND.1\ */ SAVEMODE > CURMODE; CURMODE > INTEGER; /* LOOP AS LONG AS THERE:S A ** SIGN */ DO WHILE [TOKEN > STAR2]; LABEL1 > GEN=LABEL; LABEL2 > GEN=LABEL; CALL GET=TOKEN; CALL OPERAND; /* )OPERAND.2\ */ IF SAVEMODE > INTEGER THEN DO; CALL OUT[:LR R5,R3:]; CALL OUT[:L R4,STACK[R10]:]; CALL OUT[:LA R3,1:]; CALL OUT[:LTR R5,R5:]; CALL OUT[:BZ : "" LABEL2]; CALL OUT[:BP : "" LABEL1]; CALL OUT[:CR R3,R4:]; CALL OUT[:BE : "" LABEL2]; CALL OUT[:SR R3,R3:]; CALL OUT[:B : "" LABEL2]; LABEL=FLD > LABEL1; CALL OUT[:MR R2,R4:]; CALL OUT[:BCT R5,: "" LABEL1]; LABEL=FLD > LABEL2; CALL OUT[:S R10,>F::4:::]; END; ELSE DO; CALL OUT[:LER F4,F2:]; CALL OUT[:LE F2,>E::1.0E0:::]; CALL OUT[:LPR R5,R3:]; CALL OUT[:BZ : "" LABEL2]; LABEL=FLD > LABEL1; CALL OUT[:MER F2,F4:]; CALL OUT[:BCT R5,: "" LABEL1]; CALL OUT[:LTR R3,R3:]; CALL OUT[:BNM : "" LABEL2]; CALL OUT[:LER F4,F2:]; CALL OUT[:LE F2,>E::1.0E0:::]; CALL OUT[:DER F2,F4:]; LABEL=FLD > LABEL2; CALL OUT[:S R10,>F::4:::]; END; END; CURMODE > SAVEMODE; END FACTOR; OPERAND 9 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* GENERATES CODE FOR AN OPERAND */ DECLARE SAVEX /* SAVES XNAMTAB OF OPERAND */ FIXED BINARY; DECLARE NEGATIVE BIT[1]; DECLARE ISIGN FIXED[31,0] BINARY; DECLARE RSIGN FLOAT BINARY; DECLARE OPRND CHARACTER[8] VARYING; NEGATIVE > FALSE; ARITHMETIC > TRUE; ISIGN, RSIGN > 1; /* PREFIX <"- */ IF TOKEN > MINUS THEN DO; NEGATIVE > TRUE; ISIGN, RSIGN > -1; CALL GET=TOKEN; END; ELSE IF TOKEN > PLUS THEN CALL GET=TOKEN; /* DETERMINE THE MODE OF AN EXPRESSION FROM THE FIRST OPERAND */ IF CURMODE > NULL THEN DO; IF [TOKEN > SIMPLE=VAR] " [TOKEN > ARRAY=VAR] THEN DO; IF MODE[XNAMTAB] > LOGICAL THEN DO; ARITHMETIC > FALSE; CURMODE > INTEGER; END; ELSE CURMODE > MODE[XNAMTAB]; END; ELSE IF TOKEN > INTEGER=NO THEN CURMODE > INTEGER; ELSE IF TOKEN > REAL=NO THEN CURMODE > RREAL; ELSE IF [TOKEN > RW=TRUE] " [TOKEN > RW=FALSE] THEN DO; ARITHMETIC > FALSE; CURMODE > INTEGER; END; ELSE IF TOKEN > FUNCTION=NAME THEN CURMODE > MODE[XNAMTAB]; END; IF [TOKEN > SIMPLE=VAR] " [TOKEN > ARRAY=VAR] THEN DO; SAVEX > XNAMTAB; IF TOKEN > ARRAY=VAR THEN DO; CALL ARRAY=ELMT[:R8:]; OPRND > :0[R8]: ; END; ELSE OPRND > WORD; /* IS MODE CONVERSION NECESSARY+ */ IF [MODE[SAVEX] > CURMODE] " [ [MODE[SAVEX] > LOGICAL] & [CURMODE > INTEGER] ] THEN CALL PUSHV[OPRND]; ELSE DO; IF CURMODE > INTEGER THEN DO; CALL ERR[MXMDINTG]; CALL OUT[:LE F4,: "" OPRND]; CALL OUT[:LA R10,4[R10]:]; CALL OUT[:ST R3,STACK[R10]:]; CALL FLOATTOFIX[:F4:, :R3:]; /* CONVERSION */ END; ELSE DO; CALL ERR[MXMDREAL]; CALL OUT[:L R4,: "" OPRND]; CALL OUT[:LA R10,4[R10]:]; CALL OUT[:STE F2,STACK[R10]:]; CALL FIXTOFLOAT[:R4:, :F2:]; /* CONVERSION */ END; END; CALL GET=TOKEN; END; ELSE IF TOKEN > INTEGER=NO THEN DO; IF CURMODE > INTEGER THEN CALL PUSHI[ISIGN*INUMBER]; ELSE DO; CALL ERR[MXMDREAL]; RNUMBER > ISIGN*INUMBER; CALL PUSHR[RNUMBER]; END; NEGATIVE > FALSE; CALL GET=TOKEN; END; ELSE IF TOKEN > REAL=NO THEN DO; IF CURMODE > RREAL THEN CALL PUSHR[RSIGN*RNUMBER]; ELSE DO; CALL ERR[MXMDINTG]; INUMBER > RSIGN*RNUMBER; CALL PUSHI[INUMBER]; END; NEGATIVE > FALSE; CALL GET=TOKEN; END; ELSE IF TOKEN > LPAREN THEN DO; CALL GET=TOKEN; CALL LOGIC=EXPR; /* RECURSIVE CALL */ IF TOKEN > RPAREN THEN CALL GET=TOKEN; ELSE CALL ERR[MISRPARN]; END; ELSE IF TOKEN > FUNCTION=NAME THEN CALL FUNCTION=REF; ELSE IF TOKEN > RW=TRUE THEN DO; IF CURMODE > INTEGER THEN CALL PUSHI[1]; ELSE DO; CALL ERR[MXMDREAL]; CALL PUSHR[1.0E0]; END; CALL GET=TOKEN; END; ELSE IF TOKEN > RW=FALSE THEN DO; IF CURMODE > INTEGER THEN CALL PUSHI[0]; ELSE DO; CALL ERR[MXMDREAL]; CALL PUSHR[0.0E0]; END; CALL GET=TOKEN; END; ELSE DO; /* ON ERROR, USE THE MODELESS DUMMY VARIABLE */ CALL ERR[MISOPRND]; IF CURMODE > INTEGER THEN CALL PUSHV[:INTG$VAR:]; ELSE IF CURMODE > RREAL THEN CALL PUSHV[:REAL$VAR:]; ELSE CALL PUSHV[:XXXX$VAR:]; END; /* GENERATE CODE TO NEGATE AN OPERAND */ IF NEGATIVE THEN IF CURMODE > INTEGER THEN CALL OUT[:LCR R3,R3:]; ELSE CALL OUT[:LCER F2,F2:]; END OPERAND; ARRAY=ELMT 12 ^^ , , 32 , 8 , 20,8,o PROCEDURE [REG]; /* PROCESSES A REFERENCE TO AN ARRAY ELEMENT */ DECLARE REG /* R8 FOR AN EXPRESSION OPERAND */ /* R9 FOR AN ASSIGNMENT DESTINATION */ CHARACTER[*]; DECLARE [SAVEX, /* SAVES XNAMTAB OF ARRAY NAME */ D, /* NO. OF DIMENSIONS */ I, DIM=COUNT] FIXED BINARY; GET=SUBSCRIPT 20 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES A SUBSCRIPT */ DECLARE ADDITION BIT[1]; /* TOO MANY SUBSCRIPTS+ */ IF DIM=COUNT > D THEN DO; CALL ERR[NUMSUBSC]; CALL SKIP=SUBSCRIPTLIST; RETURN; /* ERROR RETURN */ END; DIM=COUNT > DIM=COUNT < 1; IF TOKEN > INTEGER=NO THEN DO; CALL OUT[:L R3,>F::: "" CVS=I[INUMBER] "" ::::]; CALL GET=TOKEN; IF TOKEN > STAR THEN CALL GET=TOKEN; ELSE GO TO END=SS; /* SS OF FORM (CONST( */ END; ELSE CALL OUT[:LA R3,1:]; IF [TOKEN > SIMPLE=VAR] & [MODE[XNAMTAB] > INTEGER] THEN DO; CALL OUT[:M R2,: "" WORD]; CALL GET=TOKEN; IF [TOKEN > PLUS] " [TOKEN > MINUS] THEN DO; ADDITION > [TOKEN > PLUS]; CALL GET=TOKEN; END; ELSE GO TO END=SS; /* SS OF FORM (CONST * VAR( OR (VAR( */ END; ELSE GO TO BAD=SS; IF TOKEN > INTEGER=NO THEN DO; IF ADDITION THEN CALL OUT[:A R3,>F::: "" CVS=I[INUMBER] "" ::::]; ELSE CALL OUT[:S R3,>F::: "" CVS=I[INUMBER] "" ::::]; CALL GET=TOKEN; /* SS OF FORM (CONST.1 * VAR <"- CONST.2( OR */ /* (VAR <"- CONST( */ GO TO END=SS; END; ELSE GO TO BAD=SS; END=SS 18 ^^ , , 32 , 8 , 20,8,o CALL OUT[:BCTR R3,0:]; RETURN; BAD=SS 18 ^^ , , 32 , 8 , 20,8,o CALL ERR[INVSUBSC]; CALL SKIP=SUBSCRIPT; CALL OUT[:SR R3,R3:]; RETURN; END GET=SUBSCRIPT; SAVEX > XNAMTAB; D > NODIM[SAVEX]; CALL OUT[:L : "" REG "" :,: "" WORD]; CALL GET=TOKEN; IF TOKEN > LPAREN THEN CALL GET=TOKEN; ELSE CALL ERR[MISLPARN]; /* PROCESS THE SUBSCRIPT LIST */ DIM=COUNT > 0; CALL OUT[:LA R10,4[R10]:]; CALL OUT[:ST R3,STACK[R10]:]; CALL GET=SUBSCRIPT; CALL OUT[:LR R5,R3:]; DO WHILE [TOKEN > COMMA]; CALL OUT[:M R4,>F::: "" CVS=I[ DIMENSION[SAVEX, DIM=COUNT] ] "" ::::]; CALL GET=TOKEN; CALL GET=SUBSCRIPT; CALL OUT[:AR R5,R3:]; END; /* DEFAULT FOR MISSING SUBSCRIPTS IS 1 */ IF DIM=COUNT ) D THEN DO; CALL ERR[NUMSUBSC]; DO I > DIM=COUNT < 1 TO D; CALL OUT[:M R4,>F::: "" CVS=I[ DIMENSION[SAVEX, DIM=COUNT] ] "" ::::]; END; END; CALL POP[INTEGER]; CALL OUT[:LA R5,1[R5]:]; CALL OUT[:SLA R5,2:]; CALL OUT[:AR : "" REG "" :,R5:]; IF TOKEN _> RPAREN THEN CALL ERR[MISRPARN]; END ARRAY=ELMT; FUNCTION=REF 14 ^^ , , 32 , 8 , 20,8,o PROCEDURE RECURSIVE; /* PROCESSES A FUNCTION CALL */ DECLARE SAVEMODE /* SAVES MODE OF FUNCTION */ FIXED BINARY; SAVEMODE > MODE[XNAMTAB]; CALL SUBPROGRAM=CALL; CALL OUT[:LA R10,4[R10]:]; /* GET THE FUNCTION VALUE FROM REGISTER R0 OR F0 */ IF SAVEMODE > RREAL THEN DO; CALL OUT[:STE F2,STACK[R10]:]; CALL OUT[:LER F2,F0:]; END; ELSE DO; CALL OUT[:ST R3,STACK[R10]:]; CALL OUT[:LR R3,R0:]; END; END FUNCTION=REF; 1 /* *************************************************************** */ /* *************************************************************** */ /* *************************************************************** */ /* 3. L E X I C A L A N A L Y S I S */ /* THE STAR OF THIS SECTION IS THE SCANNER, */ /* PROCEDURE GET=TOKEN. WITH THE AID OF THE OTHER */ /* PROCEDURES, IT EXTRACTS AND IDENTIFIES THE TOKENS */ /* FROM THE SOURCE STATEMENTS. HEAVY USE IS MADE OF */ /* THE PL/1 STRING FUNCTIONS INDEX, LENGTH, SUBSTR, */ /* AND VERIFY FOR EFFICIENCY:S SAKE. */ /* *************************************************************** */ /* *************************************************************** */ /* *************************************************************** */ GET=TOKEN 11 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* EXTRACTS AND IDENTIFIES A TOKEN FROM THE SOURCE CODE */ DECLARE CONTINUE BIT[1]; CONTINUE > TRUE; DO WHILE [CONTINUE]; CONTINUE > FALSE; /* SKIP OVER BLANKS */ IF CHARR > : : THEN DO; CALL GET=CHAR; IF CHARR > : : THEN DO; CARD=PTR > VERIFY[ SUBSTR[CARD, CARD=PTR], : :] < CARD=PTR - 2; CALL GET=CHAR; END; END; IF TYPE > LETTER THEN CALL GET=WORD; ELSE IF TYPE > DIGIT THEN CALL GET=NUMBER; ELSE IF CHARR > :*: THEN DO; /* (*( OR (**( */ CALL GET=CHAR; IF CHARR > :*: THEN DO TOKEN > STAR2; SYMBOL > :**:; CALL GET=CHAR; END; ELSE DO; TOKEN > STAR; SYMBOL > :*:; END; END; ELSE IF CHARR > :;: THEN DO; /* END OF STATEMENT */ CALL NEXT=CARD; IF CONTINUATION THEN DO; CARD=PTR > 6; CALL GET=CHAR; CONTINUE > TRUE; /* MORE TO COME */ END; ELSE TOKEN > STMTEND; END; ELSE IF CHARR > :.: THEN /* FRACTION OR LOGICAL WORD */ BEGIN; DECLARE LAST=PTR=POS FIXED BINARY; LAST=PTR=POS > CARD=PTR; CALL GET=NUMBER; /* TRY FRACTION FIRST */ IF CARD=PTR > LAST=PTR=POS < 1 THEN DO; CALL GET=WORD; /* TRY LOGICAL WORD */ IF TOKEN ) 1000 THEN DO; TOKEN > ILLEGAL; CALL ERR[ILLGTOKN]; CONTINUE > TRUE; END; IF CHARR > :.: THEN CALL GET=CHAR; ELSE DO; /* INVALID TOKEN */ TOKEN > ILLEGAL; CALL ERR[ILLGTOKN]; CONTINUE > TRUE; END; END; END; ELSE DO; /* SPECIAL SYMBOL */ TOKEN > TYPE; SYMBOL > CHARR; CALL GET=CHAR; END; END; END GET=TOKEN; GET=CHAR 10 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* EXTRACTS AND IDENTIFIES A CHARACTER FROM THE SOURCE CODE */ DECLARE CONTINUE BIT[1]; CONTINUE > TRUE; DO WHILE [CONTINUE]; CONTINUE > FALSE; CARD=PTR > CARD=PTR < 1; CHARR > SUBSTR[CARD, CARD=PTR, 1]; IF INDEX[:ABCDEFGHIJKLMNOPQRSTUVWXYZ:, CHARR] _> 0 THEN TYPE > LETTER; ELSE IF INDEX[:0123456789:, CHARR] _> 0 THEN TYPE > DIGIT; ELSE DO; TYPE > INDEX[: .[<*];-/,::>:, CHARR]; IF TYPE > 0 THEN DO; TYPE > ILLEGAL; CALL ERR[ILLGCHAR]; CONTINUE > TRUE; END; END; END; END GET=CHAR; NEXT=CARD 11 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* MOVES TO THE NEXT CARD STORED IN BUFFER, AND CHECKS FOR CONTROL */ /* AND CONTINUATION CARDS */ DECLARE NEWCARD CHARACTER[73]; XBUF > XBUF < 1; NEWCARD > BUFFER[XBUF]; IF SUBSTR[NEWCARD, 1, 1] _> :$: THEN CONTINUATION > [SUBSTR[NEWCARD, 6, 1] _> : :] & [SUBSTR[NEWCARD, 6, 1] _> :0:]; ELSE DO; ENDPROG > TRUE; ENDJOB > [SUBSTR[NEWCARD, 2, 3] > :END:]; ENDBATCH > [SUBSTR[NEWCARD, 2, 4] > :EXIT:]; END; END NEXT=CARD; GET=WORD 10 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* EXTRACTS RESERVED WORDS AND IDENTIFIERS FROM THE SOURCE CODE */ DECLARE [ENDPTR, WORDLEN] FIXED BINARY; DECLARE WORDMASK CHARACTER[8] VARYING; /* PULL OUT THE WORD */ ENDPTR > VERIFY[ SUBSTR[CARD, CARD=PTR], :ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789: ] < CARD=PTR - 1; WORDLEN > ENDPTR - CARD=PTR; WORD > SUBSTR[CARD, CARD=PTR, WORDLEN]; CARD=PTR > ENDPTR - 1; /* SET CARD=PTR AHEAD */ CALL GET=CHAR; CALL RWTAB=SEARCH; /* RESERVED WORD+ */ IF FOUND THEN TOKEN > XRWTAB; ELSE DO; IF WORDLEN \ 6 THEN DO; CALL ERR[IDLENGTH]; WORD > SUBSTR[WORD, 1, 6]; WORDLEN > 6; END; /* TAG THE IDENTIFIER WITH THE PROGRAM COUNT */ SAVEWORD > WORD; WORDMASK > :000000: "" STR=PROG=COUNT; SUBSTR[WORDMASK, 1, WORDLEN] > WORD; WORD > WORDMASK; CALL NAMTAB=SEARCH; IF _FOUND THEN DO; IF _[CLASSDEC " MODEDEC] THEN DO; CALL NAMTAB=INSERT; TOKEN > CLASS[XNAMTAB]; END; ELSE TOKEN > ID; END; ELSE TOKEN > CLASS[XNAMTAB]; END; END GET=WORD; GET=NUMBER 12 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* EXTRACTS A NUMERIC CONSTANT FROM THE SOURCE CODE */ DECLARE [WHOLE, FRACTION] FLOAT DECIMAL; DECLARE ENDPTR FIXED BINARY; /* POINT TO THE END OF THE WHOLE NUMBER PART */ ENDPTR > VERIFY[ SUBSTR[CARD, CARD=PTR], :0123456789: ] < CARD=PTR - 1; /* EXTRACT THE WHOLE NUMBER PART */ IF ENDPTR \ CARD=PTR THEN DO; GET STRING[ SUBSTR[CARD, CARD=PTR, ENDPTR - CARD=PTR] ] LIST [WHOLE]; CARD=PTR > ENDPTR - 1; CALL GET=CHAR; END; ELSE WHOLE > 0; IF TYPE > DOT THEN DO; /* REAL NUMBER [WITH DECIMAL POINT]+ */ /* POINT TO THE END OF THE FRACTION */ ENDPTR > VERIFY[ SUBSTR[CARD, CARD=PTR < 1], :0123456789: ] < CARD=PTR; /* EXTRACT THE FRACTION */ IF ENDPTR \ CARD=PTR < 1 THEN GET STRING[ SUBSTR[CARD, CARD=PTR, ENDPTR - CARD=PTR] ] LIST [FRACTION]; ELSE FRACTION > 0; CARD=PTR > ENDPTR - 1; CALL GET=CHAR; RNUMBER > WHOLE < FRACTION; TOKEN > REAL=NO; END; ELSE DO; /* JUST AN INTEGER */ IF WHOLE \ MAXINTEGER THEN DO; CALL ERR[INTGSIZE]; INUMBER > MAXINTEGER; END; ELSE INUMBER > WHOLE; TOKEN > INTEGER=NO; END; END GET=NUMBER; 1 /* *************************************************************** */ /* *************************************************************** */ /* *************************************************************** */ /* 4. T A B L E M A I N T E N A N C E */ /* THE PROCEDURES OF THIS SECTION ARE INVOLVED WITH */ /* MAINTAINING THE VARIOUS TABLES USED DURING THE */ /* COMPILATION PROCESS. */ /* THE SYMBOL TABLES ARE RW=TAB FOR RESERVED WORDS, */ /* NAMTAB FOR THE IDENTIFIERS [SIMPLE VARIABLES, ARRAY */ /* VARIABLES, FUNCTION NAMES, SUBROUTINE NAMES, AND */ /* CHARACTER NAMES], AND SPTAB FOR SUBPROGRAM NAMES */ /* [FUNCTION AND SUBROUTINE]. */ /* THE CONTAINMENT, REFERENCE, AND STATEMENT */ /* NUMBER TABLES HELP ENSURE THE CORRECTNESS OF THE */ /* STATEMENT GROUP STRUCTURE AND OF THE INTER-GROUP */ /* REFERENCES. */ /* ALSO INCLUDED HERE ARE PROCEDURES WHICH */ /* INITIALIZE AND RESET THESE TABLES. */ /* *************************************************************** */ /* *************************************************************** */ /* *************************************************************** */ /* --------------------------------------------------------------- */ /* 4.1 SYMBOL TABLES */ /* --------------------------------------------------------------- */ RWTAB=SEARCH 14 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* SEARCHES THE RESERVED WORD TABLE */ DECLARE HASHCODE FIXED BINARY; HASHCODE > HASH[WORD, RW=HEADLISTSIZE]; XRWTAB > RW=HEADLIST[HASHCODE]; FOUND > FALSE; /* CHASE DOWN LINKS */ DO WHILE [ _FOUND & [XRWTAB _> NULL] ]; IF WORD > RESWORD[XRWTAB] THEN FOUND > TRUE; ELSE XRWTAB > RWTAB.LINK[XRWTAB]; END; END RWTAB=SEARCH; NAMTAB=INSERT 15 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* INSERTS A NAME INTO THE NAME TABLE */ /* ALONG WITH ITS CLASS AND MODE */ IF TOP=NAMTAB > NAMTABSIZE THEN DO; CALL ERR[OVFNAMTB]; CALL CRASH; END; ELSE BEGIN; DECLARE HASHCODE FIXED BINARY; XNAMTAB, TOP=NAMTAB > TOP=NAMTAB < 1; HASHCODE > HASH[WORD, HEADLISTSIZE]; NNAME[XNAMTAB] > WORD; IF CLASSDEC THEN CLASS[XNAMTAB] > CURCLASS; ELSE CLASS[XNAMTAB] > SIMPLE=VAR; IF MODEDEC THEN MODE[XNAMTAB] > CURMODE; ELSE IF INDEX[ :IJKLMN:, SUBSTR[WORD, 1, 1] ] _> 0 THEN MODE[XNAMTAB] > INTEGER; ELSE MODE[XNAMTAB] > RREAL; DO=INDEX[XNAMTAB], ARGUMENT[XNAMTAB] > FALSE; NAMTAB.LINK[XNAMTAB] > HEADLIST[HASHCODE]; HEADLIST[HASHCODE] > XNAMTAB; END; END NAMTAB=INSERT; NAMTAB=SEARCH 15 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* SEARCHES THE NAME TABLE */ DECLARE HASHCODE FIXED BINARY; HASHCODE > HASH[WORD, HEADLISTSIZE]; XNAMTAB > HEADLIST[HASHCODE]; FOUND > FALSE; /* CHASE DOWN LINKS */ DO WHILE [ _FOUND & [XNAMTAB _> NULL] ]; IF WORD > NNAME[XNAMTAB] THEN FOUND > TRUE; ELSE XNAMTAB > NAMTAB.LINK[XNAMTAB]; END; /* SET XNAMTAB TO 0 IF IT WAS NULL */ IF XNAMTAB > NULL THEN XNAMTAB > 0; END NAMTAB=SEARCH; SPTAB=ROUTINE 15 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* INSERTS A SUBPROGRAM NAME INTO THE SUBPROGRAM TABLE */ /* FIRST, MAKE A (TEMPORARY( INSERTION AT THE END */ SUBPROGNAME, SPNAME[TOP=SPTAB < 1] > SAVEWORD; XSPTAB > 2; /* RUN DOWN THE TABLE */ DO WHILE [ SUBPROGNAME _> SPNAME[XSPTAB] ]; XSPTAB > XSPTAB < 1; END; /* IF (NOT FOUND,( MAKE THE INSERTION PERMANENT */ IF XSPTAB > TOP=SPTAB < 1 THEN DO; TOP=SPTAB > XSPTAB; SP=DEFINED[XSPTAB] > FALSE; END; END SPTAB=ROUTINE; HASH 6 ^^ , , 32 , 8 , 20,8,o PROCEDURE [KEY, HEADSIZE] RETURNS [FIXED BINARY]; /* THE HASH FUNCTION */ DECLARE KEY CHARACTER[*] VARYING; DECLARE HEADSIZE FIXED BINARY; DECLARE HASHSUM FIXED BINARY; DECLARE I FIXED BINARY; HASHSUM > 0; DO I > 1 TO LENGTH[KEY]; HASHSUM > HASHSUM < INDEX[ :ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789:, SUBSTR[KEY, I, 1] ]; END; RETURN [ MOD[HASHSUM, HEADSIZE] ]; END HASH; /* --------------------------------------------------------------- */ /* 4.2 CONTAINMENT AND REFERENCE TABLES */ /* --------------------------------------------------------------- */ GRP=IN 8 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PROCESSES A STATEMENT GROUP ENTRANCE */ DECLARE I FIXED BINARY; IF GRP=COUNT > MAXGCOUNT THEN DO; CALL ERR[MANYGRPS]; CALL CRASH; END; ELSE IF CURLEV > MAXLEVEL THEN DO; CALL ERR[MANYLEVL]; CALL CRASH; END; ELSE DO; /* UPDATE CONTAINMENT TABLE */ /* FIND INDEX OF CONTAINING STATEMENT GROUP */ DO I > GRP=COUNT TO 0 BY -1 WHILE [ GLEVEL[I] _> CURLEV ]; END; GRP=COUNT > GRP=COUNT < 1; CURLEV > CURLEV < 1; CURCOUNT[CURLEV] > GRP=COUNT; GLEVEL[GRP=COUNT] > CURLEV; GCONT[GRP=COUNT] > I; GRP=PTR[GRP=COUNT] > NULL; END; END GRP=IN; REFSTMT=INSERT 16 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* UPDATES REFSTMT OF REFTAB */ IF TOP=REFSTMT > MAXREFS THEN DO; CALL ERR[OVFREFTB]; CALL CRASH; END; ELSE DO; TOP=REFSTMT > TOP=REFSTMT < 1; SEQNUM[TOP=REFSTMT] > SEQASM; SEQ=PTR[TOP=REFSTMT] > NULL; REFSTMT.LINK[TOP=REFSTMT] > GRP=PTR[GRP=COUNT]; /* BACK LINK */ GRP=PTR[GRP=COUNT] > TOP=REFSTMT; /* POINTER FROM GRP=PTR */ END; END REFSTMT=INSERT; REFSN=INSERT 14 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* UPDATES REFSN OF REFTAB */ IF TOP=REFSN > MAXSN THEN DO; CALL ERR[OVFREFTB]; CALL CRASH; END; ELSE DO; TOP=REFSN > TOP=REFSN < 1; SN=PTR[TOP=REFSN] > XSNTAB; /* POINTER INTO SNTAB */ REFSN.LINK[TOP=REFSN] > SEQ=PTR[TOP=REFSTMT]; /* BACK LINK */ SEQ=PTR[TOP=REFSTMT] > TOP=REFSN; /* POINTER FROM REFSTMT */ END; END REFSN=INSERT; SNTAB=INSERT 14 ^^ , , 32 , 8 , 20,8,o PROCEDURE [DEFN=FLAG, CASE=FLAG]; /* UPDATES SNTAB */ DECLARE [DEFN=FLAG, CASE=FLAG] BIT[*]; DECLARE HASHCODE FIXED BINARY; IF TOP=SNTAB > SNTABSIZE THEN DO; CALL ERR[OVFSNTAB]; CALL CRASH; END; ELSE DO; HASHCODE > MOD[INUMBER, SN=HEADLISTSIZE]; XSNTAB, TOP=SNTAB > TOP=SNTAB < 1; SNTAB.STMTNUM[XSNTAB] > INUMBER; /* INSERT STMT NO. */ SN=DEFINED[XSNTAB] > DEFN=FLAG; SN=CASE[XSNTAB] > CASE=FLAG; SN=GCOUNT[XSNTAB] > CURCOUNT[CURLEV]; SN=GLEVEL[XSNTAB] > CURLEV; SNTAB.LINK[XSNTAB] > SN=HEADLIST[HASHCODE]; /* BACK LINK */ SN=HEADLIST[HASHCODE] > XSNTAB; /* POINTER FROM HEADLIST */ END; END SNTAB=INSERT; SNTAB=SEARCH 14 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* SEARCHES SNTAB */ DECLARE HASHCODE FIXED BINARY; HASHCODE > MOD[INUMBER, SN=HEADLISTSIZE]; XSNTAB > SN=HEADLIST[HASHCODE]; FOUND > FALSE; /* CHASE DOWN LINKS */ DO WHILE [ _FOUND & [XSNTAB _> NULL] ]; IF INUMBER > SNTAB.STMTNUM[XSNTAB] THEN FOUND > TRUE; ELSE XSNTAB > SNTAB.LINK[XSNTAB]; END; END SNTAB=SEARCH; /* --------------------------------------------------------------- */ /* 4.3 INITIALIZE AND RESET */ /* --------------------------------------------------------------- */ INITIALIZE=TABLES 19 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* INITIALIZES RWTAB, NAMTAB, REFTAB, AND SNTAB */ DECLARE HASHCODE FIXED BINARY; DECLARE I FIXED BINARY; DECLARE RESWORDS[1001 29 ^^ , , 32 , 8 , 20,8,o 1000 NULL; /* FILL RWTAB WITH THE RESERVED WORDS */ RWTAB.RESWORD > RESWORDS; /* LINK :EM UP BY HASHCODES */ DO I > 1001 TO 1000 < RWTABSIZE; HASHCODE > HASH[RWTAB.RESWORD[I], RW=HEADLISTSIZE]; RWTAB.LINK[I] > RW=HEADLIST[HASHCODE]; RW=HEADLIST[HASHCODE] > I; END; /* INITIALIZE THE DUMMY ELEMENT OF NAMTAB */ NNAME[0] > ::; CLASS[0], MODE[0], NAMTAB.LINK[0] > NULL; DO=INDEX[0], ARGUMENT[0] > FALSE; NODIM[0] > 0; TOP=REFSTMT, TOP=REFSN, TOP=SNTAB > 0; GLEVEL[0] > 0; GCONT[0] > NULL; END INITIALIZE=TABLES; RESET=TABLES 14 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* RESETS NAMTAB, REFTAB, AND SNTAB */ TOP=NAMTAB, TOP=SNTAB, TOP=REFSTMT, TOP=REFSN > 0; HEADLIST > NULL; SN=HEADLIST > NULL; GRP=PTR[0] > NULL; END RESET=TABLES; 1 /* *************************************************************** */ /* *************************************************************** */ /* *************************************************************** */ /* 5. C O D E G E N E R A T I O N */ /* IN THIS SECTION ARE PROCEDURES WHICH PERFORM THE */ /* ACTUAL OUTPUTTING OF IBM 360 ASSEMBLY CODE, AND */ /* PROCEDURES WHICH GENERATE CODE TO PERFORM COMMON */ /* RUNTIME FUNCTIONS SUCH AS PROGRAM PROLOGUES AND */ /* EPILOGUES, STACK PUSH AND POP, AND MODE CONVERSION. */ /* ALSO INCLUDED ARE SEVERAL PROCEDURES WHICH */ /* CONVERT NUMBERS INTO STRINGS. THIS IS USEFUL FOR */ /* OUTPUTTING MANY OF THE ASSEMBLY INSTRUCTIONS. */ /* *************************************************************** */ /* *************************************************************** */ /* *************************************************************** */ /* --------------------------------------------------------------- */ /* 5.1 OUTPUT IBM 360 ASSEMBLY CODE */ /* --------------------------------------------------------------- */ OUT 5 ^^ , , 32 , 8 , 20,8,o PROCEDURE [INSTRUCTION]; /* PUTS OUT A GENERATED ASSEMBLY INSTRUCTION */ DECLARE INSTRUCTION CHARACTER[*]; PUT SKIP EDIT [LABEL=FLD, INSTRUCTION] [A, X[1], A]; LABEL=FLD > : :; END OUT; COMMENT=LINE 14 ^^ , , 32 , 8 , 20,8,o PROCEDURE [COMMENT]; GEN=LABEL 11 ^^ , , 32 , 8 , 20,8,o PROCEDURE RETURNS [CHARACTER[8]]; /* GENERATES LABELS FOR ASSEMBLY INSTRUCTIONS */ LABEL=COUNT > LABEL=COUNT < 1; RETURN [ :L: "" CVS=I7[LABEL=COUNT] ]; END GEN=LABEL; /* PUTS OUT A COMMENT */ DECLARE COMMENT CHARACTER[*]; PUT SKIP EDIT [:*:, :* :, COMMENT, :*:] [A, SKIP, A, A, SKIP, A]; END COMMENT=LINE; /* --------------------------------------------------------------- */ /* 5.2 PROLOGUES, EPILOGUE, AND FINALE */ /* --------------------------------------------------------------- */ MAIN=PROLOGUE 15 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* GENERATES THE PROLOGUE CODE FOR THE MAIN PROGRAM */ DECLARE LABELS[1 23 ^^ , , 32 , 8 , 20,8,o20] CHARACTER[8] INITIAL [:R0:, :R1:, :R2:, :R3:, :R4:, :R5:, :R6:, :R7:, :R8:, :R9:, :R10:, :R11:, :R12:, :R13:, :R14:, :R15:, :F0:, :F2:, :F4:, :F6:]; DECLARE OPERANDS[1 25 ^^ , , 32 , 8 , 20,8,o20] CHARACTER[2] INITIAL [:0:, :1:, :2:, :3:, :4:, :5:, :6:, :7:, :8:, :9:, :10:, :11:, :12:, :13:, :14:, :15:, :0:, :2:, :4:, :6:]; PUT PAGE EDIT [:&START:, JOB=COUNT, PROG=COUNT] [A, [2]F[3]]; IF JOB=COUNT > 1 THEN DO; PUT SKIP LIST [://SPASM JOB [B235,605,0.1],: "" :::RONALD MAK:::]; PUT SKIP LIST [:/* SERVICE CLASS>QUICK:]; PUT SKIP LIST [:// EXEC SPASM:]; PUT SKIP LIST [://GO.SYSIN DD *:]; PUT SKIP LIST [:>JOB [RONALD MAK]:]; END; PUT SKIP LIST [:>SPASM NXREF,ERR>4,NFIX,NSYM,NUMAP:]; LABEL=FLD > :BEGIN : ; CALL OUT[:START:]; CALL OUT[:BALR 11,0:]; CALL OUT[:USING *,11:]; CALL COMMENT=LINE[:PROLOGUE [MAIN]:]; /* CODE TO SET UP EQU:S */ DO I > 1 TO 20; LABEL=FLD > LABELS[I]; CALL OUT[:EQU : "" OPERANDS[I]]; END; LABEL=FLD > :*:; CALL OUT[::]; CALL OUT[:STM R14,R12,12[R13]:]; CALL OUT[:LR R12,R13:]; CALL OUT[:LA R13,: "" SAVEAREA]; CALL OUT[:ST R13,8[R12]:]; CALL OUT[:ST R12,4[R13]:]; LABEL=FLD > :*:; CALL OUT[::]; CALL OUT[:L R4,>X::0E000000:::]; CALL OUT[:SPM R4:]; CALL OUT[:SR R10,R10:]; END MAIN=PROLOGUE; SUBPROGRAM=PROLOGUE 21 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* GENERATES THE PROLOGUE CODE FOR A SUBPROGRAM */ CALL COMMENT=LINE[:PROLOGUE [SUBPROGRAM : "" SUBPROGNAME "" :]: ]; LABEL=FLD > SUBPROGNAME; CALL OUT[:B 12[R15]:]; CALL OUT[:DC X::7:::]; CALL OUT[:DC CL7::: "" SUBPROGNAME "" SUBSTR[ : :, 1, 7-LENGTH[SUBPROGNAME] ] "" :::: ]; LABEL=FLD > :*:; CALL OUT[::]; CALL OUT[:STM R14,R15,12[R13]:]; CALL OUT[:STM R4,R9,36[R13]:]; CALL OUT[:LR R12,R13:]; CALL OUT[:LA R13,: "" SAVEAREA]; CALL OUT[:ST R13,8[R12]:]; CALL OUT[:ST R12,4[R13]:]; END SUBPROGRAM=PROLOGUE; EPILOGUE 10 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* GENERATES THE PROGRAM EPILOGUE CODE */ DECLARE [I, J, ARRAYSIZE] FIXED[31,0] BINARY; CALL COMMENT=LINE[:EPILOGUE:]; /* DUMP THE NAME TABLE */ DO I > 1 TO TOP=NAMTAB; IF [CLASS[I] > SIMPLE=VAR] " [CLASS[I] > FUNCTION=NAME] THEN DO; LABEL=FLD > NNAME[I]; IF MODE[I] > RREAL THEN CALL OUT[:DS E:]; ELSE CALL OUT[:DS F:]; END; ELSE IF CLASS[I] > ARRAY=VAR THEN DO; LABEL=FLD > NNAME[I]; /* ALLOCATE ONLY ONE WORD FOR ARGUMENT ARRAYS */ IF ARGUMENT[I] THEN CALL OUT[:DS F:]; ELSE DO; CALL OUT[:DC A[: "" NNAME[I] "" :]: ]; /* CALCULATE THE ARRAY SIZE */ ARRAYSIZE > 1; DO J > 1 TO NODIM[I]; ARRAYSIZE > ARRAYSIZE*DIMENSION[I,J]; END; IF MODE[I] > RREAL THEN CALL OUT[:DS : "" CVS=I[ARRAYSIZE] "" :E:]; ELSE CALL OUT[:DS : "" CVS=I[ARRAYSIZE] "" :F:]; END; END; END; LABEL=FLD > :*:; CALL OUT[::]; LABEL=FLD > SAVEAREA; CALL OUT[:DS 18F:]; /* DO SAVE AREAS */ DO I > 1 TO HIDOLEVEL; LABEL=FLD > :D: "" CVS=I7[I]; CALL OUT[:DS 2F:]; END; /* TEMPORARY VARIABLES */ CALL OUT[:DS 0D:]; LABEL=FLD > :T: "" CVS=I7[1]; CALL OUT[:DC X::4E000000:::]; DO I > 2 TO TEMP=COUNT; LABEL=FLD > :T: "" CVS=I7[I]; CALL OUT[:DS F:]; END; CALL OUT[:SPACE 10:]; END EPILOGUE; FINALE 8 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* GENERATES THE CODE WHICH COMES AT THE END OF A JOB */ CALL COMMENT=LINE[:FINALE:]; /* DUMMY VARIABLES */ LABEL=FLD > :INTG$VAR:; CALL OUT[:DS F:]; LABEL=FLD > :REAL$VAR:; CALL OUT[:DS E:]; LABEL=FLD > :XXXX$VAR:; CALL OUT[:DS F:]; CALL OUT[:SPACE 1:]; CALL OUT[:LTORG:]; CALL OUT[:SPACE 1:]; /* THE STACK */ LABEL=FLD > :STACK: ; CALL OUT[:DS 32F:]; CALL OUT[:END BEGIN:]; PUT SKIP LIST [:>GO:]; PUT SKIP EDIT [:&END :, JOB=COUNT, PROG=COUNT] [A, [2]F[3]]; END FINALE; /* --------------------------------------------------------------- */ /* 5.3 STACK PUSH AND POP */ /* --------------------------------------------------------------- */ PUSHV 7 ^^ , , 32 , 8 , 20,8,o PROCEDURE [OPRND]; /* GENERATES CODE TO PUSH A VARIABLE ONTO THE STACK */ DECLARE OPRND CHARACTER[*] VARYING; IF CURMODE > INTEGER THEN DO; CALL OUT[:LA R10,4[R10]:]; CALL OUT[:ST R3,STACK[R10]:]; CALL OUT[:L R3,: "" OPRND]; END; ELSE DO; CALL OUT[:LA R10,4[R10]:]; CALL OUT[:STE F2,STACK[R10]:]; CALL OUT[:LE F2,: "" OPRND]; END; END PUSHV; PUSHI 7 ^^ , , 32 , 8 , 20,8,o PROCEDURE [OPRND]; /* GENERATES CODE TO PUSH AN INTEGER ONTO THE STACK */ DECLARE OPRND FIXED[31,0] BINARY; CALL OUT[:LA R10,4[R10]:]; CALL OUT[:ST R3,STACK[R10]:]; CALL OUT[:L R3,>F::: "" CVS=I[OPRND] "" ::::]; END PUSHI; PUSHR 7 ^^ , , 32 , 8 , 20,8,o PROCEDURE [OPRND]; /* GENERATES CODE TO PUSH A REAL NUMBER ONTO THE STACK */ DECLARE OPRND FLOAT BINARY; CALL OUT[:LA R10,4[R10]:]; CALL OUT[:STE F2,STACK[R10]:]; CALL OUT[:LE F2,>E::: "" CVS=R[OPRND] "" ::::]; END PUSHR; POP 5 ^^ , , 32 , 8 , 20,8,o PROCEDURE [POPMODE]; /* GENERATES CODE TO POP THE STACK */ DECLARE POPMODE FIXED BINARY; IF POPMODE > INTEGER THEN CALL OUT[:L R3,STACK[R10]:]; ELSE CALL OUT[:LE F2,STACK[R10]:]; CALL OUT[:S R10,>F::4:::]; END POP; /* --------------------------------------------------------------- */ /* 5.4 MODE CONVERSION [INTEGER AND REAL] */ /* --------------------------------------------------------------- */ FLOATTOFIX 12 ^^ , , 32 , 8 , 20,8,o PROCEDURE [FS, RD]; /* GENERATES CODE TO CONVERT FROM REAL MODE TO INTEGER */ DECLARE [FS, /* SOURCE REGISTER [REAL] */ RD] /* DESTINATION REGISTER [INTEGER] */ CHARACTER[*]; DECLARE [LABEL1, TEMP2, TEMP3] CHARACTER[8]; LABEL1 > GEN=LABEL; TEMP2 > :T: "" CVS=I7[2]; TEMP3 > :T: "" CVS=I7[3]; CALL OUT[:LD F4,>D::0:::]; CALL OUT[:LPER F4,: "" FS]; CALL OUT[:AW F4,>X::4E00000000000000:::]; CALL OUT[:STD F4,: "" TEMP2]; CALL OUT[:L : "" RD "" :,: "" TEMP3]; CALL OUT[:LTER : "" FS "" :,: "" FS]; CALL OUT[:BNM : "" LABEL1]; CALL OUT[:LCR : "" RD "" :,: "" RD]; LABEL=FLD > LABEL1; CALL OUT[:NOP 0:]; END FLOATTOFIX; FIXTOFLOAT 12 ^^ , , 32 , 8 , 20,8,o PROCEDURE [RS, FD]; /* GENERATES CODE TO CONVERT FROM INTEGER MODE TO REAL */ DECLARE [RS, /* SOURCE REGISTER [INTEGER] */ FD] /* DESTINATION REGISTER [REAL] */ CHARACTER[*]; CALL OUT[:ST : "" RS "" :,T: "" CVS=I7[2]]; CALL OUT[:LD : "" FD "" :,T: "" CVS=I7[1]]; CALL OUT[:AD : "" FD "" :,>D::0:::]; END FIXTOFLOAT; /* --------------------------------------------------------------- */ /* 5.5 CONVERT TO STRING */ /* --------------------------------------------------------------- */ CVS=R 7 ^^ , , 32 , 8 , 20,8,o PROCEDURE [RNO] RETURNS [CHARACTER[13] VARYING]; /* CONVERTS A REAL NUMBER INTO A STRING */ DECLARE RNO FLOAT BINARY; DECLARE STRNO CHARACTER[13] VARYING; PUT STRING[STRNO] EDIT [RNO] [E[13,6]]; /* RETURN STRING WITHOUT LEADING BLANKS */ IF RNO \> 0 THEN RETURN [ SUBSTR[STRNO, 2] ]; ELSE RETURN [STRNO]; END CVS=R; CVS=I 7 ^^ , , 32 , 8 , 20,8,o PROCEDURE [INTNO] RETURNS [CHARACTER[11] VARYING]; /* CONVERTS AN INTEGER INTO A STRING */ DECLARE INTNO FIXED[31,0] BINARY; DECLARE STRNO CHARACTER[11] VARYING; PUT STRING[STRNO] EDIT [INTNO] [F[6]]; /* RETURN STRING WITHOUT LEADING BLANKS */ RETURN [ SUBSTR[STRNO, VERIFY[STRNO, : :]] ]; END CVS=I; CVS=I3 8 ^^ , , 32 , 8 , 20,8,o PROCEDURE [INTNO] RETURNS [CHARACTER[3]]; /* CONVERTS A SMALL INTEGER INTO A 3-CHARACTER STRING */ /* WITH LEADING ZEROES */ DECLARE INTNO FIXED BINARY; DECLARE STRNO CHARACTER[3]; PUT STRING[STRNO] EDIT [INTNO] [F[3]]; /* INSERT THE LEADING ZEROES */ DO I > 1 TO 3 WHILE [SUBSTR[STRNO, I, 1] > : :]; SUBSTR[STRNO, I, 1] > :0:; END; RETURN [STRNO]; END CVS=I3; CVS=I7 8 ^^ , , 32 , 8 , 20,8,o PROCEDURE [INTNO] RETURNS [CHARACTER[7]]; /* CONVERTS AN INTEGER INTO A 7-CHARACTER STRING WHERE THE */ /* FIRST TWO CHARACTERS ARE THE PROGRAM NUMBER */ DECLARE INTNO FIXED[31,0] BINARY; DECLARE STRNO CHARACTER[7]; PUT STRING[STRNO] EDIT [100000*PROG=COUNT < INTNO] [F[7]]; IF PROG=COUNT ) 10 THEN SUBSTR[STRNO, 1, 1] > :0: ; RETURN [STRNO]; END CVS=I7; 1 /* *************************************************************** */ /* *************************************************************** */ /* *************************************************************** */ /* 6. E R R O R H A N D L I N G */ /* THE PROCEDURES IN THIS SECTION HANDLE VARIOUS */ /* ASPECTS OF ERROR RECOVERY. PROCEDURE ERR PRINTS ERROR */ /* MESSAGES. PROCEDURES SN=REF=ERRORS AND */ /* SUBPROG=ERRORS CHECK THE TABLES CREATED IN SECTION 4. */ /* PROCEDURE LOGIC=ERR GENERATES CODE FOR RUNTIME */ /* FIXUPS OF ERRORS ARISING FROM IMPROPERLY MIXING */ /* LOGICAL AND ARITHMETIC EXPRESSIONS. THE OTHER */ /* PROCEDURES REPRESENT LAST-RESORT MEASURES -- THEY */ /* SKIP OVER PARTS OF THE SOURCE CODE. */ /* *************************************************************** */ /* *************************************************************** */ /* *************************************************************** */ ERR 5 ^^ , , 32 , 8 , 20,8,o PROCEDURE [MESSAGE]; /* PRINTS THE COMPILE-TIME ERROR MESSAGES */ DECLARE MESSAGE /* THE ERROR MESSAGE */ CHARACTER[*]; DECLARE PTR FIXED BINARY; PTR > MAX[CARD=PTR - 10, 1]; PUT SKIP EDIT [:********** ERROR -- (:, SUBSTR[CARD, PTR, CARD=PTR - PTR], :( [:, CARD=PTR, :] -- :, MESSAGE] [ [3]A, F[2], [2]A ]; END ERR; SN=REF=ERRORS 15 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* CHECKS FOR STATEMENT NUMBER REFERENCE ERRORS */ DECLARE [STNUMBER, /* THE STMT NO. BEING REFERENCED */ SNGCOUNT, /* THE GROUP COUNT OF SAME */ L, LL, LLL, /* VARIOUS LINKS */ GRP, G, NOCONT] FIXED BINARY; DECLARE /* THE LIST OF STMT GRPS WHICH CONTAINS A */ /* GIVEN STMT GRP */ CONTGRPS[1 25 ^^ , , 32 , 8 , 20,8,oMAXLEVEL] FIXED BINARY; DECLARE ERRFLAG BIT[1]; DECLARE SEQUENCE CHARACTER[3]; BANNER 13 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* PUTS OUT THE ERROR MESSAGE HEADER */ PUT SKIP[5] LIST [:********** ERRORS IN STMT NO. REFS.:]; PUT SKIP; ERRFLAG > FALSE; END BANNER; ERRFLAG > TRUE; /* CHECK EACH STATEMENT GROUP IN TURN */ DO GRP > 0 TO GRP=COUNT; IF GRP=PTR[GRP] > NULL THEN GO TO NEXT=ITERATION; /* CONSTRUCT IN DESCENDING ORDER THE LIST */ /* OF CONTAINING STATEMENT GROUPS */ NOCONT > 1; G, CONTGRPS[1] > GRP; DO WHILE [G _> 0]; NOCONT > NOCONT < 1; G > GCONT[G]; CONTGRPS[NOCONT] > G; END; /* LINK L RUNS DOWN REFSTMT OF REFTAB */ L > GRP=PTR[GRP]; DO WHILE [L _> NULL]; SEQUENCE > CVS=I3[SEQNUM[L]]; /* LINK LL RUNS DOWN REFSN OF REFTAB */ LL > SEQ=PTR[L]; DO WHILE [LL _> NULL]; /* LINK LLL POINTS INTO SNTAB FROM REFSN */ LLL > SN=PTR[LL]; STNUMBER > SNTAB.STMTNUM[LLL]; /* IS THE REFERENCED STMT NO. DEFINED+ */ IF _SN=DEFINED[LLL] THEN DO; IF ERRFLAG THEN CALL BANNER; PUT SKIP EDIT [:IN SEQ :, SEQUENCE, : 33 ^^ , , 32 , 8 , 20,8,o REFERENCE TO UNDEFINED STMT NO.:, STNUMBER] [X[5], [3]A, F[6]]; END; ELSE DO; /* IS IT AN INVALID REFERENCE INTO A */ /* NON-CONTAINING STMT GRP+ */ SNGCOUNT > SN=GCOUNT[LLL]; DO I > 1 TO NOCONT WHILE [SNGCOUNT ) CONTGRPS[I]]; END; IF SNGCOUNT \ CONTGRPS[I] THEN DO; IF ERRFLAG THEN CALL BANNER; PUT SKIP EDIT [:IN SEQ :, SEQUENCE, : 38 ^^ , , 32 , 8 , 20,8,o INVALID REFERENCE TO STMT NO.:, STNUMBER] [X[5], [3]A, F[6]]; END; END; LL > REFSN.LINK[LL]; END; L > REFSTMT.LINK[L]; END; NEXT=ITERATION 26 ^^ , , 32 , 8 , 20,8,o ; END; END SN=REF=ERRORS; SUBPROG=ERRORS 16 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* CHECKS FOR MISSING SUBPROGRAMS */ DECLARE I FIXED BINARY; DECLARE ERRFLAG BIT[1]; ERRFLAG > TRUE; DO I > 2 TO PROG=COUNT; IF _SP=DEFINED[I] THEN DO; IF ERRFLAG THEN DO; PUT SKIP[5] LIST [:********** MISSING SUBPROGS 68 ^^ , , 32 , 8 , 20,8,o:]; ERRFLAG > FALSE; END; PUT DATA [SPNAME[I]]; END; END; END SUBPROG=ERRORS; LOGIC=ERR 11 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* REPLACES THE VALUE OF AN ARITHMETIC EXPRESSION WITH THE LOGICAL */ /* VALUE .FALSE. */ CALL ERR[MXMDLOGC]; IF CURMODE > INTEGER THEN CALL OUT[:SR R3,R3:]; ELSE DO; CALL OUT[:LE F2,STACK[R10]:]; CALL OUT[:ST R3,STACK[R10]:]; CALL OUT[:SR R3,R3:]; END; ARITHMETIC > FALSE; END LOGIC=ERR; SKIP=SUBSCRIPT 16 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* SKIPS OVER A SUBSCRIPT */ DO WHILE [ [TOKEN _> COMMA] & [TOKEN _> STMTEND] ]; CALL GET=TOKEN; END; END SKIP=SUBSCRIPT; SKIP=SUBSCRIPTLIST 20 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* SKIPS OVER A SUBSCRIPT LIST */ DO WHILE [ [TOKEN _> RPAREN] & [TOKEN _> STMTEND] ]; CALL GET=TOKEN; END; END SKIP=SUBSCRIPTLIST; FLUSH=STATEMENT 17 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* FLUSHES A STATEMENT */ CALL ERR[FLUSHSTM]; IF TOKEN _> STMTEND THEN DO; CALL NEXT=CARD; TOKEN > STMTEND; END; DO WHILE [CONTINUATION]; CALL NEXT=CARD; END; END FLUSH=STATEMENT; FIND=PROGRAM=END 18 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* FLUSHES CARDS TO THE PROGRAM END */ CALL ERR[FLUSHPGM]; DO WHILE [_ENDPROG]; CALL NEXT=CARD; END; END FIND=PROGRAM=END; CRASH 7 ^^ , , 32 , 8 , 20,8,o PROCEDURE; /* FORCES THE END-OF-PROGRAM CONDITION */ ENDPROG > TRUE; PUT SKIP[2] LIST [:********** COMPILER CRASHED. WILL ATTEMPT : "" :A SAFE RECOVERY. **********:]; PUT SKIP; END CRASH; END MAIN=BLOCK; END FORTRAN; /* // *DATA $FORTRANM C MULTIPLICATION TABLE C INTEGER MATRIX[5, 5]; C C INITIALIZE THE FIRST ROW AND COLUMN DO 10 N > 1, 5 MATRIX[1,N] > N MATRIX[N,1] > N 10 CONTINUE C C CALCULATE THE BODY OF THE TABLE DO 30 IR > 2, 5 DO 20 IC > 2, 5 MATRIX[IR,IC] > MATRIX[1,IC]*MATRIX[IR,1] 20 CONTINUE 30 CONTINUE C C PRINT THE TABLE DO 50 IR > 1, 5 DO 40 IC > 1, 5 M > MATRIX[IR,IC] PRINT, IR, IC, M 40 CONTINUE 50 CONTINUE C STOP END $END $FORTRANM C TEST OF ABS AND SQRT C FUNCTION TEST C EXTERNAL ABS, SQRT REAL I C DO 10 FOR I > 1.0, -4.0, -9.0, 16.0 A > ABS[I] PRINT, I, A X > SQRT[A] PRINT, X Y > SQRT[ ABS[I] ]; 10 PRINT, I, X, Y C STOP END $ FUNCTION ABS[Q] Z > Q IF [Z .LT. 0.0] Z > -Z ABS > Z RETURN END $ FUNCTION SQRT[A] EXTERNAL ABS X > A XOLD > 999999.0 DELTA > 999999.0 C DO 10 UNTIL [ DELTA .LT. 0.000001*X ] X > [X < A/X]/2.0 DELTA > ABS[ [X - XOLD] ] 10 XOLD > X C SQRT > X RETURN END $END $FORTRANM C SUBROUTINE TEST C TESTS THE CALL-BY-REFERENCE AND CALL-BY-VALUE FACILITIES C I > 1 J > 2 K > 3 C PRINT, I, J, K CALL ADD[I, J, [K], 5, -J<4] PRINT, I, J, K C M > 0 C CALL ADD[M, 123 C PRINT, N CALL ADD[ [N], 1, 2, 3, 4 ] PRINT, N C STOP END $ SUBROUTINE ADD[I, J, K, L, M] I > I < J < K < L < M RETURN END $END $FORTRANM C THREE-DIGIT NUMBERS EQUAL TO THE C SUM OF THE CUBES OF THEIR DIGITS C INTEGER HUNS, TENS, ONES, PARSUM, PARNUM C DO 30 HUNS > 1, 9 DO 20 TENS > 1, 9 PARSUM > HUNS**3 < TENS**3 PARNUM > 100*HUNS < 10*TENS IF [PARSUM .GT. PARNUM] EXIT DO 10 ONES > 0, 9, 1 SUM > PARSUM < ONES**3 NUMBER > PARNUM < ONES IF [SUM .GT. NUMBER] EXIT IF [SUM .EQ. NUMBER] PRINT, SUM, NUMBER 10 CONTINUE 20 CONTINUE 30 CONTINUE C STOP END $END $FORTRANM C PRIME NUMBERS LESS THAN 100 C AS FOUND BY BRUTE FORCE C C CHEAT ON THE FIRST TWO NUMBER > 2 PRINT, NUMBER NUMBER > 3 PRINT, NUMBER C C TEST ODD NUMBERS DO 20 NUMBER > 5, 100, 2 IFACT1 > 3 C DO 10 ITERATE C C 1ST TEST SUCCESSFUL 36 ^^ , , 32 , 8 , 20,8,o PRIME C 2ND TEST SUCCESSFUL 36 ^^ , , 32 , 8 , 20,8,o COMPOSITE C O T H E R W I S E 36 ^^ , , 32 , 8 , 20,8,o DONT:T KNOW YET C IF [IFACT1 .GT. IFACT2] THEN PRINT, NUMBER NEXT 1 C ELSE IF [NUMBER .EQ. IFACT1*IFACT2] NEXT 1 C 10 CONTINUE 20 CONTINUE C STOP END $END $FORTRANM C NEWTON:S ALGORITHM FOR FINDING SQUARE ROOTS C GIVEN A , FIND X > SQRT[A] USING THE C ITERATIVE FORMULA X > [X < A/X]/2 C DO 60 FOR A > 1.0, 4.0, -9.0, 16.0, 25.0 X > A XOLD > 999.999 DELTA > 987654. ICOUNT > 0 C DO 30 EVENT [40, 50] C EVENT 40 32 ^^ , , 32 , 8 , 20,8,o CONVERGENCE C EVENT 50 32 ^^ , , 32 , 8 , 20,8,o NO CONVERGENCE IF [DELTA .LT. 0.000001*X] CAUSE 40 IF [ICOUNT .EQ. 5] CAUSE 50 ICOUNT > ICOUNT < 1 X > [X < A/X]/2.0 DELTA > XOLD - X IF [DELTA .LT. 0.0] DELTA > -DELTA XOLD > X 30 CONTINUE C C EVENT 40 20 ^^ , , 32 , 8 , 20,8,o CONVERGENCE 40 PRINT, A, X, ICOUNT C C EVENT 50 20 ^^ , , 32 , 8 , 20,8,o NO CONVERGENCE 50 PRINT, A, X, ICOUNT, DELTA C FIN C 60 CONTINUE STOP END $END $FORTRANM C COMPUTED GO TO " CASE STATEMENT TEST C N0 > 0 N1 > 1 N2 > 2 N3 > 3 N4 > 4 N5 > 5 N6 > 6 N7 > 7 C DO 100 FOR I > 0, 1, 2, -5, -6, 5, -1, 6 C C NOTE THAT "I<1" GOES 32 ^^ , , 32 , 8 , 20,8,o 1, 2, 3, 4, 5, 6, 0, 7 GO TO [10, 20, 30, 40, 50, 60, 70], I<1 C GO TO 101 10 PRINT, N1 20 PRINT, N2 30 PRINT, N3 40 PRINT, N4 50 PRINT, N5 60 PRINT, N6 70 PRINT, N7 100 CONTINUE C 101 DO 200 FOR K > 3, 5, 7, 1, 9 CASE [ [K-1]/2 ] OF [111, 112, 113, 114] 113 PRINT, N3 111 PRINT, N1 112 PRINT, N2 114 PRINT, N4 FIN 200 CONTINUE STOP END $END $FORTRANM C EXIT " NEXT STATEMENT TEST C DO 40 I > 1000, 5000, 1000 DO 30 J > 100, 500, 100 DO 20 K > 1, 5 C PRINT, I, J, K C IF [I .EQ. 2] NEXT 2 IF [I .EQ. 4] EXIT 2 C IF [J .EQ. 2] NEXT 1 IF [J .EQ. 4] EXIT 1 C IF [K .EQ. 2] NEXT IF [K .EQ. 4] EXIT C DO 10 L > 3, 1, -1 PRINT, L 10 CONTINUE 20 CONTINUE 30 CONTINUE 40 CONTINUE STOP END $END $FORTRANM C FIBONACCI SEQUENCE BY DEFINITION AND BY FORMULA C C DUMMY STARTER VALUES FOR DEFINITION I > -1 J > 1 C C NAMED CONSTANTS FOR FORMULA SQRT5 > 2.236068 COEF > SQRT5/5.0 BASE1 > [1.0 < SQRT5]/2.0 BASE2 > [1.0 - SQRT5]/2.0 C DO 10 N > 1, 25 C C BY DEFINITION IFIB > I < J C C BY FORMULA FIB > COEF*[BASE1**N - BASE2**N] C PRINT, N, IFIB, FIB C I > J J > IFIB C 10 CONTINUE C STOP END $END $FORTRANM C SOLVE THE SYSTEM 2X - 3Y > 7 C 3X < 5Y > 1 C BY CRAMER:S RULE C REAL A[2,2], B[2], DETB[2] C C THE COEFFICIENT MATRIX A[1,1] > 2.0 A[1,2] > -3.0 A[2,1] > 3.0 A[2,2] > 5.0 C C THE RIGHT HAND SIDE B[1] > 7.0 B[2] > 1.0 C C CALCULATE THE DETERMINANT OF A DETA > DET[A] C C CONSECUTIVELY FOR EACH COLUMN OF A 43 ^^ , , 32 , 8 , 20,8,o SWAP WITH B , C CALCULATE THE DETERMINANT OF THE RESULTING MATRIX, C AND SWAP THE COLUMN BACK IN C DO 10 IC > 1, 2 C C SWAP OUT CALL SWAP[A, B, IC] C DETB[IC] > DET[A] C C SWAP BACK IN CALL SWAP[A, B, IC] C 10 CONTINUE C C SOLVE X > DETB[1]/DETA Y > DETB[2]/DETA PRINT, X, Y C STOP END $ FUNCTION DET[D] C DIMENSION D[2,2] C C RETURN THE VALUE OF THE DETERMINANT OF D C DET > D[1,1]*D[2,2] - D[1,2]*D[2,1] PRINT, DET C END $ SUBROUTINE SWAP[MATRIX, VECTOR, N] C REAL MATRIX[2,2], VECTOR[2] C C SWAP THE NTH COLUMN OF MATRIX AND VECTOR C DO 10 IR > 1, 2 TEMP > MATRIX[IR,N] MATRIX[IR,N] > B[IR] 10 B[IR] > TEMP C END $END //PROGRAMS JOB [B235,605,FREE],:RONALD MAK: /* KEY>MML /* SERVICE CLASS>QUICK // EXEC PLC //GO.SYSIN DD * *PL/C LISTER 8 ^^ , , 32 , 8 , 20,8,o PROC OPTIONS[MAIN]; DCL CARD CHAR[80]; DO I > 3 TO 1000; GET EDIT [CARD] [COL[1], A[80]]; PUT SKIP EDIT [I, CARD] [F[3], X[2], A]; END; END LISTER; *DATA /* //