From 283bfd0e1f86996a4a4b91dc6d7ffb957b9e2a0b Mon Sep 17 00:00:00 2001 From: Paul Kimpel Date: Mon, 24 Jun 2013 14:32:08 +0000 Subject: [PATCH] Commit initial version of Mark XVI FORTRAN compiler to source control. Transcribed and generously donated to the project by Fausto Saporito of Naples, Italy. --- SYMBOL/FORTRAN.alg_m | 8264 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 8264 insertions(+) create mode 100644 SYMBOL/FORTRAN.alg_m diff --git a/SYMBOL/FORTRAN.alg_m b/SYMBOL/FORTRAN.alg_m new file mode 100644 index 0000000..a2ac57e --- /dev/null +++ b/SYMBOL/FORTRAN.alg_m @@ -0,0 +1,8264 @@ + 00000000 +% F O R T R A N C O M P I L E R XVI.0.00 10/01/74 00001000 + COMMENT: | TITLE: B5500/B5700 MARK XVI SYSTEM RELEASE | + | FILE ID: SYMBOL/FORTRAN TAPE ID: SYMBOL1/FILE000 | + | THIS MATERIAL IS PROPRIETARY TO BURROUGHS CORPORATION | + | AND IS NOT TO BE REPRODUCED, USED, OR DISCLOSED | + | EXCEPT IN ACCORDANCE WITH PROGRAM LICENSE OR UPON | + | WRITTEN AUTHORIZATION OF THE PATENT DIVISION OF | + | BURROUGHS CORPORATION, DETROIT, MICHIGAN 48232 | + | | + | COPYRIGHT (C) 1971, 1972, 1974 | + | BURROUGHS CORPORATION | + | AA320206 AA393180 AA332366 |; +% BEWARE ALL YE WHO SEEK HEREIN: %997- +% THIS COMPILER IS A MESS. THE CONCEPTS OF CHARACTER CONVERSION FROM +% HOLLERITH (= EBCDIC), SCANNING, AND PARSING ARE NOT CLEARLY SEPARATED +% IN THE CODE, FOR EXAMPLE, PROCEDURE "SCAN" TRIES TO DO ALL 3 AT ONCE. +% DAN ROSS UCSC APRIL 12, 1977 +COMMENT + FORTRAN ERROR MESSAGES 00002000 +000 SYNTAX ERROR 00003000 +001 MISSING OPERATOR OR PUNCTUATION 00004000 +002 CONFLICTING COMMON AND/OR EQUIVALENCE ALLOCATION 00005000 +003 MISSING RIGHT PARENTHESIS 00006000 +004 ENTRY STMT ILLEGAL IN MAIN PGM OR BLOCK DATA 00007000 +005 MISSING END STATEMENT 00008000 +006 ARITHMETIC EXPRESSION REQUIRED 00009000 +007 LOGICAL EXPRESSION REQUIRED 00010000 +008 TOO MANY LEFT PARENTHESES 00011000 +009 TOO MANY RIGHT PARENTHESES 00012000 +010 FORMAL PARAMETER ILLEGAL IN COMMON 00013000 +011 FORMAL PARAMETER ILLEGAL IN EQUIVALENCE 00014000 +012 THIS STATEMENT ILLEGAL IN BLOCK DATA SUBPROGRAM 00015000 +013 INFO ARRAY OVERFLOW 00016000 +014 IMPROPER DO NEST 00017000 +015 DO LABEL PREVIOUSLY DEFINED 00018000 +016 UNRECOGNIZED STATEMENT TYPE 00019000 +017 ILLEGAL DO STATEMENT 00020000 +018 FORMAT STATEMENT MUST HAVE LABEL 00021000 +019 UNDEFINED LABEL 00022000 +020 MULTIPLE DEFINITION 00023000 +021 ILLEGAL IDENTIFIER CLASS IN THIS CONTEXT 00024000 +022 UNPAIRED QUOTES IN FORMAT 00025000 +023 NOT ENOUGH SUBSCRIPTS 00026000 +024 TOO MANY SUBSCRIPTS 00027000 +025 FUNCTION OR SUBROUTINE PREVIOUSLY DEFINED 00028000 +026 FORMAL PARAMETER MULTIPLY DEFINED IN HEADING 00029000 +027 ILLEGAL USE OF NAMELIST 00030000 +028 NUMBER OF PARAMETERS INCONSISTENT 00031000 +029 CANNOT BRANCH TO FORMAT STATEMENT 00032000 +030 SUBROUTINE OR FUNCTION NOT DEFINED IN PROGRAM 00033000 +031 IDENTIFIER ALREADY GIVEN TYPE 00034000 +032 ILLEGAL FORMAT SYNTAX 00035000 +033 INCORRECT USE OF FILE 00036000 +034 INCOSISTENT USE OF IDENTIFIER 00037000 +035 ARRAY IDENTIFIER EXPECTED 00038000 +036 EXPRESSION VALE REQUIRED 00039000 +037 ILLEGAL FILE CARD SYNTAX 00040000 +038 ILLEGAL CONTROL ELEMENT 00041000 +039 DECLARATION MUST PRECEDE FIRST REFERENCE 00042000 +040 INCONSISTENT USE OF LABEL AS PARAMETER 00043000 +041 NO. OF PARAMS, DISAGREES WITH PREV, REFERENCE 00044000 +042 ILLEGAL USE OF FORMAL PARAMETER 00045000 +043 ERROR IN HOLLERITH LITERAL CHARACTER COUNT 00046000 +044 ILLEGAL ACTUAL PARAMETER 00047000 +045 TOO MANY SEGMENTS IN SOURCE PROGRAM 00048000 +046 TOO MANY PRT ASSIGNMENTS IN SOURCE PROGRAM 00049000 +047 LAST BLOCK DECLARATION HAD LESS THAN 1024 WORDS 00050000 +048 ILLEGAL I/O LIST ELEMENT 00051000 +049 LEFT SIDE MUST BE SIMPLE OR SUBSCRIPTED VARIABLE 00052000 +050 VARIABLE EXPECTED 00053000 +051 ILLEGAL USE OF .OR. 00054000 +052 ILLEGAL USE OF .AND. 00055000 +053 ILLEGAL USE OF .NOT. 00056000 +054 ILLEGAL USE OF RELATIONAL OPERATOR 00057000 +055 ILLEGAL MIXED TYPES 00058000 +056 ILLEGAL EXPRESSION STRUCTURE 00059000 +057 ILLEGAL PARAMETER 00060000 +058 RECORD BLOCK GREATER THAN 1023 00061000 +059 TOO MANY OPTIONAL FILES 00062000 +060 FILE CARDS MUST PRECEDE SOURCE DECK 00063000 +061 BINARY WRITE STATEMENT HAS NO LIST 00064000 +062 UNDEFINED FORMAT NUMBER 00065000 +063 ILLEGAL EXPONENT IN CONSTANT 00066000 +064 ILLEGAL CONSTANT IN DATA STATEMENT 00067000 +065 MAIN PROGRAM MISSING 00068000 +066 PARAMETER MUST BE ARRAY IDENTIFIER 00069000 +067 PARAMETER MUST BE EXPRESSION 00070000 +068 PARAMETER MUST BE LABEL 00071000 +069 PARAMETER MUST BE FUNCTION IDENTIFIER 00072000 +070 PARAMETER MUST BE FUNCTION OR SUBROUTINE ID 00073000 +071 PARAMETER MUST BE SUBROUTINE IDENTIFIER 00074000 +072 PARAMETER MUST BE ARRAY IDENTIFIER OR EXPRESSION 00075000 +073 ARITHMETIC - LOGICAL CONFLICT ON STORE 00076000 +074 ARRAYID MUST BE SUBSCRIPTED IN THIS CONTEXT 00077000 +075 MORE THAN ONE MAIN PROGRAM 00078000 +076 ONLY COMMON ELEMENTS PERMITTED 00079000 +077 TOO MANY FILES 00080000 +078 FORMAT OR NAMELIST TOO LONG 00081000 +079 FORMAL PARAMETER MUST BE ARRAY IDENTIFIER 00082000 +080 FORMAL PARAMETER MUST BE SIMPLE VARIABLE 00083000 +081 FORMAL PARAMETER MUST BE FUNCTION IDENTIFIER 00084000 +082 FORMAL PARAMETER MUST BE SUBROUTINE IDENTIFIER 00085000 +083 FORMAL PARAMETER MUST BE FUNCTION OR SUBROUTINE 00086000 +084 DO OR IMPLIED DO INDEX MUST BE INTEGER OR REAL 00087000 +085 ILLEGAL COMPLEX CONSTANT 00088000 +086 ILLEGAL MIXED TYPE STORE 00089000 +087 CONSTANT EXCEEDS HARDWARE LIMITS 00090000 +088 PARAMETER TYPE CONFLICTS WITH PREVIOUS USE 00091000 +089 COMPLEX EXPRESSION ILLEGAL IN IF STATEMENT 00092000 +090 COMPLEX EXPRESSION ILLEGALE IN RELATION 00093000 +091 TOO MANY FORMATS REFERENCED BUT NOT YET FOUND 00094000 +092 VARIABLE ARRAY BOUND MUST BE FORMAL VARIABLE 00095000 +093 ARRAY BOUND MUST HAVE INTEGER OR REAL TYPE 00096000 +094 COMMA OR RIGHT PARENTHESIS EXPECTED 00097000 +095 ARRAY ALREADY GIVEN BOUNDS 00098000 +096 ONLY FORMAL ARRAYS MAY BE GIVEN VARIABLE BOUNDS 00099000 +097 MISSING LEFT PARENTHESIS IN IMPLIED DO 00100000 +098 SUBSCRIPT MUST BE INTEGER OR REAL 00101000 +099 ARRAY SIZE CANNOT EXCEED 32767 WORDS 00102000 +100 COMMON OR EQUIV BLOCK CANNOT EXCEED 32767 WORDS 00103000 +101 THIS STATEMENT ILLEGAL IN LOGICAL IF 00104000 +102 REAL OR INTEGER TYPE REQUIRED 00105000 +103 ARRAY BOUND INFORMATION REQUIRED 00106000 +104 REPLACEMENT OPERATOR EXPECTED 00107000 +105 IDENTIFIER EXPECTED 00108000 +106 LEFT PARENTHESIS EXPECTED 00109000 +107 ILLEGAL FORMAL PARAMETER 00110000 +108 RIGHT PARENTHESIS EXPECTED 00111000 +109 STATEMENT NUMBER EXPECTED 00112000 +110 SLASH EXPECTED 00113000 +111 ENTRY STATEMENT CANNOT START PROGRAM UNIT 00114000 +112 ARRAY MUST BE DIMENSIONED PRIOR TO EQUIV STMT 00115000 +113 INTEGER CONSTANT EXPECTED 00116000 +114 COMMA EXPECTED 00117000 +115 SLASH OR END OF STATEMENT EXPECTED 00118000 +116 FORMAT, ARRAY OR NAMELIST EXPECTED 00119000 +117 END OF STATEMENT EXPECTED 00120000 +118 IO STATEMENT WITH NAMELIST CANNOT HAVE IO LIST 00121000 +119 COMMA OR END OF STATEMENT EXPECTED 00122000 +120 STRING TOO LONG 00123000 +121 MISSING QUOTE AT END OF STRING 00124000 +122 ILLEGAL ARRAY BOUND 00125000 +123 TOO MANY HANGING BRANCHES 00126000 +124 TOO MANY COMMON OR EQUIVALENCE ELEMENTS 00127000 +125 ASTERISK EXPECTED 00128000 +126 COMMA OR SLASH EXPECTED 00129000 +127 DATA SET TOO LARGE 00130000 +128 TOO MANY ENTRY STATEMENTS IN THIS SUBPROGRAM 00131000 +129 DECIMAL WIDTH EXCEEDS FIELD WIDTH 00132000 +130 UNSPECIFIED FIELD WIDTH 00133000 +131 UNSPECIFIED SCALE FACTOR 00134000 +132 ILLEGAL FORMAT CHARACTER 00135000 +133 UNSPECIFIED DECIMAL FIELD 00136000 +134 DECIMAL FIELD ILLEGAL FOR THIS SPECIFIER 00137000 +135 ILLEGAL LABEL 00138000 +136 UNDEFINED NAMELIST 00139000 +137 MULTIPLY DEFINED ACTION LABELS 00140000 +138 TOO MANY NESTED DO STATEMENTS 00141000 +139 STMT FUNCTION ID AND EXPRESSION DISAGREE IN TYPE 00142000 +140 ILLEGAL USE OF STATEMENT FUNCTION 00143000 +141 UNRECOGNIZED CONSTRUCT +142 RETURN, STOP OR CALL EXIT REQUIRED IN SUBPROGRAM +143 FORMAT NUMBER USED PREVIOUSLY AS LABEL +144 LABEL USED PREVIOUSLY AS FORMAT NUMBER +145 NON-STANDARD RETURN REQUIRES LABEL PARAMETERS +146 DOUBLE OR COMPLEX REQUIRES EVEN OFFSET +147 FORMAL PARAMETER ILLEGAL IN DATA STATEMENT +148 TOO MANY LOCAL VARIABLES IN SOURCE PROGRAM +149 A $FREEFORM SOURCE LINE MUST HAVE < 67 COLS +150 A HOL/STRING UNDER $FREEFORM MUST BE ON ONE LINE +151 THIS CONSTRUCT IS ILLEGAL IN TSS FORTRAN +152 ILLEGAL FILE CARD PARAMETER VALUE +153 RETURN IN MAIN PROGRAM NOT ALLOWED +154 NON-POSITIVE SUBSCRIPTS ARE ILLEGAL +155 NON-IDENTIFIER USED FOR NAME OF LIBRARY ROUTINE +156 HYPHEN EXPECTED +157 SEQUENCE NUMBER EXPECTED +158 TOO MANY RECURSIVE CALLS ON LIBRARY ROUTINES +159 ASTERISK NOT ALLOWED IN READ STATEMENT +160 ASTERISK ONLY ALLOWED IN FREE FIELD OUTPUT +161 TOO MANY |-ED LIST ELEMENTS IN OUTPUT +162 HOL OR QUOTED STRING GREATER THAN 7 CHARACTERS IN EXPRESSION +164 PLUS NOT ALLOWED IN THIS FORMAT PHRASE +165 K NOT ALLOWED IN THIS FORMAT PHRASE +166 $ NOT ALLOWED IN THIS FORMAT PHRASE +167 INTRINSICS-NAMED FUNCT MUST HAVE PREVIOUS EXTERNAL REFERENCE. +168 DATA STMT COMMON ELEM MUST BE IN BLK DATA SUBPRM +169 VARIABLE CANNOT BE A FORMAL PARAMETER OR IN COMMON +170 CURRENT SUBPROGRAM ID EXPECTED +171 SUBPROGRAM, EXTERNAL, OR ARRAY ID EXPECTED +172 REPEAT, WIDTH, AND DECIMAL PARTS MUST BE LESS THAN 4091 +173 REPEAT PART MUST BE EMPTY OR >0 AND < 4091 +174 IN SUBPRGM:VARBL IS USED PRIOR TO USE IN DATSTMT +175 SYNTATICAL TOKEN CONTAINS TOO MANY CHARACTERS +176 INTEGER VALUE OF 8 EXPECTED +177 INTEGER VALUE OF 4 EXPECTED +178 INTEGER VALUE OF 4 OR 8 EXPECTED +179 AN ALPHABETIC LETTER (A,B,C,...,Z) IS REQUIRED +180 SECOND RANGE LETTER MUST BE GREATER THAN FIRST +181 IMPLICIT MUST BE FIRST STATEMENT IN PROGRAM UNIT +182 REAL/INTEGER/LOGICAL/COMPLEX/DOUBLEPRECISION REQ +183 ILLEGAL USE OF ASTERISK FOR RUN-TIME EDITING %111- +184 NO PROGRAM UNIT FOR THIS END STATEMENT %112- +; +BEGIN +INTEGER ERRORCT; COMMENT MUST BE FIRST DECLARED VARIABLE; +INTEGER SAVETIME; COMMENT MUST BE 2 ND DECLARED VARIABLE; +INTEGER CARDCOUNT,ESTIMATE,SEQERRCT ; +INTEGER SWARYCT; +REAL TWODPRTX; +REAL INITIALSEGNO; +REAL NEXT, FNEXT, NAME, NUMTYPE; +REAL A, B, I, J, P, T, TS, Z; +REAL RTT; % START COMPILE TIME +REAL EXPVALUE, EXPRESULT, EXPLINK; +REAL SPLINK, FUNVAR; + REAL DATAPRT,DATASTRT,DATALINK,DATASKP; +BOOLEAN SCANENTER ; % TRUE IFF SCAN JUST DID AN ENTER ON AN ID. +DEFINE NUMINTM1= +83 +#;% NUMINTM1 IS THE NUMBER OF INTRINSICS MINUS 1; FOR EACH NEW INTRINSIC +% WHICH IS ADDED, ADD 1 TO THE VALUE ON SEQ# 00155211. +DEFINE MAXEL=15#; +REAL ARRAY ENTRYLINK[0:MAXEL]; +REAL ELX; +ALPHA FNEW, NNEW; +REAL LABELMOM; +INTEGER LOCALS,PARMS,PRTS,FLAGROUTINECOUNTER ; +REAL LIMIT, VOIDTSEQ; +REAL IDINFO, TYPE, NSEG; +REAL FX1, FX2, FX3, NX1, NX2, NX3; +INTEGER LENGTH, LOWERBOUND, GROUPPRT; +ALPHA EQVID, INTID, REALID; +INTEGER ROOT, ADR; +INTEGER LASTMODE ; %%% = 1 FOR $CARD; = 2 FOR $TAPE. +BOOLEAN ERRORTOG,%PREVIOUS LISTED RECORD. + EOSTOG,%END OF STMT TOGGLE. + CODETOG,%LIST CODE GENERATED.. + TAPETOG,%MERGE TAPE INPUT. + EODS,%END OF DECLRSTMTS, RESET BY ENDS. + FILETOG,%PROCESSING FILE CARDS. + DEBUGTOG,%TO LIST OUT ENTRING AND EXITING PROCEDURES. + DESCREQ,%DESCRIPTOR REQUIRED. + XRFF,%TO CREATE XREF OF PROGRAM. + SAVETOG;%VARIOUS BOOLEANS. +DEFINE LIBTAPE = SAVETOG.[47:1]#,%USE TO SAVE NEW WHILE INCLUDE. + SAVEDEBUGTOG = SAVETOG.[46:1]#,%SAVE DEBUGTOG WHILE IN $INCLUDE. + SAVECODETOG = SAVETOG.[45:1]#,%SAVE CODETOG WHILE IN $INCLUDE. + SAVEPRTTOG = SAVETOG.[44:1]#,%SAVE PRTOG WHILE IN $INCLUDE. + SAVELISTOG = SAVETOG.[43:1]#,%SAVE LISTOG WHILE IN $INCLUDE. + VOIDTOG = SAVETOG.[42:1]#,%TO VOID CARDS OR TAPE + DATASTMTFLAG = SAVETOG.[41:1]#,%WHILE IN DATA STMTS, + F2TOG = SAVETOG.[40:1]#,%ADDR REL TO F+2, + CHECKTOG = SAVETOG.[39:1]#,%SEQ # CHECK, + LISTOG = SAVETOG.[38:1]#,%TO LIST OUTPUT, + LISTLIBTOG = SAVETOG.[37:1]#,%TO LIST LIBRARY OUTPUT, + SEQTOG = SAVETOG.[36:1]#,%TO RESEQ INPUTS, + SEQERRORS = SAVETOG.[35:1]#,%IF SEQUENCE ERRORS. + TIMETOG = SAVETOG.[34:1]#,%TO LIST WRAPUP INFO ONLY. + PRTOG = SAVETOG.[33:1]#,%TO LIST STORAGE MAP. + NEWTPTOG = SAVETOG.[32:1]#,%CREATE NEW SYMBOLIC TAPE. + SINGLETOG = SAVETOG.[31:1]#,%TO LIST OUTPUT SINGLE SPACED. + SEGOVFLAG = SAVETOG.[30:1]#,%SEGMENT OVERFLOW. + FIRSTCALL = SAVETOG.[29:1]#,%TO LIST COMPILER HEADING. + RETURNFOUND = SAVETOG.[28:1]#,%RETURN,CALL EXIT,STOP FOUND. + ENDSEGTOG = SAVETOG.[27:1]#,%END OF SEGMENT. + LOGIFTOG = SAVETOG.[26:1]#,%PROCESSING LOGICAL IF STMT. + NOTOPIO = SAVETOG.[25:1]#, + DATATOG = SAVETOG.[24:1]#,%WHILE IN DATA STMTS. + FREEFTOG = SAVETOG.[23:1]#,%FREE FIELD INPUT. + SEGPTOG = SAVETOG.[22:1]#,%DONT PAGE AFTER SUBPRGM + GLOBALNAME = SAVETOG.[21:1]#,%TO WRITE ALL IDENTIFIERS. + NAMEDESC = SAVETOG.[20:1]#,%IF GLOBALNAME OR LOCALNAME TRUE + LOCALNAME = SAVETOG.[19:1]#,%TO WRITE AN IDENTIFIER. + TSSEDITOG = SAVETOG.[18:1]#,%TSSEDIT. + UNPRINTED = SAVETOG.[17:1]#,%TO LIST CARD,FALSE IF LISTED. + DCINPUT = SAVETOG.[16:1]#,%IF USING TSS FORTRAN. + SEGSW = SAVETOG.[15:1]#,%TO MAINTAIN LINEDICT/LINESEG. + TSSMESTOG = SAVETOG.[14:1]#,%TSSMES(ERRMES). + WARNED = SAVETOG.[13:1]#,%IS TSSEDIT WAS EVER EVOKED. + SEGSWFIXED = SAVETOG.[12:1]#,%IF SEGSW IS NOT TO BE ALTERED. + REMFIXED = SAVETOG.[11:1]#,%IF REMOTETOG ISNT TO BE ALTERED + RANDOMTOG = SAVETOG.[10:1]#,%IF EXPR USED FOR RANDOM I/O. + VOIDTTOG = SAVETOG.[ 9:1]#,%TO VOID TAPE RECORDS ONLY. + DOLIST = SAVETOG.[ 8:1]#,%LIST DOLLAR CARDS. + HOLTOG = SAVETOG.[ 7:1]#,%INPUT IN HOLLERITH. + LISTPTOG = SAVETOG.[ 6:1]#,%LIST PATCHES ONLY. + PXREF = SAVETOG.[ 5:1]#,%TO LIST XREF OF PROGRAM. + LASTLINE = SAVETOG.[ 4:1]#,%TO DETR TO SKIP XREF. + XGLOBALS = SAVETOG.[ 3:1]#,%TO LET XREF KNOW OF DOING GLOBAL + NTAPTOG = SAVETOG.[ 2:1]#,%TO CLOSE NEWTAPE IF EVER OPENED + SEENADOUB = SAVETOG.[40:1]#,%ARRAYDEC WONT BE USING THIS + %WHILE WE FIX DP COMMON ARRAY SZ +ENDSAVTOGDEF=#; +ARRAY SSNM[0:18] ; % THESE WORDS ARE USED FOR TEMP STORAGE AND STORING + % PERMANENT FLAGGED DATA. +DEFINE LASTSEQ=SSNM[0]#, LASTERR=SSNM[1]#, LINKLIST=SSNM[2]# ; +DEFINE VOIDSEQ=SSNM[3] # ; +ALPHA ARRAY ERRORBUFF,PRINTBUFF[0:14] ; +ARRAY INLINEINT[0:35] ; +DEFINE XRBUFF = 150#, XRBUFFDIV3=50 #; +ARRAY XRRY[0:XRBUFF-1] ; +INTEGER SEQBASE,SEQINCR; +INTEGER SCN,LABL,NEXTSCN,NEXTCARD; +INTEGER SAVECARD; % TO SAVE NEXTCART WHILE IN $ INCLUDE +INTEGER RESULT,INSERTDEPTH; +REAL INCLUDE; % CONTAINS "INCLUDE" +REAL DEBUGADR ; +ALPHA ACRO, CHRO, INITIALNCR; +ALPHA ACR, NCR ; +SAVE ARRAY TIPE[0:63] ; +REAL LASTNEXT ; +ALPHA NEXTACC, NEXTACC2; +ALPHA BLANKS; +ALPHA XTA; +ALPHA ARRAY EDOC[0:7, 0:127]; COMMENT HOLDS CODE EMITTED; +ALPHA ARRAY HOLDID[0:2]; +REAL NXAVIL,STRTSEG; +ALPHA ARRAY WOP[0:139]; % HOLDS NAME AND CODE OF WORD MODE OPERATORS +SAVE ALPHA ARRAY DB,TB,CB[0:9], + CRD[0:14]; +ALPHA ARRAY XR[0:32]; INTEGER XRI; +SAVE ARRAY ACCUM, EXACCUM[0:20] ; +REAL ACCUMSTOP, EXACCUMSTOP ; +REAL DBLOW; +REAL MAX; +ALPHA ACR1, CHR1; +ALPHA ARRAY PERIODWORD[0:10]; +REAL ARRAY MAP[0:7]; +REAL F1, F2; +INTEGER C1, C2; +DEFINE + RSP=14 #, RSP1=15 #, RWP=29 #, + RSH=41 #, RSH1=42 #, RWS=83 #; +ALPHA ARRAY RESERVEDWORDSLP[0:RWP], RESLENGTHLP,LPGLOBAL[0:RSP], + RESERVEDWORDS [0:RWS], RESLENGTH [0:RSH] ; +SAVE REAL ARRAY PR, OPST [0:25]; % USED IN EXPR ONLY +DEFINE PARMLINK = LSTT#; +ALPHA BUFF, BUFL, SYMBOL; +INTEGER TV, % INDEX INTO INFO FOR PRT OF LIST NAMES + SAVESUBS, % MAX NUMBER OF SUBSCRIPTS FOR NAMELIST IDENTIFIERS + NAMEIND ; % INDEX INTO NAMLIST IDENTIFIERS ARRAY +ARRAY NAMLIST[0:256]; % ARRAY TO STOKE NAMELIST IDENTIFIERS +ALPHA LISTID; +REAL ARRAY BDPRT[0:20]; REAL RDX; +DEFINE MAXSTRING = 49#; +ALPHA ARRAY STRINGARRAY[0:MAXSTRING]; +REAL STRINGSIZE; % NUMBER OF WORDS IN STRING +DEFINE LSTMAX = 256#; +REAL ARRAY LSTT, LSTP[0:LSTMAX]; +INTEGER LSTI,LSTS,LSTA; +DEFINE MAXOPFILES = 63#, BIGGESTFILENB = 99#; +ARRAY FILEINFO[0:3,0:MAXOPFILES]; +DEFINE % SOME FILE STUFF + SLOWV = 2#, + FASTV = 1#, + SENSPDEUNF= [1:8]#, + SENSF= [1:1]#, + SPDF = [2:2]#, + EUNF = [4:5]#, + FPBVERSION= 1#, + FPBVERSF = [1:8]#, + DKAREASZ = [9:39]#, +ENDFILDEF=#; +INTEGER MAXFILES; +ARRAY TEN[0:137]; +DEFINE LBRANCH = 50#; +REAL ARRAY BRANCHES[0:LBRANCH]; REAL LAX, BRANCHX; +INTEGER INXFIL,FILEARRAYPRT; +DEFINE MAXCOM=15 # ; +INTEGER SUPERMAXCOM; %%% SUPERMAXCOM = 128|(MAXCOM+1). +ALPHA ARRAY COM[0:MAXCOM,0:127] ; +REAL NEXTCOM; +ALPHA ARRAY INFO[0:31, 0:127]; +REAL ARYSZ; +ALPHA ARRAY EXTRAINFO[0:31, 0:127]; +REAL EXPT1, EXPT2, EXPT3; +DEFINE IR = [36:5]#, IC = [41:7]#; +REAL INFA,INFB,INFC; +INTEGER NEXTINFO, GLOBALNEXTINFO, NEXTEXTRA; +INTEGER NEXTSS; +DEFINE SHX=189#, GHX=61#; +REAL ARRAY STACKHEAD[0:SHX]; +REAL ARRAY GLOBALSTACKHEAD[0:GHX]; +REAL LA, DT, TEST; +ALPHA LADR1,LADR2,LADR3,LADR4,LADR5,LINFA; INTEGER LINDX,LADDR; +DEFINE MAXDOS=20#; +ALPHA ARRAY DOTEST, DOLAB[0:MAXDOS]; +ALPHA LISTART; +ALPHA ARRAY INT[0:NUMINTM1+NUMINTM1+2]; +ALPHA ARRAY TYPES[0:6], KLASS[0:14]; +INTEGER OP, PREC, IP, IT; +DEFINE DUMPSIZE=127 #; +ARRAY FNNHOLD[0:DUMPSIZE]; +INTEGER FNNINDEX,FNNPRT; +DEFINE MAXNBHANG = 30#; +ARRAY FNNHANG[0:MAXNBHANG]; +DEFINE INTCLASS=[6:3]#, INTPARMCLASS=[9:3]#, INTINLINE=[12:6]#, + INTPRT =[24:6]#, INTPARMS =[30:6]#, INTNUM =[36:12]#, + INAM =[12:36]#, INTX =[2:10]#, INTSEEN =[2:1]# ; +DEFINE + INSERTMAX = 20 #, % MAX NO OF RECURSIVE CALL ALLOW ON LIB ROUT + INSERCOP = INSERTINFO[INSERTDEPTH,4] #, + INSERTMID = INSERTINFO[INSERTDEPTH,0] #, + INSERTFID = INSERTINFO[INSERTDEPTH,1] #, + INSERTINX = INSERTINFO[INSERTDEPTH,2] #, + INSERTSEQ = INSERTINFO[INSERTDEPTH,3] #; +ARRAY INSERTINFO[0:INSERTMAX,0:4]; +DEFINE MSRW=11 #; +ALPHA ARRAY MESSAGE[0:MSRW,0:96] ; +BOOLEAN ARRAY MSFL[0:MSRW]; +ALPHA ARRAY LINEDICT[0:7,0:127]; % LINE DICTIONARY ARRAY +ALPHA ARRAY LINESEG [0:11,0:127]; % LINE SEGMENT ARRAY +ARRAY TSSMESA[0:15] ; %%% BIT FLAGS PRNTD ERR MESSGS ({748). +INTEGER NOLIN; % NUMBER OF ENTRIES IN LINE SEGMENT +REAL LASTADDR; %%% STORES LAST ADR. +INTEGER WARNCOUNT; %%% COUNTS NUMBER OF TSS WARNINGS. +DEFINE CE = [2:1]#, %INFA %996- + LASTC = [3:12]#, %INFA %996- + SEGNO = [3:9]#, %INFA %996- + CLASS = [15:5]#, %INFA %996- + EQ = [20:1]#, %INFA %996- + SUBCLASS = [21:3]#, %INFA %996- + CLASNSUB = [14:10]#, %INFA %996- + ADJ = [14:1]#, %INFA %996- + TWOD = [14:1]#, %INFA %996- + FORMAL = [13:1]#, %INFA %996- + TYPEFIXED= [12:1]#, %INFA %996- + ADDR = [24:12]#, %INFA %996- + LINK = [36:12]#, %INFC %996- + BASE = [18:15]#, %INFC %996- + SIZE = [33:15]#, %INFC %996- + BASENSIZE= [18:30]#, %INFC %996- + NEXTRA = [2:6]#, %INFC %996- + ADINFO = [8:10]#, %INFC %996- + RELADD = [21:15]#, %INFA %996- + TOCF = 2:47:1#, %INFA %996- + TOSFGNO = 3:39:9#, %INFA %996- + TOLASTC = 3:36:12#, %INFA %996- + TOCLASS = 15:43:5#, %INFA %996- + TOEQ = 20:47:1#, %INFA %996- + TOSUBCL = 21:45:3#, %INFA %996- + TOADJ = 14:47:1#, %INFA %996- + TOFORMAL = 13:47:1#, %INFA %996- + TOTYPF = 12:47:1#, %INFA %996- + TOADDR = 24:36:12#, %INFA %996- + TOLINK = 36:36:12#, %INFC %996- + TOBASE = 18:33:15#, %INFC %996- + TONEXTRA = 2:42:6#, %INFC %996- + TOADINFO = 8:38:10#, %INFC %996- + %THE FOLLOWING CLASSES APPEAR IN THE 1ST WORD OF EACH 3-WORD ENTRY + %OF THE "INFO" ARRAY, AND MAY BE COPIED TO INFA.CLASS. %996- + UNKNOWN = 0#, + ARRAYID = 1#, + VARID = 2#, + STMTFUNID= 3#, + NAMELIST = 4#, + FORMATID = 5#, + LABELID = 6#, + FUNID = 7#, + INTRFUNID= 8#, + EXTID = 9#, + SUBRID = 10#, + BLOCKID = 11#, + FILEID = 12#, + SUBSVAR = 13#, + EXPCLASS = 14#, + SBVEXP = 15#, + LISTSID = 16#, + JUNK = 17#, % NOT A GENUINE CLASS %996- + DUMMY = 27#, + NUMCLASS = 28#, + RESERVED = 29#, + HEADER = 30#, + ENDCOM = 31#, + %THE FOLLOWING SUBCLASSES APPEAR IN THE 1ST WORD OF SOME 3-WORKD%996- + %ENTRIES OF THE "INFO" ARRAY, AND MAY BE COPIED TO INFA.SUBCLASS. + INTYPE = 1#, + STRINGTYPE=2#, + REALTYPE = 3#, + LOGTYPE = 4#, + DOUBTYPE = 5#, + COMPTYPE = 6#; +DEFINE EOF= 500#, ID= 501#, NUM= 502#, PLUS= 503#, MINUS= 504#, + STAR= 505#, SLASH= 506#, LPAREN= 507#, RPAREN= 508#, + EQUAL= 509#, COMMA= 510#, SEMI= 511#, DOLLAR=0#, UPARROW=0# ; +DEFINE THRU = STEP 1 UNTIL #; %996- +DEFINE + ADD = 16#, BBC = 22#, BBW = 534#, BFC = 38#, BFW = 550# + ,CDC =168#, CHS =134#, COC = 40#, KOM =130#, DEL = 10# + ,DUP =261#, EQUL=581#, GBC = 278#, GBW =790#, GEQL= 21# + ,GFC =294#, GFW =806#, GRTR= 37#, IDV =384#, INX = 24# + ,ISD =532#, ISN =548#, LEQL= 533#, LND = 67#, LNG = 19# + ,LOD =260#, LOR = 35#, LQV = 131#, LESS=549#, MDS = 515# + ,MKS = 72#, MUL = 64#, NEQL= 69#, NOP = 11#, PRL = 18# + ,XRT = 12#, RDV =896#, RTN = 39#,RTS =167#, SND = 132# + , SSN = 70#, SSP = 582#, STD = 68#, SUB = 48#, XCH = 133# + ,XIT = 71#, ZP1 =322#, DIU =128#, STN =132# + ,DIA = 45#, DIB = 49#, TRB = 53#, ISO = 37# + ,AD2 =17#, SB2 = 49#, ML2 = 65#, DV2 =129#, FTC = 197# + ,SSF =280#, FTF =453#, CTC =709#, CTF = 965# + ,TOP=262# + ; +FORMAT FD(X100,"NEXT = ",I3,X2,2A6) ; +FORMAT SEGSTRT(X63, " START OF SEGMENT **********", I4), + FLAGROUTINEFORMAT(X41,A6,A2,X1,2A6," (",A1,I*,")"), + XHEDM(X40,"CROSS REFERENCE LISTING OF MAIN PROGRAM",X41,/, + X40,"----- --------- ------- -- ---- -------",X41), + XHEDS(X38, "CROSS REFERENCE LISTING OF SUBROUTINE ",A6,X38,/, + X38, "----- --------- ------- -- ---------- ",A6,X38), + XHEDF(X35,"CROSS REFERENCE LISTING OF ",A6,A1," FUNCTION ",A6, + X35,/,X35,"----- --------- ------- -- ",A6,A1," -------- ",A6, + X35), + XHEDG(X43,"CROSS REFERENCE LISTING OF GLOBALS",X43,/, + X43,"----- --------- ------- -- -------",X43), + XHEDB(X34,"CROSS REFERENCE LISTING OF BLOCK DATA SUBPROGRAM",X35, + /,X34,"----- --------- ------- -- ----- ---- ----------",X35), + SEGEND (X70," SEGMENT",I5," IS",I5," LONG"); +ARRAY PDPRT [0:31,0:63]; +REAL PDINX; % INDEX OF LAST ENTRY IN PDPRT +REAL TSEGSZ; % RUNNING COUNT OF TOTAL SEGMENT SIZE; + COMMENT FORMAT OF PRT&SEGMENT ENTRIES, IN PDPRT; +DEFINE STYPF= [1:2]#, % 0 = PROGRAM SEGMENT-SEGMENT ENTRY ONLY + STYPC= 1:46:2#, % 1 = MCP INTRINSIC + % 2 = DATA SEGMENT + DTYPF= [4:2]#, % 0 = THUNK - PRT ENTRY ONLY + DTYPC= 4:46:2 #,% 1 = WORD MODE PROGRAM DESCRIPTOR + % 2 = LABEL DESCRIPTOR + % 3 = CHARACTER MODE PROGRAM DESCRIPTOR + PRTAF= [8:10]#, % ACTUAL PRT ADDRESS - PRT ENTRY + PRTAC= 8:38:10#, + RELADF = [18:10]#, % ADDRESS WITHIN SEGMENT -PRT ONLY + RELADC= 18:38:10#, + SGNOF= [28:10]#, % SEGMENT NUMBER - BOTH + SGNOC= 28:38:10#, + DKAI = [13:15]#, % RELATIVE DISK ADDRESS - SEGMENT ENTRY + DKAC = 13:33:15#, + SEGSZF =[38:10]#, % SEGMENT SIZE - SEGMENT ENTRY + SEGSZC =38:38:10#;% MUST BE 0 IF PRT ENTRY +DEFINE % SOME EXTERNAL CONSTANTS + BLKCNTRLINT = 5#, + FPLUS2 = 1538#, +ENDEXTCONDEF=#; +DEFINE PDIR = PDINX.[37:5]#, + PDIC = PDINX.[42:6]#; +DEFINE CIS = CRD[0]#, % CARD + TIS = CRD[1]#, % TAPE + TOS = CRD[2]#, % NEW TAPE + LOS = CRD[3]#; % PRINTER +DEFINE PWROOT=ROOT.IR,ROOT.IC #,PWI=I.IT,I.IC # ; +DEFINE GLOBALNEXT=NEXT#; +BEGIN % SCAN FPB TO SEE IF VARIOUS FILES ARE DISK OR TAPE +INTEGER STREAM PROCEDURE GETFPB(Q); VALUE Q; + BEGIN + SI ~ LOC GETFPB; SI ~ SI - 7; DI ~ LOC Q; DI ~ DI + 5; + SKIP 3 DB; 9(IF SB THEN DS ~ SET ELSE DS ~ RESET; + SKIP SB); + DI ~ LOC Q; SI ~ Q; DS ~ WDS; SI ~ Q; GETFPB ~ SI; + END; +INTEGER STREAM PROCEDURE GNC(Q); VALUE Q; + BEGIN SI ~ Q; SI ~ SI + 7; DI ~ LOC GNC; DI ~ DI +7; DS ~CHR END; +INTEGER FPBBASE; + FPBBASE ~ GETFPB(3); + TIS ~ TOS ~ 50; CIS ~ LOS ~ 0; + IF GNC(FPBBASE+3) =12 THEN CIS ~ 150; % CARD + IF GNC(FPBBASE+8) =12 THEN LOS ~ 150; % PRINTER + IF GNC(FPBBASE+13) = 12 THEN TOS ~ 150; % NEW TAPE; + IF GNC(FPBBASE+18) =12 THEN TIS ~ 150; % TAPE + END; +BEGIN COMMENT INNER BLOCK; +% *** DO NOT DECLARE ANY FILES PRIOR TO THIS POINT, DO NOT ALTER +% SEQUENCE OF FOLLOWING FILE DECLARATIONS +FILE CARD (5,10,CIS); +DEFINE LINESIZE = 900 #; +SAVE FILE LINE DISK SERIAL [20:LINESIZE] (2,15,LOS,SAVE 10); +SAVE FILE NEWTAPE DISK SERIAL [20:LINESIZE] "FORSYM" (2,10,TOS,SAVE 10); +FILE TAPE "FORSYM" (2,10,TIS); +FILE REMOTE 19(2,10) ; +DEFINE CHUNK = 180#; +DEFINE PTR=LINE#,RITE=LINE#,CR=CARD#,TP=TAPE#; %515- +FILE CODE DISK RANDOM [20:CHUNK] (4,30,SAVE ABS(SAVETIME)); +FILE LIBRARYFIL DISK RANDOM (2,10,150); +DEFINE LF = LIBRARYFIL#; +FILE XREFF DISK SERIAL[20:1500](2,XRBUFF) ; +FILE XREFG DISK SERIAL[20:1500](2,3,XRBUFF); +REAL DALOC; % DISK ADDRESS +LABEL POSTWRAPUP; +PROCEDURE EMITNUM(N); VALUE N; REAL N; FORWARD; +REAL PROCEDURE LOOKFORINTRINSIC(L); VALUE L; REAL L; FORWARD ; +PROCEDURE SEGOVF; FORWARD; +DEFINE BUMPADR= IF (ADR~ADR+1)=4089 THEN SEGOVF#; +DEFINE BUMPLOCALS = BEGIN IF LOCALS.LOCALS+1>255 THEN BEGIN FLAG(148); + LOCALS~2 END END#; +DEFINE BUMPPRT=BEGIN IF PRTS~PRTS+1>1023 THEN BEGIN FLAG(46); + PRTS~40 END END#; +DEFINE FDOCI = ADR.[36:3], ADR.[39:7]#; +DEFINE TWODPRT=IF TWODPRTX=0 THEN(TWODPRTX~PRTS~PRTS+1)ELSE TWODPRTX#; +REAL PROCEDURE SEARCH(E); VALUE E; REAL E; FORWARD; +PROCEDURE PRINTCARD; FORWARD; +INTEGER PROCEDURE FIELD(X); VALUE X; INTEGER X; FORWARD ; +ALPHA PROCEDURE NEED(T, C); VALUE T, C; ALPHA T, C; FORWARD; +ALPHA PROCEDURE GETSPACE(S); VALUE S; ALPHA S; FORWARD; +PROCEDURE EQUIV(R); VALUE R; REAL R; FORWARD; +PROCEDURE EXECUTABLE; FORWARD; +ALPHA PROCEDURE B2D(B); VALUE B; REAL B; FORWARD; +PROCEDURE DEBUGWORD (N); VALUE N; REAL N; FORWARD; +PROCEDURE EMITL(N); VALUE N; REAL N; FORWARD; +PROCEDURE ADJUST;FORWARD; +PROCEDURE DATIME; FORWARD; +PROCEDURE EMITB(A,C); VALUE A,C; REAL A; BOOLEAN C; FORWARD; +PROCEDURE FIXB(N); VALUE N; REAL N; FORWARD; +PROCEDURE EMIT0PDCLIT(N); VALUE N; REAL N; FORWARD; +PROCEDURE EMITDESCLIT(N); VALUE N; REAL N; FORWARD; +PROCEDURE EMITPAIR(L,OP); VALUE L,OP; INTEGER L,OP; FORWARD; +PROCEDURE EMITN(N); VALUE N; REAL N; FORWARD; +PROCEDURE ARRAYDEC(I); VALUE I; REAL I; FORWARD; +INTEGER PROCEDURE ENTER(W, E); VALUE W, E; ALPHA W, E; FORWARD; +REAL PROCEDURE PRGDESCBLDR(A,B,C,D); VALUE A,B,C,D; REAL A,B,C,D; + FORWARD; +PROCEDURE WRITEDATA(A,B,C); VALUE A,B; REAL A,B; + ARRAY C[0]; FORWARD; +PROCEDURE SCAN; FORWARD; +PROCEDURE SEGMENT(A,B,C,D); VALUE A,B,C; + REAL A,B; BOOLEAN C; ARRAY D[0,0]; FORWARD; +STREAM PROCEDURE MOVESEQ(OLD,NEW); BEGIN DI~OLD; SI~NEW; DS~WDS END ; +PROCEDURE WRITAROW(N,ROW); VALUE N; INTEGER N; REAL ARRAY ROW[0] ; +IF SINGLETOG THEN WRITE(LINE,N,ROW[*]) ELSE WRITE(RITE,N,ROW[*]) ; +PROCEDURE WRITALIST(FMT,N,L1,L2,L3,L4,L5,L6,L7,L8); +VALUE N,L1,L2,L3,L4,L5,L6,L7,L8; INTEGER N; +REAL L1,L2,L3,L4,L5,L6,L7,L8; FORMAT FMT; + BEGIN + PRINTBUFF[1]~L1; + L1~1 ; + FOR L2~L2,L3,L4,L5,L6,L7,L8 DO PRINTBUFF[L1~L1+1]~L2 ; + IF SINGLETOG THEN WRITE(LINE,FMT,FOR L1~1 THRU N DO PRINTBUFF[L1]) + ELSE WRITE(RITE,FMT,FOR L1~1 THRU N DO PRINTBUFF[L1]) ; + END WRITALIST ; +STREAM PROCEDURE BLANKIT(A,N,P); VALUE N,P; +BEGIN DI~A; N(DS~8 LIT" "); P(DS~8 LIT"99999999") END ; +BOOLEAN STREAM PROCEDURE TSSMES(A,B); VALUE B; +BEGIN SI~A; SKIP B SB; IF SB THEN ELSE BEGIN TALLY~1; TSSMES~TALLY ; +DI~A; SKIP B DB; DS~SET END END OF TSSMES ; +STREAM PROCEDURE TSSEDIT(X,P1,P2,P3,P,N); VALUE P1,P2,P3,N ; +BEGIN DI~P;DS~16LIT"TSS WARNING: ";SI~X;SI~SI+2; DS~6CHR; DS~4LIT" "; +P1(DS~48LIT"A TSS HOL OR QUOTED STRING MUST BE ON 1 LINE ") ; +P2(DS~48LIT"THIS CONSTRUCT IS ILLEGAL IN TSS FORTRAN ") ; +P3(DS~48LIT"THIS CONSTRUCT IS UNRESERVED IN TSS FORTRAN ") ; +DS~26LIT" "; DS~8LIT"*"; DS~LIT" "; SI~LOC N; DS~3DEC END TSSEDIT ; +PROCEDURE TSSED(X,N); VALUE X,N; ALPHA X; INTEGER N ; +BEGIN IF NOT (LISTOG OR SEQERRORS) THEN PRINTCARD ; UNPRINTED~FALSE ; +TSSEDIT(X,N=1,N=2,N=3,PRINTBUFF,WARNCOUNT~WARNCOUNT+1) ; +WRITAROW(14,PRINTBUFF) END OF TSSED; +PROCEDURE ERRMESS(N); VALUE N; INTEGER N; +BEGIN +STREAM PROCEDURE PLACE(D,N,X,S,E,L); VALUE N,E ; +BEGIN DI ~ D; DS ~ 6 LIT "ERROR "; + SI ~ LOC N; DS ~ 3 DEC; DS ~ 5 LIT ": "; + SI ~ X; SI ~ SI + 2; DS ~ 6 CHR; DS ~ 4 LIT " "; + SI~S; DS~6 WDS; DS~6 LIT" "; SI~L; DS~8 CHR; DS~14 LIT" " ; + DS ~ 8 LIT "X"; DS ~ LIT " "; + SI ~ LOC E; DS ~ 3 DEC; +END PLACE; +STREAM PROCEDURE DCPLACE(D,N,X,S,M,P); VALUE N,P; + BEGIN DI~D; DS~4LIT"ERR#"; SI~LOC N; DS~3 DEC; DS~3LIT" @ "; + SI~S; DS~8CHR; DS~2LIT": "; SI~X; SI~SI+2; DS~6CHR; DS~54LIT" " ; + END OF DCPLACE ; +ERRORCT~ERRORCT+1; +IF NOT MSFL[N DIV 16] THEN + BEGIN + MSFL[N DIV 16]~TRUE ; + CASE(N DIV 16)OF +BEGIN + FILL MESSAGE[0,*] WITH +"SYNTAX E","RROR "," "," "," "," ", %000 +"MISSING ","OPERATOR"," OR PUNC","TUATION "," "," ", %001 +"CONFLICT","ING COMM","ON AND/O","R EQUIVA","LENCE AL","LOCATION", %002 +"MISSING ","RIGHT PA","RENTHESI","S "," "," ", %003 +"ENTRY ST","MT ILLEG","AL IN MA","IN PGM O","R BLOCK ","DATA ", %004 +"MISSING ","END STAT","EMENT "," "," "," ", %005 +"ARITHMET","IC EXPRE","SSION RE","QUIRED "," "," ", %006 +"LOGICAL ","EXPRESSI","ON REQUI","RED "," "," ", %007 +"TOO MANY"," LEFT PA","RENTHESE","S "," "," ", %008 +"TOO MANY"," RIGHT P","ARENTHES","ES "," "," ", %009 +"FORMAL P","ARAMETER"," ILLEGAL"," IN COMM","ON "," ", %010 +"FORMAL P","ARAMETER"," ILLEGAL"," IN EQUI","VALENCE "," ", %011 +"THIS STA","TEMENT I","LLEGAL I","N BLOCK ","DATA SUB","PROGRAM ", %012 +"INFO ARR","AY OVERF","LOW "," "," "," ", %013 +"IMPROPER"," DO NEST"," "," "," "," ", %014 +"DO LABEL"," PREVIOU","SLY DEFI","NED "," "," ", %015 +0; + FILL MESSAGE[1,*] WITH +"UNRECOGN","IZED STA","TEMENT T","YPE "," "," ", %016 +"ILLEGAL ","DO STATE","MENT "," "," "," ", %017 +"FORMAT S","TATEMENT"," MUST HA","VE LABEL"," "," ", %018 +"UNDEFINE","D LABEL "," "," "," "," ", %019 +"MULTIPLE"," DEFINIT","ION "," "," "," ", %020 +"ILLEGAL ","IDENTIFI","ER CLASS"," IN THIS"," CONTEXT"," ", %021 +"UNPAIRED"," QUOTES ","IN FORMA","T "," "," ", %022 +"NOT ENOU","GH SUBSC","RIPTS "," "," "," ", %023 +"TOO MANY"," SUBSCRI","PTS "," "," "," ", %024 +"FUNCTION"," OR SUBR","OUTINE P","REVIOUSL","Y DEFINE","D ", %025 +"FORMAL P","ARAMETER"," MULTIPL","Y DEFINE","D IN HEA","DING ", %026 +"ILLEGAL ","USE OF N","AMELIST "," "," "," ", %027 +"NUMBER O","F PARAME","TERS INC","ONSISTEN","T "," ", %028 +"CANNOT B","RANCH TO"," FORMAT ","STATEMEN","T "," ", %029 +"SUBROUTI","NE OR FU","NCTION N","OT DEFIN","ED IN PR","OGRAM ", %030 +"IDENTIFI","ER ALREA","DY GIVEN"," TYPE "," "," ", %031 +0; + + FILL MESSAGE[2,*] WITH +"ILLEGAL ","FORMAT S","YNTAX "," "," "," ", %032 +"INCORREC","T USE OF"," FILE "," "," "," ", %033 +"INCONSIS","TENT USE"," OF IDEN","TIFIER "," "," ", %034 +"ARRAY ID","ENTIFIER"," EXPECTE","D "," "," ", %035 +"EXPRESSI","ON VALUE"," REQUIRE","D "," "," ", %036 +"ILLEGAL ","FILE CAR","D SYNTAX"," "," "," ", %037 +"ILLEGAL ","CONTROL ","ELEMENT "," "," "," ", %038 +"DECLARAT","ION MUST"," PRECEDE"," FIRST R","EFERENCE"," ", %039 +"INCONSIS","TENT USE"," OF LABE","L AS PAR","AMETER "," ", %040 +"NO. OF P","ARAMS, D","ISAGREES"," WITH PR","EV, REFE","RENCE ", %041 +"ILLEGAL ","USE OF F","ORMAL PA","RAMETER "," "," ", %042 +"ERROR IN"," HOLLERI","TH LITER","AL CHARA","CTER COU","NT ", %043 +"ILLEGAL ","ACTUAL P","ARAMETER"," "," "," ", %044 +"TOO MANY"," SEGMENT","S IN SOU","RCE PROG","RAM "," ", %045 +"TOO MANY"," PRT ASS","IGNMENTS"," IN SOUR","CE PROGR","AM ", %046 +"LAST BLO","CK DECLA","RATION H","AD LESS ","THAN 102","4 WORDS ", %047 +0; + FILL MESSAGE[3,*] WITH +"ILLEGAL ","I/O LIST"," ELEMENT"," "," "," ", %048 +"LEFT SID","E MUST B","E SIMPLE"," OR SUBS","CRIPTED ","VARIABLE", %049 +"VARIABLE"," EXPECTE","D "," "," "," ", %050 +"ILLEGAL ","USE OF .","OR. "," "," "," ", %051 +"ILLEGAL ","USE OF .","AND. "," "," "," ", %052 +"ILLEGAL ","USE OF .","NOT. "," "," "," ", %053 +"ILLEGAL ","USE OF R","ELATIONA","L OPERAT","OR "," ", %054 +"ILLEGAL ","MIXED TY","PES "," "," "," ", %055 +"ILLEGAL ","EXPRESSI","ON STRUC","TURE "," "," ", %056 +"ILLEGAL ","PARAMETE","R "," "," "," ", %057 +"RECORD B","LOCK GRE","ATER THA","N 1023 "," "," ", %058 +"TOO MANY"," OPTIONA","L FILES "," "," "," ", %059 +"FILE CAR","DS MUST ","PRECEDE ","SOURCE D","ECK "," ", %060 +"BINARY W","RITE STA","TEMENT H","AS NO LI","ST "," ", %061 +"UNDEFINE","D FORMAT"," NUMBER "," "," "," ", %062 +"ILLEGAL ","EXPONENT"," IN CONS","TANT "," "," ", %063 +0; + FILL MESSAGE[4,*] WITH +"ILLEGAL ","CONSTANT"," IN DATA"," STATEME","NT "," ", %064 +"MAIN PRO","GRAM MIS","SING "," "," "," ", %065 +"PARAMETE","R MUST B","E ARRAY ","IDENTIFI","ER "," ", %066 +"PARAMETE","R MUST B","E EXPRES","SION "," "," ", %067 +"PARAMETE","R MUST B","E LABEL "," "," "," ", %068 +"PARAMETE","R MUST B","E FUNCTI","ON IDENT","IFIER "," ", %069 +"PARAMETE","R MUST B","E FUNCTI","ON OR SU","BROUTINE"," ID ", %070 +"PARAMETE","R MUST B","E SUBROU","TINE IDE","NTIFIER "," ", %071 +"PARAMETE","R MUST B","E ARRAY ","IDENTIFI","ER OR EX","PRESSION", %072 +"ARITHMET","IC - LOG","ICAL CON","FLICT ON"," STORE "," ", %073 +"ARRAYID ","MUST BE ","SUBSCRIP","TED IN T","HIS CONT","EXT ", %074 +"MORE THA","N ONE MA","IN PROGR","AM "," "," ", %075 +"ONLY COM","MON ELEM","ENTS PER","MITTED "," "," ", %076 +"TOO MANY"," FILES "," "," "," "," ", %077 +"FORMAT O","R NAMELI","ST TOO L","ONG "," "," ", %078 +"FORMAL P","ARAMETER"," MUST BE"," ARRAY I","DENTIFIE","R ", %079 +0; + FILL MESSAGE[5,*] WITH +"FORMAL P","ARAMETER"," MUST BE"," SIMPLE ","VARIABLE"," ", %080 +"FORMAL P","ARAMETER"," MUST BE"," FUNCTIO","N IDENTI","FIER ", %081 +"FORMAL P","ARAMETER"," MUST BE"," SUBROUT","INE IDEN","TIFIER ", %082 +"FORMAL P","ARAMETER"," MUST BE"," FUNCTIO","N OR SUB","ROUTINE ", %083 +"DO OR IM","PLIED DO"," INDEX M","UST BE I","NTEGER O","R REAL ", %084 +"ILLEGAL ","COMPLEX ","CONSTANT"," "," "," ", %085 +"ILLEGAL ","MIXED TY","PE STORE"," "," "," ", %086 +"CONSTANT"," EXCEEDS"," HARDWAR","E LIMITS"," "," ", %087 +"PARAMETE","R TYPE C","ONFLICTS"," WITH PR","EVIOUS U","SE ", %088 +"COMPLEX ","EXPRESSI","ON ILLEG","AL IN IF"," STATEME","NT ", %089 +"COMPLEX ","EXPRESSI","ON ILLEG","AL IN RE","LATION "," ", %090 +"TOO MANY"," FORMATS"," REFEREN","CED BUT ","NOT YET ","FOUND ", %091 +"VARIABLE"," ARRAY B","OUND MUS","T BE FOR","MAL VARI","ABLE ", %092 +"ARRAY BO","UND MUST"," HAVE IN","TEGER OR"," REAL TY","PE ", %093 +"COMMA OR"," RIGHT P","ARENTHES","IS EXPEC","TED "," ", %094 +"ARRAY AL","READY GI","VEN BOUN","DS "," "," ", %095 +0; + FILL MESSAGE[6,*] WITH +"ONLY FOR","MAL ARRA","YS MAY B","E GIVEN ","VARIABLE"," BOUNDS ", %096 +"MISSING ","LEFT PAR","ENTHESIS"," IN IMPL","IED DO "," ", %097 +"SUBSCRIP","T MUST B","E INTEGE","R OR REA","L "," ", %098 +"ARRAY SI","ZE CANNO","T EXCEED"," 32767 W","ORDS "," ", %099 +"COMMON O","R EQUIV ","BLOCK CA","NNOT EXC","EED 3276","7 WORDS ", %100 +"THIS STA","TEMENT I","LLEGAL I","N LOGICA","L IF "," ", %101 +"REAL OR ","INTEGER ","TYPE REQ","UIRED "," "," ", %102 +"ARRAY BO","UND INFO","RMATION ","REQUIRED"," "," ", %103 +"REPLACEM","ENT OPER","ATOR EXP","ECTED "," "," ", %104 +"IDENTIFI","ER EXPEC","TED "," "," "," ", %105 +"LEFT PAR","ENTHESIS"," EXPECTE","D "," "," ", %106 +"ILLEGAL ","FORMAL P","ARAMETER"," "," "," ", %107 +"RIGHT PA","RENTHESI","S EXPECT","ED "," "," ", %108 +"STATEMEN","T NUMBER"," EXPECTE","D "," "," ", %109 +"SLASH EX","PECTED "," "," "," "," ", %110 +"ENTRY ST","ATEMENT ","CANNOT B","EGIN PRO","GRAM UNI","T ", %111 +0; + FILL MESSAGE[7,*] WITH +"ARRAY MU","ST BE DI","MENSIONE","D PRIOR ","TO EQUIV"," STMT ", %112 +"INTEGER ","CONSTANT"," EXPECTE","D "," "," ", %113 +"COMMA EX","PECTED "," "," "," "," ", %114 +"SLASH OR"," END OF ","STATEMEN","T EXPECT","ED "," ", %115 +"FORMAT, ","ARRAY OR"," NAMELIS","T EXPECT","ED "," ", %116 +"END OF S","TATEMENT"," EXPECTE","D "," "," ", %117 +"IO STATE","MENT WIT","H NAMELI","ST CANNO","T HAVE I","O LIST ", %118 +"COMMA OR"," END OF ","STATEMEN","T EXPECT","ED "," ", %119 +"STRING T","OO LONG "," "," "," "," ", %120 +"MISSING ","QUOTE AT"," END OF ","STRING "," "," ", %121 +"ILLEGAL ","ARRAY BO","UND "," "," "," ", %122 +"TOO MANY"," HANGING"," BRANCHE","S "," "," ", %123 +"TOO MANY"," COMMON ","OR EQUIV","ALENCE E","LEMENTS "," ", %124 +"ASTERISK"," EXPECTE","D "," "," "," ", %125 +"COMMA OR"," SLASH E","XPECTED "," "," "," ", %126 +"DATA SET"," TOO LAR","GE "," "," "," ", %127 +0; + FILL MESSAGE[8,*] WITH +"TOO MANY"," ENTRY S","TATEMENT","S IN THI","S SUBPRO","GRAM ", %128 +"DECIMAL ","WIDTH EX","CEEDS FI","ELD WIDT","H "," ", %129 +"UNSPECIF","IED FIEL","D WIDTH "," "," "," ", %130 +"UNSPECIF","IED SCAL","E FACTOR"," "," "," ", %131 +"ILLEGAL ","FORMAT C","HARACTER"," "," "," ", %132 +"UNSPECIF","IED DECI","MAL FIEL","D "," "," ", %133 +"DECIMAL ","FIELD IL","LEGAL FO","R THIS S","PECIFIER"," ", %134 +"ILLEGAL ","LABEL "," "," "," "," ", %135 +"UNDEFINE","D NAMELI","ST "," "," "," ", %136 +"MULTIPLY"," DEFINED"," ACTION ","LABELS "," "," ", %137 +"TOO MANY"," NESTED ","DO STATE","MENTS "," "," ", %138 +"STMT FUN","CTION ID"," AND EXP","RESSION ","DISAGREE"," IN TYPE", %139 +"ILLEGAL ","USE OF S","TATEMENT"," FUNCTIO","N "," ", %140 +"UNRECOGN","IZED CON","STRUCT "," "," "," ", %141 +"RETURN, ","STOP OR ","CALL EXI","T REQUIR","ED IN SU","BPROGRAM", %142 +"FORMAT N","UMBER US","ED PREVI","OUSLY AS"," LABEL "," ", %143 +0; + FILL MESSAGE[9,*] WITH +"LABEL US","ED PREVI","OUSLY AS"," FORMAT ","NUMBER "," ", %144 +"NON-STAN","DARD RET","URN REQU","IRES LAB","EL PARAM","ETERS ", %145 +"DOUBLE O","R COMPLE","X REQUIR","ES EVEN ","OFFSET "," ", %146 +"FORMAL P","ARAMETER"," ILLEGAL"," IN DATA"," STATEME","NT ", %147 +"TOO MANY"," LOCAL V","ARIABLES"," IN SOUR","CE PROGR","AM ", %148 +"A $FREEF","ORM SOUR","CE LINE ","MUST HAV","E < 67 C","OLS ", %149 +"A HOL/ST","RING UND","ER $FREE","FORM MUS","T BE ON ","ONE LINE", %150 +"THIS CON","STRUCT I","S ILLEGA","L IN TSS","FORTRAN "," ", %151 +"ILLEGAL ","FILE CAR","D PARAME","TER VALU","E "," ", %152 +"RETURN I","N MAIN P","ROGRAM N","OT ALLOW","ED "," ", %153 +"NON-POSI","TIVE SUB","SCRIPTS ","ARE ILLE","GAL "," ", %154 +"NON-IDEN","TIFIER U","SED FOR ","NAME OF ","LIBRARY ","ROUTINE ", %155 +"HYPHEN E","XPECTED "," "," "," "," ", %156 +"SEQUENCE"," NUMBER ","EXPECTED"," "," "," ", %157 +"TOO MANY"," RECURSI","VE CALLS"," ON LIBR","ARY ROUT","INE ", %158 +"ASTERISK"," NOT ALL","OWED ID ","READ STA","TEMENT "," ", %159 +0; + FILL MESSAGE[10,*] WITH +"ASTERISK"," ONLY AL","LOWED IN"," FREE FI","ELD OUTP","UT ", %160 +"TOO MANY"," |-ED LI","ST ELEME","NTS IN O","UTPUT "," ", %161 +"HOL OR Q","UOTED ST","RING > 7"," CHARACT","ERS IN E","XPRESSN ", %162 +"DECIMAL ","FIELD GR","EATER TH","AN FIELD"," WIDTH-5"," ", %163 +"PLUS NOT"," ALLOWED"," IN THIS"," FORMAT ","PHRASE "," ", %164 +"K NOT AL","LOWED IN"," THIS FO","RMAT PHR","ASE "," ", %165 +"$ NOT AL","LOWED IN"," THIS FO","RMAT PHR","ASE "," ", %166 +"INTRNSCS","-NAMD FU","NCT MUST"," HAV PRE","V EXTRNL"," REFERNC", %167 +"DATA STM","T COMMON"," ELEM MU","ST BE IN"," BLK DAT","A SUBPRG", %168 +"VARIABLE"," CANNOT ","BE A FOR","MAL PARA","METER OR"," IN CMMN", %169 +"CURRENT ","SUBPROGR","AM ID EX","PECTED "," "," ", %170 +"SUBPROGR","AM, EXTE","RNAL, OR"," ARRAY I","D EXPECT","ED ", %171 +"REPEAT, ","WIDTH, A","ND DECIM","AL PARTS"," MUST BE"," < 4091 ", %172 +"REPEAT P","ART MUST"," BE EMPT","Y OR > 0"," AND < 4","091 ", %173 +"IN SUBPR","GM:VARBL"," IS USED"," PRIOR T","O USE IN"," DATSTMT", %174 +"SYNTATIC","AL TOKEN"," CONTAIN","S TOO MA","NY CHARA","CTERS. ", %175 +0; + FILL MESSAGE[11,*] WITH +"INTEGER ","VALUE OF"," 8 EXPEC","TED "," "," ", %176 +"INTEGER ","VALUE OF"," 4 EXPEC","TED "," "," ", %177 +"INTEGER ","VALUE OF"," 4 OR 8 ","EXPECTED"," "," ", %178 +"AN ALPHA","BETIC LE","TTER (A,","B,C,...,","Z) IS RE","QUIRED ", %179 +"SECOND R","ANGE LET","TER MUST"," BE GREA","TER THAN"," FIRST ", %180 +"IMPLICIT"," MUST BE"," FIRST S","TATEMENT"," IN PROG","RAM UNIT", %181 +"REAL/INT","EGER/LOG","ICAL/COM","PLEX/DOU","BLEPRECI","SION REQ", %182 + "ILLEGAL ","USE OF A","STERISK ","FOR RUN-","TIME EDI","TING ",%111" + "NO PROGR","AM UNIT ","FOR THIS"," END STA","TEMENT "," ",%112" +0; + +END FILL STATEMENTS; + + + END ; +IF DCINPUT THEN + BEGIN + DCPLACE(ERRORBUFF,N,XTA,LASTSEQ,MESSAGE[N DIV 16,6|(N MOD 16)], + IF TSSMESTOG THEN TSSMES(TSSMESA[(N-1)DIV 48], + ENTIER((N-1) MOD 48)) ELSE FALSE) ; + WRITE(REMOTE,9,ERRORBUFF[*]) ; + END ; +IF LISTOG OR NOT DCINPUT THEN + BEGIN + PLACE(ERRORBUFF,N,XTA,MESSAGE[N DIV 16,6|(N MOD 16)],ERRORCT, + LASTERR) ; + WRITAROW(14,ERRORBUFF) ; + END; +MOVESEQ(LASTERR,LINKLIST) ; +END ERRMESS; + +PROCEDURE FLAGROUTINE(NAME1,NAME2,ENTERING) ; +VALUE NAME1,NAME2,ENTERING ; +ALPHA NAME1,NAME2; +BOOLEAN ENTERING; +IF ENTERING THEN WRITALIST(FLAGROUTINEFORMAT,7,"ENTERI","NG",NAME1, +NAME2,"+",FIELD(FLAGROUTINECOUNTER~FLAGROUTINECOUNTER+1), +FLAGROUTINECOUNTER,0) ELSE + BEGIN + WRITALIST(FLAGROUTINEFORMAT,7,"LEAVIN","G ",NAME1,NAME2,"-", + FIELD(FLAGROUTINECOUNTER),FLAGROUTINECOUNTER,0) ; + FLAGROUTINECOUNTER~FLAGROUTINECOUNTER-1 ; + END ; +%END OF FLAGROUTINE +PROCEDURE FLAG(N); VALUE N; INTEGER N; +IF NOT ERRORTOG OR DEBUGTOG THEN +BEGIN + IF NOT (LISTOG OR SEQERRORS OR DCINPUT) THEN PRINTCARD ; + ERRMESS(N); + IF ERRORCT } LIMIT THEN GO TO POSTWRAPUP; +END; +PROCEDURE FLOG(N); VALUE N; INTEGER N; +IF NOT ERRORTOG OR DEBUGTOG THEN + BEGIN ERRORTOG ~ TRUE; + IF NOT (LISTOG OR SEQERRORS OR DCINPUT) THEN PRINTCARD; + ERRMESS(N); + IF ERRORCT } LIMIT THEN GO TO POSTWRAPUP; + END; +PROCEDURE FATAL(N); VALUE N; INTEGER N; +BEGIN + FORMAT FATALERR("XXXXXXX", X18, + "PREVIOUS ERROR IS FATAL - REMAINDER OF SUBPROGRAM IGNORED", + X17, "XXXXXXXX"); + ERRORTOG ~ FALSE; + FLAG(N); + WRITALIST(FATALERR,0,0,0,0,0,0,0,0,0) ; + WHILE NEXT ! 11 DO % LOOK FOR END STMT + BEGIN + WHILE NEXT ! SEMI DO SCAN; + EOSTOG ~ TRUE; + SCAN; + END; + SEGMENT((ADR+4) DIV 4, NSEG, FALSE, EDOC); + SCAN; +END FATAL; + +REAL STREAM PROCEDURE D2B(BCL); BEGIN SI~BCL; DI~LOC D2B; DS~8OCT END; +REAL PROCEDURE GET(I); VALUE I; INTEGER I ; + BEGIN + GET ~ INFO[(I~I).IR,I.IC]; + END GET; +PROCEDURE PUT(I,VLU); VALUE I,VLU; INTEGER I; REAL VLU; + BEGIN + INFO[(I~I).IR,I.IC] ~ VLU; + END PUT; +PROCEDURE GETALL(I,INFA,INFB,INFC); +VALUE I; INTEGER I; REAL INFA,INFB,INFC; + BEGIN + INFA ~ INFO[(I~I).IR,I.IC] ; + INFB ~ INFO[(I~I+1).IR,I.IC]; + INFC ~ INFO[(I~I+1).IR,I.IC]; + END; +PROCEDURE PUTC(I,V); VALUE I,V; INTEGER I; REAL V; +IF I~I>SUPERMAXCOM THEN FATAL(124) ELSE COM[I.IR,I.IC]~V; +REAL PROCEDURE GETC(I); VALUE I; INTEGER I ; +GETC~COM[(I~I),IR,I,IC]; +PROCEDURE BAPC(V); VALUE V; REAL V; +IF NEXTCOM~NEXTCOM+1 > SUPERMAXCOM THEN FATAL(124) +ELSE COM[NEXTCOM.IR,NEXTCOM.IC]~V ; +STREAM PROCEDURE MOVEW(F,T,D,M); VALUE D,M; + BEGIN SI ~ F; DI ~ T; D(DS ~32 WDS; DS ~ 32 WDS); DS ~ M WDS; END; +PROCEDURE CALLEQUIV(I,B,G); VALUE I,B,G; INTEGER I; REAL G; BOOLEAN B ; +BEGIN REAL A,T,R,INFA,INFC; + REAL LAST,D; LABEL L; +PROCEDURE CORRECTINFO(R,A); VALUE R,A; INTEGER R,A; +COMMENT THIS PROCEDURE CORRECTS THE INFO TABLE FOR COMMON AND + EQUIVALENCE ELEMENTS. + IF ITEMS ARE IN COMMON THE INFA[EQ] BIT IS SET + THIS BIT IS USED TO TELL DATA STATEMENTS THAT THIS IS A + COMMON ELEMENT AND IF NOT IN BLOCK DATA SUBPROGRAM EMIT + SYNTAX ERROR 168. + THE INFA[CE] BIT IS SET TO TELL THAT IF THE CLASS IS VARID + EMIT CODE AS IF THIS ITEM WERE ARRAYID BUT DO NOT + ALLOW SUBSCRIPTING; +BEGIN + REAL T,I,LAST,L,REL,TWODBIT,INFA,INFB,INFC; + REAL CEBIT; + DEFINE LB = LOWERBOUND#; + TWODBIT ~ REAL(LENGTH > 1023); + CEBIT ~ REAL(LENGTH > 1); + T ~ R; + DO + BEGIN + LAST~GETC(T).LASTC-1 ; + FOR I ~ T+2 STEP 1 UNTIL LAST DO + BEGIN + IF GETC(I).CLASS = ENDCOM THEN I~GET(I).LINK ; + INFA~GET(L~GETC(I).LINK); INFC~GET(L+2) ; + IF INFC > 0 AND LB ! 0 THEN + BEGIN + IF BOOLEAN(INFA,ADJ) THEN + REL ~ -INFC.BASE ELSE REL~INFC.BASE; + PUT(L+2,-(INFC&(REL-LB)[TOBASE])); + END; + PUT(L,INFA&TWODBIT[TOADJ]&CEBIT[TOCE]&A[TOEQ]); + END; + END UNTIL T~GETC(T).ADDR=R ; +END CORRECTINFO; + + LABEL XIT; +IF DEBUGTOG THEN FLAGROUTINE(" CALLE","QUIV ",TRUE ); +COMMENT THIS PROCEDURE MAKES THE DETERMINATION IF THIS GROUP + IS EQUIVALENCE OR COMMON IF BOTH TREATED AS COMMON; + T ~ I; + GROUPPRT ~ LENGTH ~ A ~ 0; + LOWERBOUND ~ 32000; + DO BEGIN IF GETC(T).CE=1 THEN + BEGIN IF GROUPPRT ! 0 THEN + BEGIN XTA~G; + FLAG(2); + END; + GROUPPRT~GET(A~GETC(T+1)).ADDR; + END; + IF T > R THEN R ~ T; + END UNTIL T~GETC(T).ADDR=I ; + IF GROUPPRT = 0 THEN + IF B THEN BEGIN BUMPPRT;GROUPPRT~ PRTS END ELSE %OWN + BEGIN BUMPLOCALS; GROUPPRT~LOCALS + 1536 END; + T ~ R; + SWARYCT ~0; + SSNM[6]~LOCALS ; SSNM[7]~PARMS ; SSNM[8]~PRTS ; + SSNM[9]~LSTS ; SSNM[10]~LSTA ; SSNM[11]~TV ; + SSNM[12]~SAVESUBS; SSNM[13]~NAMEIND ; SSNM[14]~LST ; + SSNM[15]~FX1 ; SSNM[16]~FX2 ; SSNM[17]~FX3 ; + SSNM[18]~NX1 ; + SEENADOUB~FALSE;% + DO IF GETC(T+1) ! 0 THEN BEGIN EQUIV(T); T~R; END + ELSE T~GETC(T).ADDR UNTIL T = R; + IF GETC(T) > 0 THEN EQUIV(T); + LOCALS~SSNM[6]; PARMS~SSNM[7]; PRTS~SSNM[8]; LSTS~SSNM[9] ; + LSTA~SSNM[10]; TV~SSNM[11]; SAVESUBS~SSNM[12]; NAMEIND~SSNM[13] ; + LSTI~SSNM[14]; FX1~SSNM[15]; FX2~SSNM[16]; FX3~SSNM[17]; + NX1~SSNM[18] ; + LENGTH ~ LENGTH - LOWERBOUND; + IF SEENADOUB THEN LENGTH~LENGTH+LENGTH.[47:1];% EVEN UP LENGTH + SEENADOUB~FALSE; + IF A = 0 THEN + BEGIN COMMENT THIS IS AN EQUIVALENCE GROUP; + IF SWARYCT } 1 AND LENGTH = 1 THEN LENGTH ~ 2; + IF LENGTH > 1 THEN + BEGIN + A ~ ENTER(-0 & ARRAYID[TOCLASS] & GROUPPRT[TOADDR], + EQVID ~ EQVID+1); + PUT(A+2,0 & LENGTH[TOSIZE]); + END; + CORRECTINFO(R,0); + GO TO XIT; + END; + COMMENT THIS IS A COMMON BLOCK; + IF T ~ (INFO ~ GET(A+2)).SIZE ! 0 THEN + IF T { 1023 AND LENGTH > 1023 THEN + BEGIN XTA ~ GET(A+1); FLAG(47) END; + IF T < LENGTH THEN PUT(A+2, INFC&LENGTH[TOSIZE]) ELSE LENGTH ~ T; + IF LENGTH = 1 THEN LENGTH ~ 2; + CORRECTINFO(R,1); + XIT: + IF LENGTH > 32767 THEN BEGIN XTA ~ GET(A+1); FLAG(100) END; +IF DEBUGTOG THEN FLAGROUTINE(" CALLE","QUIV ",FALSE) ; +END CALLEQUIV; + +STREAM PROCEDURE STOSEQ(XR,SEQ,ID); VALUE ID; +BEGIN LOCAL T; LABEL L1,L2 ; + SI ~ LOC ID; DI ~ XR; DS ~ 7LIT"0"; DS ~ CHR; SI ~ SI+1; + IF SC } "0" THEN + BEGIN SI~SI+4; DI~DI-2; + 5(IF SC= " " THEN SI~SI-1 + ELSE BEGIN DS~CHR; SI~SI-2; DI~DI-2; END); + END ELSE + BEGIN DI~DI-6; + 6(IF SC=" " THEN BEGIN TALLY~TALLY+1; SI~SI+1 END + ELSE DS~CHR); + T~TALLY; + END; + DI~XR; DI~DI+8; SI~SEQ; + 8(IF SC=" " THEN SI~SI+1 ELSE JUMP OUT TO L1); DS~8LIT"BLANKSEQ"; + GO L2; L1: SI~SEQ; DS~WDS; L2: + DI~DI+4; SI~LOC T; SI~SI+7; DS~CHR; +END; +PROCEDURE ENTERX(IDENT,ADINFO); VALUE IDENT, ADINFO; +REAL IDENT,ADINFO; +BEGIN REAL R,S; + IF ADINFO.CLASS>LABELID THEN + BEGIN + XR[2]~ADINFO; STOSEQ(XR,LINKLIST,IDENT); + IF ADINFO.CLASS=FUNID THEN XR[2].[26:1]~S~1 ; + WRITE(XREFG,3,XR[*]); XGLOBALS~TRUE; + END ; + IF R~XRI MOD XRBUFFDIV3=0 THEN + IF XRI!0 THEN WRITE(XREFF,XRBUFF,XRRY[*]) ; + XRRY[(R~R+R+R)+2]~ADINFO&S[26:47:1] ; + STOSEQ(XRRY[R],LINKLIST,IDENT) ; + IF XRI~XRI+1=1 THEN BEGIN XR[3]~IDENT; XR[4]~XRRY[2] END; +END ENTERX; + STREAM PROCEDURE TRANSFER(W2,B,K); VALUE K; + BEGIN DI~W2; SI~B; SI~SI+8; K(DS~WDS; SI=SI+16) END ; +BOOLEAN STREAM PROCEDURE CMPA(F,S); +BEGIN SI~F; DI ~ S; IF 8 SC { DC THEN TALLY ~ 1; CMPA~TALLY; END; +BOOLEAN PROCEDURE CMP(A,B); ARRAY A,B[0]; +BEGIN +CMP ~ IF A[0] < B[0] THEN TRUE ELSE IF A[0] = B[0] THEN + IF A[2].[26:4] < B[2].[26:4] THEN TRUE ELSE + IF A[2].[26:4] = B[2].[26:4] THEN CMPA(A[1],B[1]) ELSE FALSE + ELSE FALSE; +END; +PROCEDURE HV(V); ARRAY V[0]; +FILL V[*] WITH OCT777777777777777,OCT777777777777777,OCT777777777777777; + +BOOLEAN PROCEDURE INP(XR); ARRAY XR[0]; +BEGIN LABEL EOF; REAL R ; +IF EODS THEN READ(XREFG,3,XR[*])[EOF] ELSE +IF IT ~ IT+1 > XRI THEN + BEGIN EOF: INP~TRUE; IT~XRI~0; END +ELSE BEGIN + IF R~(IT-1) MOD XRBUFFDIV3=0 THEN READ(XREFF,XRBUFF,XRRY[*]) ; + XR[0]~XRRY[R~R+R+R]; XR[2]~XRRY[R+2]; TRANSFER(XR[1],XRRY[R],1) ; + END ; +END OF INP ; + +PROCEDURE VARIABLEDIMS(A,C); VALUE A, C; REAL A, C; +BEGIN + REAL NSUBS, BDLINK, BOUND, I; + LABEL XIT; +IF DEBUGTOG THEN FLAGROUTINE("VARIAB","LEDIMS",TRUE); + IF NSUBS ~ C.NEXTRA = 1 AND A.SUBCLASS < DOUBTYPE THEN GO TO XIT; + BDLINK ~ C.ADINFO; + FOR I ~ 1 STEP 1 UNTIL NSUBS DO + BEGIN + IF BOUND ~ EXTRAINFO[BDLINK.IR,BDLINK.IC] < 0 THEN + EMIT0PDCLIT(BOUND) ELSE EMITNUM(BOUND); + BDLINK ~ BDLINK -1; + IF I > 1 THEN EMIT0(MUL); + END; + IF A.SUBCLASS } DOUBTYPE THEN EMITPAIR(2, MUL); + EMITPAIR( C,SIZE,STD); + XIT: +IF DEBUGTOG THEN FLAGROUTINE("VARIAB","LEDIMS",FALSE); +END VARIABLEDIMS; + +PROCEDURE EMITD(R,OP); VALUE R,OP; REAL R,OP; FORWARD; +STREAM PROCEDURE SETPNT(W1,W2,PNT,CL,SUBC,STAR,POS,F,S,Q) ; +VALUE CL,SUBC,STAR,POS,F,S,Q ; +BEGIN F(SI~W1; SI~SI+2; DI~PNT ; + IF SC}"0" THEN + BEGIN DS~5CHR; DS~LIT" "; DI~DI-6; DS~5FILL ; + END ELSE BEGIN DS~6LIT" "; DI~PNT; DS~Q CHR END); + S(DI~PNT; DI~DI+6; DS~LIT" "; + SI ~ LOC SUBC; SI ~ SI+2; DS ~ 6 CHR; DS ~ LIT " "; + SI~LOC CL; SI~SI+2; DS~6CHR; DS~LIT" "); + DI~PNT; DI~DI+21; + POS(DI~DI+11); + SI ~ LOC STAR; SI ~ SI+7; DS ~ CHR; + SI ~ W2; DS~8CHR ; + SI ~ LOC STAR; SI ~ SI+7; DS ~ CHR; +END OF SETPNT; +PROCEDURE PT(EOF,REC); VALUE EOF; BOOLEAN EOF; ARRAY REC[0]; +BEGIN LABEL L6; REAL L; + IF EOF THEN WRITE(LINE,15,PRINTBUFF[*]) + ELSE + IF BOOLEAN(L~REAL(REC[0]~REC[0]&REC[2] [1:26:1]=XTA)) THEN + BEGIN + IF IT~IT+1=9 THEN + BEGIN LASTLINE~FALSE; WRITE(LINE,15,PRINTBUFF[*]) ; +L6: BLANKIT(PRINTBUFF,15,IT~0) ; + END; + SETPNT(REC[0],REC[1],PRINTBUFF,KLASS[REC[2],CLASS],TYPES[REC[2] + ,SUBCLASS],IF BOOLEAN(REC[2]) THEN "*" ELSE " ",IT,L-1, + LASTLINE,6-REC[2],[27:3]) ; + END + ELSE BEGIN + LASTLINE~TRUE; WRITE(RITE,15,PRINTBUFF[*]); XTA~REC[0] ; + GO L6 ; + END ; +END OF PT ; + +PROCEDURE CHECKINFO; +BEGIN REAL I, T, A; + REAL LASTF; + REAL INFB,INFC; + LABEL NXT; ALPHA N; + FORMAT INFOF( 3(A6, X2), + " ADDRESS = ", A2, A4, + ", LENGTH = ", I5, + ", OFFSET = ", I5), + INFOT( / "LOCAL IDENTIFIERS:"), + LABF(A6,X10,"LABEL REL-ADR = ",I6,", SEGMNT = ",I5); + IF PRTOG THEN + WRITALIST(INFOT,0,0,0,0,0,0,0,0,0) ; + IF I ~ SEARCH("ERR ") ! 0 THEN + IF GET(I).CLASS = UNKNOWN THEN PUT(I+1, "......"); + IF I ~ SEARCH("END ") ! 0 THEN + IF GET(I).CLASS = UNKNOWN THEN PUT(I+1, "......"); + IF NOT DCINPUT THEN IF I~SEARCH("ZIP ") ! 0 THEN + IF GET(I).CLASS=UNKNOWN THEN PUT(I+1,"......") ; + FOR I ~ 0 STEP 1 UNTIL NEXTCOM DO + IF GETC(I).CLASS=HEADER THEN + + IF GETC(I).CE=1 THEN + PUT((T~GETC(I+1).LINK+2),GET(T)&O[TOADINFO]) ; + + T ~ 2; WHILE T < NEXTINFO DO + BEGIN + GETALL(T,A,INFB,INFC); + IF I ~ A.CLASS > FILEID THEN GO TO NXT; + IF N ~ INFB = "......" THEN GO TO NXT; + XTA ~ N; + IF I = LABELID THEN + BEGIN + IF A > 0 THEN FLAG(19) ELSE + IF PRTOG THEN WRITALIST(LABF,3,N,A.ADDR DIV 4,A,SEGNO,0,0,0,0, + 0) ; + GO TO NXT; + END; + IF I = FORMATID THEN + IF A > 0 THEN BEGIN FLAG(62); GO TO NXT END ; + IF I = NAMELIST THEN + IF A > 0 THEN BEGIN FLAG(136); GO TO NXT END; + IF I = ARRAYID THEN + IF BOOLEAN(A.CE) THEN BEGIN IF A>0 THEN T~GETSPACE(T) END + ELSE IF A<0 THEN + IF BOOLEAN(A.FORMAL) THEN + BEGIN IF SPLINK > 1 AND ELX > 1 THEN + BEGIN % THIS IS A FORMAL PARAMETER FOR A SUBROUTINE OR A + % FUNCTION THAT HAS ONE OR MORE ENTRY STATEMENT. THIS + % PARAMETER WILL BE INITIALIZED TO AN ARRAY DESCRIPTOR + % TO 0 SO THAT IF THE PARAMETERS ARE NOT SET UP BY THE + % CALL ANY REFERENCE TO THEM WILL CAUSE AN INVALID + % ADDRESS + IF LASTF = 0 THEN % FIRST TIME THRU + BEGIN LASTF ~ A.ADDR; + EMITDESCLIT(2); EMITL(1); + EMITD(50,DIA); EMITD(10,DIB); EMITD(10,TRB); + END ELSE EMITPAIR(LASTF,LOD); + EMITPAIR(A.ADDR,SND); + END + END + ELSE ARRAYDEC(T); + IF PRTOG THEN + WRITALIST(INFOF,7,INFB, + IF BOOLEAN(A.TYPEFIXED) THEN TYPES[A.SUBCLASS] ELSE " ", + KLASS[A.CLASS], + IF A.ADDR < 1024 AND A < 0 THEN "R+" ELSE " ", + IF A < 0 THEN B2D(A.[26:10]) ELSE "NULL", + INFC.SIZE, + INFC.BASE,0); + IF BOOLEAN(A.CE) THEN IF A.SUBCLASS } DOUBTYPE THEN + IF BOOLEAN(INFC.BASE) THEN FLAG(146); + NXT: + T ~ T+3; + END; +END CHECKINFO; + +PROCEDURE SEGMENTSTART; +BEGIN + NSEG ~ NXAVIL ~ NXAVIL + 1; + IF LISTOG THEN WRITALIST(SEGSTRT,1,NSEG,0,0,0,0,0,0,0) ; + DEBUGADR~ADR~-1; + IF NOT SEGOVFLAG THEN + BEGIN + DATAPRT~DATASTRT~DATALINK~DATASKP~ + LABELMOM ~ BRANCHX ~ FUNVAR ~ + DT ~ SPLINK ~ NEXTCOM ~ ELX ~ 0; + NEXTSS ~ 1022; + INITIALSEGNO ~ NSEG; + FOR I ~ 0 STEP 1 UNTIL LBRANCH DO BRANCHES[I] ~ I+1; + FOR I~0 STEP 1 UNTIL SHX DO STACKHEAD[I] ~ 0; + NEXTINFO ~ LOCALS ~ 2; + F2TOG ~ FALSE; RETURNFOUND ~ FALSE; + END; + ENDSEGTOG ~ FALSE; + IF SEGSW THEN LINESET[NOLIN~0,0]~0 & D2B(LASTSEQ)[10:20:28] ; +END SEGMENTSTART; +PROCEDURE FIXPARAMS(I); VALUE I; INTEGER I; +BEGIN + REAL FMINUS, NPARMS, ELINK, LABX; + REAL PLINKX, PLINK; + REAL PTYPEX, PTYPE; + REAL CL, INF; + LABEL ARRY, LOAD, INDX; + REAL EWORD; +IF DEBUGTOG THEN FLAGROUTINE(" FIXP","ARMS ",TRUE); + EWORD ~ ENTRYLINK[I]; + ELINK ~ EWORD.LINK; + IF LABX ~ EWORD.CLASS > 0 THEN + BEGIN + EMIT0(MKS); + EMITDESCLIT(LABELMOM); + EMITL(LABX); + EMITL(1); EMITL(1); EMITL(0); + EMIT0PDCLIT(BLKCNTRLINT); + EMITL(1); EMITPAIR(FPLUS2,STD);% F+2~TRUE FOR BLKXIT CALL + END; %106- + FMINUS ~ 1920; + NPARMS ~ (J~GET(ELINK+2)).NEXTRA; + IF NPARMS > 0 THE %106- + BEGIN + PLINKX ~ EWORD.ADDR-NPARMS+1; + PTYPEX ~ J.ADINFO + NPARMS-1; + FOR J ~ 1 STEP 1 UNTIL NPARMS DO + BEGIN + PLINK ~ EXTRAINFO[PLINKX.IR,PLINKX.IC]; + PTYPE ~ EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS; + FMINUS ~ FMINUS+1; + IF PLINK = 0 THEN + BEGIN + EMIT0PDCLIT(FMINUS); + EMITL(LABX ~ LABX-1); + EMITDESCLIT(LABELMOM); + EMIT0(STD); + END ELSE + BEGIN + IF CL ~ (INF ~ GET(PLINK)).CLASS = UNKNOWN THEN CL ~ VARID; + XTA ~ GET(PLINK+1); + IF PTYPE = 0 THEN EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS + ~ PTYPE ~ CL; + CASE PTYPE OF + BEGIN ; + IF CL ! ARRAYID THEN FLAG(79) ELSE + ARRY: + BEGIN + FMINUS ~ FMINUS+1; + IF INF < 0 THEN + BEGIN + EMITPAIR(FMINUS, LOD); + EMITPAIR(T~INF.ADDR, STD); + EMIT0PDCLIT(FMINUS-1); + EMITPAIR(T-1, STD); + END; + END; + IF CL ! VARID THEN FLAG(80) ELSE + LOAD: + BEGIN + IF INF.SUBCLASS}DOUBTYPE AND CL=VARID THEN FMINUS~FMINUS+1; + IF INF<0 THEN + BEGIN + EMITPAIR(FMINUS, LOD); + EMITPAIR(T~INF.ADDR,STD); + IF INF.SUBCLASS}DOUBTYPE AND CL=VARID THEN %105- + BEGIN EMIT0PDCLIT(FMINUS-1); + EMITPAIR(T+1,STD); + END; + END ; + END; + ; ; ; ; + IF CL = FUNID THEN GO TO LOAD ELSE FLAG(81); + + ; + IF CL = FUNID OR CL = SUBRID OR CL = EXTID THE GO TO LOAD + ELSE FLAG(83); + IF CL = SUBRID THEN GO TO LOAD ELSE FLAG(82); + ; ; + BEGIN + IF CL = ARRAYID THEN + BEGIN + EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS ~ CL; + GO TO ARRY; + END; + INDX: + IF CL ! VARID THEN FLAG(80); + FMINUS ~ FMINUS+1; + IF INF < 0 THEN + BEGIN + EMIT0PDCLIT(FMINUS-1); + EMITDESCLIT(FMINUS); + EMITPAIR(INF.ADDR, STD); + END; + END; + IF CL = VARID THEN GO TO LOAD ELSE FLAG(80); + GO TO INDX; + END CASE STATEMENT; + + + A ~ INF.SUBCLASS; + IT T ~ EXTRAINFO[PTYPEX.IR,PTYPEX.IC].SUBCLASS = 0 OR + T = INTYPE AND A = REALTYPE THEN + EXTRAINFO[PTYPEX.IR,PTYPEX.IC].SUBCLASS ~ A ELSE + IF T ! A THEN + BEGIN XTA ~ GET(PLINK+1); FLAG(88) END; + END; + PLINKX ~ PLINKX+1; + PTYPEX ~ PTYPEX-1; + END; + PLINKX ~ PLINKX-NPARMS; + FOR J ~ 1 STEP 1 UNTIL NPARMS DO + BEGIN + PLINK ~ EXTRAINFO[PLINKX.IR,PLINKX.IC]; + IF PLINK ! 0 THEN + IF (A~GET(PLINK)).CLASS = ARRAYID THEN + IF T~GET(PLINK+2) <0 THEN VARIABLEDIMS(A, T); + PLINKX ~ PLINKX+1; + END; + END; + EMITB(GET(ELINK+2).BASE & (GET(ELINK).SEGNO)[TOSEGNO], FALSE); +IF DEBUGTOG THEN FLAGROUTINE(" FIXP","ARMS ",FALSE) ; +END FIXPARAMS; + +PROCEDURE XREFCORESORT ; + BEGIN + REAL F,G,H,J,K,L,T,TT,IJ,M,TN ; + SAVE ARRAY A[0:XRI-1], IL,IU[0:8]; + ARRAY W2,W3[0:XRI-1] ; + LABEL L1,L2,L3,L4,L5,L6,L11,L12,L13,L14 ; + DEFINE CMPARGT(A) = A.NAME=TN THEN IF (IF G~W3[H~A.[2:10]].[26:4] + =TT~W3[F~T.[2:10]].[26:4] THEN NOT CMPA(W2[H], + W2[F]) ELSE G>TT) #, + CMPARLS(A) = A.NAME=TN THEN IF (IF G~W3[H~T.[2:10]].[26:4] + =TT~W3[F~A.[2:10]].[26:4] THEN NOT CMPA(W2[H], + W2[F]) ELSE G>TT) #, + NAME = [12:36] # ; + J~XRI-1; G~XRI DIV K~XRBUFFDIV3; H~XRBUFF ; + FOR L~1 STEP 1 UNTIL G DO + BEGIN +L11: READ(XREFF,H,XRRY[*]); TRANSFER(W2[T~(L-1)|50,XRRY,K) ; + IJ~T+K-1; TN~-3; + FOR F~T STEP 1 UNTIL IJ DO + BEGIN A[F]~XRRY[TN~TN+3]&F[2:38:10]; W3[F]~XRRY[TN+2] END; + END; + IF H=XRBUFF THEN IF K~XRI MOD K DIV 1!0 THEN BEGIN H~3|X;GO L11 END; + GO L4 ; +L1: IF A[K~I].NAME>TN~(T~A[IJ~((L~J)+I+1).[37:10]]).NAME THEN +L12: BEGIN A[IJ]~A[I]; A[I]~T; TN~(T~A[IJ]).NAME END + ELSE IF CMPARGT(A[I]) THEN GO L12 ; + IF A[J].NAMETN THEN GO L2; IF CMPARGT(A[L]) THEN GO L2; +L3: IF A[K~K+1].NAMEJ+I THEN BEGIN IL[M]~I; IU[M]~L; I~K END + M~M+1 ; +L4: IF I+10TN~(T~A[I]).NAME THEN + BEGIN +L5: A[K+1]~A[K]; IF A[K~K-1].NAME>TN THEN GO L5 ; + IF CMPARGT(A[K]) THEN GO L5 ; + A[K+1]~T ; + END + ELSE IF CMPARGT(A[K]) THEN GO L5 ; + IF (M~M-1) GEQ 0 THEN BEGIN I~IL[M]; J~IU[M]; GO L4 END ; + G~XRI-1 ; + FOR I~ 0 STEP 1 UNTIL G DO + IF BOOLEAN(L~REAL(A[I]~A[I].NAME&(TN~W3[J~A[I].[2:10]])[1:26:1] + =XTA)) THEN + BEGIN + IF IT~IT+1=9 THEN + BEGIN LASTLINE~FALSE; WRITE(LINE,15,PRINTBUFF[*]) ; +L6: BLANKIT(PRINTBUFF,15,IT~0) ; + END ; + SETPNT(A[I],W2[J],PRINTBUFF,KLASS[TN.CLASS],TYPES[TN. + SUBCLASS],IF BOOLEAN(TN) THEN "*" ELSE " ",IT,L-1, + LASTLINE,6-TN.[27:3]) ; + END + ELSE BEGIN + LASTLINE~TRUE; WRITE(RITE,15,PRINTBUFF[*]); XTA~A[I]; + GO L6; + END ; + WRITE(LINE,15,PRINTBUFF[*]); XRI~0; + END OF XREFCORESORT ; + +PROCEDURE SETPSTACK ; +BEGIN + REAL I; + EMIT0PDCLIT(16); + EMITL(1); + EMIT0(ADD); + EMITL(16); + EMIT0(SND); + FOR I ~ 1 STEP 1 UNTIL LOCALS DO EMITL(0); + CHECKINFO; + IF DATAPRT ! 0 THEN + BEGIN ADJUST; EMIT0PDCLIT(DATAPRT); EMIT0(LNG); EMITB(-1,TRUE); + DATASKP~LAX; EMITB(DATASTRT,FALSE); FIXB(DATALINK); + EMITL(1); EMITPAIR(DATAPRT,STD); FIXB(DATASKP); + END; + ADJUST; +END SETUPSTACK; + +PROCEDURE BRANCHLIT(X,Y); VALUE X,Y; REAL X; BOOLEAN Y; +BEGIN + IF ADR } 4075 THEN + BEGIN ADR ~ ADR+1; SEGOVF END; + ADJUST; + IF X.SEGNO!NSEG THEN BEGIN + IF(PRTS+1).[37:2]=1 AND Y THEN + EMIT0PDCLIT(PRGDESCBLDR(2,0,(ADR+5) DIV 4+1,NSEG)) + ELSE EMIT0PDCLIT(PRGDESCBLDR(2,0,(ADR+5) DIV 4,NSEG)) END + ELSE + EMITL((ADR+5) DIV 4 - X.LINK DIV 4) ; +END BRANCHLIT; +PROCEDURE SEGMENT(SZ,CURSEG,SEGTYP,EDOC); % WRITES OUT EDOC AS SEGMENT + VALUE SZ,CURSEG,SEGTYP; % UPDATES PDPRT WITH PSUEDO + REAL SZ,CURSEG; % UPDATES PDPRT WITH PSUEDO + BOOLEAN SEGTYP; % TRUE TO WRAP UP A SUBROUTINE BLOCK + % FALSE TO WRAP UP A SPLIT BLOCK + ARRAY EDOC[0,0]; % CONTAINS DATA TO WRITE; + BEGIN + STREAM PROCEDURE M1(F,T); BEGIN DI ~ T; SI ~ F; DS ~ 2 WDS END; + REAL T; + REAL BEGINSUB, ENDSUB, HERE; + LABEL WRITEPGM; + INTEGER I, CNTR; +IF DEBUGTOG THEN FLAGROUTINE(" SEGM","ENT ",TRUE ); + IF NOT SEGTYP THEN GO TO WRITEPGM; + IF SPLINK > 1 AND NOT RETURNFOUND THEN + BEGIN XTA ~ BLANKS; FLAG(142) END; + IF SPLINK < 0 THEN + BEGIN + ADJUST; + BDPRT[BDX~BDX+1] ~ PRGDESCBLDR(1, 0, (ADR+1) DIV 4, NSEG); + FOR I ~ 1 STEP 1 UNTIL LOCALS DO EMITL(0); + CHECKINFO; + + EMITB(0&INITIALSEGNO[TOSEGNO], FALSE); + END + ELSE + IF SPLINK = 1 THEN % MAIN PROGRAM + BEGIN + ADJUST; + IF STRTSEG ! 0 THEN FLAG(75); + STRTSEG ~ NSEG & + PRGDESCBLDR(1, 0, (ADR+1) DIV 4, NSEG)[18:33:15]; + SETUPSTACK; + + EMITB(0&INITIALSEGNO[TOSEGNO]), FALSE); + END + ELSE + IF ELX { 1 THEN + BEGIN + ADJUST; + T ~ PRGDESCBLDR(1, GET(SPLINK).ADDR, (ADR+1) DIV 4, NSEG); + SETUPSTACK; + FIXPARAMS(0); + INFO[SPLINK.IR, SPLINK.IC].SEGNO ~ NSEG; + END + ELSE + BEGIN + ADJUST; + BEGINSUB ~ (ADR+1) & NSEG[TOSEGNO]; + EMITL(17); EMIT0(STD); + SETUPSTACK; + EMIT0PDCLIT(17); EMIT0(GFW); + ENDSUB ~ ADR & NSEG[TOSEGNO]; + FOR I ~ 0 STEP 1 UNTIL ELX-1 DO + BEGIN + ADJUST; + HERE ~ (ADR+1) DIV 4; + T ~ ENTRYLINK[I].LINK; +%VOID + T ~ PRGDESCBLDR(1, GET(T).ADDR, HERE, NSEG); + BRANCHLIT(ENDSUB,FALSE); + EMITB(BEGINSUB, FALSE); + ADJUST; + FIXPARAMS(I); + INFO[(ENTRYLINK[I].LINK).IR,(ENTRYLINK[I].LINK).IC].SEGNO~NSEG; + END; + END; + SZ ~ (ADR+4) DIV 4; + CNTR ~ 0; + CURSEG ~ NSEG; + WRITEPGM; + NSEG ~ ((T ~ SZ) + 29) DIV 30; + IF DALOC DIV CHUNK < I ~ (DALOC+NSEG) DIV CHUNK + THEN DALOC ~ CHUNK | I; % INSURE SEGMENT DONT BREAK + % ACROSS ROW + IF LISTOG THEN WRITALIST(SEGEND,2,CURSEG,T,0,0,0,0,0,0) ; + PDPRT[PDIR,PDIC] ~ % PDPRT ENTRY FOR SEGMENT + SZ&DALOC[DKAC] + & GET(SPLINK)[12:41:1] + &CURSEG[SGNOC]; + IF ERRORCT = 0 THEN + DO BEGIN + FOR I~0 STEP 2 WHILE I < 30 AND CNTR < SZ DO + BEGIN M1(EDOC[CNTR.[38:3],CNTR.[41:7]],CODE(I)); + CNTR ~ CNTR + 2; + END; + WRITE(CODE[DALOC]); + DALOC ~ DALOC +1; + END UNTIL CNTR } SZ; + PDINX ~ PDINX +1; + IF NOT SEGOVFLAG THEN + IF PXREF THEN + IF(EODS~(NEXT=EOF))AND NOT XGLOBALS THEN ELSE + BEGIN KLASS[6]~ "LABEL "; + WRITE(XREFF,XRBUFF,XRRY[*]) ; + IF FIRSTCALL THEN DATIME ELSE WRITE(PTR[PAGE]); + IF SPLINK<0 THEN + BEGIN WRITE(PTR,XHEDB);REWIND(XREFF);END + ELSE + IF FODS THEN BEGIN WRITE(PTR,XHEDG); REWIND(XREFG) END + ELSE BEGIN REWIND(XREFF); C2~(XR[4].SUBCLASS|2+5); + IF TT~XR[4].CLASS=FUNID THEN WRITE(PTR,XHEDF, + XR[C2],XR[C2+1],XR[3],XR[C2+12], + XR[C2+13],"------") + ELSE IF IT=SUBRID THEN WRITE(PTR,XHEDS,XR[3], + "------") ELSE WRITE(PTR,XHEDM); + END; + IT~XTA~0; + LASTLINE ~ FALSE; + BLANKIT(PRINTBUFF,15,0); + IF XRI>1023 OR EODS THEN SORT(PT,INP,0,HV,CMP,3,4000) + ELSE XREFCORESORT ; + REWIND(XREFF); + PXREF~IF XREF THEN TRUE ELSE FALSE; + KLASS[6] ~ "ERROR "; + IF (NOT SEGTYP AND EODS) OR (SEGTYP AND LISTOG AND + NOT SEGPTOG) THEN WRITE (PTR[PAGE]); + END; + IF LISTOG AND SEGTYP AND SEGPTOG THEN WRITE(PTR[PAGE]); + IF SEGTYP THEN + BEGIN + FOR I~12,17 STEP 1 UNTIL 24,39 STEP 1 UNTIL 41, + 50 STEP 1 UNTIL 57 DO TIPE[I]~REALID ; + FOR I~25,33 STEP 1 UNTIL 37 DO TIPE[I]~INTID ; + LASTNEXT ~ 1000; + END; + ENDSEGTOG ~ TRUE; + TSEGSZ ~ TSEGSZ + SZ; + COMMENT IF SEGSW THEN LETS ALSO WRITE OUT THE LINE SEGMENTS + THAT WE VE GONE TO SUCH TROUBLE BUILDING. LINESEG + CONTAINS A CARD SEQUENCE NUMBER(BINARY) IN [10:28] + AND THE WORD BOUNDARY ADDRESS OF THE FIRST CODE + SYLLABE IN [38:10]; + IF SEGSW THEN + IF NOLIN > 0 THEN + BEGIN + LINEDICT[CURSEG.IR,CURSEG.IC] ~ % UPDATE LINE DICTIONARY + 0 & NOLIN[18:33:15] & DALOC[33:33:15];%FOR THIS SEGMENT + CNTR ~ 0; DO BEGIN + FOR I ~ 0 STEP 2 WHILE I<30 AND CNTR 30 THEN 30 ELSE (SZ-I)); + WRITE(CODE[DALOC]); + DALOC ~ DALOC +1; + END; + IF LISTOG THEN WRITALIST(SEGEND,2,SEG,T,0,0,0,0,0,0) ; + TSEGSZ ~ TSEGSZ + SZ; + END WRITEDATA; + +REAL PROCEDURE PRGDESCBLDR(DT,PRT,RELADR,SGNO); + VALUE DT,PRT,RELADR,SGNO; + REAL DT,PRT,RELADR,SGNO; + BEGIN + FORMAT FMT("PRT=",A4,", REL-ADR=",A4,", SEG=",I4,", TYPE=",A2); + IF PRT=0 THEN BEGIN BUMPPRT; PRT~PRTS END; + PDPRT[PDIR,PDIC] ~ + 0&DT[DTYPC] + &PRT[PRTAC] + &RELADR[RELADC] + &SGNO[SGNOC]; + PDINX ~ PDINX +1; + IF CODETOG THEN WRITALIST(FMT,4,B2D(PRT),B2D(RELADR),SGNO, + IF DT=0 THEN "AE" ELSE IF DT=1 THEN "PD" ELSE "LD",0,0,0,0) ; + PRGDESCBLDR ~ PRT; + END PRGDESCBLDR; + +PROCEDURE EQUIV(R); VALUE R; REAL R; +COMMENT THIS PROCEDURE FIXES UP THE INFO TABLE FOR THE EQUIV OR + COMMON RING. THE FIRST ELEMENT PAST HAS AN OFFSET (DO NOT + ALTER THIS) THE TYPE IS FIXED, THE OFFSET IS DETERMINED + FROM THE FIRST, CORRECTINFO ADJUST THE OFFSET IF THERE + IS A NEGATIVE OFFSET ON ANY ELEMENT. THE INFA[ADJ] BIT IS + SET IF THE ELEMENT HAS A NEGATIVE OFFSET. IF THE ELEMENT + APPEARED IN MORE THAN ONE EQUIVALENCE STATEMENT OR AN + EQUIVALENCE STATEMENT AND A COMMON STATEMENT THE ELEMENTS + ARE LINKED BY COM[LASTC] WHICH POINTS TO THE HEADER + OF THAT STATEMENT; +BEGIN + DEFINE BASS = LOCALS #, % THESE DEFINES ARE USED TO REDUCE THE + REL = PARMS #, % STACKSIZE OF EQUIV FOR RECURSION + I = PRTS #, + T = LSTS #, + Q = LSTA #, + LAST = TV #, + B = SAVESUBS #, + P = NAMEIND #, + PRTX = LSTI #, + C = FX1 #, + INFA = FX2 #, + INFB = FX3 #, + INFC = NX1 #; + LABEL XIT, CHECK; +IF DEBUGTOG THEN FLAGROUTINE(" EQU","IV ",TRUE) ; + IF GETC(R) <0 THEN GO TO XIT; + PUTC(R,-GETC(R)) ; + PRTX ~ GROUPPRT; + C~REAL(GETC(R),CE=1) ; + LAST~GETC(R).LASTC=1 ; + BASS~GETC(R+1); P~0 ; + FOR I ~ R+2 STEP 1 UNTIL LAST DO + BEGIN IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; + GETALL(T~GETC(I).LINK,INFA,INFB,INFC) ; + IF Q~INFC.SIZE=0 THEN % A SIMPLE VARIABLE + INFC.SIZE ~ Q ~ IF INFA.SUBCLASS { LOGTYPE THEN 1 ELSE 2; + PUT(T+2,INFC); + IF INFA.SUBCLASS>LOGTYPE THEN SEENADOUB~TRUE; + IF BOOLEAN(C) THEN + BEGIN COM[PWI].RELADD~REL~P ; + P ~ P + Q; + END ELSE COM[PWI].RELADD~REL~BASS-GETC(I).RELADD ; + IF INFA < 0 THEN IF INFA .ADJ = 1 THEN + B ~ -INFC.BASE - REL ELSE B ~ INFC.BASE - REL; + END; + FOR I ~ R+2 STEP 1 UNTIL LAST DO + BEGIN IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; + GETALL(T~GETC(I).LINK,INFA,INFB,INFC) ; + IF INFA.CLASS = 1 THEN SWARYCT ~ 1; + P~B+GETC(I).RELADD ; + Q ~ INFC .SIZE; + IF INFA < 0 THEN + BEGIN IF INFA .ADJ = 1 THEN BASS ~ -INFC .BASE ELSE + BASS ~ INFC.BASE; + IF P ! BASS THEN + BEGIN XTA ~ INFB ; FLAG(2) END; + GO TO CHECK; + END; + INFA ~ -INFA & PRTX[TOADDR]; + IF INFA .CLASS = UNKNOWN THE INFA .CLASS ~ VARID; + INFA .TYPEFIXED ~ 1; + INFC.BASE ~ P; + PUT(T+2,INFC); + IF P < 0 THEN INFA .ADJ ~ 1; + PUT(T,INFA); + CHECK: + IF P+Q > LENGTH THEN LENGTH ~ P+Q; + IF P < LOWERBOUND THEN LOWERBOUND ~ P; + END; + FOR I ~ R+2 STEP 1 UNTIL LAST DO + BEGIN + IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; + IF T~GETC(I).LASTC|R THEN + IF GETC(T)}0 THEN + BEGIN R~R&LAST[3:33:15]&[18:33:15] ; + EQUIV(T); LAST~R.[3:15]; I~R.[18:15]; R~R.[33.15] ; + END; + END; + XIT: +IF DEBUGTOG THEN FLAGROUTINE(" EQU","IV ",FALSE) ; +END EQUIV; +ALPHA PROCEDURE GETSPACE(S); VALUE S; ALPHA S; +BEGIN LABEL RPLUS, FMINUS, XIT; + LABEL DONE; + REAL A; + BOOLEAN OWNID; + IF OWNID ~ S < 0 THEN S~ -S; % IN DATA STMT, THUS OWN + IF A ~ GET(GETSPACE~S) < 0 THEN GO TO DONE; + IF A.CLASS GEQ 13 THEN FLAG(34) ELSE +CASE A.CLASS OF +BEGIN +BEGIN + PUT(S,A~A&VARID[TOCLASS]); + PUT(S+2,(GET(S+2) &(IF A.SUBCLASS { LOGTYPE + THEN 1 ELSE 2 )[TOSIZE])); +END; + IF BOOELAN(A,FORMAL) THEN BUMPLOCALS; +; +BEGIN A.TYPEFIXED ~ 1; GO TO RPLUS END; +GO TO RPLUS; +GO TO RPLUS; +GO TO DONE; +BEGIN A.TYPEFIXED ~ 1; IF BOOLEAN(A.FORMAL) THE GO TO FMINUS + ELSE GO TO RPLUS; +END; +BEGIN A.TYPEFIXED ~ 1; GO TO RPLUS END; +IF BOOLEAN(A.FORMAL) THEN GO TO FMINUS ELSE GO TO RPLUS; +IF BOOLEAN(A.FORMAL) THEN GO TO FMINUS ELSE GO TO RPLUS; +GO TO RPLUS; +GO TO RPLUS; +END OF CASE STATEMENT; + + +A.TYPEFIXED ~ 1; +IF BOOLEAN(A.FORMAL) THEN + GO TO FMINUS; +IF BOOLEAN(A.CE) OR BOOLEAN(A.EQ) THEN +BEGIN + PUT(S,A); + CALLEQUIV(A,ADDR,OWNID,GET(S+1)) ; + GO TO DONE; +END; + A.TWOD ~ REAL(GET(S+2).SIZE > 1023); +FMINUS: + IF OWNID THEN BEGIN BUMPPRT; A.ADDR~PRTS END ELSE + BEGIN BUMPLOCALS; A.ADDR ~ LOCALS +1536 END; + IF A.CLASS = VARID THEN IF A.SUBCLASS } DOUBTYPE THEN + IF OWNID THEN BUMPPRT ELSE + BUMPLOCALS; + GO TO XIT; +RPLUS: + BUMPPRT; A.ADDR~PRTS; +XIT: + PUT(S, -A); +DONE: +END GETSPACE; +INTEGER STREAM PROCEDURE LBLSHFT(S); VALUE S; + BEGIN + LOCAL T; + LABEL L; + DI ~ LOC LBLSHFT; DS ~ 8 LIT "00 "; + DI ~ DI - 6; SI ~LOC S; SI ~ SI + 2; + TALLY ~ 1; T ~ TALLY; + 5(T(IF SC="0" THEN BEGIN SI~SI+1; JUMP OUT 1 TO L END + ELSE TALLY~0; T~TALLY); + IF SC}"0" THEN DS~CHR ELSE IF SC=" " THEN SI~SI+1 + ELSE JUMP OUT; L: ) ; + IF SC ! " " THEN BEGIN DI ~ LOC LBLSHFT; DS ~ LIT "+" END; + END LBLSHFT; + COMMENT EMITTERS AND CODE CONTROL; +ALPHA PROCEDURE B2D(B); VALUE B; REAL B; + B2D ~ O&B[45:45:3]&B[39:42:3]&B[33:39:3]&B[27:36:3]; +PROCEDURE DEBUG(S); % PRINTS OUT DEBUG CODE + VALUE S; REAL S; % IF S<0 THEN S IS FIELD TYPE OPERATOR + BEGIN + FORMAT FF(X35,*(33(".")),A4,":",A1,2(X2,A4),X4,A4) ; + ALPHA CODF,MNM,SYL; + REAL T; +PROCEDURE SEARCH(CODE,S); VALUE S; REAL S,CODE; + BEGIN % SEARCHS WOP TO FIND CODE FOR S + REAL N,I; + LABEL L; + N ~ 64; + FOR I ~ 66 STEP IF WOP[I] < S THEN N ELSE -N + WHILE N ~ N DIV 2 } 1 DO + IF WOP[I] =S THEN GO TO L; + I ~ 0; % NOT FOUND + L: CODE ~ WOP[I+1]; + END SEARCH; + + IF S < 0 THEN + BEGIN % FIELD TYPE OPERATOR + SYL ~ S; + MNM ~ B2D(S.[36:6]); + IF (S ~ S.[42:6]) = 37 THEN CODE ~ "ISO " ELSE + IF S = 45 THEN CODE ~ "DIA " ELSE + IF S = 49 THEN CODE ~ "DIB " ELSE + IF S = 53 THEN CODE ~ "TRB "; + END + ELSE + BEGIN + IF (T ~ S.[46:2]) ! 1 THEN + BEGIN + SYL ~ S; + MNM ~ B2D(S.[36:10]); + IF T = 0 THEN CODE ~ "LITC" + ELSE IF T =2 THEN CODE ~ "OPDC" + ELSE CODE ~ "DESC"; + END + ELSE + BEGIN % SEARCH WOP FOR OPERATOR NAME + SYL ~ S; + MNM ~ " "; + SEARCH(CODE,S.[36:10]); + END; + END; + WRITALIST(FF,6,IF ADR{DEBUGADR THEN 1 ELSE -1,B2D(ADR.[36:10]), + B2D(ADR.[46:2]),CODE,MNM,B2D(SYL),0,0) ; + IF DEBUGADR0 THEN S~GET(GETSPACE(P)); + IF S.CLASS = VARID THEN IF BOOLEAN(S.CE) THEN + IF BOOLEAN(S.TWOD) THEN + BEGIN + EMITL( (T~GET(P+2).BASE).[33:7]); + EMITDESCLIT(S.ADDR); + EMIT0(LOD); + EMITL(T.[40:8]); + EMIT0(CDC); + GO TO XIT; + END ELSE + EMITNUM(GET(P+2).BASE) + ELSE + IF NOT BOOLEAN(S.FORMAL) THEN IF NOT DESCREQ THEN + BEGIN + EMITL(S~S.ADDR); + IF S.[37:2]=1 THEN %REFERENCING 2ND HALF OF PRT; + BEGIN + IF ADR } 4087 THEN + BEGIN ADR ~ ADR+1; SEGOVF END; + EMIT0(XRT); + END; + GO TO XIT; + END; + EMITDESCLIT(S.ADDR); + XIT: +END EMITN; + +PROCEDURE EMITV(P); VALUE P; ALPHA P; + BEGIN + ALPHA S; + IF S~ GET(P) > 0 THEN S ~ GET(GETSPACE(P)); + IF S.CLASS = VARID THEN + IF BOOLEAN(S.CE) THEN + IF BOOLEAN(S.TWOD) THEN + BEGIN + EMITL( (T~GET(P+2).BASE).[33:7]); + EMITDESCLIT(S.ADDR); + EMIT0(LOD); + IF S.SUBCLASS } DOUBTYPE THEN + BEGIN + EMIT0(DUP); + EMITPAIR(T.[40:8]+1, COC); + EMIT0(XCH); + EMITPAIR(T.[40:8], COC); + END ELSE EMITPAIR(T.[40:8], COC); + END + ELSE + IF S.SUBCLASS } DOUBTYPE THEN + BEGIN + EMITNUM( (T~GET(P+2).BASE)+1); + EMIT0PDCLIT(S.ADDR); + EMITNUM(T); + EMIT0PDCLIT(S.ADDR); + END ELSE + BEGIN + EMITNUM(GET(P+2).BASE); + EMIT0PDCLIT(S.ADDR); + END + ELSE + IF S.SUBCLASS } DOUBTYPE THEN + IF BOOLEAN(S.FORMAL) THEN + BEGIN + EMITDESCLIT(S.ADDR); + EMIT0(DUP); + EMITPAIR(1, XCH); + EMIT0(INX); + EMIT0(LOD); + EMIT0(XCH); + EMIT0(LOD); + END ELSE + BEGIN + EMIT0PDCLIT(S.ADDR+1); + EMIT0PDCLIT(S.ADDR); + END + ELSE EMIT0PDCLIT(S.ADDR) + ELSE EMIT0PDCLIT(S.ADDR); +END EMITV; + +PROCEDURE EMITL(N); VALUE N; REAL N; + BEGIN + BUMPADR; + PACK(EDOC[EDOCI],(N~0&N[36:38:10]),ADR.[46:2]); + IF CODETOG THEN DEBUG(N); +END EMITL; +PROCEDURE EMITD(R, OP); VALUE R, OP; REAL R, OP; +BEGIN + BUMPADR; + PACK(EDOC[EDOCI], (R ~ OP & R[36:42:6]), ADR.[46:2]); + IF CODETOG THEN DEBUG(-R); +END EMITD; +PROCEDURE EMITDDT(B,A,X); VALUE B,A,X; INTEGER B,A,X ; + BEGIN % DOES DIB B, DIA A, TRB X; HANDLES [B:A:X]. + EMITD(B~B MOD 6+B DIV 6|8,DIB); EMITD(A~A MOD 6+A DIV 6|8,DIA) ; + EMITD(X~X,TRB); + END OF EMITDDT ; +PROCEDURE EMITPAIR(L, OP); VALUE L, OP; INTEGER L, OP; +BEGIN + EMITL(L); + IF L.[37:2] = 1 THEN + BEGIN + IF ADR } 4087 THEN + BEGIN ADR ~ ADR+1; SEGOVF END; + EMIT0(XRT); + END; + EMIT0(OP); +END EMITPAIR; +PROCEDURE ADJUST; + WHILE ADR.[46:2] ! 3 DO EMIT0(NOP); +PROCEDURE EMITNUM(N); VALUE N; REAL N; + BEGIN + DEFINE CPLUS = 1792#; + IF N.[3:6] =0 AND ABS(N) < 1024 THEN + BEGIN + EMITL(N); + IF N < 0 THEN EMIT0(SSN); + END ELSE + BEGIN + IF ADR } 4079 THEN + BEGIN ADR ~ ADR+1; SEGOVF END; + EMIT0PDCLIT(CPLUS + (ADR+1).[46:1] + 1); + EMITL(2); + EMIT0(GFW); + ADJUST; + BUMPADR; + PACK(EDOC[EDOCI],N.[1:11],ADR.[46:2]); + BUMPADR; + PACK(EDOC[EDOCI],N.[12:12],ADR.[46:2]); + BUMPADR; + PACK(EDOC[EDOCI],N.[24:12],ADR.[46:2]); + BUMPADR; + PACK(EDOC[EDOCI],N.[36:12],ADR.[46:2]); + IF N.[36:12]=49 THEN %%% IF C-REL CONSTANT LOOKS LIKE AN XRT + EMIT0(NOP); %%% THEN INSURE AGAINST P-BIT INTERRUPT. + IF CODETOG THEN DEBUGWORD(N); + END; +END EMITNUM; + +PROCEDURE EMITNUM2(HI,LO);VALUE HI,LP; REAL HI,LO; + BEGIN + BOOLEAN B; REAL I,N; + LABEL Z,X; + DEFINE CPLUS = 1792#; + IF HI=0 OR LO=0 THEN BEGIN EMITNUM(LO); EMITNUM(HI); GO Z END; + ADJUST; + IF ADR } 4077 THEN + BEGIN ADR~ADR+1; SEGOVF; ADR~-1 END; + EMIT0PDCLIT(CPLUS + 2); EMIT0PDCLIT(CPLUS + 1); + EMITPAIR(3,GFW); + X: FOR I ~ 0 STEP 1 UNTIL 3 DO + BEGIN + CASE I OF BEGIN + N ~ HI.[ 1:11]; + N ~ HI.[12:12]; + N ~ HI.[24:12]; + N ~ HI.[36:12]; + END CASE; + BUMPADR; PACK(EDOC[EDOCI],N,ADR.[46:2]); + END; + IF CODETOG THEN DEBUGWORD(HI); + IF NOT B THEN BEGIN B~TRUE; HI~LO; GO TO X; END; + IF N=49 THEN %%% IF C-REL CONSTANT LOOKS LIKE AN XRT + EMIT0(NOP) ; %%% THEN INSURE AGAINST P-BIT INTERRUPT. +Z: + END EMITNUM2; + +PROCEDURE EMITLINK(N); VALUE N; REAL N; % EMITS LINKS + BEGIN + FORMAT FF(X35,*(33(".")),A4,":",A1," LINK",X10,A4,"******") ; + BUMPADR; + PACK(EDOC[EDOCI],N,ADR.[46:2]); + IF CODETOG THEN + WRITALIST(FF,4,IF ADR{DEBUGADR THEN 1 ELSE -1,B2D(ADR.[36:10]), + B2D(ADR.[46:2]),B2D(N),0,0,0,0) ; + IF DEBUGADRLBRANCH THEN FATAL(123); + BRANCHX ~ BRANCHES[LAX~BRANCHX]; + BRANCHES[LAX] ~ -(ADR+1); + EMITLINK(0); + EMIT0(IF C THEN BFC ELSE BFW); + EMIT0(NOP); + END ELSE + BEGIN + SEG ~ A.SEGNO; + A ~ A.LINK; + BEOREF ~ ADR > A; + IF A.[46:2] =0 THEN + BEGIN + IF SEG > 0 AND SEG ! NSEG THEN + EMIT0PDCLIT(PRGDESCBLDR(2, 0, A.[36:10], SEG)) + ELSE + EMITL(ABS((ADR+2).[36:10] - A.[36:10])); + IF BEOREF THEN + EMIT0( IF C THEN GBC ELSE GBW) ELSE + EMIT0( IF C THEN GFC ELSE GFW); + END ELSE + BEGIN + EMITL(ABS(ADR + 3 - A)); + IF BEOREF THEN + EMIT0(IF C THEN BBC ELSE BBW) ELSE + EMIT0(IF C THEN BFC ELSE BFW); + END; + END; +END EMITB; + +PROCEDURE EMITDESCLIT(N); VALUE N; REAL N; + BEGIN + IF N.[37:2] = 1 THEN + BEGIN + IF ADR } 4087 THEN + BEGIN ADR ~ ADR+1; SEGOVF END; + EMIT0(XRT); + END; + BUMPADR; + PACK(EDOC[EDOCI],(N~3&N[36:38:10]),ADR.[46:2]); + IF CODETOG THEN DEBUG(N); +END EMITDESCLIT; +PROCEDURE EMIT0PDCLIT(N); VALUE N; REAL N; + BEGIN + IF N.[37:2] = 1 THEN + BEGIN + IF ADR } 4087 THEN + BEGIN ADR ~ ADR+1; SEGOVF END; + EMIT0(XRT); + END; + BUMPADR; + PACK(EDOC[EDOCI],(N~2&N[36:38:10]),ADR.[46:2]); + IF CODETOG THEN DEBUG(N); +END EMIT0PDCLIT; +PROCEDURE EMITLABELDESC(N); VALUE N; ALPHA N; +BEGIN + LABEL XIT; + REAL T,B,C,D ; + IF N ~ LBLSHFT(XTA~N) = 0 OR N = BLANKS THEN + BEGIN FLAG(135); GO TO XIT END; + IF T ~ SEARCH(N) = 0 THEN + T ~ ENTER(0 & LABELID[TOCLASS], N) ELSE + IF GET(T).CLASS ! LABELID THEN + BEGIN FLAG(144); GO TO XIT END; + IF XREF THEN ENTERX(N,0&LABELID[TOCLASS]); + IF B ~(C~GET(T+2)).BASE =0 THEN + IF (D~GET(T)).SEGNO!0 THEN C.BASE~B~PRGDESCBLDR(2,0,D.ADDR DIV 4, + D.SEGNO) ELSE + BEGIN BUMPPRT; C.BASE~B~PRTS END; PUT(T+2,C); + EMITL(B); EMIT0(MKS); + EMITDESCLIT(1536); % F+0 + EMIT0PDCLIT(1537); % F+1 + EMITV(NEED(".LABEL", INTRFUNID)); + XIT: +END EMITLABELDESC; + +COMMENT TRACEBACK, OFLOWHANGERS, AND PRTSAVER ARE +PROCEDURES USED TO ACCUMULATE FORMAT AND NAMELIST ARRAYS; +PROCEDURE TRACEBACK(M,DEX,PRT); VALUE M,DEX,PRT; INTEGER M,DEX,PRT; +BEGIN INTEGER I,J; REAL C; + IF (C~GET(M+2)).BASE ! 0 THEN + BEGIN I ~ ADR; ADR ~ C.BASE; + DO BEGIN J ~ GIT(ADR); + ADR ~ ADR - 1; + EMITL(DEX); + EMITPAIR(PRT,LOD); + END UNTIL ADR ~ J = 0; + ADR ~ I; + END; +INFO[M,IR,M,IC].ADDR ~ PRT; PUT(M+2,0&DEX[TOBASE]); +END TRACEBACK; + +PROCEDURE OFLOWHANGERS(I); VALUE I; INTEGER I; +BEGIN INTEGER J; LABEL XIT; +FOR J ~ 1 STEP 1 UNTIL MAXNBHANG DO +IF FNNHANG[J] = 0 THEN % MAKE AN ENTRY +BEGIN FNNHANG[J] ~ I; + PUT(I+2,J); + GO TO XIT; +END; +XTA ~ MAXNBHANG; % IF WE REACH HERE WERE HURTIN +FLAG(91); +XIT: +END OFLOWHANGERS; + +PROCEDURE PRTSAVER(M,SZ,ARY); VALUE M,SZ; +INTEGER M,SZ; ARRAY ARY[0]; +BEGIN INTEGER I; REAL INFA; +LABEL SHOW,XIT; +IF (INFA~GET(M)) < 0 THEN % PREVIOUSLY DEFINED +BEGIN XTA ~ GET(M+1); + FLAG(20); GO TO XIT; +END; +IF I ~ INFA .ADDR ! 0 THEN % PRT ASSIGNED AT OFLOW TIME +SHOW: +BEGIN I ~ PRGDESCBLDR(1,I,0,NXAVIL ~ NXAVIL + 1); + WRITEDATA(SZ,NXAVIL,ARY); + FNNHANG[GET(M+2).SIZE] ~ 0; +END ELSE % ADD THIS ARRAY TO HOLD +BEGIN IF FNNPRT=0 THEN BEGIN BUMPPRT; FNNPRT~PRTS END; + IF FNNINDEX + SZ > DUMPSIZE THEN % ARRAY WONT FIT + BEGIN BUMPPRT;FNNHANG[GET(M+2).SIZE]~0; TRACEBACK(M,0,I~PRTS); + GO TO SHOW; + END ELSE % DUMP OUT CURRENT HOLDINGS + BEGIN FNNPRT ~ PRGDESCBLDR(1,FNNPRT,0,NXAVIL ~ NXAVIL + 1); + WRITEDATA(FNNINDEX,NXAVIL,FNNHOLD); + FNNINDEX ~ 0; BUMPPRT; FNNPRT ~PRTS; + END; + FNNHANG[GET(M + 2).SIZE] ~0; + TRACEBACK(M,FNNINDEX,FNNPRT); + MOVEW(ARY,FNNHOLD[FNNINDEX],SZ.[36:6],SZ); + FNNINDEX ~ FNNINDEX + SZ; +END; +PUT(M,-GET(M)); % ID NOW ASSIGNED +XIT: +END PRTSAVER; + +PROCEDURE SEGOVF; + BEGIN + REAL I, T, A, J, SADR, INFC, LABPRT; + REAL SAVINS; + FOR T ~ 1 STEP 1 UNTIL MAXNGHANG DO +IF J~FNNHANG[T]!0 THEN BEGIN BUMPPRT;TRACEBACK(J,FNNHANG[T]~0,PRTS) END; + SEGOVFLAG ~ TRUE; +BUMPPRT; + IF PRTS.[37:2]=1 THEN BEGIN + PACK(EDOC[EDOCI],(T~1&XRT[36:38:10]),ADR.[46:2]); + IF CODETOG THEN DEBUG(T); ADR~ADR+1 END; + PACK(EDOC[EDOCI], (T~2&PRTS[36:38:10]), ADR.[46:2]); + IF CODETOG THEN DEBUG(T); + ADR ~ ADR+1; + PACK(EDOC[EDOCI], (T~1&BFW [36:38:10]), ADR.[46:2]); + IF CODETOG THEN DEBUG(T); + SADR ~ ADR; + T ~ PRGDESCBLDR(2, PRTS, 0, NXAVIL+1); + FOR I ~ 0 STEP 1 UNTIL SHX DO + BEGIN T ~ STACKHEAD[I]; + WHILE T ! 0 DO + BEGIN IF (A~ GET(T)).CLASS = LABELID THEN + IF A > 0 THEN + BEGIN + ADR ~ A.ADDR; + IF LABPRT ~ (INFC~GET(T+2)).BASE = 0 THEN + BEGIN + BUMPPRT; LABPRT~PRTS; + PUT(T+2, INFC & PRTS[TOBASE]); + END; + WHILE ADR ! 0 DO + BEGIN J ~ GIT(ADR); ADR ~ ADR-1; + SAVINS~GIT(ADR+2).[36:10]; + EMIT0PDCLIT(LABPRT); + EMIT0(SAVINS); + ADR ~ J; + END; + INFO[T.IR,T.IC].ADDR ~ 0; + END; + T ~ A.LINK; + END; + END; + FOR I ~ 0 STEP 1 UNTIL LBRANCH DO + IF T ~ - BRANCHES[I] > 0 AND T < 4096 THEN + BEGIN + ADR ~ T-1; + SAVINS~GIT(ADR+2).[36:10]; + BUMPPRT; EMIT0PDCLIT(PRTS); + EMIT0(SAVINS); + BRANCHES[I] ~ - (PRTS+4096); + END; + SEGMENT((SADR+4) DIV 4,NSEG,FALSE,EDOC); + SEGMENTSTART; + EMIT0(NOP); EMIT0(NOP); + SEGOVFLAG ~ FALSE; +END SEGOVF; + +PROCEDURE ARRAYDEC(I); VALUE I; REAL I; + BEGIN % DECLARES ARRAYS WHOSE INFO INDEX IS I + REAL PRT,LNK,J; + LABEL XIT; + BOOLEAN OWNID; REAL X; +IF DEBUGTOG THEN FLAGROUTINE(" ARRA","YDEC ",TRUE ); + PRT ~ GET(I).ADDR; + IF LNK ~ GET(I+2).SIZE = 0 THEN GO TO XIT ; + IF (OWNID ~ PRT < 1536 AND DATAPRT ! 0) THEN + BEGIN + EMIT0PDCLIT(DATAPRT); EMIT0(LNG); + EMITB(-1, TRUE); X ~ LAX; + END; + EMIT0(MKS); + EMITDESCLIT(PRT); % STACK OR PRT ADDRESS + IF LNK { 1023 THEN + BEGIN + IF OWNID THEN EMITL(0); % LOWER BOUND + EMITL(LNK); % ARRAY SIZE + EMITL(1); % ONE DIMENSION + END + ELSE + BEGIN + J ~ (LNK + 255) DIV 256; + LNK ~ 256; %INCLUDE ENTIRE ARRAY SIZE IN ESTIMATE %512- + IF OWNID THEN EMITL(0); % FIRST LOWER BOUND + EMITL(J); % NUMBER OF ROWS + IF OWNID THEN EMITL(0); % SECOND LOWER BOUND + EMITL(256); % SIZE OF EACH ROW + EMITL(2); % TWO DIMENSIONS + END; + EMITL(1); % ONE ARRAY + EMITL(IF OWNID THEN 2 ELSE 0); %OWN OR LOCAL + EMIT0PDCLIT(5); % CALL BLOCK + ARYSZ ~ ARYSZ + J + LNK; + IF NOT(F2TOG OR OWNID) THEN + BEGIN + F2TOG ~ TRUE; + EMITL(1); + EMITPAIR(FPLUS2,STD);% F+2~TRUE + END; + IF OWNID THEN FIXB(X); + XIT: +IF DEBUGTOG THEN FLAGROUTINE(" ARRA","YDEC ",FALSE) ; + END ARRAYDEC; + +REAL PROCEDURE SEARCH(E); VALUE E; REAL E; +BEGIN REAL T; LABEL XIT; + T ~ STACKHEAD[E MOD SHX]; + WHILE T ! 0 DO + IF INFO[(T+1).IR,(T+1).IC] = E THEN GO TO XIT + ELSE T ~ INFO[T.IR,T.IC].LINK; + XIT: SEARCH ~ T; +END SEARCH; + +INTEGER PROCEDURE GLOBALSEARCH(E); VALUE E; REAL E; +BEGIN REAL T; LABEL XIT; + T ~ GLOBALSTACKHEAD[E MOD GHX]; + WHILE T ! 0 DO + IF INFO[(T+1).IR,(T+1).IC] = E THEN GO TO XIT + ELSE T ~ INFO[T.IR,T.IC].LINK; + XIT: GLOBALSEARCH ~ T; +END GLOBALSEARCH; + +PROCEDURE PURGEINFO; +BEGIN REAL J; + FLAG(13); + FOR J ~ 0 STEP 1 UNTIL SHX DO STACKHEAD[J] ~ 0; + NEXTINFO ~ 2; + NEXTCOM ~ 0; + END; + +INTEGER PROCEDURE ENTER(W, E); VALUE W, E; ALPHA W, E; +BEGIN REAL J; + IF GLOBALNEXTINFO { NEXTINFO THEN PURGEINFO; + W.LINK ~ STACKHEAD[J ~ F MOD SHX]; + STACKHEAD[J] ~ ENTER ~ J ~ NEXTINFO; + INFO[J.IR,J.IC] ~ W; + INFO[(J~J+1).IR,J.IC] ~ E; + INFO[(J~J+1).IR,J.IC] ~ 0; + NEXTINFO ~ NEXTINFO + 3; +END ENTER; + +INTEGER PROCEDURE GLOBALENTER(W, E); VALUE W, E; ALPHA W, E; +BEGIN REAL J; + IF GLOBALNEXTINFO { NEXTINFO THEN PURGEINFO; + W.LINK ~ GLOBALSTACKHEAD[J ~ E MOD GHX]; + GLOBALSTACKHEAD[J] ~ GLOBALENTER ~ J ~ GLOBALNEXTINFO; + INFO[J.IR,J.IC] ~ W; + INFO[(J~J+1).IR,J.IC] ~ E; + INFO[(J~J+1).IR,J.IC] ~ 0; + GLOBALNEXTINFO ~ GLOBALNEXTINFO - 3; +END GLOBALENTER; + +PROCEDURE LABELBRANCH(K, C); VALUE K, C; REAL K; BOOLEAN C; +BEGIN REAL TS,T,I,X; +DEFINE LABL = K#; +COMMENT LABELBRANCH GENERATES A "LITC ..." AND "BRANCH" FROM THE +CURRENT ADDRESS TO LABEL K: IF THE BOOLEAN C IS TRUE +THE BRANCH IS CONDITIONAL. IF THE LABEL HAS NOT BEEN ENCOUNTERED +THEN THE APPROPRIATE LINKAGE IS MADE; + LABEL XIT; + IF ADR } 4086 THEN + BEGIN ADR ~ ADR+1; SEGOVF END; + IF LABL ~ LBLSHFT(XTA~LABL) { 0 OR LABL = BLANKS THEN + BEGIN FLAG(135); GO TO XIT END; + IF T ~ SEARCH(LABL) ! 0 THEN + BEGIN TS ~ (I ~ GET(T)).ADDR; + IF I.CLASS ! LABELID THEN BEGIN FLAG(144); GO TO XIT END; + IF I > 0 THEN + BEGIN EMITLINK(TS); + EMIT0(IF C THEN BFC ELSE BFW); + PUT(T,I&(ADR-1)[TOADDR]); + EMIT0(NOP); + END ELSE + IF I.SEGNO = NSEG THEN EMITB(TS, C) ELSE + BEGIN IF TS~(X~GET(T+2)).BASE = 0 THEN + X.BASE ~ TS ~ PRGDESCBLDR(2,0,(I.ADDR).[36:10],I.SEGNO); + PUT(T+2,X); + EMIT0PDCLIT(TS); + EMIT0(IF C THEN BFC ELSE BFW); + END; +END ELSE + BEGIN + IF ADR < 0 THEN EMIT0(NOP); + EMITLINK(0); + EMIT0( IF C THEN BFC ELSE BFW); + T ~ ENTER(0 & LABELID[TOCLASS] & (ADR-1)[TOADDR], LABL); + EMIT0(NOP); + END; + IF XREF THEN ENTERX(LABL,0&LABELID[TOCLASS]); + XIT: +END LABELBRANCH; + +PROCEDURE DATASET; % SCANS CONSTANTS IN BLOCK DATA + BEGIN + REAL LST,CUR,LTYP,CTYP,SIZ,RPT; + REAL CUD; + BOOLEAN SGN; + DEFINE TYP = GLOBALNEXT#, + TYPC = 18:33:15#; + LABEL XIT,ERROR,DPP,SPP,CPP,COMM.S; +IF DEBUGTOG THEN FLAGROUTINE(" DATA","SET ",TRUE) ; + DATATOG ~ TRUE; FILETOG ~ TRUE; + SCAN; + LSTS ~ -1; LTYPE ~77; + S: IF TYP = PLUS OR (SGN ~ TYP = MINUS ) THEN SCAN; + IF TYP = NUM THEN + BEGIN + IF NUMTYPE = STRINGTYPE AND STRINGSIZE > 1 THEN + BEGIN + IF LTYP ! 77 THEN + BEGIN % NOT FIRST ENTRY-PUSH DOWN PRIOR NUMBER + IF LSTS+2 > LSTMAX THEN + BEGIN FLAG(127); GO TO ERROR END; + LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; + LSTT[LSTS~LSTS+1] ~ LST; + LTYP ~ 77; + END; + + IF LSTS + STRINGSIZE > LSTMAX THEN + BEGIN FLAG(127); GO TO ERROR END; + LSTT[LSTS+LSTS+1] ~ STRINGSIZE & STRINGTYPE[TYPC] + & SIZ[3:33:15]; + MOVEW(STRINGARRAY,LSTT[LSTS~LSTS+1], + STRINGSIZE.[36:6],STRINGSIZE); + LSTS ~ LSTS + STRINGSIZE -1; + SCAN; + GO TO COMM; + END; + % GOT NUMBER + IF NUMTYPE = STRINGTYPE THEN + BEGIN + FNEXT ~ STRINGARRAY[0]; + NUMTYPE ~ INTYPE; + IF SIZ = 0 THEN SIZ ~ 1; + END; + CUR ~ IF SGN THEN -FNEXT ELSE FNEXT; + CTYP ~ NUMTYPE; CUD ~ DBLOW; + + SCAN; + IF TYP = COMMA OR TYP = SLASH THEN + BEGIN + IF SIZ = 0 THEN SIZ ~ 1; + IF CTYP = DOUBTYPE THEN + BEGIN + DPP: IF LTYP ! 77 THEN + BEGIN + IF LSTS+2 > LSTMAX THEN + BEGIN FLAG(127); GO TO ERROR END; + LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; + LSTT[LSTS~LSTS+1] ~ LST; + LTYP ~ 77; + END; + IF LSTS+3 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END; + LSTT[LSTS~LSTS+1] ~ SIZ&DOUBTYPE[TYPC]; + LSTT[LSTS~LSTS+1] ~ CUR; + LSTT[LSTS~LSTS+1] ~ CUD; + GO TO COMM; + END; + % SINGLE PRECISION + SPP: + IF LTYP = 77 THEN + BEGIN + LST ~ CUR; + LTYP ~ CTYP; + RPT ~ SIZ; + GO TO COMM; + END; + IF LTYP = CTYP THEN + IF REAL(BOOLEAN(CUR) EQV BOOLEAN(LST)) = REAL(NOT FALSE) THEN + BEGIN + RPT ~ RPT + SIZ; + GO TO COMM; + END; + IF LSTS+2 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END; + LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; + LSTT[LSTS~LSTS+1] ~ LST; + RPT ~ SIZ; + LST ~ CUR; LTYP ~ CTYP; + GO TO COMM; + END; + % TYP ! COMMA - CHECK FOR * + IF TYP ! STAR THEN BEGIN FLAG(125); GO TO ERROR END; + IF CTYP ! INTYPE THEN BEGIN FLAG(113); GO TO ERROR END; + IF SIZ ! 0 OR SIZ ~ CUR { 0 THEN + BEGIN FLAG(64); GO TO ERROR END; + SCAN; GO TO S; + END; + % TYP ! NUM AT LABEL S + IF SIZ = 0 THEN SIZ ~ 1; + IF NAME = "T " OR NAME = "F " THEN + BEGIN + CUR ~ REAL(NAME = "T "); + CTYPE ~ LOGTYPE; + SCAN; GO TO SPP; + END; + IF TYP ! LPAREN THEN BEGIN FLAG(64); GO TO ERROR END; + CPP: % COMPLEX + IF LTYP ! 77 THEN + BEGIN + IF LSTS+2 > LSTMAX THEN + BEGIN FLAG(127); GO TO ERROR END; + LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; + LSTT[LSTS~LSTS+1] ~ LST; + LTYP ~ 77; + END; + SCAN; + IF TYP = PLUS OR (SGN~TYP=MINUS) THEN SCAN; + IF TYP ! NUM OR NUMTYPE > REALTYPE THEN + BEGIN FLAG(64); GO TO ERROR END; + IF LSTS+2 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END; + LSTT[LSTS~LSTS+1] ~ SIZ&COMPTYPE[TYPC]; + LSTT[LSTS~LSTS+1] ~ IF SGN THEN -FNEXT ELSE FNEXT; + SCAN; + IF TYP ! COMMA THEN BEGIN FLAG(114); GO TO ERROR END; + SCAN; + IF TYP = PLUS OR (SGN ~ TYP = MINUS) THEN SCAN; + IT TYP ! NUM OR NUMTYPE > REALTYPE THEN + BEGIN FLAG(64); GO TO ERROR END; + LSTT[LSTS~LSTS+1]~IF SGN THEN - FNEXT ELSE FNEXT ; + SCAN; + IF TYP ! RPAREN THEN BEGIN FLAG(108); GO TO ERROR END; + SCAN; + COMM: + SIZ ~ 0; + IF TYP = COMMA THEN BEGIN SCAN; GO TO S; END; + IF TYP = SLASH THEN GO TO XIT; + FLAG(126); + ERROR: + LSTS ~ 0; + WHILE TYP ! COMMA AND TYP ! SLASH AND TYP ! SEMI DO SCAN; + IF TYP = COMMA THE GO TO COMM; + XIT: + IF LTYP ! 77 THEN + BEGIN + IF LSTS+2>LSTMAX THEN BEGIN FLAG(127); LSTS~0 END; + LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; + LSTT[LSTS~LSTS+1] ~ LST; + END; + IF LSTS+1 > LSTMAX THEN BEGIN FLAG(127); LSTS~0 END; + LSTT[LSTS~LSTS+1]~0; +IF DEBUGTOG THEN FLAGROUTINE(" DATA","SET ",FALSE); + DATATOG ~ FALSE; FILETOG ~ FALSE; +END DATASET; + +ALPHA PROCEDURE CHECKDO; +BEGIN ALPHA X, T; INTEGER N; +STREAM PROCEDURE CKDO(A, ID, LAB); +BEGIN + SI ~ A; SI ~ SI+4; DI ~ LAB; DI ~ DI+2; + 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); + DI ~ ID; DI ~ DI+2; + 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); +END CKDO; + IF (XTA~HOLDID[0]).[12:24] = "FILE" THEN FLOG(37) ELSE + IF XTA.[12:12] ! "DO" THEN FLOG(17) ELSE + BEGIN + X ~ T ~ BLANKS; + CKDO(HOLDID[0], X, T); + IF X=BLANKS THEN FLOG(105); + IF T ~ LBLSHFT(T) < 0 OR T = BLANKS THEN FLOG(17) ELSE + TEST ~ NEED(T, LABELID); + DOLAB[DT]~ T; + IF XREF THEN ENTERX(T,0&LABELID[TOCLASS]); + IF GET(TEST) < 0 THEN % TEST FOR PREV DEFINITION + BEGIN + XTA ~ GET(TEST+1); + FLAG(15); + DT ~ DT-1; + END; + IF N ~ SEARCH(X) = 0 THEN + N~ENTER(TIPE[IF T~X.[12:6]!"0" THEN T ELSE 12],X); + CHECKDO ~ GETSPACE(N); + IF XREF THEN ENTERX(X,1&GET(N) [15:15:9]); + IF (X:GET(N)).SUBCLASS > REALTYPE OR X.CLASS ! VARID THEN + BEGIN XTA ~ GET(N+1); FLAG(84) END; + IF GET(FX1).CLASS = UNKNOWN THEN PUT(FX1+1, "......"); + END; +END CHECKDO; + +PROCEDURE FIXB(N); VALUE N; REAL N; +BEGIN + REAL T, U, FROM; + LABEL XIT, BUGJ; +IF DEBUGTOG THEN FLAGROUTINE(" FI","XB ",TRUE); + IF N } 10000 THEN FROM ~ N-10000 ELSE + IF FROM ~ - BRANCHES[N] > 4095 THEN + BEGIN + ADJUST; + T ~ PRGDESCBLDR(2, FROM.LINK, (ADR+1).[36:10], NSEG); + GO TO XIT; + END; +T ~ ADR; ADR ~ FROM - 1; +IF (T + 1).[46:2] = 0 THEN GO TO BIGJ; +IF (U ~ T - 2 - ADR) { 1023 THEN EMITL(U) ELSE +BEGIN ADR ~ T; ADJUST; T ~ ADR; ADR ~ FROM - 1; +BIGJ: EMITL((T+1).[36:10] - (ADR+2).[36:10]); + EMIT0(IF BOOLEAN(GIT(FROM + 1).[36:1]) THEN GFW ELSE GFC); +END; +ADR ~ T; + XIT: + IF N < 10000 THEN BEGIN + BRANCHES[N] ~ BRANCHX; + BRANCHX ~ N; + END; +IF DEBUGTOG THEN FLAGROUTINE(" FI","XB ",FALSE); +END FIXB; + +PROCEDURE DATIME; % PRODUCES HEADING LINE FOR LISTING. + BEGIN + INTEGER D; + FORMAT T(X9,"B 5 7 0 0 F O R T R A N C O M P I L A T I O N ", +"XVI.0" + ,",",A2,",",AB,"DAY, ",2(A2,"/"),A2,",",A2,":",A2," H,"/); + WRITALIST(T,7, + "16" %999- + ,TIME(6),(D~TIME(5)).[12:12],D.[24:12],D.[36:12], + D~(D~RTI DIV 216000) MOD 10+D DIV 10|64, + D~(D~RTI DIV 3600 MOD 60) MOD 10+D DIV 10|64,0) ; + IF D~LINE.TYPE=10 OR D=12 OR D=13 THEN + BEGIN + LOCK(LINE); LINE.AREAS~0; LINE.AREASIZE~0 ; + ID D ! 12 THEN LINE.TYPE~12; SPACE(LINE,2) ; + END; + FIRSTCALL~FALSE ; + END DATIME; + +PROCEDURE PRINTCARD; +BEGIN + STREAM PROCEDURE MOVE(P, Q, A); VALUE A, Q; + BEGIN + SI ~ Q; DI ~ P; + DS ~ CHR; + DI ~ DI+11; SI ~ LOC A; + DS ~ 4 DEC; + END MOVE; + STREAM PROCEDURE MOVEBACK(P); + BEGIN DI ~ P; DS ~ LIT "J" END; + MOVE (CRD[9],BUFL,(ADR+1].[36:10]); + IF FIRSTCALL THEN DATIME; + IF UNPRINTED THEN WRITAROW(15,CRD) ; + MOVEBACK(CRD[9]); + IF SEQERRORS THEN WRITAROW(14,ERRORBUFF) ; +END PRINTCARD; + +BOOLEAN PROCEDURE READACARD; FORWARD; +PROCEDURE FILEOPTION; FORWARD; +BOOLEAN PROCEDURE LABELR; +BEGIN +LABEL XIT, LOOP; +BOOLEAN STREAM PROCEDURE CHECK(CD, LAB); +BEGIN LABEL XIT; LOCAL T1; + SI ~ CD; + IF SC ! " " THEN IF SC < "0" THEN + BEGIN DI ~ LAB; DI ~ DI + 2; + DS ~ 6 CHR; GO TO XIT; + END; + DI ~LOC T1; DS ~ 6 LIT " "; DI ~ DI -6; + 5(IF SC } "0" THEN DS ~ CHR ELSE SI ~ SI+1); + DI ~LAB; DI ~DI + 2; SI ~ LOC T1; + 5(IF SC ! "0" THEN JUMP OUT; SI ~ SI + 1); + 5(IF SC } "0" THEN DS :0 CHR ELSE JUMP OUT); + TALLY ~ 1; + XIT: CHECK ~ TALLY; +END CHECK; +BOOLEAN STREAM PROCEDURE BLANKCARD(CD); +BEGIN LABEL XIT; + SI ~ CD; + 2(36( IF SC ! " " THEN JUMP OUT 2 TO XIT ELSE SI ~ SI + 1)); + TALLY ~ 1; + XIT: BLANKCARD ~ TALLY; +END BLANKCARD; + LOOP: + LABL ~ BLANKS; + IF LABELR ~ NOT READACARD THEN GO TO XIT; + IF NOT CHECK(CRD[0].LABL) THEN + BEGIN IF LABL = "FILE " THEN FILEOPTION ELSE + BEGIN IF LISTOG THEN PRINTCARD; + IF (XTA ~ LABL).[12:6] ! "C" THEN FLAGS(135); + END; + GO TO LOOP; + END; + IF ENDSEGTOG THEN IF BLANKCARD(CRD) THEN + BEGIN IF LISTOG THEN PRINTCARD; GO TO LOOP END ELSE + BEGIN SEGMENTSTART; + IF LISTOG THEN PRINTCARD; + IF LABL = BLANKS THE GO TO XIT; + END ELSE + BEGIN + IF LABL = BLANKS THEN + BEGIN IF LISTOG THEN PRINTCARD; GO TO XIT END; + IF ADR > 0 THEN ADJUST; + IF LISTOG THEN PRINTCARD; + END; + XIT: +END LABELR; + +PROCEDURE FILEOPTION; +BEGIN COMMENT THIS PROCEDURE PROCESSES THE OPTIONAL FILE CONTROL CARD. +THE WORD "FILE" APPEARS IN COL. 1 - 4. COL. 5 AND 6 ARE BLANK. +#1 BELOW IS REQUIRED, OTHER ENTRIES MAY BE AS SPARSE AS DESIRED. +1. FILE = / + OR + FILE = + THE FOLLOWING "/" IS A DOCUMMENTARY OR. + THE SEQUENCE OF RESERVED WORDS MUST BE MAINTAINED. +2. UNIT=PRINT/READER/PUNCH/DISK/TAPE7/TAPE9/REMOTE (UNIT DESIGNATE). +3. UNLABELED (FOR UNLABELED TAPES) +4. ALPHA (FOR ALPHA RECORDING MODE) +5. BCL (IGNORED, FOR 3500 USE) +6. FIXED (IGNORED, FOR 3500 USE) +7. SAVE = (SAVE FACTOR IN DAYS) +8. LOCK (LOCK FILE AT EOJ) +9. RANDOM/SERIAL/UPDATE (DISK USE) +10. AREA = (DISK RECORDS/ROW) +11. BLOCKING = (RECORD PER BLOCK) +12. RECORD = (RECORD SIZE) +13. BUFFER = (# OF BUFFERS) +14. WORKAREA (IGNORED, FOR 3500) ; +ALPHA P,KEEP; BOOLEAN TOG,CA,TS; LABEL XIT; +COMMENT INXFI = INFC.ADINFO, MULTI FILE ID = FILEINFO][1,INXFIL], + FILE ID = FILEINFO[2,INXFIL], DISK RECORDS = FILEINFO3[3,INXFIL], + FILEINFO[0,INXFIL] FROM RIGHT TO LEFT IS; +INTEGER % NAME USE BITS + BUFF, % # BUFFERS 6 + RECORD, % RECORD SIZE 12 + BLOCK, % BLOCK SIZE 12 + SAVER, % SAVE FACTOR 12 + SPIN, % REW & LOCK @ EOJ 2 + ALPH; % RECORDING MODE 1 +PROCEDURE FETCH; +BEGIN SCAN; XTA ~ SYMBOL; + IF NEXT=COMMA OR NEXT=MINUS THEN + BEGIN SCAN; XTA ~ SYMBOL; + IF NEXT ! ID THEN FLOG(37); + END; +END FETCH; +INTEGER STREAM PROCEDURE MAKEINT(XTA); +BEGIN LABEL LOOP; LOCAL T; +SI ~ XTA; SI ~ SI + 2; +LOOP: IF SC } "0" THEN + BEGIN TALLY ~ TALLY + 1; SI ~ SI + 1; GO TO LOOP END; +T ~ TALLY; SI ~ XTA; SI ~ SI + 2; DI ~ LOC MAKEINT; DS ~ T OCT; +END MAKEINT; +INTEGER PROCEDURE REPLACEMENT; +BEGIN +FETCH; IF NEXT = EQUAL THEN +BEGIN FETCH; IF XTA.[12:6] { 11 THEN BEGIN REPLACEMENT ~ MAKEINT(XTA); + FETCH END ELSE FLOG(37); +END ELSE FLOG(37); +END REPLACEMENT; +INTEGER STREAM PROCEDURE SRI7(S); +BEGIN SI ~ S; DI ~ LOC SRI7; + SI ~ SI + 2; DI ~ DI + 1; DS ~ 7 CHR; +END SRI7; +COMMENT * * * * * START OF CODE * * * * ; +IF DEBUGTOG THEN FLAGROUTINE(" FILEO","PTION ", TRUE); +ERRORTOG ~ FALSE; +IF LISTOG THEN PRINTCARD; +XTA ~ "FILE "; +IF NSEG ! 0 THEN FLAG(60); +IF INXFIL ~ INXFIL + 1 > MAXOPFILES THEN +BEGIN FLAG(59); GO TO XIT END; +BUMPPRT; +MAXFILES ~ MAXFILES + 1; +FILETOG ~ TRUE; SCN ~ 1; % START SCAN MAINTAINENCE +FETCH; IF XTA.[12:6] > 11 THEN BEGIN FLAG(37); GO TO XIT END; + IF XTA.[12:6] = 0 THEN BEGIN FLOG(037); GO TO XIT END; +IF T ~ GLOBALSEARCH(P ~ 0&"."[12:42:6]&XTA[18:12:30]) ! 0 THEN FLAG(20) +ELSE BEGIN P~ GLOBALENTER(-0&PRTS[TOADDR]&FILEID[TOCLASS],P); + PUT(P+2,GET(P+2)&INXFIL[TOADINFO]); + IF XREF THEN ENTERX(XTA &1[TOCE],1&FILEID[TOCLASS]); + END; +INFC ~ GET(P + 2); +FETCH; IF NEXT = EQUAL THEN FETCH ELSE + BEGIN FLOG(37); GO TO XIT; END; +IF NEXT = SEMI THEN +BEGIN FLAG(37); GO TO XIT END + ELSE FILEINFO[2,INXFIL] ~ SRI7(ACCUM[1]); +FETCH; IF NEXT = SLASH THEN + BEGIN FILEINFO[1,INXFIL] ~ FILEINFO[2,INXFIL]; % MULTI FILE ID + FETCH; + IF NEXT = SEMI THEN BEGIN FLAG(37); GO TO XIT; END + ELSE FILEINFO[2,INXFIL] ~ SRI7(ACCUM[1]); + FETCH; + END; +IF XTA = "UNIT " THEN +BEGIN + FETCH; + IF NEXT = EQUAL THEN FETCH ELSE FLOG(37); + INFC.LINK ~ KEEP ~ (IF TOG ~ XTA = "PRINT " + OR XTA = "PRINTE" THEN 16 ELSE + IF CA ~ TOG ~ XTA = "READ " + OR XTA = "READER" THEN 2 ELSE + IF CA ~ TOG ~ XTA = "PUNCH " THEN 0 ELSE + IF TOG ~ XTA = "DISK " THEN 12 ELSE + IF TOG ~ XTA = "TAPE " + OR XTA = "TAPE7 " THEN 2 ELSE + IF TOG ~ XTA = "PAPER " THEN 6 ELSE + IF CA ~TOG~XTA= "REMOTE" THEN 19 ELSE + IF TOG ~ XTA = "TAPE9 " THEN 2 ELSE 2); + IF TOG THEN FETCH ELSE FLOG(37) +END ELSE INFC.LINK~KEEP~IF DCINPUT THEN 12 ELSE 2 ; +TS~KEEP=12 ; +IF XTA="BACKUP" THEN + BEGIN + FETCH; IF KEEP!0 AND KEEP!18 THEN FLAG(37); + IF TOG~XTA="DISK " THEN KEEP~IF KEEP=0 THEN 22 ELSE 15 + ELSE IF TOG~XTA="TAPE " THEN KEEP~IF KEEP=0 THEN 20 ELSE 6 + ELSE BEGIN + TOG~XTA="ALTERN"; KEEP~IF KEEP=0 THEN 25 ELSE 16 ; + END; + IF TOG THEN FETCH; INFC.LINK~KEEP ; + END ; +IF XTA = "UNLABE" THEN % FOR UNLABELED TAPES + BEGIN IF KEEP = 2 THEN INFC .LINK ~ 9; FETCH; END; +IF XTA = "ALPHA " THEN FETCH ELSEIF KEEP = 2 THE ALPH ~ 1; % MODE +IF XTA = "BCL " THEN FETCH; % FOR B3500 +IF XTA = "FIXED " THEN FETCH; % FOR B3500 +IF XTA = "SAVE " THEN SAVER ~ REPLACEMENT; +IF XTA = "LOCK " THEN BEGIN SPIN ~ 2; FETCH END; % REW & LOCK AT EOJ + IF TOG ~ XTA = "RANDOM" THEN T ~ 10 ELSE + IF TOG ~ XTA = "SERIAL" THEN T ~ 12 ELSE + IF TOG ~ XTA = "UPDATE" THEN T ~ 13; +IF TOG THEN + BEGIN IF KEEP=12 THEN INFC.LINK~T ELSE FLAG(37); FETCH END; +IF XTA="AREA " THEN + BEGIN + IF KEEP!12 THEN FLAG(37); + T~REPLACEMENT; + IF XTA="EU " THEN + IF I~REPLACEMENT>19 THEN FLAG(37) + ELSE T.EUNF~I+1;% 0 MEANS EU NOT SPECIFIED + IF XTA="SPEED " THEN + BEGIN + FETCH; + IF NEXT=EQUAL THEN + BEGIN + FETCH; + IF XTA.[12:6]{SLOWV THEN + IF I~MAKEINT(XTA)>SLOWV THEN FLAG(37) + ELSE + ELSE IF XTA="FAST " THEN T.SPDF~FASTV + ELSE IF XTA="SLOW " THEN T.SPDF~SLOWV + ELSE FLOG(37); + FETCH; + END + ELSE FLOG(37); + END; + IF XTA="SENSIT" THEN + BEGIN + T.SENSE~1; + FETCH; + END; + FILEINFO[3,INXFIL]~T; + END; +IF XTA = "BLOCKI" THEN BLOCK ~ REPLACEMENT & 1[2:47:1]; +RECORD ~ IF XTA="RECORD" THEN REPLACEMENT ELSE IF CA THEN 10 ELSE IF TS + AND NOT (BOOLEAN(BLOCK.[2:1])) THEN 10 & 1[2:47:1] ELSE 17; +BUFF ~ IF XTA = "BUFFER" THEN REPLACEMENT ELSE 2; +IF XTA = "WORKAR" THEN FETCH % IGNORED. FOR 3500 +IF BUFF<1 OR BUFF>32 THEN BEGIN XTA~"BUFFER"; FLAG(152) END ; +IF RECORD<1 THEN BEGIN XTA~"RECORD"; FLAG(152)END ; +IF SAVER>999 THEN BEGIN XTA~"SAVE "; FLAG(152) END ; +IF T~INFC.LINK=10 OR T=12 OR T=13 THEN %%% ARE IN DISK FILE + BEGIN + IF BOOLEAN(RECORD.[2:1])THEN BLOCK ~ 300 + ELSE + IF BLOCK~BLOCK|RECORD>1890 OR RECORD>1023 THEN + BEGIN XTA~"BK/RFC"; FLAG(152) END + END +ELSE IF BLOCK~BLOCK|RECORD>1023 OR RECORD>1023 THEN IF KEEP ! 2 THEN + BEGIN XTA~"BK/REC"; FLAG(58 ) END ELSE BEGIN RECORD~257; BLOCK~0END; +FILEINFO[0,INXFIL] ~ 0&BUFF[42:42:6]&RECORD[30:36:12]&BLOCK[18:36:12] + &SAVER[6:36:12]&SPIN[4:46:2]&ALPH[3:47:1]; +XIT: IF NEXT ! SEMI THEN + BEGIN FLOG(37); DO SCAN UNTIL NEXT = SEMI; END; + FILETOG ~ FALSE; % END SCAN MAINTAINENCE + PUT(P+2,INFC); +IF DEBUGTOG THEN FLAGROUTINE(" FILEO","PTION ",FALSE) ; +END FILEOPTION; + +PROCEDURE DOLOPT; +BEGIN +REAL STREAM PROCEDURE SCAN(BUF,ID); VALUE BUF; + BEGIN LABEL LP,LA,LE,XIT; + SI ~ BUF; DI ~ ID; DS ~ 2 LIT "0"; + LP: IF SC = " " THEN BEGIN SI~SI+1; GO TO LP; END; + IF SC = "," THEN BEGIN SI~SI+1; GO TO LP; END; + IF SC = "+" THEN BEGIN DS~CHR; GO TO XIT; END; + IF SC = "-" THEN BEGIN DS~CHR; GO TO XIT; END; + IF SC < "A" THEN BEGIN DI ~ ID; DS ~ 8 LIT "+0000001"; +LE: SI~SI+1; + GO TO XIT; + END; + IF SC="|" THEN GO TO LE;% THIS IS > "A" + IF SC="!" THEN GO TO LE;% THIS IS > "A" + 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); + LA: IF SC = ALPHA THEN BEGIN SI~SI+1; GO TO LA; END; + XIT: + SCAN ~ SI; + END SCAN; +REAL STREAM PROCEDURE GETVOID(BUG,VOIDSEQ,FR); VALUE BUF,FR; + BEGIN LABEL L,LC,LD,LE,XIT; LOCAL TA; + SI ~ BUF; DI~VOIDSEQ; DS~8LIT" "; DI~VOIDSEQ; + L: IF SC = " " THEN BEGIN SI~SI+1; GO TO L; END; + TA ~ SI; + IF SC = """ THEN + BEGIN 9(SI~SI+1; + IF SC = """ THEN BEGIN SI~SI+1; JUMP OUT TO LC; END + ELSE TALLY ~ TALLY + 1); + TALLY~TALLY+63; SI~TA; SI~SI+1; GO TO LE; + END; + IF SC < "0" THEN GO TO LD; + DS~8LIT"0"; %115- + 8(SI~SI+1; DI~DI-1; TALLY~TALLY+1; %115- + IF SC LSS "0" THEN JUMP OUT); %115- + LC: SI ~ TA; + LE: TA~TALLY; DS~TA CHR; GETVOID~SI; GO TO XIT; + LD: GETVOID~SI; + FR(DS~8LIT"9"); + XIT: + END GETVOID; +REAL STREAM PROCEDURE SEQNUM(BUF,VLU); VALUE BUF; + BEGIN LABEL L,LA,LC; LOCAL TA,TB; + SI ~ BUF; + L: IF SC = " " THEN BEGIN SI~SI+1; GO TO L; END; + IF SC = "," THEN BEGIN SI~SI+1; GO TO L; END; + TA ~ SI; + IF SC = "+" THEN + BEGIN SI~SI+1; + LA: IF SC = " " THEN BEGIN SI~SI+1; GO TO LA;END; + TB ~ SI; + IF SC < "0" THEN BEGIN SI~TA; GO TO LC; END; + DI~TB;TA~DI; + END; + 8(IF SC < "0" THEN JUMP OUT TO LC; + TALLY~TALLY+1; SI~SI+1;); + LC: TB ~ TALLY; SEQNUM ~ SI; + SI ~ TA; DI ~ VLU; DS ~ TB OCT; + END SEQNUM; +REAL STREAM PROCEDURE MKABS(S); + BEGIN SI ~ S; SI~SI+1; MKABS ~ SI; + DI ~ S; 9(DI ~ DI + 8); DS ~ LIT "["; + END MKABS; +STREAM PROCEDURE MOVEW(P,Q); VALUE Q; +BEGIN SI~P; DI ~ Q; DS~CHR; END ; + REAL BUF,ID; + BOOLEAN VAL, SAVELISTOG; %511- + LABEL LP,SET,RESET; + FORMAT WARN(X18,A6," ILLEGAL CONSTRUCT ON DALLAR CARD XXXX",X39, + "WARNING"); + DEFINE GETID = BEGIN ID~ " "; BUF ~ SCAN(BUF,ID) END#; + SAVELISTOG ~ LISTOG; %511- + MOVEW(CRD[9],BUFL); + BUF ~ MKABS(CRD[0]); + GETID; + IF ID = "VOID " THEN + BEGIN BUF ~ GETVOID(BUF, VOIDSEQ,0); VOIDTOG ~ TRUE + END ELSE + IF ID = "VOIDT " THEN + BEGIN BUF ~ GETVOID(BUF, VOIDTSEQ,0); VOIDTTOG ~ TRUE + END ELSE + BEGIN + TAPETOG.[47:1] ~ LASTMODE = 2; %517- + IF ID = "SET " OR ID = "+ " THEN +SET: BEGIN GETID; VAL~ TRUE END + ELSE + IF ID = "RESET " OR ID = "- " THEN +RESET: BEGIN GETID; VAL ~ FALSE END + ELSE + BEGIN + TSSMESTOG ~ VAL; TSSEDITOG ~ VAL; CHECKTOG ~ VAL %501- + SINGLETOG~NOT VAL; HOLTOG~VAL; %501- + LISTOG~VAL; CODETOG ~ DEBUGTOG ~ VAL; NEWTPTOG ~ VAL; + PRTOG~VAL; DOLIST~VAL; LIBTAPE~VAL; SEGPTOG~VAL; %501- + LISTPTOG ~ VAL; FREEFTOG ~ XREF ~ VAL ; + VAL ~ TRUE; + END; +LP: IF ID > 0 THEN + BEGIN + IF ID = "TRACE " THEN + BEGIN PRTOG~VAL; LISTOG~VAL; CODETOG~DEBUGTOG~VAL; + END ELSE + IF ID = "CARD " THEN + BEGIN TAPETOG.[47:1]~NOT VAL; LASTMODE~2-REAL(VAL) END ELSE + IF ID = "TAPE " THEN + BEGIN TAPETOG.[47:1] ~ VAL; LASTMODE ~ REAL(VAL)+1; END ELSE + IF ID = "NOSEQ " THEN SEQTOG ~ FALSE ELSE + IF ID = "SET " OR ID = "+ " THEN GO TO SET ELSE + IF ID = "RESET " OR ID = "- " THEN GO TO RESET ELSE + IF ID = "ONSITE" AND NOT REMFIXED THEN REMOTETOG ~ FALSE ELSE + IF ID = "REMOTE" AND NOT REMFIXED THEN REMOTETOG ~ VAL ELSE + IF ID = "FREEFO" THEN FREEFTOG ~ VAL ELSE + IF ID = "SINGLE" OR ID = "SGL " THEN + BEGIN SINGLETOG ~ VAL; LISTOG ~ TRUE; END ELSE + IF ID = "NEW " OR ID = "NEWTAP" THEN + BEGIN LIBTAPE~VAL; NEWTPTOG~VAL; NTAPTOG~TRUE; %501- + IF ID = "NEW " THEN %501- + BEGIN %501- + GETID; %501- + IF ID ! "TAPE " THEN %501- + GO TO LP; %501- + END; %501- + END ELSE %501- + IF ID = "LIST " THEN LISTOG ~ VAL ELSE + IF ID = "SEQXEQ" AND NOT SEGSWFIXED THEN SEGSW ~ VAL ELSE + IF ID = "PRT " THEN PRTOG ~ VAL ELSE + IF ID = "DEBUGN" THEN + BEGIN LISTOG~VAL; CODETOG~VAL; PRTOG ~ VAL END ELSE + IF ID = "TIME " THEN TIMETOG ~ VAL ELSE + IF ID = "ERRMES" THEN TSSMESTOG ~ VAL ELSE + IF ID = "TSSEDI" THEN TSSEDITOG ~ VAL ELSE + IF ID = "LISTLI" THEN LISTLIBTOG ~ VAL ELSE + IF(ID = "SEGMEN" OR ID = "SEG ") AND VAL THEN + BEGIN ADR~ADR+1; SEGOVF; END ELSE + IF ID = "PAGE " AND VAL THEN WRITE(LINE[PAGE]) ELSE + IF ID = "VOID " THEN + BEGIN VOIDTOG ~ VAL; + IF VAL THEN BUF ~ GETVOID(BUF,VOIDSEQ,1); + END ELSE + IF ID = "VOIDT " THEN + BEGIN VOIDTTOG ~ VAL; + IF VAL THE BUF ~ GETVOID(BUF,VOIDTSEQ,1); + END ELSE + IF ID = "LIMIT " THEN + BEGIN LIMIT ~ IF VAL THEN 0 ELSE @60; + BUF ~ SEQNUM(BUF,LIMIT); + IF LIMIT LEQ ERRORCT THEN GO TO POSTWRAPUP; + END ELSE + IF ID = "XREF " THEN + BEGIN + PXREF ~ TRUE; XREF ~ VAL; + END ELSE + IF ID = "SEQ " THEN + BEGIN SEQTOG ~ VAL; + IF VAL THEN + BEGIN SEQBASE ~ SEQINCR ~ 0; + BUF ~ SEQNUM(BUF,SEQBASE); + BUG ~ SEQNUM(BUF,SEQINCR); + IF SEQINCR { 0 THEN SEQINCR ~ 1000; + END END ELSE + IF ID = "LISTDO" THEN DOLIST ~ VAL ELSE + IF ID = "HOL " THEN HOLTOG ~ VAL ELSE + IF ID = "CHECK " THEN CHECKTOG ~ VAL ELSE + IF ID = "NEWPAG" THEN SEGPTOG ~ VAL ELSE %501- + IF ID = "LISTP " THEN LISTPTOG ~ VAL ELSE + BEGIN IF FIRSTCALL THEN DATIME; + IF UNPRINTED THEN BEGIN PRINTCARD; UNPRINTED~FALSE END; + IF SINGLETOG THEN WRITE(LINE,WARN,ID) + ELSE WRITE(RITE,WARN,ID); + END + ; + GETID; + GO TO LP; + END; + END; + IF DOLIST OR LISTOG OR SAVELISTOG THEN %511- + IF UNPRINTED THEN PRINTCARD; %517- + UNPRINTED ~ TRUE; +END DOLOPT; + +STREAM PROCEDURE NEWSEQ(A,B); VALUE B; + BEGIN + SI ~ LOC B; DI ~ A; DS ~ 8 DEC; + END NEWSEQ; +INTEGER STREAM PROCEDURE SEQCHK(T,C); + BEGIN + SI ~ T; DI ~ C; + IF 8 SC < DC THEN TALLY ~ 4 ELSE + BEGIN + SI ~ SI - 8; DI ~ DI - 8; + IF 8 SC =DC THEN TALLY ~ 2 + ELSE TALLY ~ 3; + END; + SEQCHK ~ TALLY; + END SEQCHK; +BOOLEAN PROCEDURE READACARD; +BEGIN +DEFINE FLAGI(FLAGI1) = BEGIN FLAG(FLAGI1); GO TO E4A;END #; +REAL STREAM PROCEDURE SCANINC(BUF,ID,RESULT,N,M); + VALUE BUF,M,N; + BEGIN + LOCAL TA; + LABEL LP,LQ,XIT; + DI ~ RESULT; DI ~ DI +7; + SI ~ BUF; + LP: IF SC = " " THEN BEGIN SI ~ SI + 1; GO TO LP; END; + IF SC = ALPHA THEN ELSE BEGIN DS~LIT "1"; DI~ID; DS~2LIT"0"; + DS ~ CHR; DS ~ 5LIT" ";GO TO XIT; END; + IF SC LSS "0" THEN DS~LIT "2" ELSE DS~LIT "3"; %400- + N (DI~ID; DS~8 LIT "0 "; DI~DI-7; %400- + 7(IF SC=ALPHA THEN DS~CHR ELSE JUMP OUT 2 TO XIT); + JUMP OUT TO XIT); + M ( 8 ( IF SC LSS "0" THEN JUMP OUT 2 TO LQ; %400- + IF SC GTR "9" THEN JUMP OUT 2 TO LQ; %400- + SI~SI+1; TALLY~TALLY+1)); %400- + LQ: TA ~ TALLY; + SI ~ SI - TA; + DI ~ ID; + DS ~ TA OCT; + XIT: SCANINC ~ SI; + END SCANINC; +REAL STREAM PROCEDURE MKABS(S); + BEGIN SI ~ S; SI ~ SI + 1; MKABS ~ SI; END; +STREAM PROCEDURE MOVE(P, Q); VALUE Q; +BEGIN SI ~ P; DI ~ Q; DS ~ CHR; + DI ~ P; DS ~ LIST "J"; +END MOVE; +STREAM PROCEDURE MOVEC(C,B); VALUE B; +BEGIN SI~B; DI~C; DS~CHR; END; +BOOLEAN STREAM PROCEDURE GETCOL1(BUF); + BEGIN + SI ~ BUF; IF SC = "$" THEN TALLY ~ 1; + GETCOL1 ~ TALLY; + END; +STREAM PROCEDURE TSSEDITS(C,P); BEGIN SI~C; DI~P; DS~10WDS; SI~C ; +IF SC="C" THEN BEGIN DI~P; DI~DI+1; DS~LIT"-" END ELSE +IF SC!"$" THEN BEGIN SI~SI+5; IF SC!" " THEN IF SC!"0" THEN BEGIN DI~P; +DS~6LIT"- " END END END OF TSSEDITS ; +STREAM PROCEDURE MOVEW(F,T,B,R); VALUE B, R; + BEGIN + LABEL XIT; + SI ~ F; DI ~ T; + B( + 2(40( IF SC = ALPHA THEN DS ~ CHR ELSE + IF SC = " " THEN DS ~ CHR ELSE + IF SC = "%" THEN BEGIN DS ~ LIT "("; SI ~ SI+1 END ELSE + IF SC = "[" THEN BEGIN DS ~ LIT ")"; SI ~ SI+1 END ELSE + IF SC = "#" THEN BEGIN DS ~ LIT "="; SI ~ SI+1 END ELSE + IF SC = "&" THEN BEGIN DS ~ LIT "+"; SI ~ SI+1 END ELSE + IF SC = "@" THEN BEGIN DS ~ LIT """; SI ~ SI+1 END ELSE + IF SC = ":" THEN BEGIN DS ~ LIT """; SI ~ SI+1 END ELSE + IF SC = "<" THEN BEGIN DS ~ LIT "+"; SI ~ SI+1 END ELSE + IF SC = ">" THEN BEGIN DS ~ LIT "="; SI ~ SI+1 END ELSE + DS ~ CHR )); JUMP OUT TO XIT); + XIT: + SI~LOC R; SI~SI+7; DI~DI+1 ; + DS~CHR ; + END MOVEW; +ALPHA STREAM PROCEDURE DCMOVEW(F,T,B,FIL,R); VALUE B,FIL,R; + BEGIN LOCAL C; LABEL L1,L2,L3,L4 ; + SI~F; DI~T; 2(SI~SI+36; DS~36LIT" "); C~SI; DS~8CHR ; + SI~LOC R; SI~SI+6; DS~2CHR; DI~C; DS~8LIT"]";TALLY~33;SI~F; + IF SC = " " THEN %%% IT MIGHT BE A FILES CARD. + BEGIN SI~SI+1; IF SC="F" THEN + BEGIN DI~LOC FIL; DI~DI+2; IF 5SC=DC THEN + BEGIN DI~F; SI~LOC FIL; SI~SI+2; DS~6CHR ; GO TO L1; END + ELSE SI~F END ELSE SI~F END + ELSE IF SC = "F" THE BEGIN DI~LOC FIL;DI~DI+2;IF 6SC=DC THEN GO L1 + ELSE SI~F;END + ELSE IF SC="-" THEN + BEGIN %%% IT IS A CONTINUATION CARD. + SI~SI+1; DI~T; DS~6LIT" *" ; + 5(IF SC=" " THEN SI~SI+1 ELSE JUMP OUT); GO TO L2 ; + END + ELSE IF SC="C" THEN + BEGIN %%% IT MIGHT BE A COMMENT CARD. + SI~SI+1; IF SC="-" THEN GO TO L1 ELSE SI~F ; + END ; + IF SC!"$" THEN %%% IT IS NOT A COMMENT CARD, NOR IS IT A $ CARD, + BEGIN %%% NOR A CONTINUATION CARD, NOR A FILES CARD. + 2(33(IF SC=" " THEN SI~SI+1 ELSE JUMP OUT 2 TO L3)); L3: DI~T; + 5(IF SC=" " THEN SI~SI+1 ELSE IF SC}"0" THEN IF SC{"9" + THEN DS~CHR ELSE JUMP OUT ELSE JUMP OUT) ; + DI~T; DI~DI+6; IF SC=" " THEN SI~SI+1 ; + END + ELSE + BEGIN + L1: SI~F; DI~T; TALLY~36 ; + END ; + L2: C~TALLY ; + B(2(C(IF SC>">" THEN DS~CHR ELSE IF SC<"[" THEN DS~CHR ELSE + IF SC="%" THEN BEGIN DS~LIT"("; SI~SI+1 END ELSE + IF SC="#" THEN BEGIN DS~LIT"="; SI~SI+1 END ELSE + IF SC="&" THEN BEGIN DS~LIT"+"; SI~SI+1 END ELSE + IF SC="@" THEN BEGIN DS~LIT"""; SI~SI+1 END ELSE + IF SC=";" THEN BEGIN DS~LIT"""; SI~SI+1 END ELSE + IF SC="<" THEN BEGIN DS~LIT"+"; SI~SI+1 END ELSE + IF SC=">" THEN BEGIN DS~LIT"="; SI~SI+1 END ELSE + IF SC="[" THEN BEGIN DS~LIT")"; SI~SI+1 END ELSE + IF SC="]" THEN JUMP OUT 3 TO L4 ELSE DS~CHR));JUMP OUT TO L4); + 2(C(IF SC="]" THEN JUMP OUT 2 TO L4 ELSE DS~CHR)) ; + L4: DI~LOC DCMOVEW; DS~8LIT"00 "; DI~DI-6 ; + 6(IF SC="]" THEN JUMP OUT ELSE DS~CHR) ; + END OF DCMOVEW ; +STREAM PROCEDURE SEQERR(BUFF, NEW, OLD); +BEGIN + DI ~ BUFF; DS ~ 18 LIT "SEQUENCE ERROR "; + SI ~ NEW; DS ~ LIT"""; + DS ~ 8 CHR; DS ~ LIT """; + DS ~ 3 LIT " < "; + SI ~ OLD; DS ~ LIT """; + DS ~ 8 CHR; DS ~ LIT """; + DS ~ 59 LIT " "; + DS ~ 8 LIT "X"; DS ~ 4 LIT " "; +END SEQERR; +STREAM PROCEDURE DCMOVE(E,C,A,N); VALUE A,N; +BEGIN SI~C; DI~E; DS~10WDS; DS~4CHR; SI~LOC A; DS~4DEC; + N(DS~8LIT" PATCH"); END; + REAL BUF,ID; + BOOLEAN NOWRI; LABEL ENDPB, E4B; + LABEL LIBADD, ENDPA, E4A, E4, STRTA; + LABEL E1,E2,E3,STRT,ENDP,XIT; + UNPRINTED~TRUE; + GO TO STRT; +LIBADD: + XTA ~ BLABNKS; + IF INSERTDEPTH = -1 THEN SAVECARD ~ NEXTCARD; + MOVE (CRD[9],BUFL); + + IF (INSERTDEPTH ~ INSERTDEPTH + 1) GTR INSERTMAX THEN + FLAG(158); + NEWPTOG ~ FALSE; + INSERTINX ~ -1; + INSERTCOP ~ 0; + BLANKIT(SSNM[5],1,0); + BUF ~ SCANINC(BUF,INSERTMID,RESULT,1,0); + IF RESULT = 1 AND INSERTMID = "+ "THEN + BEGIN BUF~SCANINC(BUF,ID,RESULT,1,0); + IF ID = "COPY " THEN INSERTCOP ~ 1 + ELSE FLAG(155); + BUF~SCANINC(BUF,INSERTMID,RESULT,1,0); + END; + IF RESULT NEQ 2 THEN FLAGI (155); + BUF ~ SCANINC(BUF,ID,RESULT,0,1); %107- + IF RESULT = 1 THEN IF ID = "/ " THEN + BEGIN BUF ~ SCANINC(BUF,INSERTFID,RESULT,1,0); + IF RESULT NEQ 2 THEN FLAGI(155); + BUF ~ SCANINC(BUF,ID,RESULT,0,1); + END ELSE INTERFID ~ TIME(-1) ELSE INSERTFID ~ TIME(-1); + IF RESULT = 3 THEN + BEGIN NEWSEQ(SSNM[5],ID); + BUF ~ SCANINC(BUF,ID,RESULT,0,1); + IF RESULT NEQ 1 THEN FLAGI(156); + IF ID = "] " THEN NEWSEQ (INSERTSEQ,99999999) %400- + ELSE BEGIN %400- + BUF ~ SCANINC(BUF,ID,RESULT,0,1); + IF RESULT NEQ 3 THEN FLAGI(157); + NEWSEQ (INSERTSEQ,ID); + END %400- + END ELSE IF ID = "] " THEN NEWSEQ(INSERTSEQ,999999999) + ELSE FLAGI(157); + IF INSERDEPTH > 0 THEN CLOSE (LF,RELEASE); + FILL LF WITH INSERTMID,INSERTFID; + DO BEGIN + READ (LF[INSERTINX ~ INSERTINX+1],10,DB[*])[E4]; + END UNTIL SEQCHK(SSNM[5],DB[9]) NEQ 3; + NEWPTOG ~ BOOLEAN(INSERTCOP); + IF NOT NEWTPTOG THEN + BEGIN + IF SEQTOG THEN + BEGIN NEWSEQ(CRD[9],SEQBASE); MOVE(CRD[9],BUFL); + SEQBASE~SEQBASE+SEQINCR; + END; MOVEC(CRD[9],BUFL); + IF LIBTAPE AND(INSERTDEPTH = 0 ) THEN WRITE(NEWTAPE,10,CRD[*]); + END; %511- + IF LISTOG OR DOLIST THEN PRINTCARD; %511- + NEXTCARD~7; + GO TO STRT; + E1: IF NEXTCARD=1 THEN IF TAPETOG THEN + BEGIN + NEXTCARD~5; READ(TP,10,TB[*])[E2]; GO TO STRT ; + END + ELSE + BEGIN + NEXTCARD~6; + IF GETCOL1(CRD[0]) THEN BEGIN BUF ~ MKABS(CRD[0]); + BUF~SCANINC(BUF,ID,RESULT,1,0); IF ID NEQ INCLUDE + THEN BLANKIT(CRD,9,1); END; + GO TO ENDP ; + END ; + NEXTCARD ~ 5; GO TO ENDP; + E2: IF NEXTCARD = 5 THEN + BEGIN + NEXTCARD~6; + IF GETCOL1(CRD[0]) THEN BEGIN BUF ~ MKABS(CRD[0]); + BUF~SCANINC(BUF,ID,RESULT,1,0); IF ID NEQ INCLUDE + THEN BLANKIT(CRD,9,1); END; + END + ELSE IF NEXTCARD!2 THEN NEXTCARD~1 ELSE + BEGIN + NEXTCARD~1; TAPETOG~BOOLEAN(2); READ(CR,10,CB[*])[E1] ; + END ; + IF VOIDTTOG THEN IF SEQCHK(CRD[0],VOIDTSEQ) < 4 %114- + THEN VOIDTTOG~FALSE %114- + ELSE BEGIN VOIDTTOG~FALSE; GO TO STRT; END; %114- + GO TO ENDP ; + E4B: NOWRI ~TRUE; + IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); + IF NEWTPTOG THEN IF TSSEDITOG THEN + BEGIN TSSEDITS(CRD,PRINTBUFF); WRITE(NEWTAPE,10,PRINTBUFF[*]); + END ELSE WRITE(NEWTAPE,10,CRD[*]); + E4: CLOSE (LF,RELEASE); + NEWTPTOG~ SAVETOG; + IF (INSERTDEPTH ~ INSERTPDEPTH - 1) = -1 THEN + BEGIN NEXTCARD ~ SAVECARD; GO TO ENDPA; END + ELSE NEWTPTOG ~ BOOLEAN(INSERTCOP); + FILL LF WITH INSERTMID,INSERTFID; + READ(LF[INSERTINX ~ INSERTINX + 1],10,DB[*])[E4]; + IF SEQCHK(INSERTSEQ,DB[9]) = 4 THEN GO TO E4; + GO TO ENDP; + E4A: + NEWTPTOG~SAVETOG; + IF (INSERTDEPTH ~ INSERTDEPTH-1) = -1 THEN NEXTCARD~SAVECARD + ELSE NEWTPTOG ~ BOOLEAN(INSERTCOP); + STRT: + STRTA: + IF NEXTCARD=6 THEN GO XIT ; + CARDCOUNT ~ CARDCOUNT+1; + IF NEXTCARD = 1 THEN + BEGIN % CARD ONLY + IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG + THEN MOVEW(CB,CRD,HOLTOG,IF DCINPUT THEN "D" ELSE "R") + ELSE IF SNNM[4]~DCMOVEW(CB,CRD,HOLTOG,"FILE ",IF FREEFTOG + THEN " R" ELSE " D") ! " " THEN + BEGIN XTA~SSNM[4] ; + MOVESEQ(SSNM[4],LASTSEQ); MOVESEQ(LASTSEQ,CRD[9]) ; + IF LISTOG THEN + BEGIN IF FIRSTCALL THEN DATIME ; + DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],0); + WRITAROW(11,PRINTBUFF); UNPRINTED~FALSE ; + END ; + FLOG(149); MOVESEQ(LASTSEQ,SSNM[4]) ; + END ; + IF GETCOL1(CRD[0]) THEN + BEGIN + BUF ~ MKABS(CRD[0]); + BUF ~ SCANINC(BUF,ID,RESULT,1,0); + IF ID NEQ INCLUDE THEN + BEGIN + DOLOPT; + IF REAL(TAPETOG)=3 THEN READ(TP) ; + READ(CR,10,CB[*])[E1]; + IF NOT TAPETOG THEN GO TO STRT; + READ(TP,10,TB[*])[E2]; + NEXTCARD ~ SEQCHK(TB[9], CB[9]); + GO TO STRT; + END; + END; + IF LISTPTOG THEN + BEGIN IF FIRSTCALL THEN DATIME; + IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); + DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],1); + WRITAROW (12,PRINTBUFF); UNPRINTED ~ FALSE; + END; + READ(CR,10,CB[*])[E1]; + GO TO ENDP; + END; + IF NEXTCARD = 5 THEN + BEGIN + MOVEW(TB,CRD,HOLTOG,"T") ; + READ(TP, 10, TB[*])[E2]; + IF VOIDTTOG THEN IF SEQCHK(CRD[9],VOIDTSEQ) < 4 THEN + VOIDTTOG ~ FALSE ELSE GO TO STRT; + GO TO ENDP; + END; + IF NEXTCARD { 3 THEN + BEGIN % CARD OVER TAPE + IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG + THEN MOVEW(CB,CRD,HOLTOG,IF DCINPUT THEN "D" ELSE "R") + ELSE IF SSNM[4]~DCMOVEW(CB,CRD,HOLTOG,"FILE ",IF FREEFTOG + THEN " R" ELSE " D") ! " " THEN + BEGIN XTA~SSNM[4] ; + MOVESEQ(SSNM[4],LASTSEQ); MOVESEQ(LASTSEQ,CRD[9] ); + IF LISTOG THEN + BEGIN IF FIRSTCALL THEN DATIME; + DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],0); + WRITAROW(11,PRINTBUFF); UNPRINTED~FALSE ; + END; + FLOG(149); MOVESEQ(LASTSEQ,SSNM[4]) ; + END; + IF NEXTCARD =2 THEN READ(TP,10,TB[*])[E2]; + IF GETCOL1(CRD) THEN + BEGIN + BUF ~ MKABS(CRD[0]); + BUF ~ SCANINC(BUF,ID,RESULT,1,0); + IF ID NEQ INCLUDE THEN + BEGIN + DOLOPT; + READ(CR,10,CB[*])[E3]; + NEXTCARD ~ SEQCHK(TB[9], CB[9]); + GO TO STRT; + E3: NEXTCARD~5; GO TO STRT; + END; + END; + IF LISTPTOG THEN + BEGIN IF FIRSTCALL THEN DATIME; + IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); + DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],1); + WRITAROW (12,PRINTBUFF); UNPRINTED ~ FALSE; + END; + READ(CR,10,CB[*])[E1]; + NEXTCARD ~ SEQCHK(TB[9], CB[9]); + GO TO ENDP; + END; + % TAPE BEFORE CARD + IF NEXTCARD = 7 THEN + BEGIN + IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG + THEN MOVEW(DB,CRD,HOLTOG,"L") ELSE IF XTA~DCMOVEW(DB,CRD, + HOLTOG,"FILE ",IF FREETOG THE " R" ELSE " D") + ! " " THEN FLOG(149); + IF GETCOL1(CRD[0]) THEN + BEGIN + BUF ~ MKABS(CRD[0]); + BUF ~ SCANINC(BUF,ID,RESULT,1,0); + IF ID = INCLUDE THEN GO TO LIBADD; + END; + READ(LF[INSERTINX~INSERTINX+1],10,DB[*])[E4B]; + IF SEQCHK(INSERTSEQ,DB[9]) = 4 THEN GO TO E4B; + IF GETCOL1(CRD[0]) THEN BEGIN DOLOPT; GO TO STRT; END; + GO TO ENDP; + END; + MOVEW(TB,CRD,HOLTOG,"T") ; + READ(TP,10,TB[*])[E2]; + IF VOIDTTOG THEN IF SEQCHK(CRD[9],VOIDTSEQ) < 4 THEN + VOIDTTOG~FALSE ELSE BEGIN NEXTCARD~SEQCHK(TB[9],CB[9]); + GO TO STRT; END; %114- + NEXTCARD ~ SEQCHK(TB[9], CB[9]); + ENDP: + IF NEXTCARD NEQ 7 THEN + IF VOIDTOG THEN IF SEQCHK(CRD[9],VOIDSEQ) < 4 THEN + VOIDTOG ~ FALSE ELSE GO TO STRT; + IF GETCOL1(CRD[0]) THEN + BEGIN + BUF ~ MKABS(CRD[0]); + BUF ~ SCANINC(BUF,ID,RESULT,1,0); + IF ID = INCLUDE THEN GO TO LIBADD ELSE GO TO STRT; + END; + SEQERRORS ~ FALSE; + IF NEXTCARD = 7 THEN + BEGIN MOVESEQ(LASTSEQ,CRD[9]); GO TO ENDPA; END; + IF CHECKTOG AND SEQERRCT=0 THEN SEQERRCT~1 ; + IF CHECKTOG THEN IF SEQCHK(LASTSEQ,CRD[9])=3 THEN + BEGIN + SEQERR(ERRORBUFF,CRD[9],LASTSEQ) ; + MOVESEQ(LASTSEQ,CRD[9]) ; + IF SEQTOG THEN + BEGIN NEWSEQ(CRD[9],SEQBASE);SEQBASE~SEQBASE+SEQINCR END; + MOVESEQ(LINKLIST,CRD[9]); + MOVE(CRD[9],BUFL) ; + SEQERRCT~SEQERRCT+1 ; + SEQERRORS~TRUE ; + IF NOT LISTOG THEN PRINTCARD ; + END + ELSE MOVESEQ(LASTSEQ,CRD[9]) ELSE MOVESEQ(LASTSEQ,CRD[9]) ; + + + + + + + + +ENDPA: + IF SEQTOG THEN + BEGIN + NEWSEQ(CRD[9],SEQBASE); + SEQBASE ~ SEQBASE + SEQINCR; + END; + IF NOWRI THEN GO TO ENDPB; + IF NEWTPTOG THEN IF TSSEDITOG THEN BEGIN TSSEDITS(CRD,PRINTBUFF) ; + WRITE(NEWTAPE,10,PRINTBUFF[*]) END ELSE WRITE(NEWTAPE,10,CRD[*]) ; +ENDPB: + IF NOT SEQERRORS THEN + BEGIN + MOVESEQ(LINKLIST,CRD[9]) ; + MOVE(CRD[9],BUFL) ; + END ; + NCR ~ INITIALNCR; + READACARD ~ TRUE; +XIT: + SEGSWFIXED ~ TRUE ; + REMFIXED~TRUE ; + IF TSSEDITOG THEN WARNED~TRUE ; + IF LISTOG AND FIRSTCALL THEN DATIME; + IF SEGSW THEN %%% ENTER SEQ# AND ADR TO LINESEG ARRAY. + BEGIN IF LASTADDR!ADR THEN BEGIN NOLIN~NOLIN+1; LASTADDR~ADR END; + LINESEG[NOLIN,IR,NOLIN,IC]~0 & D2B(LASTSEQ)[10:20:28] & (ADR+3) + [38:36:10] ; + END ; +END READACARD; + +INTEGER STREAM PROCEDURE CONVERT(NUB,SIZE,P,CHAR); VALUE P; + BEGIN + LOCAL T; + SI ~ P; + 8(IF SC < "0" THEN JUMP OUT; + SI ~ SI + 1; TALLY ~ TALLY + 1); + CONVERT ~ SI; + DI ~ CHAR; DS ~ 7 LIT "0"; DS ~ CHR; + T ~ TALLY; + SI ~ P; DI ~ NUB; DS ~ T OCT; + DI ~ SIZE ; SI ~ LOC T; DS ~ WDS; + END CONVERT; +PROCEDURE SCAN; +BEGIN +BOOLEAN STREAM PROCEDURE ADVANCE(NCR, ACR, CHAR, NCRV, ACRV); +VALUE NCRV, ACRV, CHAR; +BEGIN LABEL LOOP; + LABEL DIG, ALPH, BK1, BK2, SPEC; + DI ~ ACRV; + SI ~ CHAR; SI ~ SI+8; + IF SC ! " " THEN + IF SC } "0" THEN BEGIN SI ~ NCRV; GO TO BK1 END ELSE + BEGIN SI ~ NCRV; GO TO BK2 END; + SI ~ NCRV; + LOOP: + IF SC = " " THEN BEGIN SI~SI+1; GO TO LOOP END; + IF SC } "0" THEN + BEGIN + DIG: DS ~ CHR; + BK1: IF SC = " " THEN BEGIN SI ~ SI+1; GO TO BK1 END; + IF SC } "0" THEN GO TO DIG; + GO TO SPEC; + END; + IF SC = ALPHA THEN + BEGIN + ALPH: DS ~ CHR; + BK2: IF SC = " " THEN BEGIN SI ~ SI+1; GO TO BK2 END; + IF SC = ALPHA THEN GO TO ALPH; + END; + SPEC: + ACRV ~ DI; + DS ~ 6 LIT " "; + IF SC = "]" THEN + BEGIN TALLY ~ 1; SI ~ LOC ACRV; + DI ~ ACR; DS ~ WDS; + DI ~ CHAR; DS ~ LIT ";"; + END ELSE + BEGIN DI ~ CHAR; DS ~ CHR; + ACRV ~ SI; SI ~ LOC ACRV; + DI ~ NCR; DS ~ WDS; + END; + ADVANCE ~ TALLY; +END ADVANCE; +BOOLEAN PROCEDURE CONTINUE; +BEGIN +LABEL LOOP; + +BOOLEAN STREAM PROCEDURE CONTIN(CD); +BEGIN SI~CD; IF SC!"C" THEN IF SC!"$" THEN BEGIN SI~SI+5; IF SC!" " +THE IF SC!"0" THEN BEGIN TALLY~1; CONTIN~TALLY END END END OF CONTIN ; +BOOLEAN STREAM PROCEDURE COMNT(CD,T); VALUE T; +BEGIN LABEL L ; + SI ~ CD; IF SC = "C" THEN BEGIN T(SI~SI+1; IF SC="-" THEN TALLY~1 + ELSE JUMP OUT TO L); TALLY~1; L: END; COMNT~TALLY ; +END COMMNT; +BOOLEAN STREAM PROCEDURE DCCONTIN(CD); +BEGIN + SI ~ CD; IF SC = "-" THEN TALLY ~ 1; + DCCONTIN ~ TALLY; +END DCCONTIN; +LOOP: IF NOT(CONTINUE ~ + IF(DCINPUT AND NOT TSSEDITOG)OR FREEFTOG THEN + IF NEXTCARD < 4 THEN DCCONTIN(CB) + ELSE IF NEXTCARD = 7 THEN DCCONTIN(DB)ELSE CONTIN(TB) + ELSE IF NEXTCARD = 7 THEN CONTIN(DB) + ELSE IF NEXTCARD < 4 THEN CONTIN(DB) ELSE + CONTIN(TB)) THEN + IF(IF NEXTCARD < 4 THEN + COMNT(CB,(DCINPUT AND NOT TSSEDITOG) OR FREEFTOG) + ELSE IF NEXTCARD = 7 THEN + COMNT(CB,(DCINPUT AND NOT TSSEDITOG) OR FREEFTOG) + ELSE COMNT(TB,0) AND NEXTCARD ! 6) THEN + BEGIN + IF READACARD THEN IF LISTOG THEN PRINTCARD; + GO TO LOOP; + END; +END CONTINUE; + +PROCEDURE SCANX(EOF1, EOF2, EOS1, EOS2, OK1, OK2); + VALUE EOF1, EOF2, EOS1, EOS2, OK1, OK2; + INTEGER EOF1, EOF2, EOS1, EOS2, OK1, OK2; +BEGIN LABEL LOOP, LOOP0 ; + LOOP0: + EXACCUM[1] ~ BLANKS; + ACR ~ ACR1; + LOOP: + IF ADVANCE(NCR, ACR, CHR1, NCR, ACR) THEN + IF CONTINUE THEN + IF READACARD THEN + BEGIN + IF LISTOG THEN PRINTCARD ; + IF ACR.[33:15]}EXACCUMSTOP THEN + BEGIN XTA~BLANKS; FLOG(175); GO LOOP0 END ; + GO LOOP ; + END + END SCN ~ IF EXACCUM[1] = BLANKS THEN EOF1 ELSE EOF2 + ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN EOS1 ELSE EOS2 + ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN OK1 ELSE OK2; +END SCANX; + +DEFINE CHAR = ACCUM[0]#; +DEFINE T=SYMBOL#; +INTEGER N; +BOOLEAN STREAM PROCEDURE CHECKEXP(NCR, NCRV, A); VALUE NCRV; +BEGIN + SI ~ NCRV; + IF SC = "*" THEN + BEGIN DI ~ A; DI ~ DI+2; DS ~ 2 LIT "*"; SI ~ SI+1; NCRV ~ SI; + TALLY ~ 1; CHECKEXP ~ TALLY; + SI ~ LOC NCRV; DI ~ NCR; DS ~ WDS END; +END CHECKEXP; +PROCEDURE CHECKRESERVED; +BEGIN LABEL RESWD, XIT, FOUND1, FOUND2, DONE; +BOOLEAN STREAM PROCEDURE COMPLETECHECK(A,B,N); VALUE N ; + BEGIN LABEL L ; + SI~A; SI~SI-2; DI~B; N(IF SC!DC THEN JUMP OUT TO L); TALLY~1; + L: COMPLETECHECK~TALLY ; + END OF COMPLETECHECK; ; +STREAM PROCEDURE XFER(FROM, T1, T2, N, M); VALUE FROM, N, M; +BEGIN SI ~ FROM; DI ~ T1; DI ~ DI+2; + DS ~ M CHR; + SI ~ FROM; SI ~ SI+N; + DI ~ T2; DI ~ DI+2; + DS ~ 6 CHR; +END XFER; +STREAM PROCEDURE XFERA(FROM, NEXT1, NEXT2); + VALUE FROM; +BEGIN SI ~ FROM; SI ~ SI+6; + DI ~ NEXT1; DI ~ DI+2; + 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); + SI ~ SI+2; + DI ~ NEXT2; DI ~ DI+2; + 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); +END XFERA; +BOOLEAN STREAM PROCEDURE CHECKFUN(FROM, TOO, N); VALUE FROM, N; +BEGIN SI ~ FROM; SI ~ SI +N; + IF SC = "0" THEN + BEGIN SI ~ SI+1; + IF SC = "N" THEN + BEGIN SI ~ SI+1; TALLY ~ 1; + DI ~ TOO; DI ~ DI+2; + DS ~ 6 CHR; + END; + END; + CHECKFUN ~ TALLY; +END CHECKFUN; +BOOLEAN STREAM PROCEDURE MORETHAN6(P); +BEGIN SI ~ P; + IF SC ! " " THEN TALLY ~ 1; + MORETHAN6 ~ TALLY; +END MORETHAN6; +INTEGER I; ALPHA ID; +INTEGER STOR ; + IF ACCUM[1] = " " THEN + BEGIN XTA ~ CHAR; FLOG(16); GO TO XIT END; + IF CHAR = "= " OR CHAR = "# " THEN GO TO XIT; + IF CHAR = "~ " THEN GO TO XIT; + IF CHAR ! "( " AND CHAR ! "% " THEN GO TO RESWD; + IF MORETHAN6(ACCUM[2]) THEN GO TO RESWD; + COMMENT AT THIS POINT WE HAVE ( . + THIS MUST BE ONE OF THE FOLLOWING: + ASSIGNMENT STATEMENT WITH SUBSCRIPTED VARIABLE AT THE LEFT. + STATEMENT FUNCTION DECLARATION. +CALL, REAL, ENTRY, GO TO, READ, WRITE, FORMAT, IF, DATA, CHAIN, PRINT OR + PUNCH; + IF I ~ SEARCH(T) > 0 THEN + IF GET(I).CLASS = ARRAYID THEN GO TO XIT; + ID ~ T; ID.[36:12] ~ " "; + FOR I~0 THRU RSP DO IF RESERVEDWORDSLP[I]=ID THEN IF (IF STOR + ~RESLENGTHLP[I]-4<1 THEN TRUE ELSE COMPLETECHECK(ACCUM[2], + RESERVEDWORDSLP[I+RSP1],STOR)) THEN GO FOUND1 ; + GO TO XIT; + FOUND1: + NEXT ~ LPGLOBAL[I]; + T ~ " "; + XFER(ACR0, T, NEXTACC, I~RESLENGTHLP[I], IF I> 6 THEN 6 ELSE I); + GO TO DONE; + RESWD: + COMMENT AT THIS POINT WE KNOW THE MUST BE A SPECIAL WORD + TO IDENTIFY THE STATEMENT TYPE; + ID ~ T; ID.[36:12] ~ " "; + IF T = "ASSIGN" THEN + BEGIN + NEXTSCN ~ SCN; SCN ~ 14; + NEXTACC ~ NEXTACC2 ~ " "; + XFERA(ACR0, NEXTACC, NEXTACC2); + NEXT ~ 1; + GO TO XIT; + END; + FOR I~1 THRU RSH DO IF RESERVEDWORDS[I]=ID THEN IF (IF STOR~ + RESLENGTH[I]-4<1 THEN TRUE ELSE COMPLETECHECK(ACCUM[2],RESERVEDWORDS + [I+RSH1],IF STOR>8 THEN 8 ELSE STOR)) THEN GO FOUND2 ; + XTA ~ T; FLOG(16); GO TO XIT; + FOUND2: + NEXT ~ I+1; + T ~ " "; + XFER(ACR0, T, NEXTACC, I~RESLENGTH [I], IF I> 6 THEN 6 ELSE I); + DONE: NEXTSCN ~ SCN; + SCN ~ 6; + IF NEXTACC = "FUNCTI" THEN + IF CHECKFUN(ACR0, NEXTACC, I+6) THEN SCN ~ 13; + XIT: + EOSTOG~FALSE; +END CHECKRESERVED; + +BOOLEAN PROCEDURE CHECKOCTAL; +BEGIN + INTEGER S, T; LABEL XIT; +INTEGER STREAM PROCEDURE COUNT(ACRV,T); VALUE ACRV,T ; + BEGIN + LOCAL A,B; SI~LOC T; SI~SI+7 ; + IF SC="1" THEN BEGIN SI~ACRV;IF SC="0" THEN SI~SI+1 END ELSE SI~ACRV; + IF SC!" " THEN + BEGIN A~SI; + 17(IF SC>"7" THEN BEGIN TALLY~17; JUMP OUT END ELSE IF SC < "0" THEN + BEGIN IF SC!" " THEN TALLY~17; JUMP OUT END; SI~SI+1; + TALLY~TALLY+1) ; + B~TALLY; SI~LOC B; SI~SI+7 ; + IF SC="+" THEN BEGIN SI~A; IF SC>"3" THEN TALLY~17 END; + END ; + COUNT~TALLY ; + END OF COUNT ; +ALPHA STREAM PROCEDURE CONV(ACRV, S, T); VALUE ACRV, S, T; +BEGIN SI ~ ACRV; IF SC = "0" THEN SI ~ SI+1; + DI ~ LOC CONV; SKIP S DB; + T(SKIP 3 SB; 3(IF SB THEN DS ~ SET ELSE DS ~ RESET; SKIP 1 SB)); +END CONV; + IF T~COUNT(ACR0,1) = 0 THEN + BEGIN S ~ 1; + IF T ~ CHAR ! "+ " AND T ! "& " THEN + IF T = "- " THEN S ~ -1 ELSE GO TO XIT; + SCANX(4, 4, 3, 3, 10, 10); + IF SC ! 10 THEN GO TO XIT; + IF T~COUNT(ACR1,2) = 0 OR T > 16 THEN GO TO XIT ; + FNEXT ~ CONV(ACR1, (16-T)|3, T); + IF S < 0 THEN FNEXT ~ -FNEXT; + END ELSE IF T < 17 THEN FNEXT~CONV(ACR0,(16-T)|3,T) ELSE GO TO XIT ; + CHECKOCTAL ~ TRUE; + NEXT ~ NUM; + NUMTYPE ~ REALTYPE; + XIT: +END CHECKOCTAL; + +PROCEDURE HOLLERITH; +BEGIN + REAL T, COL1, T2, ENDP; + LABEL XIT; + INTEGER STREAM PROCEDURE STRCNT(S,D,SZ); VALUE S,SZ; + BEGIN + SI ~ S; DS ~ D;DS ~ 8 LIT "00 "; DI ~ D; + DI ~ D; DI ~ DI + 2; DS ~SZ CHR; STRCNT ~ SI; + END STRCNT; + INTEGER STREAM PROCEDURE RSTORE(S,D,SKP,SZ); + VALUE S, SKP, SZ; + BEGIN + DI ~ D; + SI ~ S; DI ~DI + SKP; DS ~ SZ CHR; RSTORE ~ SI; + END RSTORE; + F1 ~ FNEXT; + NUMTYPE ~ STRINGTYPE; + T ~ 0 & NCR[30:33:15] & NCR[45:30:3]; + COL1 ~ 0 & INITIALNCR[30:33:15]; + ENDP ~ COL1 + 72; + STRINGSIZE ~ 0; + WHILE F1 >0 DO + BEGIN + T2 ~ IF F1 > 6 THEN 6 ELSE F1; + IF STRINGSIZE > MAXSTRING THEN + BEGIN FLAG(120); STRINGSIZE ~ 0 END; + IF T+T2> ENDP THEN IF DCINPUT OR FREEFTOG THEN + BEGIN XTA~BLANKS; FLOG(150); GO TO XIT END + ELSE BEGIN + IF TSSEDITOG THEN IF NOT DCINPUT THEN TSSED(BLANKS,1) ; + NCR ~ STRCNT(NCR, STRINGARRAY[STRINGSIZE], ENDP-T); + IF NOT CONTINUE THEN + BEGIN FLOG(43); GO TO XIT END; + IF READACARD THEN; + IF LISTOG THEN PRINTCARD; + NCR ~ RSTORE(NCR,STRINGARRAY[STRINGSIZE],ENDP-T+2,T2-(ENDP-T)); + STRINGSIZE ~ STRINGSIZE+1; + F1 ~ F1 - T2; + T ~ COL1 + 6 + T2 - (ENDP - T); + END ELSE + BEGIN + NCR ~ STRCNT(NCR, STRINGARRAY[STRINGSIZE], T2); + STRINGSIZE ~ STRINGSIZE +1; + T ~ T +T2; + F1 ~ F1 - T2; + END; + END; + NUMTYPE ~ STRINGTYPE; + SCN ~ 1; + XIT: +END HOLLERITH; +PROCEDURE QUOTESTRING; +BEGIN + REAL C; + LABEL XIT; + ALPHA STREAM PROCEDURE STRINGWORD(S,D,SKP,SZ,C); + VALUE S,SKP,SZ; + BEGIN + LABEL QT, XIT; + DI ~ D; SI ~ S; + DI ~ DI+SKP; DI ~ DI+2; + TALLY ~ SKP; + SZ( IF SC = """ THEN JUMP OUT TO QT; + IF SC = ":" THEN JUMP OUT TO QT; + IF SC = "@" THEN JUMP OUT TO QT; + IF SC = "]" THEN JUMP OUT TO XIT; + DS ~ CHR; TALLY ~ TALLY+1); + GO TO XIT; + QT: TALLY ~ TALLY+7; SI ~ SI+1; + XIT: STRINGWORD ~ SI; S ~ TALLY; + SI ~ LOC S; DI ~ C; DS ~ WDS; + END STRINGWORD; + STRINGSIZE ~ 0; + DO + BEGIN + IF STRINGSIZE > MAXSTRING THEN + BEGIN FLAG(120); STRINGSIZE ~ 0 END; + STRINGARRAY[STRINGSIZE] ~ BLANKS; + NCR ~ STRINGWORD(NCR, STRINGARRAY[STRINGSIZE], 0, 6, C); + IF C<6 THEN IF DCINPUT OF FREEFTOG + THEN BEGIN XTA~BLANKS; FLOG(150); GO TO XIT END + ELSE BEGIN + IF TSSEDITOG THEN IF NOT DCINPUT THEN TSSED(BLANKS,1) ; + IF NOT CONTINUE THEN + BEGIN FLOG(121); GO TO XIT END; + IF READACARD THEN; + IF LISTOG THEN PRINTCARD; + NCR ~ STRINGWORD(NCR, STRINGARRAY[STRINGSIZE ],C,6-C,C); + END; + STRINGSIZE ~ STRINGSIZE + 1; + END UNTIL C } 7; + IF C = 7 THEN STRINGSIZE ~ STRINGSIZE-1; + FNEXT ~ STRINGSIZE; + NEXT ~ NUM; + SYMBOL ~ NAME - STRINGARRAY[0]; + NUMTYPE ~ STRINGTYPE; + SCN ~ 1; + XIT: +END QUOTESTRING; + +PROCEDURE CHECKPERIOD; +BEGIN +LABEL FRACTION, XIT, EXPONENT, EXPONENTSIGN; +LABEL NUMFINI, FPLP, CHKEXP; +ALPHA S, T, I, TS; + INTEGER C2; +BOOLEAN CON; + IF T ~ CHAR ! ". " THEN GO TO CHKEXP; +SCANX(4, 9, 3, 8, 10, 11); +IF T ~ EXACCUM[1] = " " THEN + BEGIN IF NUMTYPE ! DOUBTYPE THEN NUMTYPE ~ REALTYPE; GO TO XIT END; +IF T = "E " OR T = "D " THEN GO TO EXPONENTSIGN; +IF T.[12:6] { 9 THEN GO TO FRACTION; +IF T.[18:6] { 9 THEN +BEGIN + IF S ~ T.[12:6] ! "E" AND S ! "D" THEN + BEGIN XTA ~ T; FLOG(63); GO TO XIT END; + EXACCUM[1].[12:6] ~ 0; + I ~ 1; GO TO EXPONENT; +END; +IF EXACCUM[0] ! ". " THEN GO TO XIT; +FOR I ~ 0 STEP 1 UNTIL 10 DO + IF T = PERIODWORD[I] THEN + BEGIN EXACCUM[2] ~ I; SCN ~ 12; GO TO XIT END; +GO TO XIT; +FRACTION: NEXT ~ NUM; +IF NUMTYPE !DOUBTYPE THEN NUMTYPE ~ REALTYPE; XTA ~ ACR1; +FPLP: +F1 ~ 0; +XTA ~ CONVERT(F1,C1,XTA ,TS); +C2 ~ C2 + C1; +IF (F2 ~ FNEXT|TEN[C1]+F1) { MAX + THEN FNEXT ~ F2 + ELSE BEGIN + NUMTYPE ~ DOUBTYPE; + CON ~ TRUE; + DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|, + F1,0,+,~,FNEXT,DBLOW); + END; +IF TS { 9 THEN GO TO FPLP; +F1 ~ 0; +IF T ~ EXACCUM[0] ! "E " AND T ! "D " THEN +BEGIN IF SCN = 8 THEN SCN ~ 3 ELSE SCN ~ 10; + GO TO NUMFINI; +END; +CHKEXP: FNEXT ~ FNEXT | 1.0; +F1 ~ 0; +I ~ 1; +SCANX(4, 4, 3, 3, 20, 10); +IF SCN = 20 THEN +EXPONENTSIGN: +BEGIN IF S ~ EXACCUM[0] ! "+ " AND S ! "& " THEN + IF S = "- " THEN I ~ -1 ELSE + BEGIN XTA ~ S; FLOG(63); SCN ~ 10; GO TO XIT END; + SCANX(4, 4, 3, 3, 10, 10); + END; + IF (S ~ EXACCUM[1]).[12:6] > 9 THEN + BEGIN XTA ~ IF S ! BLANKS THEN S ELSE T; FLOG(63); GO TO XIT END; + EXPONENT: + IF NUMTYPE ! DOUBTYPE THEN NUMTYPE ~ REALTYPE; +IF T.[12:6] = "D" THEN NUMTYPE ~ DOUBTYPE; + IF SCN = 8 THEN SCN ~ 3 ELSE IF SCN = 11 THEN SCN ~ 10; + XTA ~ ACR1; + XTA ~ CONVERT(F1,C1,XTA ,TS); + IF I < 0 THEN F1 ~ -F1; + NUMFINI: + C1 ~ F1 - C2; + IF I ~ (ABS(C1+(FNEXT.[3:6]&FNEXT[1:2:1]))) > 63 OR((ABS(C1) = I OR + FNEXT } 5) AND ABS(F1) } 69) + THEN BEGIN XTA ~ T; FLOG(87); GO TO XIT; END; + IF NUMTYPE ! DOUBTYPE THEN + BEGIN + IF C1} 0 THEN FNEXT ~ FNEXT | TEN[C1] + ELSE FNEXT ~ FNEXT / TEN[-C1]; + END ELSE + BEGIN + IF C1 } 0 + THEN DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|,~,FNEXT,DBLOW) + ELSE DOUBLE(FNEXT,DBLOW,TEN[-C1],TEN[69-C1],/,~,FNEXT,DBLOW); + IF CON THEN IF DBLOW.[9:33] = MAX.[9:33] THEN + IF FNEXT.[3:6] LSS 14 + THEN IF BOOLEAN(FNEXT.[2;1]) THEN + BEGIN DBLOW ~ 0; FNEXT ~ FNEXT + 1&FNEXT[2:2:7]; END; + END; + XIT: +END CHECKPERIOD; + +LABEL LOOP0, NUMBER ; +LABEL L,XIT; +LABEL L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15,L16,L17, + L18,L19,L20,L21,BK ; +SWITCH CASEL~L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15, + L16,L17,L18,L19,L20,L21 ; +LABEL LOOP, CASESTMT; %994- +LABEL CASE0,CASE1,CASE2,CASE3,CASE4,CASE5,CASE6,CASE7; %994- +LABEL CASE8,CASE9,CASE10,CASE11,CASE12,CASE13,CASE14; %994- +PREC~NEXT~FNEXT~REAL(SCANENTER~FALSE) ; +CASESTMT: +CASE SCN OF +BEGIN +CASE0: %994- +GO TO IF LABELR THEN CASE5 ELSE CASE1; +CASE1: +BEGIN + LOOP0: + ACR ~ ACR0; + ACCUM[1] ~ BLANKS; + LOOP: + IF ADVANCE(NCR, ACR, CHR0, NCR, ACR) THEN + IF CONTINUE THEN + IF READACARD THEN + BEGIN + IF LISTOG THEN PRINTCARD ; + IF ACR.[33:15]}ACCUMSTOP THEN + BEGIN XTA~BLANKS; FLOG(175); GO LOOP0 END ; + GO LOOP ; + END + ELSE IF T ~ ACCUM[1] = " " THEN GO TO CASE5 ELSE SCN ~ 4 + ELSE IF T ~ ACCUM[1] = " " THEN + GO TO CASE3 ELSE SCN ~ 3 + ELSE IF T ~ ACCUM[1] = " " THEN GO TO CASE2 ELSE SCN ~ 2; +END; +CASE2: +BEGIN T ~ CHAR; SCN ~ 1 END; +CASE3: +BEGIN T ~ "; "; NEXT ~ SEMI; SCN ~ 0; + IF FOSTOG THEN IF LOGIFTOG THEN BEGIN LOGIFTOG ~ FALSE; XTA ~ T; + FLAG(101); END; + GO TO XIT; +END; +CASE4: %994- +BEGIN T ~ "; "; NEXT ~ SEMI; SCN ~ 5; GO TO XIT END; +CASE5: +BEGIN T ~ " "; NEXT ~ EOF; EOSTOG ~ FALSE; GO TO XIT END; +CASE6: %994- +BEGIN T ~ ACCUM[1] ~ NEXTACC; SCN ~ NEXTSCN; + IF T = " " THEN GO TO CASESTMT; +END; +CASE7: %994- +BEGIN EOSTOG ~ TRUE; + IF LABELR THEN GO TO CASE5 ELSE GO TO CASE1; +END; +CASE8: %994- +BEGIN T ~ EXACCUM[1]; SCN ~ 3 END; +CASE9: %994- +BEGIN T ~ EXACCUM[1]; SCN ~ 4 END; +CASE10: %994- +BEGIN T ~ CHAR ~ EXACCUM[0]; SCN ~ 1 END; +CASE11: %994- +BEGIN T ~ EXACCUM[1]; SCN ~ 10 END; +CASE12: %994- +BEGIN T ~ EXACCUM[1]; SCN ~ 1; + IF N ~ EXACCUM[2] { 1 THEN + BEGIN NEXT ~ NUM; FNEXT ~ N; GO TO XIT END; + NEXT ~ 0; + OP ~ N-1; + PREC ~ IF N { 4 THEN N-1 ELSE 4; + GO TO XIT; +END; +CASE13: %994- +BEGIN T ~ "FUNCTI"; NEXT ~ 16; SCN ~ 6; GO TO XIT END; +CASE14: %994- +BEGIN T ~ ACCUM[1] ~ NEXTACC; + NEXTACC ~ NEXTACC2; SCN ~ 6; +END; +END OF CASE STATEMENT; +IF NOT FILETOG THEN + IF EOSTOG THEN + BEGIN + NEXT ~ 0; + IF T = "; " THEN GO TO CASESTMT; + CHECKRESERVED; + IF NEXT > 0 THEN GO TO XIT; + END; +IF (IDINFO~TIPE[T.[12:6]])>0 THEN + BEGIN +BK: NEXT~ID ; + IF NOT FILETOG THEN + IF SCANENTER~((FNEXT~SEARCH(T))=0) THEN FNEXT~ENTER(IDINFO,T) + ELSE IF GET(FNEXT).CLASS=DUMMY THEN FNEXT~GET(FNEXT+2).BASE ; + GO XIT ; + END ; +GO CASEL[-IDINFO]; % SEE INITIALIZATION OF "TIP". LINE 03433100%993- +L1: %DIGITS %993- +BEGIN NUMTYPE ~ INTYPE; NEXT ~ NUM; XTA ~ ACR0; + FNEXT ~ DBLOW ~ C1 ~ 0; + XTA ~ CONVERT(FNEXT,C1,XTA ,TS); + WHILE TS { 9 DO + BEGIN + XTA ~ CONVERT(F1,C1,XTA ,TS); + IF (F2 ~ FNEXT|TEN[C1]+F1) { MAX + THEN FNEXT ~ F2 + ELSE BEGIN + NUMTYPE ~ DOUBTYPE; + DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|, + F1,0,+,~,FNEXT,DBLOW); + END; + END; + IF CHAR = ". " OR CHAR = "E " OR CHAR = "D " THEN + CHECKPERIOD + ELSE IF CHAR = "H " THEN HOLLERITH; + GO TO XIT; +END; +L2: % > %993- +BEGIN PREC ~ 4; OP ~ 7; GO TO XIT END; +L3: % } %993- +BEGIN PREC ~ 4; OP ~ 8; GO TO XIT END; +L4: % & OR + %993- +BEGIN PREC ~ 5; OP ~ 10; NEXT ~ PLUS; GO TO XIT END; +L5: % . +BEGIN + FNEXT ~ DBLOW ~ C1 ~ 0; NUMTYPE ~ REALTYPE; + CHECKPERIOD; + T ~ EXACCUM[1]; + IF SCN = 12 THEN + BEGIN SCN ~ 1; + IF N ~ EXACCUM[2] { 1 THEN + BEGIN + NEXT ~ NUM; FNEXT ~ N; + NUMTYPE ~ LOGTYPE; GO TO XIT; + END; + NEXT ~ 0; + OP ~ N-1; + PREC ~ IF N { 4 THEN N-1 ELSE 4; + GO TO XIT; +END; + IF NEXT ! NUM THEN BEGIN NEXT ~ NUM; XTA ~ T; FLOG(141) END; + GO TO XIT; +END; +L6: % % OR ( %993- +BEGIN NEXT ~ LPAREN; GO TO XIT END; +L7: % < %993- +BEGIN PREC ~ OP ~ 4; GO TO XIT END; +L8: % LETTER 0 %993- +BEGIN IF DATATOG THEN IF CHECKOCTAL THEN GO TO XIT; + IDINFO~TIPE[12]; GO BK ; +END; +L9: % $ %993- +BEGIN NEXT ~ DOLLAR; GO TO XIT END; +L10: % * %993- +IF CHECKEXP(NCR, NCR, T) THEN +BEGIN PREC ~ 9; OP ~ 15; NEXT ~ UPARROW; GO TO XIT END ELSE +L11: +BEGIN PREC ~ 7; OP ~ 13; NEXT ~ STAR; GO TO XIT END; +L12: % - %993- +BEGIN PREC ~ 5; OP ~ 11; NEXT ~ MINUS; GO TO XIT END; +L13: % ) OR [ %993- +BEGIN NEXT ~ RPAREN; GO TO XIT END; +L14: % ; %993- +BEGIN NEXT ~ SEMI; GO TO XIT END; +L15: % { %993- +BEGIN PREC ~ 4; OP ~ 5; GO TO XIT END; +L16: % / %993- +BEGIN PREC ~ 7; OP ~ 14; NEXT ~ SLASH; GO TO XIT END; +L17: % , %993- +BEGIN NEXT ~ COMMA; GO TO XIT END; +L18: % ! %993- +BEGIN PREC ~ 4; OP ~ 9; GO TO XIT END; +L19: % = OR ~ OR # %993- +BEGIN NEXT ~ EQUAL; GO TO XIT END; +L20: % ] %993- +BEGIN XTA ~ T; FLAG(0); GO TO CASESTMT END; +L21: % " OR : OR @ %993- +BEGIN QUOTESTRING; GO TO XIT END; +XIT: +IF DEBUGTOG THEN WRITALIST(FC,3,NEXT,T," ",0,0,0,0,0) ; + XTA ~ NAME ~ T; +END SCAN; + +PROCEDURE WRAPUP; + COMMENT WRAPUP OF COMPILIATION; + BEGIN +ARRAY PRT[0:7,0:127], + SEGDICT[0:7,0:127], + SEG0[0:29]; +ARRAY FILES[0:BIGGESTFILENB]; +INTEGER THEBIGGEST; +SAVE ARRAY FPB[0:1022]; % FILE PARAMETER BLOCK +REAL FPS,FPE; % START AND END OF FPB +REAL GSEG,PRI,FI,MFID,IDNM,FILTYP,FPBI; +BOOLEAN ALF; +REAL PRTADR, SEGMNT, LNK, TSEGSZ, T1, I, FPBSZ; + DEFINE + SPDEUN= FPBSZ#, + ENDDEF=#; +ARRAY INTLOC[0:150]; +REAL J; +FORMAT SEGUS(A6, " IS SEGMENT ", I4, + ", PRT IS ", A4, "."); +LIST SEGLS(IDNM,NXAVIL,T1); +LABEL LA, ENDWRAPUP; + LABEL QQQDISKDEFAULT; %503- + COMMENT FORMAT OF SEGMENT DICTIONARY -RUN TIME ; + SGTYPF= [1:2]#, %0 = PROGRAM SEGMENTS + SGTYPC= 1:46:2#,%1 = MCP INTRINSIC + %2 = DATA SEGMENT + PRTLINKF= [8:10]#, % LINK TO FIRT PRT ENTRY + PRTLINKC= 8:38:10#, + SGLCF = [18:15]#, % SEGMENT SIZE + SGLCC = 23:38:10#, + DKADRF = [33:15]#, % RELATIVE DISK ADDRESS OF SEGMENT + % OR MCP INTRINSIC NUMBER + DKADRC = 33:13:15#; + COMMENT FORMAT OF FIRST SEGMENT OF CODE FILE- RUN TIME; +COMMENT SEG0[0:29] + WORD CONTENTS + 0 LOCATION OF SEGMENT DICTIONARY + 1 SIZE OF SEGMENT DICTIONARY + 2 LOCATION OF PRT + 3 SIZE OF PRT + 4 LOCATION OF FILE PARAMETER BLOCK + 5 SIZE OF FILE PARAMETER BLOCK + 6 STARTING SEGMENT NUMBER + 7-[2:1] IND FORTRAN FAULT DEC + 7-[18:15] NUMBER OF FILES + 7-[33:15] CORE REQUIRED/64 + ; + COMMENT FORMAT OF PRT; + % FLGF = [0:4] = 1101 = SET BY STREAM +DEFINE MODEF =[4:2]#, % 0 = THUNK + MODEC=4:46:2#, % 1 = WORD MODE PROGRAM DESCRIPTOR + % 2 = LABEL DESCRIPTOR + % 3 = CHARACTER MODE PROGRAM DESCRIPTOR + STOPF =[6:1]#, % STOPPER = 1 FOR LAST DESCRIPTOR IN + STOPC=6:47:1#, % CHAIN OF SAME SEGMENT DESCRIPTORS + LINKF =[7:11]#, % IF STOP = 0 THEN PRTLINK + LINKC =[18:15]#,% ELSE LINK TO SEGDICT + FFF =18:33:15#, + SINX = [33:15]#;% RELATIVE ADDRESS INTO SEGMENT +DEFINE PDR = [37:5]#, + PDC = [42:6]#; +REAL STREAM PROCEDURE MKABS(F); + BEGIN + SI ~ F; MKABS ~ SI; + END MKABS; +REAL STREAM PROCEDURE BUILDFPB(DEST,FILNUM,FILTYP,MFID,FID,IDSZ, + IDNM,SPDEUN); + VALUE DEST,IDSZ,SPDEUN; + BEGIN + DI ~ DEST; + SI ~ FILNUM; SI ~ SI + 6; DS ~ 2 CHR; + SI ~ FILTYP; SI ~ SI + 7; DS ~ CHR; + SI ~ MFID; SI ~ SI + 1; DS ~ 7 CHR; + SI ~ FID; SI ~ SI + 1; DS ~ 7 CHR; + SI ~ LOC IDSZ; SI ~ SI + 1; DS ~ IDSZ CHR; + SI~LOC SPDEUN;SI~SI+6;DS~2 CHR;% DISK SPEED & EU NUMBER+1 + BUILDFPB ~ DI; + DS ~ 2 LIT "0"; + END BUILDFPB; +REAL STREAM PROCEDURE GITSZ(F); + BEGIN + SI ~ F; SI ~SI + 7; TALLY ~ 7; + 3(IF SC ! " " THEN JUMP OUT; + SI ~SI - 1; TALLY ~ TALLY + 63;); + GITSZ ~ TALLY; + END GITSZ; +STREAM PROCEDURE MOVE(F,T,SZ); VALUE SZ; + BEGIN + SI ~ F; DI ~T; DS ~ SZ WDS; + END MOVE; +INTEGER PROCEDURE MOVEANDBLOCK(FROM,SIZE); VALUE SIZE; + ARRAY FROM[0,0]; INTEGER SIZE; + BEGIN + REAL T,NSEGS,J,I; + STREAM PROCEDURE M2(F,T); BEGIN SI~F; DI~T; DS ~ 2 WDS; END M2; + NSEGS ~ (SIZE+29) DIV 30; + IF DALOC DIV CHUNK < T ~ (DALOC + NSEGS) DIV CHUNK + THEN DALOC ~ CHUNK | T; + MOVEANDBLOCK ~ DALOC; + DO BEGIN FOR J ~ 0 STEP 2 WHILE J < 30 AND I 0 THEN + BEGIN T1 ~ GET(T ~ GLOBALSEARCH(",SUBAR")+2); + PUT(T,T1~T1&SAVESUBS[TOSIZE]); + END; + T1~PRGDESCBLDR(1,23,0,NSEG~NXAVIL~NXAVIL+1) ; % BUILD TPAR + FILL LSTT[*] WITH 21(0),8(" ") ; % R+23 + WRITEDATA(29,NXAVIL,LSTT) ; + PDPRT[(PDINX-1).[37:5],(PDINX-1).[42:6]].[6:1]~1 ; % SAVE BIT + T1 ~ PRGDESCBLDR(1,22,0,NSEG ~ NXAVIL ~ NXAVIL + 1); + WRITEDATA (138,NXAVIL,TEN); % POWERS OF TEN TABLE + IF LSTI > 0 THEN + BEGIN + WRITEDATA(LSTI, NXAVIL ~ NXAVIL+1, LSTP); + LSTA ~ PRGDESCBLDR(1, LSTA, 0, NXAVIL); + END; + IF TWODPRTX ! 0 THEN + BEGIN + FILL LSTT[*] WITH + OCT0000000421410010, + OCT0301001301412025, + OCT2021010442215055, + OCT2245400320211025, + OCT0106177404310415, + OCT1025042112350000; + T ~ PRGDESCBLDR(0, TWODPRTX, 0, NXAVIL ~ NXAVIL+1); + WRITEDATA(-6, NXAVIL, LSTT); + END: + COMMENT DECLARE GLOBAL FILES AND ARRAYS; + FPS ~ FPE ~ MKABS(FPB); + SEGMENTSTART; + F2TOG ~ TRUE; + GSEG ~ NSFG; + FPBI ~ 0; + EMITL(0); EMITL(2); EMIT0(SSF); + EMITL(1); % SET BLOCK COUNTER TO 1 + EMITL(16); EMIT0(STD); + EMITL(0); EMIT0PDCLIT(23); EMIT0(DEL); + EMITL(REAL(HOLTOG)); EMITPAIR(21,STD); + I ~ GLOBALNEXTINFO; WHILE I < 4093 DO + BEGIN + I ~ I+3; + GFTALL(I,INFA,INFB,INFC); + IF INFA.CLASS = FILEID THEN %SEE COMMENTS ON LINE 02118000 %992- + BEGIN + FPBI ~ FPBI + 1; + PRI ~ INFA .ADDR; + IF (XTA ~ INFB ).[18:6] < 10 THEN + BEGIN + IF XTA ~ MAKEINT(XTA) > BIGGESTFILENB THEN FLAG(77) ELSE + FILES[XTA] ~ PRI; + IF XTA > THEBIGGEST THEN THEBIGGEST ~ XTA; + END; + EMIT0(MKS); + IF J ~ INFC .ADINFO ! 0 THEN % OPTION FILE + BEGIN FILTYP ~ INFC .LINK; + IDNM ~ " "&"FILE"[6:24:24]&INFB[30:18:18]; + T1 ~ GITSZ(IDNM); + FID ~ FILEINFO[2,J]; + MFID ~ FILEINFO[1,J]; + IF FILTYP}10 AND (T~FILEINFO[3,J].DKAREASZ)!0 THEN + BEGIN %%% SET UP ; + SPDEUN~FILEINFO[3,J].SENSPDEUNF; + B~IF (B~((J~FILEINFO[0,J]).[18:12])/(IF A~J.[30:12]{0 THEN + 1 ELSE A)){0 THEN 1 ELSE B ; + %%% B=ORIGINAL "BLOCKING" SIZE = # LOGRECS/PHYSREC. + A~ENTIER(B|ENTIER(T/(20|B)+.999999999)+.5) ; + %%% T="AREA" SIZE = # LOGRECS IN TOTAL FILE. + %%% A=# LOGRECS PER ROW. + B~ENTIER(T/A+.999999999) ; + %%% B = # ROWS IN FILE. + %%% EQUIVALENT ALGOL FILE DESCRIPTION = [B:A]. + %%% THE ABOVE LOGIC YIELDS: SHORTEST ROW CONTAINING + %%% AN INTEGER NUMBER OF PHYSICAL RECORDS AND WHICH + %%% REQUIRES 20 OR FEWER ROWS FOR THE TOTAL AREA, T. + EMITNUM(B); EMITNUM(A) ; + END ELSE + BEGIN EMITL(0); EMITL(0); + J ~ FILEINFO[0,J]; % THIS ONE HAS ALL THE GOODIES + END; + QQQDISKDEFAULT: %503- + ESTIMATE~ESTIMATE+(J.[42:6])|(IF A~J.[18:12]=0 THEN J.[30:12] + ELSE A) ; + EMITL(J.[4:2]); % LOCK + EMITL(FPBI); % FILE PARAM INDEX + EMITDESCLIT(PRI); % PRT OF FILE + EMITL(J.[42:6]); % # BUFFERS + EMITL(J.[3:1]); % RECORDING MODE + EMITNUM(J.[30:12]) ; % RECORD SIZE + EMITNUM(J.[18:12]) ; % BLOCK SIZE + EMITNUM(J.[ 6:12]) ; % SAVE FACTOR + END ELSE + BEGIN + ALF ~TRUE; + IF(FILTYP~INFC.LINK=2 OR FILTYP=12) AND INFB.[18:6]{9 THEN + IDNM ~ 0&"FILE"[6:24:24]&INFB[30:18:18] + ELSE + BEGIN + ALF ~ FALSE; + IF (IDNM ~ " "&INFB[6:18:30]) = "READR " THEN + IDNM ~ "READER "; + END; +IF IDNM="READER " OR IDNM="FILE5 " THEN IDNM~"CARD " ELSE %503- +IF IDNM="FILE6 " THEN BEGIN IDNM~"PRINTER";FILTYP~18;END ELSE %503- + BEGIN %503- + EMITL(20); EMITL(600); FILTYP~12; %20 | 600 REC DISK %503- + J~0&2[42:42:6]&10[30:36:12]&300[18:36:12]; %503- + FID~IDNM; MFID~"FORTEMP"; T1~GITSZ(IDNM); %503- + GO TO QQQDISKDEFAULT; %503- + END; %503- + T1 ~ GITSZ(IDNM); + FID ~ IDNM; + MFID ~ 0; + IF DCINPUT AND ALF THEN BEGIN + EMITL(20); % DISK ROWS + EMITL(100); % DISK RECORD PER ROW + EMITL(2); % REWIND AND LOCK + EMITL(FPBI); % FILE NUMBER + EMITDESCLIT(PRI); % PRT OF FILE + EMITL(2); % NUMBER OF BUFFERS + EMITL(1); % RECORDING MODE + EMITL(10); % RECORD SIZE + EMITL(30); % BLOCK SIZE + EMITL(1); % SAVE FACTOR + END ELSE + BEGIN + EMITL(0); % DISK ROWS + EMITL(0); % DISK RECORDS PER ROW + EMITL(0); % REWIND & RELEASE + EMITL(FPBI); % FILE NUMBER + EMITDESCLIT(PRI); % PRT OF FILE + EMITL(2); % 2 BUFFERS + EMITL(REAL(ALF)); + EMITL(IF FILTYP = 0 THEN 10 ELSE 17); + EMITL(0); % 15 WORD BUFFERS + EMITL(0); % SAVE FACTOR (SCRATCH BY DEFAULT) + END; + END; + EMITL(11); % INPUT OR OUTPUT + EMITL(8); % SWITCH CODE FOR BLOCK + EMIT0PDCLIT(5); % CALL BLOCK + FPE~BUILDFPB(FPE,FPBI,FILTYP,MFID,FID,T1,IDNM,SPDEUN); + IF PRTOG THE WRITALIST(FILEF,3,IDNM.[6:6],IDNM.B2D(PRI), + 0,0,0,0,0) ; + END + ELSE + IF INFA.CLASS = BLOCKID THEN + BEGIN + IF PRTOG THEN WRITALIST(BLOKF,3,INFB,B2D(INFA.ADDR), + INFC.SIZE,0,0,0,0,0) ; + IF INFA < 0 THEN ARRAYDEC(I); + END; + IF (T1 ~ INFA .CLASS) } FUNID + AND T1 { SUBRID THEN + BEGIN + PRI ~ 0; + IF INFA .SEGNO = 0 THEN + BEGIN + A~0; B~NUMINTM1 ; + WHILE A+1 < B DO + BEGIN + PRI ~ REAL(BOOLEAN(A+B) AND BOOLEAN(1022)); + IF IDNM ~ INT[PRI] = INFB THEN GO TO FOUND; + IF INFB < IDNM THEN B ~ PRI.[36:11] ELSE A ~ PRI.[36:11]; + END; + IF IDNM ~ INT[PRI~(A+B)|2-PRI] = INFB THEN GO TO FOUND; + XTA ~ INFB; FLAG(30); + GO TO LA; + FOUND: + IF (T1~INT[PRI+1].INTPARMS)!0 + AND INFC < 0 + THEN IF T1 ! INFC.NEXTRA THEN + BEGIN XTA ~ INFB ; FLAG(28); END; + IF (FIG~INTLOC[MFID~INT[PRI+1],INTNUM])=0 THEN + BEGIN + PDPRT[PDIR,PDIC] ~ + 0&1[STYPC] + &(FID ~ INTLOC[MFID] ~ NXAVIL ~ NXAVIL + 1)[SGNOC] + &1[SEGSZC]; + PDINX ~ PDINX + 1; + END; + T1 ~ PRGDESCBLDR(1,INFA .ADDR,0,FID); + IF PRTOG THEN WRITALIST(SEGUS,3,IDNM,FID,B2D(T1),0,0,0,0,0) ; + IF INT[PRI+1] < 0 THEN + BEGIN + T1 ~ PRGDESCBLDR(1,INT[PRI+1],INTPRT,0,FID); + INT[PRT+1] ~ ABS(INT[PRI + 1]); + END; + END + ELSE IF PRTOG THEN WRITALIST(SEGUS,3,INFB, + INFA,SEGNO,B2D(INFA.ADDR),0,0,0,0,0) ; + END; + LA: + END; +COMMENT MUST FOLLOW THE FOR STATEMENT; +IF FILEARRAYPRT ! 0 THEN +BEGIN % BUILDING OBJECT TIME FILE SEARCH ARRAY + J ~ PRGDESCBLDR(1,FILEARRAYPRT,0,NXAVIL ~ NXAVIL + 1); + WRITEDATA(THEBIGGEST + 1,NXAVIL,FILES); +END; + XTA ~ BLANKS; + IF NXAVIL > 1023 THEN FLAG(45); + IF PRTS > 1023 THEN FLAG(46); + IF STRTSEG = 0 THEN FLAG(65); + PRI ~ 0; + WHILE (IDNM ~ INT[PRI]) ! 0 DO + IF INT[PRI+1] } 0 THEN PRI ~ PRI + 2 ELSE + BEGIN + IF (FID~INTLOC[MFID~INT[PRI+1],INTNUM])=0 THEN + BEGIN + PDPRT[PDIR,PDIC] ~ + 0&1[STYPC] + &MFID[DKAC] + &(FID ~ INTLOC[MFID] ~ NXAVIL ~ NXAVIL + 1)[SGNOC] + &1[SEGSZC]; + PDINX ~ PDINX + 1; + END; + T1 ~ PRGDESCBLDR(1,INT[PRI + 1],INTPRT,0,FID); + PRI : PRI+2; + END; + FOR I ~ 1 STEP 1 UNTIL BDX DO + BEGIN EMIT0(MKS); EMIT0PDCLIT(BDPRT[I]) END; + EMIT0(MKS); + EMIT0PDCLIT(STRTSEG.[18:15]); + T ~ PRGDESCBLDR(1,0,0,NSEG); + SEGMENT((ADR+4) DIV 4,NSEG,FALSE,EDOC); + IF ERRORCT ! 0 THEN GO TO ENDWRAPUP; + FILL SEG0[*] WITH + OCT020005, % BLOCK + OCT220014, % WRITE + OCT230015, % READ + OCT240016; % FILE CONTROL + COMMENT INTRINSIC FUNCTIONS; + FOR I ~ 0 STEP 1 UNTIL 3 DO + BEGIN + T1 ~ PRGDESCBLDR(1,SEG0[I].[36:12],0, + NSEG ~ NXAVIL ~ NXAVIL + 1); + PDPRT[PDIR,PDIC] ~ + 0&1[STYPC] + &(SEG0[I].[30:6])[DKAC] + &NXAVIL[SGNOC] + &1[SEGSZC]; + PDINX ~ PDINX + 1; + END; + COMMENT GENERATE PRT AND SEGMENT DICTIONARY; + PRT[0,41] ~ PDPRT[0,0] & 63[10:42:6]; % USED FOR FAULT OPTN + FOR I ~ 1 STEP 1 UNTIL PDINX-1 DO + IF (T1~PDPRT[I.PDR,I.PDC]).SEGSZF = 0 THEN + BEGIN % PRT ENTRY + PRTADR ~T1.PRTAF; + SEGMNT ~T1.SGNOF; + LNK ~ SEGDICT[SEGMNT.[36:5], SEGMNT.[41:7]].PRTAF; + MDESC(T1,RELADF&SEGMNT[FFC] + &(REAL(LNK=0))[STOPC] + &(IF LNK=0 THEN SEGMNT ELSE LNK)[LINKC] + &(T1.DTYPF)[MODEC] + &5[1:45:3], + PRT[PRTADR.[36:5],PRTADR.[41:7]]); + SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]],PRTLINKF ~ PRTADR; + END + ELSE + BEGIN % SEGMENT DICTIONARY ENTRY + SEGMNT ~ T1.SGNOF; + SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]]~ + SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]] + &T1[SGLCC] + &T1[DKADRC] + & T1[4:12:1] + &T1[6:6:1] + &T1[1:1:2]; + TSEGSZ ~ TSEGSZ + T1.SEGSZF; + END; + COMMENT WRITE OUT FILE PARAMETER BLOCK; + FPBSZ ~ ((FPE.[33:15] - FPS) | 8 + FPE.[30:3] + 9) DIV 8; + I ~ (FPBSZ + 29) DIV 30; + IF DALOC DIV CHUNK < T1 ~ (DALOC +I) DIV CHUNK + THEN DALOC ~ CHUNK | T1; + SEG0[4] ~ DALOC; + SEG0[5] ~ FPBSZ; + SEG0[5].FPBVERSF~FPBVERSION; + FOR I ~ 0 STEP 30 WHILEI < FPBSZ DO + BEGIN + MOVE(FPB[I].CODE(9),IF (FPBSZ-I) } 30 + THEN 30 ELSE (FPBSZ-I)); + WRITE(CODE[DALOC]); + DALOC ~ DALOC + 1; + END; + SEG0[2] ~ MOVEANDBLOCK(PRT,PRTS+1); % WRITES OUT PRT + % SAVES ADDRESS OF PRT + SEG0[3] ~ PRTS + 1; % SIZE OF PRT + SEG0[0] ~ MOVEANDBLOCK(SEGDICT,NXAVIL + 1); % WRITE SEG DICT + SEG0[1] ~ NXAVIL + 1; % SIZE OF SEGMENT DICTIONARY + SEG0[6] ~ -GSEG; % FIRST SEGMENT TO EXECUTE + SEG0[7].[33:15] ~ FPBI; % NUMBER OF FILES + SEG0[7].[18:15] ~ ESTIMATE ~ IF % CORE ESTIMATE + ( I ~ + ESTIMATE+60+ %%% OPTION FILE BUFF SIZES + DEFAULT BUFF SIZES, + PRTS + 512 % PRT AND STACK SIZE + +TSEGSZ % TOTAL SIZE OF CODE + + 1022 % FOR INTRINSICS + +ARYSZ % TOTAL ARRAY SIZE + + (MAXFILES | 28) % SIZE OF ALL FIBS + +FPBSZ % SIZE OF FILE PARAMETER BLOCK + + (IF ESTIMATE = 0 THEN 0 ELSE (ESTIMATE + 1000)) + + (NXAVIL + 1) % SIZE OF SEGMENT DICTIONARY + ) > 32768 THEN 510 ELSE (I DIV 64); + COMMENT IF SEGSW THEN UPDATE LINDICT. SEG0[0] & WRITE IT ; + SEG0[7].[2:1] ~ 1; % USED FOR FORTRAN FAULT DEC; + IF SEGSW THEN + BEGIN + FOR I ~ NXAVIL + 1 STEP -1 UNTIL 1 DO + IF LINEDICT[I.IR,I.IC] = 0 THEN % INDICATE NO LINE SEGMENT + LINEDICT[I.IR,I.IC] ~ -1; % FOR THIS SEGMENT + SEG0[0] ~ SEG0[0] & (MOVEANDBLOCK(LINEDICT,NXAVIL+1))[TOBASE]; + END; + WRITE(CODE[0],30,SEG0[*]); + IF ERRORCT = 0 AND SAVETIME } 0 THEN LOCK(CODE); + ENDWRAPUP; + LOCK(TAPE); %RW/L TAPE FILE OR LOCK DISK %502- + IF NTAPTOG THEN LOCK(NEWTAPE,*); %RW/L TAPE OR CRUNCH DISK%502- + END WRAPUP; +PROCEDURE INITIALIZATION; +BEGIN COMMENT INITIALIZATION; +ALPHA STREAM PROCEDURE MKABS(P); +BEGIN SI ~ P; MKBAS ~ SI END; +STREAM PROCEDURE BLANKOUT(CRD, N); VALUE N; +BEGIN DI ~ CRD; N(DS ~ LIT " ") END; +BLANKOUT(CRD[10], 40); +BLANKOUT(LASTSEQ, 8); +BLANKOUT(LASTERR, 8); +INITIALNCR ~ MKABS(CRD[0]&6[30:45:3]; +CHR0 ~ MKABS(ACCUM[0])& 2[30:45:3]; +ACR0 ~ CHR0+1; +ACR1 :0 (CHR1~MKABS(EXACCUM[0]) & 2[30:45:4]) +1; +ACCUMSTOP~MKABS(ACCUM[11]); EXACCUMSTOP~MKABS(EXACCUM[11]) ; +BUFL ~ MKABS(BUFF) & 2[30:45:3]; +NEXTCARD ~ 1; +GLOBALNEXTINFO ~ 4093; +PDINX ~ 1; +LASTNEXT~1000 ; +PRTS ~ 41; % CURRENTLY . . . . . LAST USED PRT +READ(CR, 10, CB[*]); +LISTOG~TRUE; SINGLETOG~TRUE; CHECKTOG ~ FALSE; %DEFAULT %501- +FIRSTCALL ~ TRUE; +IF BOOLEAN(ERRORCT.[46:1]) THEN LISTOG ~ FALSE; +IF BOOLEAN(ERRORCT.[47:1]) THEN DCINPUT ~ TRUE; +ERROCT ~ 0; +IF DCINPUT THEN SEGSW ~ TRUE; +IF DCINPUT THEN REMOTETOG ~ TRUE; +LIMIT~IF DCINPUT THEN 20 ELSE 100 ; +IF SEGSW THEN SEGSWFIXED ~ TRUE; +EXTRAINFO[0,0] ~ 0 & EXPCLASS[TOCLASS]; +NEXTEXTRA ~ 1; +LASTMODE ~ 1; +DALOC ~ 1; +TYPE ~ -1; + MAP[0] ~ MAP[2] ~ MAP[4] ~ MAP[7] ~ -10; + MAP[5] ~ 1; MAP[6] ~ 2; +FILL XR[*] WITH 0,0,0,0,0,0,0, + "INTEGE","R R"," "," "," REAL "," ", + "LOGICA","L L","DOUBLE"," ","COMPLE","X X", + "------","- -"," "," "," ---- "," ", + "------","- -","------"," ","------","- -"; +FILL TYPES[*] WITH " ","INTGER"," ","REAL ", + "LOGCAL", "DOUBLE", "COMPLX"; +FILL KLASS[*] WITH + "NULL ", "ARRAY ", "VARBLE", "STFUN ", + "NAMLST", "FORMAT", "ERROR ", "FUNCTN", + "INTRSC", "EXTRNL", "SUBRTN", "COMBLK", + "FILE "; +FILL RESERVEDWORDSLP[*] WITH + "CALL ","ENTR ","FORM ","GOTO ","IF ","READ ", + "REAL ","WRIT ","DATA ","CLOS ","LOCK ","PURG ","CHAI ", + "PRIN ","PUNC ", + 0,"Y ","AT ",0,0,0,0,"E ",0,"E ",0,"E ", + "N ","T ","H "; +FILL RESERVEDWORDS[*] WITH + "ASSI ","BACK ","BLOC ","CALL ","COMM ","COMP ","CONT ", + "DATA ","DIME ","DOUB ","END ","ENDF ","ENTR ","EQUI ", + "EXTE ","FUNC ","GOTO ","INTE ","LOGI ","NAME ","PAUS ", + "PRIN ","PROG ","PUNC ","READ ","REAL ","RETU ","REWI ", + "STOP ","SUBR ","WRIT ", + "CLOS ","LOCK ","PURG ", + 0,0,0, + "FIXF ","VARY ","AUXM ","RELE ", + "IMPL ", + "GN ","SPACE ","KDATA ",0,"ON ","LEX ","INUE ", + "0,"NSION ","LEPRECIS",0,"ILE ","Y ","VALENCE ","RNAL " + ,"TION ",0,"GER ","CAL ","LIST ","E ","T ", + "RAM ","H ",0,0,"RN ","ND ",0,"OUTINE ", + "E ","E ",0,"E ",0,0,0,"D ","ING ", + "EM ","ASE " + ,"ICIT " + ; +FILL RESLENGTHLP[*] WITH + 4,5,6,4,2,4,4,5,4,5,4,5,5,5,5; +FILL LPGLOBAL[*] WITH + 4, 13, 36, 17, 35, 25, + 26, 31, 8, 32, 33, 34, 37, 22, 24; +FILL RESLENGTH[*] WITH + 0, 9, 9, 4, 6, + 7, 8, 4, 9, 15, + 3, 7, 5, 11, 8, + 8, 4, 7, 7, 8, + 5, 5, 7, 5, 4, + 4, 6, 6, 4, 10, 5, + 5, 4, 5, 0, 0, 0, 5, 7, 6, 7 + ,8 + ; + FILL WOP[*] WITH + "LITC"," ", + "OPDC","DESC", + 10,"DEL ", 11,"NOP ", 12,"XRT ", 16,"ADD ", 17,"AD2 ", 18,"PRL ", + 19,"LNG ", 21,"GEQ ", 22,"BBC ", 24,"INX ", 35,"LOR ", 37,"GTR ", + 38,"BFC ", 39,"RTN ", 40,"COC ", 48,"SUB ", 49,"SB2 ", 64,"MUL ", + 65,"ML2 ", 67,"LND ", 68,"STD ", 69,"NEQ ", 70,"SSN ", 71,"XIT ", + 72,"MKS ", + 128,"DIV ",129,"DV2 ",130,"COM ",131,"LQV ",132,"SND ",133,"XCH ", + 134,"CHS ",167,"RTS ",168,"CDC ",197,"FTC ",260,"LOD ",261,"DUP ", + 278,"GBC ",280,"SSF ",294,"GFC ",322,"ZP1 ",384,"IDV ",453,"FTF ", + 515,"MDS ",532,"ISD ",533,"LEQ ",534,"BBW ",548,"ISN ",549,"LSS ", + 550,"BFW ",581,"EQL ",582,"SSP ",584,"ECM ",709,"CTC ",790,"GBW ", + 806,"GFW ",896,"RDV ",965,"CTF ", + 1023,1023,1023,1023,1023,1023,1023,1023,1023,1023,1023, 1023; +FILL TIPE[*] WITH 10(-1),-19,-21,OCT300000000,-21,-2,-3,-4, + 8(OCT300000000),OCT100000000,-5,-13,-4,-6,-7,-19,-11, + 5(OCT100000000),-8,3(OCT300000000),-9,-10,-12,-13,-14, + -15,-100,-16,8(OCT300000000),-17,-6,-18,-19,-20,-21 ; +FILL PERIODWORD[*] WITH + "FALSE ", "TRUE ", "OR ", "AND ", "NOT ", + "LT ", "LE ", "EQ ", "GT ", "GE ", "NE "; +ACCUM[0] ~ EXACCUM[0] ~ "; "; +INCLUDE ~ "NCLUDE" & "I"[6:42:6]; +INSERTDEPTH ~ -1; +FILL TEN[*] WITH % POWERS OF TEN TO PRT 22 + OCT1141000000000000, OCT1131200000000000, OCT1121440000000000, + OCT1111750000000000, OCT1102342000000000, OCT1073032400000000, + OCT1063641100000000, OCT1054611320000000, OCT1045753604000000, + OCT1037346545000000, OCT1011240276200000, OCT0001351035564000, + OCT0011643245121000, OCT0022214116345200, OCT0032657142036440, + OCT0043432772446150, OCT0054341571157602, OCT0065432127413542, + OCT0076740555316473, OCT0111053071060221, OCT0121265707274265, + OCT0131543271153342, OCT0142074147406233, OCT0152513201307702, + OCT0163236041571663, OCT0174105452130240, OCT0205126764556310, + OCT0216354561711772, OCT0231004771627437, OCT0241206170175346, + OCT0251447626234640, OCT0261761573704010, OCT0272356132665012, + OCT0303051561442215, OCT0313664115752660, OCT0324641141345435, + OCT0336011371636744, OCT0347413670206535, OCT0361131664625026, + OCT0371360241772234, OCT0401654312370703, OCT0412227375067064, + OCT0422675274304701, OCT0433454553366061, OCT0444367706263475, + OCT0455465667740415, OCT0467003245730520, OCT0501060411731664, + OCT0511274514320241, OCT0521553637404312, OCT0532106607305374, + OCT0542530351166673, OCT0553256443424452, OCT0564132154331565, + OCT0575160607420123, OCT0606414751324147, OCT0621012014361120, + OCT0631214417455344, OCT0641457523370635, OCT0651773450267004, + OCT0662372362344605, OCT0673071057035747, OCT0703707272645341, + OCT0714671151416631, OCT0726047403722377, OCT0737461304707077, + OCT0751137556607071, OCT0761367512350710, OCT0771665435043072, + OCT0000000000000000, OCT0000000000000000, OCT0000000000000000, + OCT0000000000000000, OCT0000000000000000, OCT0000000000000000, + OCT0000000000000000, OCT0000000000000000, OCT0000000000000000, + OCT0000000000000000, OCT0000000000000000, OCT0000000000000000, + OCT0000000000000000, OCT0000000000000000, OCT0000000000000000, + OCT0000000000000000, OCT0000000000000000, OCT0004000000000000, + OCT0001000000000000, OCT0001720000000000, OCT0004304000000000, + OCT0007365000000000, OCT0005262200000000, OCT0004536640000000, + OCT0001666410000000, OCT0000244112000000, OCT0000315134400000, + OCT0000400363500000, OCT0000450046042000, OCT0006562057452400, + OCT0004316473365100, OCT0005402212262320, OCT0006702654747004, + OCT0004463430126605, OCT0007600336154346, OCT0001540425607437, + OCT0004070533151347, OCT0005106662003641, OCT0005033043640461, + OCT0002241654610575, OCT0002712227752734, OCT0001474675745524, + OCT0003447470573550, OCT0006361406732502, OCT0005005571052122, + OCT0006207127264547, OCT0001650755141700, OCT0006223150372260, + OCT0007670002470733, OCT0007646003207120, OCT0005617404050743, + OCT0001163305063137, OCT0007420166277771, OCT0001732422375777, + OCT0002321127075377, OCT0003005354714677, OCT0005606650100057, + OCT0007140422120072, OCT0003002526544103, OCT0001603254275130, + OCT0004144127354356, OCT0007175155247451, OCT0007034410521363, + OCT0007664351264566, OCT0003641443541723, OCT0004611754472310; +FILL INLINEINT[*] WITH % FILLS MUST BE IN ASCENDING ORDER FOR + % BINARY SEARCH IN FUNCTION AND DOITINLINE. + % INLINEINT[I].[1:1] = 1 ONCE CODE FOR INTRINSIC + % HAS BEEN EMITTED INLINE. + % INLINEINT[I].[2:10]=INDEX INTO 2-ND WORD OF THE + % CORR ENTRY IN INT. + % INLINEINT[I].[12:36]=NAME OF INTRINSIC. +%********FIRST FILL MUST BE NUMBER OF INTRINSICS ****************** +34, +"00ABS ", +"00AIMAG ", +"00AINT ", +"00AMAX0 ", +"00AMAX1 ", +"00AMIN0 ", +"00AMIN1 ", +"00AMOD ", +"00AND ", +"00CMPLX ", +"00COMPL ", +"00CONJG ", +"00DABS ", +"00DBLE ", +"00DIM ", +"00DSIGN ", +"00EQUIV ", +"00FLOAT ", +"00IABS ", +"00IDIM ", +"00IDINT ", +"00IFIX ", +"00INT ", +"00ISIGN ", +"00MAX0 ", +"00MAX1 ", +"00MIN0 ", +"00MIN1 ", +"00MOD ", +"00OR ", +"00REAL ", +"00SIGN ", +"00SNGL ", +"00TIME ", + 0 ; + FILL INT [*] WITH +COMMENT THESE NAMES (1-ST WORD OF EACH TWO-WORD ENTRY) MUST BE IN + ASCENDING ORDER FOR BINARY LOOKUPS. + THE SECONDO WORD HAS THE FOLLOWING FORMAT: + .[1:1] = 0 IF THE INTRINSIC DOES NOT HAVE A PERMANENT PRT + LOCATION, OTHERWISE = 1. MAY BE RESET BY + WRAPUP. SEE .[18:6] BELOW. + .[2:1] = .INTSEE = 1 IFF INTRINSICS FUNCTION HAS BEEN SEEN. + .[6:3] = .INTCLASS = CLASS OF THE INTRINSIC. + .[9:3] = .INTPARMCLASS = CLASS OF PARAMETERS. + .[12:6] = .INTINLINE = INDEX FOR DOITINLINE IF !0, OTHERWISE + DO IT VIA INTRINSIC CALL. + .[24:6] = .INTPRT = FIXED PRT LOCATION, SEE .[1:1] ABOVE. + .[30:6] = .INTPARMS = NUMBER OF PARAMETERS REQUIRED BY THE INT. + .[36:12] = .INTNUM = INTRINSICS NUMBER. + THE FIELDS .[3:3] AND .[18:6] ARE SO FAR UNUSED. +; +% +%*********************************************************************** +%********* IF YOU ADD AN INTRINSIC, BE SURE TO CHANGE NUMINTM1 ******* +%********* AT SEQUENCE NUMBER 00155211.......THANK YOU. ******* +%*********************************************************************** +% +"ABS ", OCT0033010000010007, +"AIMAG ", OCT0036020000010074, +"AINT ", OCT0033030000010054, +"ALGAMA", OCT0033000000010127, +"ALOG10", OCT0033000000010103, +"ALOG ", OCT2033000035010017, +"AMAX0 ", OCT0031250000000031, +"AMAX1 ", OCT0033250000000031, +"AMIN0 ", OCT0031250000000032, +"AMIN1 ", OCT0033250000000032, +"AMOD ", OCT0033040000020063, +"AND ", OCT0033050000020130, +"ARCOS ", OCT0033000000010117, +"ARSIN ", OCT2032000032010116, +"ATAN2 ", OCT2033000044020114, +"ATAN ", OCT2033000037010016, +"CABS ", OCT2036000045010053, +"CCOS ", OCT0066000000010110, +"CEXP ", OCT0066000000010100, +"CLOG ", OCT0066000000010102, +"CMPLX ", OCT0063060000020075, +"COMPL ", OCT0033070000010132, +"CONCAT", OCT0033000000050140, +"CONJG ", OCT0066110000010076, +"COSH ", OCT0033000000010121, +"COS ", OCT0033000000010015, +"COTAN ", OCT0033000000010112, +"CSIN ", OCT0066000000010106, +"CSQRT ", OCT0066000000010124, +"DABS ", OCT0055010000010052, +"DATAN2", OCT0055000000020115, +"DATAN ", OCT2055000041010113, +"DBLE ", OCT0053120000010062, +"DCOS ", OCT0055000000010107, +"DEXP ", OCT2055000047010077, +"DIM ", OCT0033100000020072, +"DLOG10", OCT0055000000010104, +"DLOG ", OCT2055000042010101, +"DMAX1 ", OCT0055000000000066, +"DMIN1 ", OCT0055000000000067, +"DMOD ", OCT2055000046020065, +"DSIGN ", OCT0055130000020071, +"DSIN ", OCT2055000043010105, +"DSQRT ", OCT2055000050010123, +"EQUIV ", OCT0033140000020133, +"ERF ", OCT0033000000010125, +"EXP ", OCT2033000033010020, +"FLOAT ", OCT0031150000010060, +"GAMMA ", OCT2033000040010126, +"IABS ", OCT0011010000010007, +"IDIM ", OCT0011100000020072, +"IDINT ", OCT0015240000010057, +"IFIX ", OCT0013030000010054, +"INT ", OCT0013030000010054, +"ISIGN ", OCT0011160000020070, +".ERR. ", OCT2000000030000134, +".FNINB", OCT0000000000000160, +".FINAM", OCT0000000000000154, +".FONAM", OCT0000000000000155, +".FREFR", OCT0000000000000146, +".FREWR", OCT0000000000000153, +".FTINT", OCT0000000000000050, +".FTNIN", OCT0000000000000156, +".FTNOU", OCT0000000000000157, +".FTOUT", OCT0000000000000051, +".LABEL", OCT0000000000000021, +".MATH ", OCT0000000000000055, +".MEMHR", OCT0000000000000164, +".XTOI ", OCT0000000000000056, +"MAX0 ", OCT0011250000000135, +"MAX1 ", OCT0013250000000135, +"MIN0 ", OCT0011250000000136, +"MIN1 ", OCT0013250000000136, +"MOD ", OCT0011170000020137, +"OR ", OCT0033200000020131, +"REAL ", OCT0036210000010073, +"SIGN ", OCT0033160000020070, +"SINH ", OCT0033000000010120, +"SIN ", OCT2033000034010014, +"SNGL ", OCT0035230000010061, +"SQRT ", OCT2033000031010013, +"TANH ", OCT0033000000010122, +"TAN ", OCT2033000036010111, +"TIME ", OCT0031220000010064, + 0; +BLANKS~INLINEINT[MAX~0] ; +FOR SCN~1 STEP 1 UNTIL BLANKS DO + BEGIN + EQVID~INLINEINT[SCN]; WHILE INT[MAX]!EQVID DO MAX~MAX+2 ; + INLINEINT[SCN].INTX~MAX+1 ; + END ; +INTID.SUBCLASS ~ INTYPE; +REALID.SUBCLASS ~ REALTYPE; +EQVID ~ ".EQ000"; +LISTID ~ ".LI000"; +BLANKS ~ " "; +ENDSEGTOG ~ TRUE; +SCN ~ 7; +MAX ~ REAL(NOT FALSE).[9:39]; +SUPERMAXCOM~128|(MAXCOM+1) ; +SEGPTOG ~ FALSE; %INHIBIT PAGE SKIP AFTER SUBROUTINES %501- +END INITIALIZATION; + +ALPHA PROCEDURE NEED(T, C); VALUE T, C; ALPHA T, C; +BEGIN INTEGER N; REAL ELBAT; + REAL X; + LABEL XIT, CHECK; + ALPHA INFA, INFB, INFC; +COMMENT NEED RETURNS THE ELBAT WORD FOR THE IDENTIFIER T. +IF THIS IS THE FIRST OCCURENCE OF T THEN AN INFO WORD IS BUILD AND +GIVEN THEN CLASS C; + ELBAT.CLASS ~ C; + XTA ~ T; + IF C { LABELID THEN + BEGIN + IF N ~ SEARCH(T) = 0 THEN N ~ ENTER(ELBAT, T) ELSE + IF ELBAT ~ GET(N).CLASS = UNKNOWN + THEN PUT(N,GET(N)&C[TOCLASS]) + ELSE IF ELBAT ! C THE FLOG(21); + GO TO XIT; + END; + IF N ~ SEARCH(T) = 0 THEN + BEGIN + IF N ~ GLOBALSEARCH(T) ! 0 THEN GO TO CHECK; + N ~ GLOBALENTER(ELBAT, T); + GO TO XIT; + END; + GETALL(N,INFA,INFB,INFC); + IF INFA.CLASS = DUMMY THEN BEGIN N ~ INFC.BASE; GO TO CHECK END; + IF BOOLEAN(INFA. FORMAL) THEN GO TO CHECK; + IF INFA.CLASS ! UNKNOWN THEN + BEGIN + IF N ~ GLOBALSEARCH(T) ! 0 THEN GO TO CHECK; + ELBAT.SUBCLASS ~ INFA.SUBCLASS; + N ~ GLOBALENTER(ELBAT, T); + GO TO XIT; + END; + PUT(N, INFA & DUMMY[TOCLASS]); + ELBAT.SUBCLASS ~ INFA .SUBCLASS; + IF X ~ GLOBALSEARCH(T) = 0 THEN X ~ GLOBALENTER(ELBAT, T); + PUT(N+2, INFC & X[TOBASE]); N ~ X; + CHECK: + INFA ~ GET(N); + IF ELBAT ~ INFA .CLASS = UNKNOWN THEN + BEGIN INFC[N.IR,N.IC].CLASS ~ C; GO TO XIT END; + IF ELBAT ! C THEN + IF ELBAT = EXTID AND + (C = SUBRID OR C = FUNID) THEN + INFC[N.IR,N.IC].CLASS ~ C + ELSE IF (ELBAT=SUBRID OR ELBAT= FUNID) AND C = EXTID THEN + ELSE FLOG(21); + XIT: NEED ~ GETSPACE(N); + XTA ~ NAME; % RESTORE XTA FOR DIAGNOSTIC PURPOSES +END NEED; + +INTEGER PROCEDURE EXPR(B); VALUE B; BOOLEAN B; FORWARD; + +PROCEDURE SPLIT(A); VALUE A; REAL A; +BEGIN + EMITPAIR(JUNK, ISN); + EMITD(40, DIA); + EMITD(18, ISO); + EMITDESCLIT(A); + EMIT0(LOD); + EMIT0PDCLIT(JUNK); + EMITPAIR(255,CHS); + EMIT0(LND); +END SPLIT; +BOOLEAN PROCEDURE SUBSCRIPTS(LINK,FROM); VALUE LINK,FROM; +INTEGER LINK, FROM; +BEGIN INTEGER I, NSUBS, BDLINK; + LABEL CONSTRUCT, XIT; +REAL SUM, PROD, BOUND; +REAL INFA,INFB,INFC; +REAL SAVENSEG,SAVEADR ; +INTEGER INDX; +REAL INFD; +BOOLEAN TOG, VARF; +REAL SAVIT; +DEFINE SS = LSTT#; +IF DEBUGTOG THEN FLAGROUTINE(" SUBSC","RIPTS ",TRUE ) ; + SAVIT ~ IT; + LINK ~ GETSPACE(LINK); +GETALL(LINK,INFA,INFB,INFC); + IF INFA.CLASS ! ARRAYID THEN + BEGIN XTA ~ INFB; FLOG(35); GO TO XIT END; + NSUBS ~ INFC.NEXTRA; + IF FROM = 4 THEN + BEGIN IF NSUBS GTR SAVESUBS THEN SAVESUBS ~ NSUBS; + IF NSUBS GTR NAMLIST[0] THEN NAMLIST[0] ~ NSUBS; + NAMLIST[NAMEIND].[1:8] ~ NSUBS; + INFD ~ GET(NEED(".SUBAR",BLOCKID)).ADDR; + END; + BDLINK ~ INFC.ADINFO-NSUBS+1; + VARF ~ INFC < 0; + FOR I ~ 1 STEP 1 UNTIL NSUBS DO + BEGIN + IT~IT+1; SAVENSEG~NSEG; SAVEADR~ADR ; + IF EXPR(TRUE) > REALTYPE THEN FLAG(98); + IF ADR=SAVEADR THEN FLAG(36) ; + IF VARF THEN + IF EXPRESULT=NUMCLASS AND NSEG=SAVENSEG THEN + BEGIN + ADR~SAVEADR ; + EMITNUM(EXPVALUE-1); + END ELSE EMITPAIR(1, SUB) + ELSE + IF EXPRESULT=NUMCLASS AND NSEG = SAVENSEG AND FROM NEQ 4 THEN + BEGIN + ADR~SAVEADR; IF SS[IT]~EXPVALUE{0 THEN FLAG(154) ; + END + ELSE SS[IT] ~ @9; + IF FROM = 4 THEN + BEGIN IF VARF THEN BEGIN EMIT0(DUP); EMITPAIR(1,ADD); END; + EMITL(INDX); INDX ~ INDX+1; + EMITDESCLIT(INFD); + EMIT0(IF VARF THEN STD ELSE STN); + END; + IF I < NSUBS THEN + BEGIN + IF GLOBALNEXT ! COMMA THEN + BEGIN XTA ~ INFB; FLOG(23) END; + SCAN; + END; + END; + IF GLOBALNEXT ! RPAREN THEN BEGIN XTA ~ INFB; FLOG(24); END + ELSE IF FROM < 2 THEN + BEGIN SCAN; IF PREC > 0 THEN FROM ~ 1; END; + SUM ~ 0; + TOG ~ VARF; + IF VARF THEN + FOR I ~ NSUBS-1 STEP -1 UNTIL 1 DO + BEGIN + IF BOUND ~ EXTRAINFO[(BDLINK~BDLINK+1).IR,BDLINK.IC] < 0 THEN + EMIT0PDCLIT(BOUND) ELSE EMITNUM(BOUND); + EMIT0(MUL); + EMIT0(ADD); + END + ELSE + FOR I ~ NSUBS STEP -1 UNTIL 1 DO + BEGIN + IF I = 1 THEN BOUND ~ 1 ELSE + BOUND ~ EXTRAINFO[(BDLINK~BDLINK+1).IR,BDLINK.IC]; + IF T ~ SS[SAVIT+I] < @9 THEN + BEGIN + SUM ~ (SUM+T-1)|BOUND; + IF TOG THEN PROD ~ PROD|BOUND; + END + ELSE + BEGIN + IF TOG THEN BEGIN EMITNUM(PROD); EMIT0(MUL); EMIT0(ADD) END + ELSE TOG ~ TRUE; + PROD ~ BOUND; + SUM ~ (SUM-1)|BOUND; + END; + END; + IF VARF THEN T ~ @9; + IF INFA.SUBCLASS } DOUBTYPE THEN + BEGIN + IF TOG THEN + BEGIN + IF T < @9 THEN EMITNUM(2|PROD) ELSE EMITL(2); + EMIT0(MUL); + END; + SUM ~ SUM|2; + END ELSE + IF T < @9 AND TOG THEN BEGIN EMITNUM(PROD); EMIT0(MUL) END; + IF BOOLEAN(INFA.CE) THEN + SUM ~ SUM + INFC.BASE ELSE + IF BOOLEAN(INFA.FORMAL) THEN + BEGIN EMIT0PDCLIT(INFA.ADDR-1); + IF TOG THEN EMIT0(ADD) ELSE TOG ~ TRUE; + END; + IF BOOLEAN(INFA.TWOD) AND FROM > 0 THEN + BEGIN + IF SUM = 0 THEN + IF TOG THEN ELSE + BEGIN + EMITL(0); + EMITDESCLIT(INFA.ADDR); + EMIT0(LOD); + EMITL(0); + GO TO CONSTRUCT; + END + ELSE + IF TOG THEN + BEGIN + EMITNUM(ABS(SUM)); + IF SUM < 0 THEN EMIT0(SUB) ELSE EMIT0(ADD); + END ELSE + BEGIN + EMITL(SUM.[33:7]); + EMITDESCLIT(INFA.ADDR); + EMIT0(LOD); + EMITL(SUM.[40:8]); + GO TO CONSTRUCT; + END; + SPLIT(INFA.ADDR); + CONSTRUCT: + IF BOOLEAN(FROM) THEN + BEGIN + IF INFA.SUBCLASS } DOUBTYPE THEN + BEGIN + EMIT0(CDC); + EMIT0(DUP); + EMITPAIR(1, XCH); + EMIT0(INX); + EMIT0(LOD); + EMIT0(XCH); + EMIT0(LOD); + END ELSE EMIT0(COC); + END ELSE + BEGIN + IF SUM = 0 THEN IF NOT TOG THEN EMITL(0) ELSE + ELSE + BEGIN + IF TOG THEN + BEGIN + EMITNUM(ABS(SUM)); + IF SUM < 0 THEN EMIT0(SUB) ELSE EMIT0(ADD); + END + ELSE EMITNUM(SUM); + END; + IF FROM > 0 THEN + IF BOOLEAN (FROM) THEN + IF INFA.SUBCLASS } DOUBTYPE THEN + BEGIN + EMITDESCLIT(INFA.ADDR); + EMIT0(DUP); + EMITPAIR(1,XCH); + EMIT0(INX); + EMIT0(LOD); + EMIT0(XCH); + EMIT0(LOD); + END ELSE EMITV(LINK) ELSE + BEGIN DESCREQ ~ TRUE; EMITN(LINK); DESCREQ ~ FALSE END; + END; + XIT: + IT ~ SAVIT; + SUBSCRIPTS ~ BOOLEAN(FROM); + IF DEBUGTOG THEN FLAGROUTINE(" SUBSC","RIPTS ",FALSE) ; + END SUBSCRIPTS; + +BOOLEAN PROCEDURE BOUNDS(LINK); VALUE LINK; REAL LINK; +BEGIN + COMMENT CALLED TO PROCESS ARRAY BOUNDS; + BOOLEAN VARF, SINGLETOG; %109- + DEFINE FNEW = LINK#; + REAL T, NSUBS, INFA, INFB, INFC, FIRSTSS; + LABEL LOOP; +IF DEBUGTOG THEN FLAGROUTINE(" BOU","NDS ",TRUE ); + GETALL(FNEW, INFA, INFB, INFC); + FIRSTSS ~ NEXTSS; + IF LINK < 0 THEN BEGIN SINGLETOG ~ TRUE; LINK ~ ABS(LINK) END; %109- + LOOP: + IF NEXT = ID THEN + BEGIN + T ~ GET(FNEXT ~ GETSPACE(FNEXT)); + IF T.CLASS ! VARID OR NOT BOOLEAN(T.FORMAL) THEN FLAG(92) ELSE + IT T.SUBCLASS > REALTYPE THEN FLAG(93); + T ~ -T.ADDR; + VARF ~ TRUE; + END ELSE + IF NEXT = NUM THEN + BEGIN + IF NUMTYPE!INTYPE THEN FLAG(113); + IF T~FNEXT=0 THEN FLAG(122) ; + IF NOT VARF THEN IF NSUBS = 0 THEN LENGTH ~ FNEXT ELSE + LENGTH ~ LENGTH|FNEXT; + END ELSE FLOG(122); + EXTRAINFO[NEXTSS.IR,NEXTSS.IC] ~ T; + NEXTSS ~ NEXTSS-1; + NSUBS ~ NSUBS+1; + SCAN; + IF NEXT = COMMA THEN BEGIN SCAN; GO TO LOOP END; + IF NEXT ! RPAREN THEN FLOG(94); + XTA ~ INFB; + IF INFA.CLASS = ARRAYID THEN FLAG(95); + INFA.CLASS = ARRAYID; + IF VARF THEN + BEGIN + IF NOT BOOLEAN(INFA.FORMAL) THEN FLAG(96); + IF NSUBS > 1 OR INFA .SUBCLASS } DOUBTYPE THEN + BEGIN BUMPLOCALS;LENGTH~LOCALS + 1536;BOUNDS~TRUE END ELSE + LENGTH ~-EXTRAINFO[FIRSTSS.IR,FIRSTSS.IC]; + END ELSE + IF NOT SINGLETOG AND INFA.SUBCLASS > LOGTYPE THEN %109- + BEGIN LENGTH ~ 2 | LENGTH; BOUNDS ~ TRUE END; %109- + IF LENGTH > 32767 THEN FLAG(99); + INFC ~ LENGTH & NSUBS[TONEXTRA] & FIRSTSS[TOADINFO]; + IF VARF THEN INFC ~ -INFC; + PUT(FNEW, INFA); PUT(FNEW+2, INFC); + SCAN; +IF DEBUTOG THEN FLAGROUTINE(" BOU","NDS ",FALSE) ; +END BOUNDS; + +PROCEDURE PARAMETERS(LINK); VALUE LINK; REAL LINK; +BEGIN + LABEL LOOP; + REAL NPARMS, EX, INFC, PTYPE; + ALPHA EXPNAME; + BOOLEAN CHECK, INTFID; + BOOLEAN NOTZEROP; + REAL SAVIT; + DEFINE PARMTYPE = LSTT#; + SAVIT ~ IT ~ IT+1; +IF DEBUGTOG THEN FLAGROUTINE(" PARAM","ETERS ",TRUE ) ; + INFC ~ GET(LINK+2); + IF CHECK ~ BOOLEAN(INFC.[1:1]) THEN + BEGIN + EX ~ INFC.ADINFO; + NOTZEROP ~ INFC.NEXTRA ! 0; + INTFID ~ INFC.[36:12] = 1; + END; + LOOP: + BEGIN SCAN; + EXPNAME ~ NAME; + IF GLOBALNEXT = 0 AND NAME = "$ " THEN + BEGIN EXPRESULT ~ LABELID; SCAN; + IF GLOBALNEXT ! NUM THEN FLAG(44); + EMITLABELDESC(NAME); + PTYPE ~ 0; + SCAN; + END + ELSE PTYPE ~ EXPR(CHECK AND EXTRAINFO[EX.IR,EX.IC].CLASS + = EXPCLASS AND INTFID); + IF EXPRESULT = NUMCLASS THEN + IF PTYPE = STRINGTYPE THEN + BEGIN + ADR ~ ADR - 1; + PTYPE ~ INTYPE; + EXPRESULT ~ SUBSVAR; + IF STRINGSIZE = 1 AND + (T ~ EXTRAINFO[EX.IR,EX.IC].CLASS = VARID OR + T = EXPCLASS) THEN + BEGIN + EXPRESULT ~ EXPCLASS; + EMITNUM(STRINGARRAY[0]); + END ELSE + BEGIN + EXPRESULT~ARRAYID; + EMITPARI(PRGDESCBLDR(1,0,0,NXAVIL~NXAVIL+1), LOD); + EMITL(0); + WRITEDATA(STRINGSIZE, NXAVIL, STRINGARRAY); + END; + END ELSE EXPRESULT ~ EXPCLASS; + PARMTYPE[IT] ~ 0 & EXPRESULT[TOCLASS] & PTYPE[TOSUBCL]; + XTA ~ EXPNAME; + IF TSSEDITOG THEN IF (EXPRESULT=FUNID OR EXPRESULT=SUBRID OR + EXPRESULT=EXTID) AND NOT DCINPUT THEN TSSED(XTA,2); + IF DCINPUT THEN IF EXPRESULT=FUNID OR EXPRESULT=SUBRID + OR EXPRESULT=EXTID THEN FLAG(151) ; + IF CHECK THEN + BEGIN + IF T ~ EXTRAINFO[EX.IR,EX.IC].CLASS ! EXPRESULT THEN + CASE T OF + BEGIN + EXTRAINFO[EX.IR,EX.IC] ~ 0 & EXPRESULT[TOCLASS] + & PTYPE[TOSUBCL]; + IF EXPRESULT ! SUBSVAR THEN FLAG(66); + IF EXPRESULT = SUBSVAR THEN + BEGIN EMIT0(CDC); + IF PTYPE } DOUBTYPE THEN EMITL(0); + END ELSE + ELSE + IF EXPRESULT = EXPCLASS THEN + BEGIN IF PTYPE } DOUBTYPE THEN EMIT0(XCH); + EXTRAINFO[EX.IR,EX.IC].CLASS ~ EXPCLASS + END ELSE FLAG(67); + ; ; ; + FLAG(68); + IF EXPRESULT = EXTID THEN + PUT(EXPLINK,GET(EXPLINK)&FUNID[TOCLASS]) ELSE + FLAG(69); + ; + IF EXPRESULT = FUNID OR EXPRESULT = SUBRID THEN + EXTRAINFO[EX.IR,EX.IC] ~ EXPRESULT ELSE FLAG(70); + IF EXPRESULT = EXTID THEN + PUT(EXPLINK.GET(EXPLINK)&SUBRID[TOCLASS]) ELSE + FLAG(71); + ; ; + IF EXPRESULT = ARRAYID THEN EXTRAINFO[EX.IR,EX.IC].CLASS + ~ ARRAYID ELSE + IF EXPRESULT = VARID THEN + BEGIN + EXTRAINFO[EX.IR,EX.IC].CLASS ~ SBVEXP; + EMITL(0) + END ELSE + IF EXPRESULT = EXPCLASS THEN + BEGIN + EXTRAINFO[EX.IR,EX.IC].CLASS ~ SBVEXP; + IF PTYPE } DOUBTYPE THEN EMIT0(XCH) ELSE EMITL(0); + END ELSE FLAG(72); + IF EXPRESULT = SUBSVAR THEN + IF NOT INTFID THEN + BEGIN EMIT0(CDC); + IF PTYPE } DOUBTYPE THEN EMITL(0) + END + ELSE + ELSE IF EXPRESULT = VARID THEN + IF NOT INTFID THEN + IF PTYPE } DOUBTYPE THEN EMITL(0) ELSE ELSE + ELSE FLAG(67); + IF EXPRESULT = VARID THEN + EMITL(0) ELSE + IF EXPRESULT = EXPCLASS THEN + IF PTYPE } DOUBTYPE THEN EMIT0(XCH) ELSE EMITL(0) + ELSE IF EXPRESULT ! SUBSVAR THEN FLAG(67); + END OF CASE STATEMENT + ELSE IF PTYPE } DOUBTYPE THEN + IF EXPRESULT = VARID THEN EMITL(0) + ELSE IF EXPRESULT = EXPCLASS AND NOT INTFID + THEN EMIT0(XCH); + IF T ~ EXTRAINFO[EX.IR,EX.IC].SUBCLASS = 0 OR + (T = INTYPE AND PTYPE = REALTYPE AND + GET(LINK).SEGNO = 0) THEN + EXTRAINFO[EX.IR,EX.IC].SUBCLASS ~ PTYPE ELSE + IF NOT(T = PTYPE OR T = REALTYPE AND PTYPE = INTYPE ) THEN + FLAG(88); + END OF CHECK + ELSE IF PTYPE } DOUBTYPE THEN + IF EXPRESULT = VARID THEN EMITL(0) + ELSE IF EXPRESULT = EXPCLASS THEN EMIT0(XCH); + IF NOTZEROP THEN EX ~ EX+1; + IT ~ IT+1; + END; + IF GLOBALNEXT = COMMA THEN GO TO LOOP; + NPARMS ~ IT - SAVIT; + IF GLOBALNEXT ! RPAREN THEN FLOG(108); + IF NOT CHECK THEN + BEGIN + INFC ~ GET(LINK+2); + INFC ~ -(INFC & NPARMS[TONEXTRA] + & NEXTEXTRA[TOADINFO]); + PUT(LINK+2,INFC); + FOR I ~ SAVIT STEP 1 UNTIL IT-1 DO + BEGIN + EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ PARMTYPE[I]; + NEXTEXTRA ~ NEXTEXTRA+1; + END; + END + ELSE + IF T ~ GET(LINK+2).NEXTRA > 0 AND T ! NPARMS OR + T=0 AND INTFID AND NPARMS < 2 OR + T = 0 AND NOT INTFID THEN + BEGIN XTA ~ GET(LINK+1); FLAG(28) END; +IF DEBUGTOG THEN FLAGROUTINE(" PARAM","ETERS ",FALSE) ; + IT ~ SAVIT-1; +END PARAMETERS; + +PROCEDURE STMTFUNREF(LINK); VALUE LINK; REAL LINK; +BEGIN + REAL I, PARMLINK, NPARMS, SEG; +IF DEBUGTOG THEN FLAGROUTINE(" STMTF","UNREF ",TRUE); + PARMLINK ~ GET(LINK+2).[36:12]; + DO + BEGIN + SCAN; + IF A~EXPR(TRUE) ! B~GET(PARMLINK).SUBCLASS THEN + IF A > REALTYPE OR B > REALTYPE THE %108- + BEGIN XTA ~ NNEW; FLAG(88) END; + PARMLINK ~ PARMLINK-3; + NPARMS ~ NPARMS+1; + END UNTIL NEXT ! COMMA; + IF NEXT ! RPAREN THEN FLAG(108); + SCAN; + GETALL(LINK, INFA, XTA, INFC); + IF NPARMS ! INFC.NEXTRA THEN FLAG(28); + SEG ~ INFA.SEGNO; + BRANCHLIT(INFC.BASE&SEG[TOSEGNO],FALSE); + EMITB(INFA.ADDR & SEG[TOSEGNO], FALSE); + ADJUST; + IF DEBUTOG THEN FLAGROUTINE(" STMTF","UNREF ",FALSE); + END STMTFUNREF; + + BOOLEAN PROCEDURE DOITINLINE(LNK); VALUE LNK; REAL LNK ; + BEGIN + REAL C,I,C1,C2,C3,C4,C5 ; + LABEL HUNT,FOUND,XIT,AIMAG,AINT,CMPLX,LOOP,DDT111,SNGL ; + DEFINE OPTYPE=LSTT#, E0=EMIT0#, EP=EMITPAIR#, E0L=EMIT0PDCLIT# ; + IF DEBUGTOG THEN FLAGROUTINE("DOITIN","LINE ",TRUE); + C1~1; C2~INLINEINT[0]; C3~GET(ABS(LNK)+1) ; + HUNT: + IF (C~INLINEINT[I~(C1+C2).[36:11]].INAM)C3 THEN C2~I-1 ELSE GO FOUND ; + IF C10 THEN INLINEINT[I]~-C4; I~0 ; + IF XREF THEN ENTERX(C3,0&FUNID[TOCLASS]&C[21:6:3]); + IF GLOBALNEXT!LPAREN THEN BEGIN FLOG(106); GO XIT END ; + LOOP: SCAN; C5~XTA ; + IF I=0 THEN + IF LNK=10 THEN EMIL(0) ELSE IF LNK=21 THEN EMITDESCLIT(2) ; + IF (C4~EXPR(TRUE))!C1 AND (C1!REALTYPE OR C4!INTYPE) THEN + BEGIN XTA~C5; FLAG(88); C2~-2 END ; + I~I+1; IF GLOBALNEXT=COMMA THEN GO LOOP ; + IF GLOBALNEXT!RPAREN THEN BEGIN FLOG(108); C2~-2 END; SCAN ; + IF I!C.INTPARMS THEN IF C.INTPARMS!0 OR I<2 THEN + BEGIN XTA~C3; FLAG(28); C2~-2 END ; + OPTYPE[IT]~C.INTCLASS; IF C2<0 THEN GO XIT ; + CASE (LNK-1) OF + BEGIN + E0(SSP) ; % @1: ABS, DABS, IABS. + AIMAG: E0(DEL) ; % @2: AIMAG. + AINT: EP(1,IDV) ; % @3: AINT, IFIX, INT. + E0(RDV) ; % @4: AMOD. + E0(LND) ; % @5: LOGICAL AND. + CMPLX: E0(XCH) ; % @6: CMPLX. + E0(LNG) ; % @7: LOGICAL COMPLIMENT (NEGATION). + BEGIN % @10: DIM, IDIM. + E0(SUB); E0(DUP); EP(0,LESS) ; + IF ADR>4082 THEN BEGIN ADR~ADR+1; SEGOVF END ; + EP(2,BFC); E0(DEL); EMITL(0) ; + END ; + BEGIN E0(XCH); E0(CHS); GO CMPLX END ; % @11: CONJG. + ; % @12: DBLE (SOME CODE ALREADY EMITTED ABOVE). + BEGIN E0(XCH); E0(DEL) ; % @13: DSIGN. + DDT111: EMITDDT(1,1,1) ; + END; + E0(LQV) ; % @14: LOGICAL EQUIVALENCE. + ; % @15: FLOAT. + GO DDT111 ; % @16: ISIGN, SIGN. + BEGIN E0(RDV); GO AINT END ; % @17: MOD. + E0(LOR) ; % @20: LOGICAL OR. + BEGIN E0(XCH); GO AIMAG END ; % @21: REAL. + EP(1,KOM) ; % @22: TIME. + BEGIN % @23: SNGL. + SNGL: EP(9,SND); E0(XCH); EMITDDT(47,9,1); EMITL(0) ; + EMITDDT(9,9,38); E0L(9); EMIT0(ADD); IF LNK=20 THEN GO AINT ; + END ; + GO SNGL ; % @24: IDINT. + + BEGIN % @25: AMAX0,AMAX1,AMIN0,AMIN1,MAX0,MAX1,MIN0,MIN1. + % SOME CODE ALREADY EMITTED ABOVE. + IF ADR>4068 THEN BEGIN ADR~ADR+1; SEGOVF END ; + EP(9,STD); E0(DUP); E0L(9) ; + E0(IF C3.[24:6]="A" OR C3.[24:6]="X" THEN LESS ELSE GRTR) ; + EP(2,BFC); E0(DEL); E0L(9); E0(XCH); E0(TOP); E0(LNG) ; + EP(14,BBC); E0(DEL); IF C3="MIN1 " OR C3="MAX1 " THEN GO AINT + END ; + + END OF CASE STATEMENT ; + XIT: + IF DEBUGTOG THEN FLAGROUTINE("DOITIN","LINE ",FALSE) ; + END OF DOITINLINE ; + +REAL PROCEDURE LOOKFORINTRINSIC(L); VALUE L; REAL L; +BEGIN + ALPHA ID, I, X, NPARMS; + REAL T; + LABEL FOUND, XIT; +IF DEBUGTOG THEN FLAGROUTINE("LOOKFO","RINTRN",TRUE); + LOOKFORINTRINSIC ~ L ~ NEED(ID ~ GET(L+1),FUNID); + IF GET(L+2) < 0 THEN GO TO XIT; % PARAMETER INFO KNOWN + COMMENT B MUST BE SET TO K/2, WHERE K IS THE INDEX OF THE LAST + INTRINSIC NAME IN THE ARRAY INT; + A~0; B~NUMINTM1 ; + WHILE A+1 < B DO + BEGIN + I ~ REAL(BOOLEAN(A+B) AND BOOLEAN(1022)); + IF Z ~ INT[I] = ID THEN GO TO FOUND; + IF ID < Z THEN B ~ I.[36:11] ELSE A ~ I.[36:11]; + END; + IF ID = INT[I~(A+B)|2-I] THEN GO TO FOUND; + GO TO XIT; + FOUND: + NPARMS~(X~INT[I+1]).INTPARMS; INT[I+1].INTSEEN~1 ; + INFO[L.IR,L.IC].SUBCLASS~X.INTCLASS ; + PUT(L+2,-(1&NEXTEXTRA[TOADINFO]&NPARMS[TONEXTRA])); + IF NPARMS = 0 THEN NPARMS ~ 1; + T~X.INTPARMCLASS ; + FOR I ~ 1 STEP 1 UNTIL NPARMS DO + BEGIN + EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ + 0 & EXPCLASS[TOCLASS] & T[TOSUBCL]; + NEXTEXTRA ~ NEXTEXTRA + 1; + END; + XIT: +IF DEBUGTOG THEN FLAGROUTINE("LOOKFO","RINTRN",FALSE ) ; +END LOOKFORINTRINSIC; +INTEGER PROCEDURE EXPR(VALREG); VALUE VALREQ; BOOLEAN VALREQ; +BEGIN LABEL LOOP, STACK, XIT, NOSCAN; REAL T; + + LABEL ARRY; +LABEL HERE ; + REAL SAVIT, SAVIP; + BOOLEAN CNSTSEENLAST; %FOR HANDLING CONSTANT %113- + REAL SAVEADR; %EXPONENTS %113- + DEFINE OPTYPE = LSTT#; +REAL EXPRESLT,EXPLNK; + REAL EXPV; + REAL TM ; + DEFINE E0=EMIT0#, EP=EMITPAIR#, E0L=EMIT0PDCLIT#, + ES1(OP)=BEGIN E0(XCH); EP(9,STD); E0(OP) END #, + ES2=BEGIN EP(9,STD); E0(XCH); EP(17,SND); E0(MUL) END # ; + LABEL CTYP, DTYP, RLESSC, DLESSC, CLESSD, CLESSC, RPLUSD, DTIMESC, + CTIMESR, CDIVBYD, CTIMESR1, CTIMESR2, DLESSC1 ; + LABEL SPECCHAR, RELATION; + REAL LINK; + DEFINE T1 = EXPT1#, T2 = EXPT2#, CODE = EXPT3#; +COMMENT THE FOLLOWING TABLE GIVES THE PRECEDENCE (PREC) AND +OPERATOR NUMBER (OP) OF THE ARITHMETIC AND LOGICAL OPERATORS. + OPERATOR PREC OP + ** 9 15 + UNARY - 8 12 + / 7 14 + * 7 13 + - 5 11 + + 5 10 + .NE. 4 9 + .GE. 4 8 + .GT. 4 7 + .EQ. 4 6 + .LE. 4 5 + .LT. 4 4 + .NOT. 3 3 + .AND. 2 2 + .OR. 1 1 + THE UNARY PLUS IS IGNORED; +PROCEDURE MATH(D, C, T); VALUE D, C, T; REAL D, C, T; +BEGIN + EMIT0(MKS); + EMITL(C); + EMITV(NEED(".MATH ", INTRFUNID)); + EMIT0(DFL); + IF D = 2 THEN EMIT0(DEL); + OPTYPE[IT~IT-1] ~ T; +END MATH; + NNEW ~ NAME; +IF DEBUGTOG THEN FLAGROUTINE(" EXPRE","SSION ",TRUE ) ; + OPTYPE[SAVIT ~IT ~ IT+1] ~ + PR[SAVIP~IP~IP+1] ~ OPST[IP] ~ 0; + IF GLOBALNEXT = PLUS THEN GO TO LOOP; + IF GLOBALNEXT = MINUS THEN + BEGIN PREC ~ 8; OP ~ 12; GO TO STACK END; + IF PREC > 0 THEN GO TO STACK; + LINK~(EXPLNK~FNEXT)&REAL(SCANENTER)[2:47:1] ; + GO TO NOSCAN; + LOOP: SCAN; + LINK ~ FNEXT; + NOSCAN: + CNSTSEENLAST~FALSE; %113- + IF GLOBALNEXT = ID THEN + BEGIN + IF IP ! SAVIP THEN EXPRESLT ~ EXPCLASS; + OPTYPE[IT~IT+1] ~ (A~GET(LINK)).SUBCLASS; + SCAN; + IF NOT RANDOMTOG THEN + IF NEXT=EQUAL THEN BEGIN NEXT~0; OP~6; PREC~4 END ; + IF GLOBALNEXT = ID OR GLOBALNEXT = NUM THEN + BEGIN FLOG(1); GO TO XIT END; + IF NOT VALREQ AND PREC > 0 THEN VALREQ ~ TRUE; + IF GLOBALNEXT ! LPAREN THEN + BEGIN + LINK ~ GETSPACE(LINK); + T ~ (A~GET(LINK)).CLASS; + IF XREF THEN ENTERX(GET(LINK+1),0&A[15:15:9]); + IF EXPRESLT = 0 THEN EXPRESLT ~ T; + IF VALREQ THEN + IF T = VARID THEN EMITV(LINK) ELSE + BEGIN XTA ~ GET(LINK+1); FLAG(50) END + ELSE + BEGIN + IF T = VARID THEN + IF GLOBALNEXT > SLASH AND EXPRESLT = VARID THEN + BEGIN + DESCREQ~TRUE; EMITN(LINK); DESCREQ ~ FALSE; + GO TO XIT; + END ELSE EMITV(LINK) + ELSE + BEGIN + IF T = ARRAYID THEN + BEGIN + IF BOOLEAN(A.CE) THEN + EMITNUM(GET(LINK+2).BASE) ELSE + IF BOOLEAN(A.FORMAL) THEN + EMIT0PDCLIT(A.ADDR-1) ELSE + EMITL(0); + GO TO ARRY; + END ELSE EMITPAIR(A.ADDR,LOD); + GO TO XIT; + END; + END; + GO TO SPECCHAR; + END; + IF A.CLASS ! ARRAYID THEN + BEGIN COMMENT FUNCTION REFERENCE; + EXPRESLT ~ EXPCLASS; + IF A.CLASS = STMTFUNID THEN + BEGIN + IF XREF THE ENTERX(GET(LINK+1),0&A[15:15:9]); + STMTFUNREF(LINK) ; + IF NEXT=EQUAL THEN IF NOT RANDOMTOG THEN + BEGIN NEXT~0; OP~6; PREC~4 END ; + GO TO SPECCHAR ; + END ; + IF A.CLASS=EXTID OR GET(TM~GLOBALSEARCH(GET(LINK+1))).CLASS= + EXTID THEN LINK~REAL(DOITINLINE(-LINK)) ELSE + IF A.CLASS SLASH AND EXPRESLT = SUBSVAR THEN + BEGIN + ARRY: + IF BOOLEAN((A~GET(LINK)).TWOD) THEN + BEGIN + EMITPAIR(TWODPRT, LOD); + T ~ A.ADDR; + IF T { 1023 THEN + BEGIN + EMITL(T.[38:10]); + EMITDESCLIT(10); + END ELSE + BEGIN + EMITL(T.[40:8]); + EMITDESCLIT(1536); + EMIT0(INX); + END; + EMIT0(CTF); + END ELSE EMITPAIR(A.ADDR,LOD); + EMIT0(XCH); + GO TO XIT; + END; + IF BOOLEAN(A~GET(LINK)).TWOD) THEN + BEGIN + SPLIT(A.ADDR); + IF A.SUBCLASS } DOUBTYPE THEN + BEGIN + EMIT0(CDC); + EMIT0(DUP); + EMITPAIR(1, XCH); + EMIT0(INX); + EMIT0(LOD); + EMIT0(XCH); + EMIT0(LOD); + END ELSE EMIT0(COC); + END ELSE + EMITV(LINK); + END; + END ARRAY REFERENCE; + GO TO SPECCHAR; + END; + IF GLOBALNEXT = NUM THEN + BEGIN + IF NUMTYPE = STRINGTYPE THEN + IF VALREQ THEN + BEGIN + NUMTYPE~INTYPE ; + IF STRINGSIZE=1 THEN FNEXT~STRINGARRAY[0] + ELSE BEGIN + IF STRINGSIZE>2 OR STRINGARRAY[1].[18:30]!" " THEN + FLAG(162) ; + IF (FNEXT~STRINGARRAY[1].[12:6]&STRINGARRAY[0][6:12:36]) + .[6:6]>7 THEN NUMTYPE~REALTYPE ; + END ; + END; + SAVEADR~ADR; CNSTSEENLAST~TRUE; %113- + IF NUMTYPE = DOUBTYPE THEN + EMITNUM2(FNEXT,DBLOW) ELSE EMITNUM (FNEXT); + OPTYPE[IT~IT+1] ~ NUMTYPE; + IF EXPRESLT = 0 THEN + BEGIN EXPRESLT ~ NUMCLASS; EXPV ~ FNEXT END; + SCAN; + IF NOT RANDOMTOG THEN + IF NEXT=EQUAL THEN BEGIN NEXT~0; OP~6; PREC~4 END; + IF NOT VALREQ AND PREC > 0 THEN VALREQ ~ TRUE; + IF GLOBALNEXT = ID OR GLOBALNEXT = NUM THEN + BEGIN FLOG(1); GO TO XIT END; + END; + SPECCHAR: + IF GLOBALNEXT = LPAREN THEN + BEGIN + SCAN; + OPTYPE[IT~IT+1] ~ EXPR(TRUE); + IF GLOBALNEXT = COMMA AND EXPRESULT = NUMCLASS THEN + BEGIN + IF OPTYPE[IT] > REALTYPE THEN FLAG(85); + SCAN; + IF EXPR(TRUE) > REALTYPE + OR EXPRESULT ! NUMCLASS THEN FLAG(85); + EMIT0(XCH); + OPTYPE[IT] ~ COMPTYPE; + IF EXPRESLT = 0 THEN EXPRESLT ~ NUMCLASS; + END ELSE EXPRESLT ~ EXPCLASS; + IF GLOBALNEXT ! RPAREN THEN + BEGIN FLOG(108); GO TO XIT END; + GO TO LOOP; + END; + WHILE PR[IP] } PREC DO + BEGIN + IF IT { SAVIT THEN GO TO XIT; + CODE ~ MAP[T1~OPTYPE[IT-1]]|3 + MAP[T2~OPTYPE[IT]]; + CASE OPST[IP] OF + BEGIN + GO TO XIT; + BEGIN + IF T1 = LOGTYPE AND T2 = LOGTYPE THEN EMIT0(LOR) + ELSE FLAG(51); + IT ~ IT-1; + END; + BEGIN + IF T1 = LOGTYPE AND T2 = LOGTYPE THEN EMIT0(LND) + ELSE FLAG(52); + IT ~ IT-1; + END; + IF T2 = LOGTYPE THEN EMIT0(LNG) ELSE FLAG(53); + BEGIN T ~ LESS; GO TO RELATION END; + BEGIN T ~ LEQL; GO TO RELATION END; + BEGIN T ~ EQUL; GO TO RELATION END; + BEGIN T ~ GRTR; GO TO RELATION END; + BEGIN T ~ GEQL; GO TO RELATION END; + BEGIN T ~ NEQL; + RELATION: + IF CODE < 0 THEN FLAG(54) ELSE + CASE CODE OF + BEGIN ; + BEGIN + E0(CHS); EP(9,STD); E0(XCH); E0L(9); E0(XCH); EP(0,XCH) ; + E0(AD2) ; + END; + FLAG(90); + BEGIN EMITPAIR(0, XCH); EMIT0(SB2) END; + EMIT0(SB2); + FLAG(90); + FLAG(90); + FLAG(90; + IF T! EQUL AND T! NEQL THEN FLAG(54) %103- + ELSE %103- + BEGIN %103- + EP(9,STD); E0(XCH); E0L(9); E0(T); %103- + T~(IF T=EQUL THEN LND ELSE LOR); CODE~0; %103- + END; %103- + END RELATION CASE STATEMENT; + IF CODE > 0 THEN + BEGIN EMIT0(XCH); EMIT0(DFL); EMITL(0) END; + EMIT0(T); + OPTYPE[IT~IT-1] ~ LOGTYPE; + END; + IF CODE < 0 THEN BEGIN FLAG(53); IT ~ IT-1 END ELSE + CASE CODE OF + BEGIN + BEGIN + EMIT0(ADD); + IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE + OPTYPE[IT~IT-1] ~ REALTYPE; + END; + BEGIN TM~AD2 ; + RPLUSD: EP(9,STD); E0(XCH); E0L(9); E0(XCH); EP(0,XCH); E0(TM) ; + DTYP: OPTYPE[IT~IT-1]~DOUBTYPE ; + END ; + BEGIN TM~ADD; GO RLESSC END ; + BEGIN + EMITPAIR(0, XCH); + EMIT0(AD2); + IT ~ IT-1; + END; + BEGIN EMIT0(AD2); IT ~ IT-1 END; + BEGIN TM~ADD; GO DLESSC END ; + BEGIN EMIT0(ADD); IT ~ IT-1 END; + BEGIN TM~ADD; GO CLESSD END ; + BEGIN TM~ADD; GO CLESSC END ; + END ADD CASE STATEMENT; + IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE + CASE CODE OF + BEGIN + BEGIN + EMIT0(SUB); + IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE + OPTYPE[IT~IT-1] ~ REALTYPE; + END; + BEGIN E0(CHS); TM~AD2; GO RPLUSD END; + BEGIN TM~SUB ; + RLESSC: ES1(TM); GO DLESSC1 ; + END ; + BEGIN + EMITPAIR(0, XCH); + EMIT0(SB2); + IT ~ IT-1; + END; + BEGIN EMIT0(SB2); IT ~ IT-1 END; + BEGIN TM~SUB ; + DLESSC: ES1(TM); E0(XCH); E0(DEL) ; + DLESSC1: E0L(9); IF TM=SUB THEN E0(CHS); GO CTIMESR2 ; + END ; + BEGIN EMIT0(SUB); IT ~ IT-1 END; + BEGIN TM~SUB ; + CLESSD: E0(XCH); E0(DEL); E0(TM) ; + CTYP: OPTYPE[IT~IT-1]~COMPTYPE ; + END ; + BEGIN TM~SUB ; + CLESSC: ES1(TM); GO CTIMESR1 ; + END ; + END SUBTRACT CASE STATEMENT; + BEGIN % HANDLE NEGATIVE NUMBERS CASE STATEMENT. + EXPV~-EXPV ; + IF T2 { REALTYPE THEN EMIT0(CHS) ELSE + IF T2 = LOGTYPE THEN FLAG(55) ELSE + IF T2 = DOUBTYPE THEN EMIT0(CHS) ELSE + IF T2 = COMPTYPE THEN + BEGIN + EMIT0(CHS); EMIT0(XCH); + EMIT0(CHS); EMIT0(XCH); + END ELSE FLAG(55); + END OF NEG NUMBERS CASE STATEMNT ; + IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE + CASE CODE OF + BEGIN + BEGIN + EMIT0(MUL); + IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE + OPTYPE[IT~IT-1] ~ REALTYPE; + END; + BEGIN TM~ML2; GO RPLUSD END ; + BEGIN ES2; GO DTIMESC END ; + BEGIN + EMITPAIR(0, XCH); + EMIT0(ML2); + IT ~ IT-1; + END; + BEGIN EMIT0(ML2); IT ~ IT-1 END; + BEGIN ES2; E0(XCH); E0(DEL) ; + DTIMESC: E0L(9); E0L(17); E0(MUL); GO CTYP ; + END ; + BEGIN TM~MUL ; + CTIMESR: EP(9,SND); E0(TM) ; + CTIMESR1:E0(XCH); E0L(9); E0(TM) ; + CTIMESR2:E0(XCH); GO CTYP ; + END ; + BEGIN TM~MUL; GO CDIVBYD END ; + MATH(2, 26, COMPTYPE); + END MULTIPLY CASE STATEMENT; + + IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE + CASE CODE OF + BEGIN + IF T1 = INTYPE AND T2 = INTYPE THEN + BEGIN EMIT0(IDV); IT ~ IT-1 END ELSE + BEGIN EMIT0(DIU); OPTYPE[IT~IT-1] ~ REALTYPE END; + BEGIN + EP(9,STD); EP(17,STD); EP0(0,XCH); E0L(17); E0L(9); E0(DV2) ; + GO DTYP ; + END ; + MATH(1, 29, COMPTYPE); + BEGIN + EMITPAIR(0, XCH); + EMIT0(DV2); + IT ~ IT-1; + END; + BEGIN EMIT0(DV2); IT ~ IT-1 END; + MATH(2, 32, COMPTYPE); + BEGIN TM~DIU; GO CTIMESR END ; + BEGIN TM~DIU ; + CDIVBYD: E0(XCH); E0(DEL); GO CTIMESR ; + END ; + MATH(2, 35, COMPTYPE); + END OF DIVIDE CASE STATEMENT; + IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE + BEGIN + IF CODE = 0 AND T2 = INTYPE AND + CNSTSEENLAST THEN %113- + BEGIN + IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE + OPTYPE[IT~IT-1] ~ REALTYPE; + EXPV~LINK; %113- + A~1; ADR~SAVEADR; %113- + WHILE EXPV DIV 2 ! 0 DO + BEGIN + EMIT0(DUP); + IF BOOLEAN(EXPV) THEN BEGIN A~A+1; EMIT0(DUP) END; + EMIT0(MUL); + EXPV ~ EXPV DIV 2; + END; + IF EXPV = 0 THEN BEGIN EMIT0(DEL); EMITL(1) END ELSE + WHILE A ~ A-1 ! 0 DO EMIT0(MUL); + END ELSE + BEGIN + EMIT0(MKS); + EMITL(CODE); + EMITV(NEED(".XTOI ", INTRFUNID)); + CASE CODE OF + BEGIN + BEGIN EMIT0(DEL); OPTYPE[IT~IT-1]~IF (T1=INTYPE AND T2=INTYPE) + THEN INTYPE ELSE REALTYPE END; + BEGIN EMIT0(DEL); OPTYPE[IT~IT-1] ~ DOUBTYPE END; + BEGIN EMIT0(DEL); OPTYPE[IT~IT-1]~COMPTYPE END ; + BEGIN EMIT0(DEL); IT ~ IT-1 END; + BEGIN EMIT0(DEL); EMIT0(DEL); IT ~ IT-1 END; + BEGIN EMIT0(DEL); EMIT0(DEL); OPTYPE[IT~IT-1]~COMPTYPE END ; + BEGIN EMIT0(DEL); IT ~ IT-1 END; + BEGIN EMIT0(DEL); EMIT0(DEL); IT ~ IT-1 END; + BEGIN EMIT0(DEL); EMIT0(DEL); IT~IT-1 END ; + END OF POWER CASE STATEMENT; + END; + END; + END; + IP ~ IP-1; + END; + EXPRESLT ~ EXPCLASS; + STACK: + PR[IP~IP+1] ~ PREC; + OPST[IP] ~ OP; + IF PREC > 0 AND PREC { 4 THEN + BEGIN + SCAN; LINK ~ FNEXT; + IF NEXT = PLUS THEN GO TO LOOP; + IF NEXT ! MINUS THEN GO TO NOSCAN; + PREC ~ 8; OP ~ 12; + GO TO STACK; + END; + GO TO LOOP; + XIT: IF IP ! SAVIP THEN FLOG(56); + IP ~ SAVIP-1; + EXPR ~ OPTYPE[IT]; + IF OPTYPE[IT-1] ! 0 THEN FLOG(56); + IT ~ SAVIT-1; + EXPRESULT ~ EXPRESLT; + EXPVALUE ~ EXPV; + EXPLINK ~ EXPLNK; + IF DEBUGTOG THEN FLAGROUTINE(" EXPRE","SSION ",FALSE) ; + END EXPR; + +PROCEDURE FAULT (X); + VALUE X; + REAL X; + BEGIN REAL LINK; LABEL XIT; + SCAN; IF GLOBALNEXT ! LPAREN THEN BEGIN FLAG(106); GO XIT END; + SCAN; IF GLOBALNEXT ! ID THEN BEGIN FLAG(66); GO TO XIT END; + IF X = 1 THEN PDPRT[0,0] ~ PDPRT[0,0] & 1[44:47:1] ELSE + PDPRT[0,0] ~ PDPRT [0,0] & 1[43 :47:1]; + EMIT0PDCLIT(41); EMIT0(DUP); + IF X = 1 THEN BEGIN EMITL(2); EMIT0(XCH); EMITL(1) END + ELSE EMITL(6); + EMIT0(LND); + IF X = 2 THEN EMITL(3); + EMIT0(SUB); + IF X = 2 THEN + BEGIN EMIT0(DUP); EMITL(3); EMIT0(SSN) ;EMIT0(EQUL); EMITL(2) + ;EMIT0(BFC) ; EMIT0(DEL);EMITL(2); + END; + LINK ~ GET(GETSPACE(FNEXT)); EMITPAIR(LINK,ADDR.ISD); + IF X = 1 THEN EMITL(30) ELSE EMITL(25); + EMIT0(LND); EMITL(41);EMIT0(STD); + SCAN; IF GLOBALNEXT ! RPAREN THEN FLAG(108); + SCAN; + XIT: + END FAULT; +PROCEDURE SUBREF; +BEGIN REAL LINK,INFC; + REAL ACCIDENT; + LABEL XIT; +IF DEBUGTOG THEN FLAGROUTINE(" SUB","REF ",TRUE ) ; +IF TSSEDITOG THEN IF NAME="ZIP " AND NOT DCINPUT THEN TSSED(NAME,3) ; + IF NAME = "EXIT " THEN + BEGIN + RETURNFOUND ~ TRUE; + EMITL(1); + EMITPAIR(16,STD); + EMITPAIR(10,KOM); + EMITPAIR( 5, KOM); + PUT(FNEXT+1, "......"); + SCAN; + END ELSE IF NAME="ZIP " AND NOT DCINPUT THEN + BEGIN + EMIT0(MKS); + EMITL(0); EMITL(0); % DUMMY FILE AND FORMAT + EMITPAIR(-1,SSN); + EMITB(-1,FALSE); LADR1~LAX; ADJUST; DESCREQ~FALSE; + IF ADR } 4085 THEN BEGIN ADR~ADR+1; SEGOVF END; + ACCIDENT~PRGDESCBLDR(0,0,ADR.[36:10]+1,NSEG); + EMIT0PDCLIT(19); + EMIT0(GFW); + LISTART ~ ADR&NSEG[TOSEGNO]; ADJUST;SCAN; + IF GLOBALNEXT!LPAREN THEN BEGIN FLAG(106);GO TO XIT END; + SCAN; IF GLOBALNEXT!ID THEN BEGIN FLAG(66); GO TO XIT END; + LINDX ~ FNEXT; SCAN; XTA ~ GET(LINDX+1); + IF GLOBALNEXT!RPAREN THEN BEGIN FLAG(108); GO TO XIT END; + LINDX ~ GETSPACE(LINDX); + IF T~(LINFA~GET(LINDX)).CLASS!ARRAYID THEN + BEGIN FLAG(66); GO TO XIT END; + IF XREF THEN ENTERX(XTA,0&LINFA[15:15:9]); + EMITPAIR(LADDR~LINFA.ADDR,LOD); + IF BOOLEAN(LINFA.FORMAL) THEN + BEGIN + IF T ~ GET(LINDX+2)<0 THEN EMIT0PDCLIT(T.SIZE) + ELSE EMITNUM(T.SIZE); EMIT0PDCLIT(LADDR-1); EMIT0(CTF) END + ELSE EMITNUM(GET(LINDX+2).BASENSIZE); EMITL(18); EMIT0(STD);; + EMITL(LINFA.CLASNSUB&0[44:47:1]); EMITL(19); EMIT0(STD); + BRANCHLIST(LISTART,TRUE); EMITL(19); EMIT0(STD); + EMIT0(RTS); ADJUST; + EMITL(1); EMIT0(CHS); EMITL(19); EMIT0(STD); + EMITDESCLIT(19); EMIT0(RTS); FIXB(LADR1); DESCREQ~FALSE; + EMITPAIR(ACCIDENT,LOD); EMIT0PDCLIT(7); EMIT0(FTF); + EMITL(6); % EDITCODE 6 FOR ZIP + EMITV(NEED(".FTOUT","INRFUNID)); SCAN + END ELSE IF NAME = "OVERFL" THEN FAULT(2) + ELSE IF NAME = "DVCHK " THEN FAULT(1) + ELSE + BEGIN + LINK ~ NEED(NAME, SUBRID); + IF XREF THEN ENTERX(XTA,0&GET(LINK)[15:15:5]); + EMIT0(MKS); + SCAN; + IF GLOBALNEXT = LPAREN THEN + BEGIN PARAMETERS(LINK); SCAN END ELSE + IF NOT BOOLEAN((INFC~GET(LINK+2)).[1:1]) THEN + PUT(LINK+2),-INFC) ELSE + IF INFC.NEXTRA ! 0 THEN + BEGIN XTA ~ GET(LINK+1); FLAG(28) END; + EMITV(LINK); + END; + XIT: +IF DEBUGTOG THEN FLAGROUTINE(" SUB","REF ",FALSE) ; +END SUBREF; + +PROCEDURE DECLAREPARMS(FNEW); VALUE FNEW; REAL FNEW; +BEGIN + REAL I, T, NLABELS, INFA, INFB, INFC; +IF DEBUGTOG THEN FLAGROUTINE("DECLAR","EPARMS",TRUE ) ; + INFA ~ GET(FNEW); + IF INFA.SEGNO ! 0 THEN BEGIN XTA ~ NNEW; FLAG(25) END; + INFA.SEGNO ~ NSEG; PUT(FNEW,INFA); + ENTRYLINK[ELX] ~ 0 & FNEW[TOLINK] & NEXTSS[TOADDR]; + FOR I ~ 1 STEP 1 UNTIL PARMS DO + BEGIN + EXTRAINFO[NEXTSS.IR,NEXTSS.IC] ~ PARMLINK[I]; + NEXTSS ~ NEXTSS-1; + IF T ~ PARMLINK[I] ! 0 THEN + BEGIN + GETALL(T,INFA,INFB,INFC); + IF BOOLEAN(INFA .FORMAL) THEN + BEGIN + IF INFA.SEGNO = ELX THEN + BEGIN XTA ~ INFB ; FLAG(26) END; + END ELSE IF (INFA < 0 AND INFA.ADDR < 1024) OR BOOLEAN(INFA.CE) + THEN BEGIN XTA ~ INFB; FLAG(107) END; + INFA ~ INFA & 1[TOFORMAL] & ELC[TOSEGNO]; + INFC .BASE ~ I; + PUT(T,INFA); PUT(T+2,INFC); + END ELSE NBLABELS ~ NLABELS+1; + END; + IF NLABELS > 0 THEN + BEGIN ENTRYLINK[ELC ].CLASS ~ NLABELS; + IF LABELMOM=0 THEN BEGIM BUMPLOCALS; LABELMOM~LOCALS+1536 END; + END; + GETALL(FNEW,INFA,INFB,INFC); + IF BOOLEAN(INFC.[1:1]) THEN + BEGIN + IF INFC.NEXTRA ! PARMS THEN + BEGIN XTA ~ INFB; FLOG(41); + PARMS ~ INFC.NEXTRA; + END; + T ~ INFC.ADINFO; + FOR I ~ 1 STEP 1 UNTIL PARMS DO + IF NOT(PARMLINK[I] = 0 EQV + EXTRAINFO[(T+I-1).IR,(T+I-1).IC].CLASS = LABELID) THEN + BEGIN IF PARMLINK[I] = 0 THEN XTA ~ "* " + ELSE XTA ~ GET(PARMLINK[I]+1); + FLAG(40); + END; + END + ELSE + BEGIN + IF PARMS = 0 THEN INFC ~ -INFC ELSE + INFC ~ -(INFC & PARMS[TONEXTRA] + & NEXTEXTRA[TOADINFO]); + PUT(FNEW+2,INFC); + FOR I ~ 1 STEP 1 UNTIL PARMS DO + BEGIN + EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ 0 & + (IF PARMLINK[I] = 0 THEN LABELID ELSE 0)[TOCLASS]; + NEXTEXTRA ~ NEXTEXTRA+1; + END; + END; + IF ELX ~ ELX+1 > MAXEL THEN BEGIN FLAG(128); ELX ~ 0 END; +IF DEBUGTOG THEN FLAGROUTINE("DECLAR","EPARMS",FALSE) ; +END DECLAREPARMS; +PROCEDURE IOLIST(LEVEL); REAL LEVEL; +BEGIN ALPHA LADR2,T; +BOOLEAN A; +INTEGER INDX,I,BDLINK,NSUBS; + LABEL ROUND,XIT,ERROR,LOOP,SCRAM; +INTEGER STREAM PROCEDURE CNTNAM(IDEN); VALUE IDEN; +BEGIN LABEL XIT; + SI ~ LOC IDEN; SI ~ SI + 3; TALLY ~ 1; + 5(IF SC = " " THEN JUMP OUT TO XIT;SI ~ SI+1;TALLY ~ TALLY+1); + XIT: CNTNAM ~ TALLY; +END CNTNAM; +IF DEBUGTOG THEN FLAGROUTINE(" IOL","IST ",TRUE ) ; +ROUND: DESCREQ ~ TRUE; + LOCALNAME ~ FALSE; +IF GLOBALNEXT = SEMI THEN GO TO XIT; +IF GLOBALNEXT = STAR THEN + BEGIN IF NOT NAMEDESC THEN + TV ~ ENTER(0&LISTSID[TOCLASS],LISTID~LISTID+1); + LOCALNAME ~ TRUE; NAMEDESC ~ TRUE; SCAN; + END; +IF GLOBALNEXT = ID THEN +BEGIN LINDX ~ FNEXT; + SCAN; XTA ~ GET(LINDX+1); + IF GLOBALNEXT = EQUAL THEN %RETURN TO CALLER + BEGIN IF (LINFA~GET(GETSPACE(LINDX))).CLASS ! VARID THEN FLAG(50); + SCRAM: IF (LEVEL ~ LEVEL-1) < 0 THEN FLOG(97); + GO TO XIT; + END; + + IF DATASTMTFLAG AND SPLINK } 0 THEN %DECLARE OWN + BEGIN + IF BOOLEAN(GET(LINDX).FORMAL) THEN FLAG(147); + IF SPLINK>1 THEN + IF GET(LINDX).ADDR>1023 THEN FLAG(174); + LINDX ~ GETSPACE(-LINDX); + IF BOOLEAN(GET(LINDX).EQ) THEN FLAG(168); + END ELSE LINDX ~ GETSPACE(LINDX); + IF T ~ (LINFA~GET(LINDX)).CLASS > VARID THEN FLAG(50); + IF XREF THEN ENTERX(XTA,C2&LINFA[15:15:9]); + IF GLOBALNAME OR LOCALNAME THEN + IF NAMEIND~ NAMEIND+1 GTR LSTMAX THEN FLOG(161) + ELSE NAMLIST[NAMEIND] ~ XTA & CNTNAM(XTA)[9:45:3]; + IF T = ARRAYID THEN + IF GLOBALNEXT ! LPAREN THEN + BEGIN IF SPLINK ! 1 THEN + BEGIN + EMITL(0); + EMITPAIR(LADDR ~ LINFA.ADDR,LOD); + EMIT0(FTC); + EMITDESCLIT(2); + EMIT0(INX); + EMIT0(LOD); + END ELSE EMITPAIR(LADDR-LINFA.ADDR,LOD); + NSUBS ~ (T ~ GET (LINDX+2)).NEXTRA; + IF GLOBALNAME OR LOCALNAME THEN + BEGIN + IF NSUBS GTR SAVESUBS THEN SAVESUBS ~ NSUBS; + IF NSUBS GTR NAMLIST[0] THEN NAMLIST[0] ~ NSUBS; + NAMLIST[NAMEIND].[1:8] ~ NSUBS; + INDX ~ -1; + INFA ~ GET(NEED(".SUBAR",BLOCKID)).ADDR; + BDLINK ~ T.ADINFO+1; + END; + IF BOOELAN (LINFA.FORMAL) THEN + BEGIN + IF T LSS 0 THEN EMIT0PDCLIT(T,SIZE) + ELSE EMITNUM(T.SIZE); + EMIT0PDCLIT(LADDR-1); + EMIT0(CTF); + END ELSE EMITNUM(T.BASESIZE); + IF GLOBALNAME OR LOCALNAME THEN + FOR I ~ 1 STEP 1 UNTIL NSUBS DO + BEGIN IF T ~ EXTRAINFO[(BDLINK~BDLINK-1).IR, + BDLINK.IC] LSS 0 THEN EMIT0PDCLIST(T) + ELSE EMITNUM(T); + EMITNUM(INDX ~ INDX+1); + EMITDESCLIT(INFA); + EMIT0(STD); + END; + EMITL(18); EMIT0(STD); + END ELSE + BEGIN SCAN; + A ~(IF GLOBALNAME OR LOCALNAME + THEN SUBSCRIPTS(LINDX,4) ELSE SUBSCRIPTS(LINDX,2)); + SCAN; + END + ELSE EMITN(LINDX); + IF GLOBALNAME OR LOCALNAME THEN + BEGIN EMIT0PDCLIT(18); EMITNUM(NAMEIND); + EMITD(43,DIA); EMITD(3,DIB); EMITD(15,TRB); + EMITL(18); EMIT0(STD); + END; + EMITL(LINFA.CLASNSUB&0[44:47:1]); + EMITL(20); EMIT0(STD); + IF ADR > 4083 THEN + BEGIN ADR~ADR+1; SEGOVF END ; + BRANCHLIT(LISTART,TRUE); + EMITL(19); EMIT0(STD); + EMIT0(RTS); ADJUST; + GO TO LOOP; +END; +IF GLOBALNEXT = LPAREN THEN % RECURSE ON ( +BEGIN EMITB(-1,FALSE); + ADJUST; + LADR2 ~ (ADR + 1)&LAX[TOADDR]&NSEG[TOSEGNO]; + SCAN; LEVEL ~ LEVEL + 1; + IOLIST(LEVEL); + IF GLOBALNEXT ! EQUAL THEN % PHONY IMP DO + BEGIN BRANCHES[T ~ LADR2.ADDR] ~ BRANCHX; + BRANCHX ~ T; + IF GLOBALNEXT ! RPAREN THEN GO TO ERROR; + SCAN; GO TO LOOP; + END; + IF XREF THEN ENTERX(GET(LINDX+1),1&LINFA[15:15:9]); + IF LINFA.SUBCLASS > REALTYPE THEN + BEGIN XTA ~ GET(LINDX + 1); + FLAG(84); + END; + EMITB(-1,FALSE); + LADR3 ~ LAX; + FIXB(LADR2,ADDR); + DESCREQ ~ FALSE; + SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102); % INITIAL VALUE + EMITN(LINDX); EMIT0(STD); + EMITB(LADR2,FALSE); + IF GLOBALNEXT ! COMMA THEN GO TO ERROR; + ADJUST; + LADR4 ~ (ADR + 1)&NSEG[TOSEGNO]; + SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102) ELSE EMIT0(GRTR); + EMITB(LADR2,TRUE); + EMITB(-1,FALSE); + LADR5 ~ LAX; + FIXB(LADR3); + IF GLOBALNEXT ! COMMA THEN EMITL(1) + ELSE BEGIN SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102); END; + EMITV(LINDX); EMIT0(ADD); + EMITN(LINDX); EMIT0(SND); + EMITB(LADR4,FALSE); + FIXB(LADR5); + IF GLOBALNEXT = RPAREN THEN SCAN ELSE GO TO ERROR; + LOOP: IF GLOBALNEXT = SEMI OR GLOBALNEXT = SLASH THEN GO TO XIT; + IF GLOBALNEXT = RPAREN THEN GO TO SCRAM; + IF GLOBALNEXT = COMMA THEN + BEGIN SCAN; + IF GLOBALNEXT = SEMI THEN GO TO ERROR; + GO TO ROUND; + END; + ERROR: XTA ~ NAME; + FLAG(94); + IF GLOBALNEXT = SEMI THEN GO TO XIT; + SCAN; + IF GLOBALNEXT = ID THEN GO TO ROUND; + ERRORTOG ~ TRUE; GO TO XIT; + END; + IF GLOBALNEXT = RPAREN THEN GO TO SCRAM ELSE + IF GLOBALNEXT ! SLASH THEN GO TO ERROR; + XIT: IF DEBUGTOG THEN FLAGROUTINE(" IOL","IST ",FALSE) ; + END IOLIST; + INTEGER PROCEDURE FILECHECK(FILENAME,FILETYPE); + VALUE FILENAME,FILETYPE; ALPHA FILENAME; INTEGER FILETYPE; + BEGIN COMMENT THIS PROCEDURE RETURNS THE PRT CELL ALLOCATED TO + THE FILE FILENAME... A CELL IS CREATED IF NONE EXISTS; + IF DEBUGTOG THE FLAGROUTINE(" FILEC","HECK ",TRUE); + EMITL(IF NOTOPIO THEN 2 ELSE 5); % FOR IO DESCRIPTOR + IF T ~ GLOBALSEARCH(FILENAME) = 0 THEN % FILE UNDECLARED + BEGIN MAXFILES ~ MAXFILES + 1; + BUMPPRT; + I ~ GLOBALENTER(-0&(FILECHECK~PRTS)[TOADDR] + &FILEID[TOCLASS].FILENAME)+2; + INFO[I.IR,I.IC]. LINK ~ FILETYPE; + END ELSE % FILE ALREADY EXISTS + FILECHECK ~ GET(T).ADDR; + IF DEBUGTOG THEN FLAGROUTINE(" FILEC","HECK ",FALSE) ; + END FILECHECK; + PROCEDURE INLINEFILE; + BEGIN COMMENT THIS PROCEDURE GENERATES THE CODE TO BRING UP THE FILE... + IF THE FILE IS AN INTEGER THE FILECHECK IS CALLED, IF THE FILE + IS NOT AN INTEGER THEN IN-LINE CODE IS GENERATED FOR OBJECT TIME + ANALYSIS; + REAL TEST; + COMMENT IF LAST INSTRUCTION WAS A LIT CALL THEN WE HAVE SEEN REFERENCE + TO AN INTEGER FILE ID; + IF DEBUGTOG THEN FLAGROUTINE(" INLIN","EFILE ",TRUE ) ; + TEST~ADR ; + IF EXPR(TRUE)>REALTYPE THEN FLAG(102) + ELSE IF EXPRESULT=NUMCLASS THEN + BEGIN XTA~NNEW ; + IF EXPVALUE}1.0@5 OR EXPVALUE{0.5 THEN FLAG(33) + ELSE BEGIN + IF ADR LSTMAX THEN GO TO NUL; + WSA[TOTAL] ~ I ~ 0; GO TO ROUND; + END ELSE GO TO ROUND ELSE GO TO NUL1; + END; + IF NOT STRINGF THEN + IF SLCNT > 0 THEN + IF T = "/" THEN BEGIN SLCNT ~ SLCNT+1; GO TO ROUND; END + ELSE + BEGIN WSA[TOTAL] ~ 0 & SLCNT[TOREPEAT] & SLASH[TOCODE]; + IF NOT STR THEN + IF REPEAT < 16 AND WSA[TOTAL-1].[42:6] = 0 THEN + WSA[TOTAL~TOTAL-1] ~ WSA[TOTAL] & SLCNT[42:44:4] + & 1[46:47:1]; + COMMAS~DOLLARS~BOOLEAN(SLCNT~0); NCR~BACKNCR(NCR) ; + GO TO NUL1; + END; + IF NOT QF THE IF T = """ THEN IF STRINGF ~ NOT STRINGF THEN + BEGIN IF CODE > 4 THEN BEGIN STRINF ~ FALSE; + NCR ~ BACKNCR(NCR); GO TO ENDER END; + SAVTOTAL ~ TOTAL; J~0; I~3; QF ~ TRUE; + WSA[TOTAL] ~ 0 & HPHASE[TOCODE]; + GO TO ROUND; + END ELSE + BEGIN + WSA[SAVTOTAL] ~ WSA[SAVTOTAL] & J[TOREPEAT]; + IF I = 0 THEN TOTAL ~ TOTAL - 1; + CODE ~ HPHASE; + GO TO ENDER; + END; + IF STRINGF THEN + BEGIN + STORECHAR(WSA[TOTAL],I,T); + J ~ J + 1; QF ~ FALSE; + IF I ~ I+1 = 8 THEN + BEGIN + IF TOTAL ~ TOTAL +1> LSTMAX THEN GO TO NUL; + I ~ WSA[TOTAL] ~ 0; + END; + GO TO ROUND; + END; +CASE T OF +BEGIN + BEGIN ZF ~ TRUE; % 0 + NUM: DECIMAL ~ 10 | DECIMAL + T; + IF ASK THEN + BEGIN FLAG(183); %111- + DO BEGIN NCR~GETCHAR(NCR,T); XTA~T&XTA[12:18:30] END + UNTIL T!"*" AND T>9 AND T!" " ; + NCR~BACKNCR(NCR); XTA~BLANKS&XTA[18:12:30] ; + END + ELSE + IF DECIMAL>4090 THEN BEGIN FLAG(172); DECIMAL~1 END ; + IF CODE = 0 THEN REPEAT ~ DECIMAL + ELSE IF PF THEN BEGIN IF DECIMAL>WIDTH AND WIDTH!0 AND CODE! + VPHRASE THEN FLAG(129) END ELSE WIDTH~DECIMAL ; + GO TO ROUND; + END; + GO TO NUM; GO TO NUM; GO TO NUM; % 1 2 3 + GO TO NUM; GO TO NUM; GO TO NUM; % 4 5 6 + GO TO NUM; GO TO NUM; GO TO NUM; % 7 8 9 + ; ; ; ; ; ; % # @ Q : > } + BEGIN PLUSP ~ TRUE; GO TO ROUND; END; % + + BEGIN CODE ~ APHASE; GO TO NOEND END; % A + ; % B + BEGIN CODE ~ CPHASE; GO TO NOEND END; % C + BEGIN CODE ~ DPHASE; GO TO NOEND END; % D + BEGIN CODE ~ EPHASE; GO TO NOEND END; % E + BEGIN CODE ~ FPHASE; GO TO NOEND END; % F + BEGIN CODE ~ GPHASE; GO TO NOEND END; % G + BEGIN IF REPEAT = 0 THEN FLOG(130); % H + IF ASK THEN BEGIN FLOG(32 ); GO SEMIC END ; + HF ~ TRUE; I ~ 3; CODE ~ HPHASE; + WSA[TOTAL] ~ 0 & HPHASE[TOCODE] & REPEAT[TOREPEAT]; + GO TO ROUND; + END; + BEGIN CODE ~ IPHASE; GO TO NOEND END; % I + BEGIN IF CODE < 11 OR CODE=15 THEN FLOG(134); % . + IF CODE=0 OR PF THEN FLOG(32) ; + PF~TRUE; DECIMAL~0; ASK~ZF~FALSE ; + GO TO ROUND; + END; + GO TO RP; % [ + ; % & + LP: + BEGIN IF CODE ! 0 THEN FLOG(32); % ( + IF ASK THEN REPEAT~4095; IF REPEAT=0 AND ZF THE FLAG(173) ; + NAMLIST[SAVLASTLP ~ PARENCT ~ PARENCT+1] ~ 0 & TOTAL[TOWIDTH] + &(IF REPEAT{0 AND PARENCT>1 THEN 1 ELSE REPEAT)[TOREPEAT] ; + IF ASK THEN + BEGIN ASK~VRB~FALSE ; + WSA[TOTAL]~32&LPPHRASE[TOCODE]&4095[TOREPEAT] ; + IF (TOTAL~TOTAL+1)>LSTMAX THEN GO NUL ; + END ; + ZF~BOOLEAN(REPEAT~DECIMAL~0) ; + STR ~ TRUE; + GO TO ROUND1; + END; + ; ; ; % < ~ | + BEGIN CODE~JPHASE; WIDTH~-1; GO NOEND END ; % J + BEGIN % K + IF COMMAS OR CODE!0 THEN BEGIN FLAG(32); COMMAS~TRUE END + ELSE BEGIN COMMAS~TRUE ; +KK: DO BEGIN NCR~GETCHAR(NCR,T); XTA~T&XTA[12:18:30] END + UNTIL T!" " ; + IF (T<17 OR (T>25 AND T<33) OR (T>42 AND T<50) OR T>57) + THEN BEGIN FLAG(32) ; + IF T="*" OR T<10 THEN BEGIN DECIMAL~1; GO FL END ; + END ; + NCR~BACKNCR(NCR); XTA~BLANKS&XTA[18:12:30] ; + END ; + GO ROUND ; + END OF K ; + BEGIN CODE ~ LPHASE; GO TO NOEND; END; % L + ; ; % M N + BEGIN CODE ~ OPHASE; GO TO NOEND; END; % O + BEGIN WSA[TOTAL] ~ 0 & PPHASE[TOCODE] % P + & REAL(VRB)[42:47:1] + & REAL(MINUSP)[TOSIGN] & REPEAT[TOWIDTH]&1[TOREPEAT]; + MINUSP ~ PLUSP ~ FALSE; + IF (DECIMAL = 0 AND NOT ZF) THEN FLOG(131); + GO TO NUL1; + END; + ; ; % Q R + BEGIN IF DOLLARS OR CODE!0 THEN FLAG(32) % $ + ELSE BEGIN DOLLARS~TRUE; GO KK END ; + DOLLARS~TRUE; GO ROUND ; + END OF DOLLAR SIGN ; + IF NOT ASK THEN % * + BEGIN + IF ZF OR DECIMAL NEQ 0 THEN FLAG(183); DECIMAL:=4095; %111- + IF CODE=0 THEN REPEAT~DECIMAL + ELSE IF NOT PF THE WIDTH~DECIMAL ; + VRB := ASK := LISTEL := TRUE; GO ROUND; %101- + END ELSE BEGIN DECIMAL:=4095; FLAG(183); GO FL END ; %111- + BEGIN MINUSP ~ TRUE; GO TO ROUND; END; % - + RP: + BEGIN IF FIELD THEN BEGIN NCR ~ BACKNCR(NCR); % ) + GO TO ENDER; END; + IF DECIMAL ! 0 THEN FLAG(32); + I ~ IF PARENCT = 1 THEN IF SAVLASTLP > 1 THEN 2 ELSE 1 + ELSE PARENCT; + WSA[TOTAL]~(J~NAMLIST[I])&(TOTAL+1-J~J.[18:12])[TOLINK] + & (IF PARENCT ~ PARENCT-1 = 0 THEN 77 ELSE 0)[TODECIMAL]; + IF WSA[J].[1:5]=LPPHRASE AND PARENCT!0 THEN + BEGIN WSA[J].[18:12]~TOTAL-J; WSA[TOTAL].[18:12]~TOTAL-J ; + END ; + NAMLIST[I].[6:12] ~ 0; + CODE ~ HPHASE; + GO TO NUL1; + END; + ; ; % ; LEQ + GO TO ROUND; % BLANKS + BEGIN SLCNT ~ 1; % / +SL: IF CODE=0 THEN IF ASK OR ZF OR DECIMAL!0 THEN + BEGIN FLAG(32); ASK~ZF~BOOLEAN(DECIMAL~0) END ; + IF CODE<5 THEN IF T="," THEN GO ROUND1 ELSE GO ROUND ELSE GO + ENDER ; + END; + ; % S + BEGIN IF REPEAT ! 0 THEN FLAG(32); % T + CODE ~ TPHASE; + GO TO NOEND; + END; + ; % U + BEGIN VRB~TRUE; CODE~VPHRASE; WIDTH~-1; GO NOEND END ; % V + ; % W + BEGIN IF REPEAT = 0 THEN FLOG(130); % X + IF STR THEN + NEWWD: WSA[TOTAL] ~ 0 & XPHASE[TOCODE] & REPEAT[TOWIDTH] + & 1[TOREPEAT] + & REAL(VRB)[42:47:1] + ELSE + BEGIN + IF (J~WSA[TOTAL-1].[42:6]>0 OR (I~J.[1:5])=RTPARN + OR (REPEAT}32 AND I!XPHASE) THEN GO NEWWD ; + IF I=XPHASE AND (I~J.[18:12]+REPEAT){4090 THEN + WSA[TOTAL~TOTAL-1] ~ J & I[TOWIDTH] + ELSE IF REPEAT } 32 THEN GO TO NEWWD + ELSE WSA[TOTAL~TOTAL-1] ~ J & REPEAT[TONUM] + & 1[TOCNTRL]; + END; + GO TO NUL1; + END; + ; ; % Y Z + GO SL ; % , + GO TO LP; % % + ; ; ; % ! = ] " +END OF CASE STATEMENT; +FLOG(132); % ILLEGAL CHARACTER; +GO TO FALL; +ENDER: IF CODE > 4 THEN + BEGIN IF WIDTH=0 THEN FLAG(130) ; + IF CODE=VPHRASE THEN + BEGIN + IF WIDTH=-1 THEN IF PF THEN FLAG(130)ELSE WIDTH~ + DECIMAL~4094 ELSE + IF NOT PF THEN DECIMAL~4094 ; + END + ELSE + IF CODE > 10 AND CODE ! 15 THEN + IF DECIMAL = 0 AND NOT ZF) OR NOT PF THEN FLAG(133) + ELSE ELSE DECIMAL ~ 0; + IF REPEAT=0 THEN REPEAT~1 ; + IF WIDTH=-1 THEN WIDTH~0 ; + WSA[TOTAL] ~ 0 & CODE[TOCODE] & WIDTH[TOWIDTH] + & REPEAT[TOREPEAT] & DECIMAL[TODECIMAL] + & REAL(COMMAS) [44:47:1] + & REAL(VRB)[42:47:1] + & REAL(DOLLARS)[45:47:1]; + END ELSE IF DECIMAL ! 0 THEN FLAG(32); +NUL1: IF PLUSP THEN FLAG(164); + IF CODE!VPHRASE THEN + BEGIN + IF DOLLARS AND(CODE < 9 OR CODE > 14) THEN FLAG(166); + IF COMMAS AND NOT(CODE = 10 OR CODE = 12 OR CODE = 9) + THEN FLAG(165); + END; + VRB~ + ERRORTOG ~ FIELD ~ PF ~ PLUSP ~ DOLLARS ~ COMMAS ~ STR ~ FALSE; + IF CODE = HPHASE THEN STR ~ TRUE; + CODE ~ REPEAT ~ WIDTH ~ 0; + XTA ~ BLANKS; + GO TO FALL; +NOEND: IF FIELD THEN FLAG(32); + IF CODE ! TPHASE THEN LISTEL ~ TRUE ELSE REPEAT ~ 1; + IF REPEAT=0 AND ZF THEN FLAG(173) ; + FIELD ~ TRUE; +FALL: IF MINUSP THEN BEGIN FLAG(32); MINUSP ~ FALSE END; + ASK~ZF~FALSE ; +NUL: DECIMAL ~ 0; + IF PARENCT = 0 THEN BEGIN SCN ~ 1; GO TO SEMIC END; + IF CODE < 5 THEN + IF TOTAL ~ TOTAL+1 > LSTMAX THEN + BEGIN FLOG(78);TOTAL ~ TOTAL-2; GO TO SEMIC; END; +GO TO ROUND; +NOPLACE: IF(DCINPUT OR FREEFTOG) AND (STRINGF OR HF) THEN FLOG(150); + IF TSSEDITOG THEN IF (STRINGF OR HF) AND NOT DCINPUT + THEN TSSED(XTA,1); + IF CONTINUE THEN IF READACARD THEN + BEGIN IF LISTOG THEN PRINTCARD; GO TO ROUND; END; +SCN ~ 0; NEXT ~ SEMI; +SEMIC: +IF SCN = 1 THEN SCAN; +IF STRINGF THEN FLAG(22); +IF NOT LISTEL THEN WSA[0] ~ 0; +IF PARENCT ! 0 THEN FLAG(IF PARENCT < 0 THEN 9 ELSE 8); +IF D ! 0 THEN PRTSAVER(D,TOTAL+1,WSA); +IF DEBUGTOG THEN BEGIN + WRITE(LINE,FM) ; + FOR I~0 STEP 1 UNTIL TOTAL DO BEGIN + WRITE(LINE,[13]//,I,(J~WSA[I].[1:5],J.[6:12],J.[18:12],J.[30:12], + J.[41:1],J.[42:4],J.[42:5],J.[44:1],J.[45:1], + J.[46:1],J.[46:2],J.[47:1]) ; + IF J.[1:5]=2 THEN I~I+(J.[6:12]+2).[36:9] ; + END ; + WRITE(LINE[DBL]) ; + END OF DEBUGSTUFF ; +END FORMATER; + +PROCEDURE EXECUTABLE; +BEGIN LABEL XIT; REAL T, J, TS, P; + IF SPLINK < 0 THEN FLAG(12); + IF LABL = BLANKS THEN GO TO XIT; + IF T ~ SEARCH(XTA ~ LABL) = 0 THEN + T ~ ENTER(-0 & LABELID[TOCLASS] & (ADR+1)[TOADDR] & + NSEG[TOSEGNO], LABL) ELSE + BEGIN IF (P ~ GET(T)).CLASS ! LABELID THEN + BEGIN FLAG(144); GO TO XIT END; + IF P < 0 THEN BEGIN FLAG(20); GO TO XIT END; + TS ~ P.ADDR; + WHILE TS ! 0 DO + BEGIN J ~ GIT(TS); FIXB(TS+10000); TS ~ J END; + PUT(T, P~-P & (ADR+1)[TOADDR] & NSEG[TOSEGNO]); + IF (T ~ GET(T+2)).BASE ! 0 THEN + T ~ PRGDESCBLDR(2, T.BASE, (ADR+1).[36:10], NSEG); + END; + IF XREF THEN ENTERX(LABL,1&LABELID[TOCLASS]); + XIT: +END EXECUTABLE; + +PROCEDURE IOCOMMAND(N); VALUE N; REAL N; +COMMENT N COMMAND + 0 READ + 1 WRITE + 2 PRINT + 3 PUNCH + 4 BACKSPACE + 7 DATA; +BEGIN LABEL XIT,SUCH,LISTER,NOFORM,FORMER,WRAP,DAAT,NF; +LABEL LISTER1; + BOOLEAN SUCHTOG, RDTRIN, FREEREAD; + BOOLEAN FORMARY, NOFORMT; + BOOLEAN NAMETOG; +DEFINE DATATOG = DATASTMTFLAG#; +REAL T, ACCIDENT, EDITCODE; +REAL DATAB; +PROCEDURE ACTIONLABELS(UNSEEN); VALUE UNSEEN; BOOLEAN UNSEEN; +BEGIN LABEL EOF,ERR,RATA,XIT,ACTION,MULTI; + BOOLEAN BACK,GOTERR,GOTEOF; +IF UNSEEN THEN SCAN; +EOF: IF GOTEOF THEN GO TO MULTI; + IF BACK ~ NAME = "END " THEN GO TO ACTION; +ERR: IF GOTERR THEN GO TO MULTI; + IF NAME ! "ERR " THEN IF GOTEOF THEN + BEGIN MULTI: XTA ~ NAME; FLOG(137); + GO TO XIT; + END ELSE GO TO RATA; +ACTION: SCAN; + IF NEXT = EQUAL THEN SCAN ELSE GO TO RATA; + IF NEXT ! NUM THEN GO TO RATA; + IF XREF THEN ENTERX(NAME,0&LABELID[TOCLASS]); + IF BACK THEN NX1 ~ NAME ELSE NX2 ~ NAME; + SCAN; IF NEXT = RPAREN THEN GO TO XIT; + IF NEXT = COMMA THEN SCAN ELSE GO TO RATA; + IF BACK THEN + BEGIN BACK ~ NOT ( GOTEOF ~ TRUE); + GO TO ERR; + END; + GOTERR ~ TRUE; + GO TO EOF; +RATA: XTA ~ NAME; FLOG(0); +XIT: +END ACTIONLABELS; +IF DEBUGTOG THEN FLAGROUTINE(" IOCOM","MAND ",TRUE ); +EODS~N!7 ; +C2 ~ IF N = 0 OR N = 7 THEN 1 ELSE 0; +SCAN; IF NEXT = SEMI THEN BEGIN FLOG(0); GO TO XIT END; +IF N = 7 THEN +BEGIN DATATOG ~ TRUE; + IF LOGIFTOG THEN FLAG(101); + LABL ~ BLANKS; + IF SPLINK } 0 THEN %NOT BLOCK DATA STMT + BEGIN + IF DATAPRT=0 THEN BEGIN + DATAPRT~PRTS~PRTS+1; ADJUST; + DATASTRT~(ADR+1)&NSEG[TOSEGNO] END + ELSE FIXB(DATALINK); + EMIT0PDCLIT(DATAPRT); EMIT0(LNG); + EMITB(-1, TRUE); DATAB ~ LAX; + END; + GO TO DAAT; +END; + EXECUTABLE; +EMIT0(MKS); +IF N = 4 THEN +BEGIN + INLINEFILE; + BEGIN EMITL(0); EMITL(0); EMITL(0); EMITL(0); + EMITL(5); EMITL(0); EMITL(0); + EMITV(NEED(".FBINB",INTRFUNID)); + END; + GO TO XIT; +END; +EDITCODE ~ NX1 ~ NX1 ~ 0; +IF RDTRIN ~ + N = 0 THEN IF NEXT = LPAREN THEN GO TO SUCH + ELSE EMITDESCLIT(FILECHECK(".5 ",2+17|REAL %503- + (REMOTETOG))) +ELSE IF N = 1 THEN IF NEXT ! LPAREN THEN FLAG(33) + ELSE GO TO SUCH + ELSE IF N = 2 THEN %503- + EMITDESCLIT(FILECHECK(".6 ",2+17|REAL %503- + (REMOTETOG))) + ELSE EMITDESCLIT(FILECHECK(".PUNCH",0)); +IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); +GO TO FORMER; +SUCH: SCAN; RANDOMTOG~SUCHTOG~TRUE; INLINEFILE ; + RANDOMTOG~FREEREAD~FALSE ; + IF NEXT = EQUAL THEN % RANDOM KEY + BEGIN SCAN; + IF EXPR(TRUE) > REALTYPE THEN FLAG(102); + IF RDTRIN THEN EMITPAIR(1,ADD); + END ELSE IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); + IF NEXT = RPAREN THEN GO TO NF; + IF NEXT ! COMMA THEN BEGIN FLOG(114); GO TO XIT END; + SCAN; + IF NEXT = ID THEN + IF NAME = "ERR " OR NAME = "END " THEN + BEGIN ACTIONLABELS(FALSE); + NF: IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); + EMITL(0); + NOFORMT ~ TRUE; + SCAN; GO TO NOFORM; + END; +FORMER: IF ADR } 4085 THEN + BEGIN ADR ~ ADR+1; SEGOVF END; + IF NEXT = NUM THEN % FORMAT NUMBER + BEGIN EDITCODE ~ 1; + IF TEST ~ LBLSHFT(NAME) { 0 THEN + BEGIN FLAG(135); GO TO LISTER END; + IF I ~ SEARCH(TEST) = 0 THEN % NEVER SEEN + OFLOWHANGERS(I~ENTER(0&FORMATID[TOCLASS], TEST)) ELSE + IF GET(I).CLASS ! FORMATID THEN + BEGIN FLAG(143); GO TO LISTER END; + IF XREF THEN ENTERX(TEST,0&FORMATID[TOCLASS]); + IF GET(I).ADDR = 0 THEN + BEGIN EMITLINK((INFC ~ GET(I + 2)).BASE); + PUT(I + 2,INFC&ADR[TOBASE]); + EMITL(0); EMITL(0); EMIT0(NOP); + END ELSE + BEGIN EMITL(GET(I+ 2).BASE); + EMITPAIR(GET(I),ADDR.LOD); + END; + GO TO LISTER; +END ELSE IF RDTRIN THE IF(FREEREAD := NEXT=SLASH) THE GO TO LISTER +ELSE BEGIN IF NEXT NEQ ID THEN BEGIN FLOG(116);GO TO XIT; END;END + ELSE IF NEXT NEQ ID THEN + BEGIN IF NEXT = STAR THEN + BEGIN NAMEDESC := TRUE; GLOBALNAME := TRUE; + TV := ENTER(0&LISTSID[TOCLASS],LISTID:=LISTID+1); + SCAN; + END; + IF NEXT = LPAREN THEN + BEGIN SCAN; IF EXPR(TRUE) GTR REALTYPE THEN FLAG(120) ; + SCAN; END ELSE EMITL(0); + IF GLOBALNAME AND (FREEREAD := NEXT = SLASH) OR FREEREAD THEN + GO TO LISTER ELSE BEGIN FLOG(110); GO TO XIT; END; + END; + GETALL(I ~ FNEXT,INFA,INFB,INFC); + IF T ~ INFA.CLASS = ARRAYID THEN % FORMAT ARRAY + BEGIN EDITCODE ~ 1; + FORMARY ~ TRUE; + T ~ EXPR(FALSE); + ADR ~ ADR-1; % ELIMINATE XCH EMITTED BY EXPR + IF EXPRESULT ! ARRAYID THEN FLOG(116); + GO TO LISTER1; % SCAN ALREADY DONE IN EXPR + END ELSE + IF T = NAMELIST THEN + BEGIN NAMETOG := TRUE; + IF INFA.ADDR = 0 THEN % REFERENCED, NOT DEF + BEGIN EMITLINK(INFC.BASE); + PUT(I+ 2,(INFC ~ INFC&ADR[TOBASE])); + EMITL(0); EMITL(0); EMIT0(NOP); + END ELSE + BEGIN EMITL(INC.BASE); + EMITPAIR(INFA.ADDR,LOD); + END + END + ELSE IF T = UNKNOWN THEN % ASSUME NAMELIST + BEGIN PUT(I,(INFA ~ INFA&NAMELIST[TOCLASS])); + NAMETOG := TRUE; + OFLOWHANGERS(I); + EMITLINK(0); PUT(I + 2,INFC&ADR[TOBASE]); + EMITL(0); EMITL(0); EMIT0(NOP); + END ELSE BEGIN XTA ~ INFB; FLOG(116); GO TO XIT END; + SCAN; + IF NEXT = COMMA THEN ACTIONLABELS(TRUE); + IF SUCHTOG THEN + IF NEXT ! RPAREN THEN FLOG(108) ELSE SCAN; + IF NEXT ! SEMI THEN BEGIN FLOG(118); GO TO XIT END; + EMITL(0); EDITCODE ~ 4; EMIT0PDCLIT(7); EMIT0(FTC); + GO TO WRAP; +LISTER: SCAN; + IF FREEREAD THEN IF NOT RDTRIN THEN + BEGIN IF NEXT ! SLASH THEN EMIT0(SSN) ELSE SCAN; + IF NEXT = LPAREN THEN + BEGIN SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(120);SCAN + END ELSE EMITL(0); + END; +LISTER1: + IF SUCHTOG THEN + BEGIN IF NEXT = COMMA THEN ACTIONLABELS(TRUE); + IF NEXT = RPAREN THEN SCAN ELSE BEGIN FLOG(108); GO TO XIT END; + END ELSE IF NEXT=COMMA THEN SCAN ELSE IF RDTRIN THEN + IF NEXT!SEMI THEN FLOG(114); +NOFORM: IF NEXT=SEMI THEN + BEGIN IF FREEREAD THEN FLOG(061) ELSE EMITL(0); GO TO WRAP END; + IF (NEXT NEQ LPAREN) AND (NEXT NEQ ID) AND (NEXT NEQ STAR) THEN + GO TO XIT; + EDITCODE ~ EDITCODE + 2; +DAAT: EMITB(-1,FALSE); LADR1 ~ LAX; ADJUST; DESCREQ ~ TRUE; + IF ADR } 4085 THEN + BEGIN ADR ~ ADR+1; SEGOVF; ADJUST END; + ACCIDENT ~ PRGDESCBLDR(0,0,ADR.[36:10] + 1,NSEG); + EMIT0PDCLIT(19); EMIT0(GFW); + LISTART ~ ADR&NSEG[TOSEGNO]; ADJUST; + LA ~ 0; IOLIST(LA); + EMITL(1); EMIT0(CHS); EMITL(19); EMIT0(STD); + EMITDESCLIT(19; EMIT0(RTS); + FIXB(LADR1); DESCREQ ~ FALSE; + IF DATATOG THEN + BEGIN DATASET; + IF NEXT = SLASH THEN SCAN ELSE + BEGIN FLOG(110); GO TO XIT END; + IF LSTA = 0 THEN BEGIN BUMPPRT; LSTA~PRTS END; + IF (LSTMAX - LSTI) { LSTS THEN + BEGIN WRITEDATA(LSTI,NXAVIL ~ NXAVIL + 1,LSTP); + LSTA ~ PRGDESCBLDR(1,LSTA,0,NXAVIL); + LSTI ~ 0; BUMPPRT; LSTA~PRTS; + END; + MOVEW(LSTT,LSTP[LSTI],(LSTS ~ LSTS + 1).[36:6],LSTS); + EMIT0(MKS); EMITL(LSTI); EMITPAIR(LSTA,LOD); + LSTI ~ LSTI + LSTS; + EMITPAIR(ACCIDENT,LOD); EMIT0PDCLIT(7); EMIT0(FTF); + EMITL(6); EMITL(0); EMITL(0); + EMITV(NEED(".FBINB",INTRFUNID)); + IF NEXT = COMMA THEN + BEGIN SCAN; GO TO DAAT END; + IF SPLINK } 0 THEN BEGIN + EMITB(-1,FALSE); DATALINK~LAX; + FIXB(DATAB) END; + GO TO XIT; + END; + EMITPAIR(ACCIDENT,LOD); EMIT0PDCLIT(7); EMIT0(FTF); +WRAP: IF NOT FREEREAD AND NOT NAMETOG THEN EMITL(EDITCODE); +IF RDTRIN THEN +BEGIN IF NX1 = 0 THEN EMITL(0) ELSE EMITLABELDESC(NX1); + IF NX2 = 0 THEN EMITL(0) ELSE EMITLABELDESC(NX2); + IF FREEREAD THEN EMITV(NEED(".FREFR", INTRFUNID)) + ELSE IF NAMETOG THEN EMITV(NEED(".FINAM",INTRFUNID)) + ELSE IF FORMARY THEN EMITV(NEED(".FTINT",INTRFUNID)) + ELSE IF NOFORMT THEN EMITV(NEED(".FBINB",INTRFUNID)) + ELSE EMITV(NEED(".FTNIN",INTRFUNID)); +END ELSE +IF FREEREAD THEN + BEGIN + IF NAMEDESC THEN + BEGIN + PRTSAVER(TV,NAMEIND+1,NAMLIST); + EMITL(GET(TV+2).BASE); + EMITPAIR(GET(TV).ADDR,LOD); + IF NAMELIST[0] = 0 THEN EMITL(0) + ELSE EMITPAIR(GET(GLOBALSEARCH(".SUBAR")).ADDR,LOD); + NAMLIST[0] := NAMEIND := 0; + END ELSE BEGIN EMITL(0);EMITL(0);EMITL(0);END; + EMITV(NEED(".FREWR",INTRFUNID)) + END ELSE IF NAMETOG THEN EMITV(NEED(".FONAM",INTRFUNID)) + ELSE IF FORMARY THEN EMITV(NEED(".FTOUT",INTRFUNID)) + ELSE BEGIN + IF NX1=0 THEN EMITL(0) ELSE EMITLABELDESC(NX1); + IF NX2=0 THEN EMITL(0) ELSE EMITLABELDESC(NX2); + IF NOFORMT THEN EMITV(NEED(".FBINB",INTRFUNID)) ELSE + EMITV(NEED(".FTNOU",INTRFUNID)); + END; +XIT: + IF NAMEDESC THEN IF RDTRIN THEN FLAG(159) + ELSE IF NOT FREEREAD THEN FLAG(160); + DATATOG := FALSE; NAMEDESC := FALSE; GLOBALNAME := FALSE; +IF DEBUGTOG THEN FLAGROUTINE(" IOCOM","MAND ",FALSE); +END IOCOMMAND; +PROCEDURE STMTFUN(LINK); VALUE LINK; REAL LINK; +BEGIN + DEFINE PARAM = LSTT#; + REAL SAVEBRAD, I; + REAL INFA, INFC, NPARMS, TYPE, PARMLINK, BEGINSUB, RETURN; + LABEL XIT,TIX ; + IF SPLINK < 0 THEN FLAG(12); + LABL ~ BLANKS; + FILETOG ~ TRUE; % PREVENTS SCANNER FROM ENTERING IDS IN INFO + IF XREF THEN ENTERX(GET(LINK+1),0&STMTFUNID[TOCLASS] + &(GET(LINK))[21:21:3]); + DO + BEGIN + SCAN; + IF NEXT ! ID THEN BEGIN FLOG(107); GO TO XIT END; + PARAM[NPARMS~NPARMS+1] ~ NAME; + SCAN; + END UNTIL NEXT ! COMMA; + IF NEXT ! RPAREN THEN FLOG(108) ELSE SCAN; + IF NEXT ! EQUAL THEN BEGIN FLOG(104); GO TO XIT END; + EMITB(-1,FALSE); SAVEBRAD ~ LAX; % BRANCH AROUND ST FUN + ADJUST; + BEGINSUB ~ ADR+1; + BUMPLOCALS; EMITPAIR(RETURN~LOCALS+1536,STD); + FOR I ~ NPARMS STEP -1 UNTIL 1 DO + BEGIN + IF T ~ SEARCH(PARAM[I]) ! 0 THEN + TYPE ~ GET(T).SUBCLASSE ELSE + IF T~PARAM[I].[12:6] < "I" OR T > "N" THEN + TYPE ~ REALTYPE ELSE TYPE ~ INTYPE; + EMITSTORE( ENTER(0&VARID[TOCLASS]&1[TOTYPF] + &TYPE[TOSUBCL], PARAM[I]), TYPE); + IF XREF THEN ENTERX(NAME,0&VARID[TOCLASS]&TYPE[TOSUBCL]); + END; + PARMLINK ~ NEXTINFO-3; + GETALL(LINK, INFA, XTA, INFC); + FILETOG ~ FALSE; + SCAN; + IF (TYPE~(INFA~GET(LINK)).SUBCLASS)=LOGTYPE OR TYPE=COMPTYPE OR + (I~EXPR(TRUE))=LOGTYPE OR I=COMPTYPE THEN + BEGIN IF I!TYPE THEN FLAG(139); GO TIX END ; + IF TYPE=REALTYPE OR TYPE=INTYPE THEN + BEGIN + IF I=DOUBTYPE THEN BEGIN EMIT0(XCH); EMIT0(DEL) END; + IF TYPE=INTYPE THEN IF I!INTYPE THEN EMITPAIR(1,IDV) ; + GO TIX ; + END ; + IF I!DOUBTYPE THEN EMITPAIR(0,XCH) ; +TIX: + EMIT0PDCLIT(RETURN) ; + EMIT0(GFW); + FIXB(SAVEBRAD); + IF INFA.CLASS ! UNKNOWN THEN FLAG(140); + PUT(LINK, -INFA & 1[TOTYPF] & NSEG[TOSEGNO] + & STMTFUNID[TOCLASS] & BEGINSUB[TOADDR]); + PUT(LINK+2, -(0 & NPARMS[TONEXTRA] & ADR[TOBASE] + & PARMLINK[36:36:12])); + PARMLINK ~ PARMLINK+4; + FOR I ~ 1 STEP 1 UNTIL NPARMS DO + PUT(PARMLINK ~ PARMLINK-3, "......"); + XIT: + FILETOG ~ FALSE; +END STMTFUN; +PROCEDURE ASSIGNMENT; +BEGIN + LABEL XIT; +BOOLEAN CHCK; +BOOLEAN I; +IF DEBUGTOG THEN FLAGROUTINE(" ASSIG","NMENT ",TRUE ) ; + FX1 ~ FNEXT; + SCAN; + IF NEXT = LPAREN THEN + BEGIN +CHCK~TRUE; + IF GET(FX1).CLASS = UNKNOWN THEN + IF EODS THEN + BEGIN XTA ~ GET(FX1+1); FLOG(035) ; + PUT(FX1,GET(FX1) & ARRAYID[TOCLASS]) ; + PUT(FX1+2,GET(FX1+2) & 1[TONEXTRA]) ; + END + ELSE BEGIN STMTFUN(FX1); GO TO XIT END ; + IF XREF THEN ENTERX(GET(FX1+1),1&GET(FX1) [15:15:9]); + EODS ~ TRUE ; + EXECUTABLE; + SCAN; + I ~ SUBSCRIPTS(FX1,2); + SCAN; + END ELSE + BEGIN + EODS~TRUE ; + EXECUTABLE; + IF T ~ GET(FX1).CLASS = ARRAYID THEN + BEGIN XTA ~ GET(FX1+1); FLAG(74) END; + MOVEW(ACCUM[1],HOLDID[0],0,3); + IF XREF THEN IF HOLDID[0].[12:12] ! "DO" THEN + ENTERX(GET(FX1+1),1&GET(FX1)[21:21:3]&VARID[TOCLASS]); + END; + IF NEXT ! EQUAL THEN BEGIN FLAG(104); GO TO XIT END; + SCAN; + IF NEXT=SEMI OR NEXT=COMMA THEN BEGIN FLOG(0); GO TO XIT; END; + FX2 ~ EXPR(TRUE); + IF NEXT NEQ COMMA THEN IF HOLDID[0] = "DO" THEN IF XREF THEN + ENTERX(HOLDID[0] ,1&GET(FX1)[21:21:3]&VARID[TOCLASS]); + IF NEXT = COMMA THEN IF CHCK THEN FLOG(56) ELSE + IF HOLDID[0].[12:12] ! "DO" THEN FLOG(56) ELSE + BEGIN + IF LOGIFTOG THEN FLAG(101); + IF FX2 > REALTYPE THEN FLAG(102); + IF DT ~ DT+1 > MAXDOS THEN BEGIN DT ~ 1; FLAG(138) END; + EMITN(FX1~ CHECKDO); + EMIT0(STD); + SCAN; + IF NEXT=SEMI THEN BEGIN FLAG(36); GO TO XIT END; + IF (ACCUM[0] = ", " OR ACCUM[0] = "; ") AND + GLOBALNEXT=NUM AND ABS(FNEXT) > 1023 THEN + BEGIN + IF EXPR(TRUE) > REALTYPE THEN FLAG(102); + IDINFO:=REALID;FNEXT:=ENTER(IDINFO,"2FNV00"&DT[36:36:12]); + EMITN(FNEXT:=GETSPACE(FNEXT)); EMIT0(STD); + EMITB(-1,FALSE); LADR1:=LAX; ADJUST; + LADR2 ~ (ADR+1) & NSEG[TOSEGNO]; EMITV(FNEXT); + END + ELSE BEGIN + EMITB(-1,FALSE); LADR1:=LAX; ADJUST; + LADR2:=(ADR+1)&NSEG[TOSEGNO]; + IF EXPR(TRUE) > REALTYPE THEN FLAG(102) ; + END ; + EMIT0(GRTR); + EMITB(-1, TRUE); + LADR3 ~ LAX; + EMITB(-1, FALSE); + ADJUST; + DOTEST[DT] ~ (ADR+1) & LAX[TOADDR] & NSEG[TOSEGNO]; + IF NEXT ! COMMA THEN EMITL(1) ELSE + BEGIN + SCAN; + IF NEXT=SEMI THEN BEGIN FLAG(36); GO TO XIT END ; + IF EXPR(TRUE) > REALTYPE THEN FLAG(102); + END; + EMITV(FX1); + EMIT0(ADD); + EMITN(FX1); + EMIT0(STN); + EMITB(LADR2, FALSE); + FIXB(LADR1); + FIXB(LADR3); + END ELSE EMITSTORE(FX1, FX2); + XIT: +IF DEBUGTOG THEN FLAGROUTINE(" ASSIG","NMENT ",FALSE ) ; +END ASSIGNMENT; +BOOLEAN PROCEDURE RINGCHECK; +COMMENT THIS PROCEDURE PREVENTS THE POSSIBILITY OF DELINKING A + HEADER FROM THE HEADER RING; + BEGIN + INTEGER I; + I~A; + DO + IF I ~ GETC(I).ADDR = ROOT THEN RINGCHECK ~ TRUE + UNTIL I = A; + END RINGCHECK; +PROCEDURE SETLINK(INFADDR); VALUE INFADDR; INTEGER INFADDR; +COMMENT THIS PROCEDURE LINKS AN ELEMENT TO ITS PREVIOUS HEADER; +BEGIN + INTEGER LAST,I; REAL COML; LABEL XIT; +XIT: + LAST ~(GETC(INFADDR).LASTC)-1; + FOR I ~ INFADDR+2 STEP 1 UNTIL LAST + DO BEGIN IF GETC(I).CLASS = ENDCOM THEN I~GETC(I).LINK; + IF FX1 = (COML~GETC(I)).LINK THEN + IF INFADDR~COML.LASTC=A THEN COM[PWI].LASTC~ROOT + ELSE GO XIT ; + END; +END SETLINK; +PROCEDURE DIMENSION; +BEGIN + LABEL L, LOOP, ERROR ; + BOOLEAN DOUBLED, SINGLETOG; %109- +IF DEBUGTOG THEN FLAGROUTINE(" DIMEN","SION ",TRUE ) ; + IF LOGIFTOG THEN FLAG(101); + LABL ~ BLANKS; + IF NEXT=STAR THEN IF TYPE!DOUBTYPE THEN + BEGIN + SCAN ; + IF NEXT=SUM AND NUMTYPE=INTYPE THEN + BEGIN + IF FNEXT=4 THEN + BEGIN + SINGLETOG ~ TRUE; %109- + IF TYPE=COMPTYPE THEN FLAG(176); GO L ; + END ; + IF FNEXT=8 THEN + BEGIN + IF TYPE=REALTYPE THEN TYPE~DOUBTYPE + ELSE IF TYPE!COMPTYPE THEN FLAG(177) ; + GO L ; + END ; + END ; + FLAG(IF TYPE=REALTYPE THEN 178 + ELSE 177-REAL(TYPE=COMPTYPE)) ; +L: NCR~REAL(NCR.[30:3]!0)+3"677777"+NCR; SCN~1; SCAN ; + END ; + LOOP: DOUBLED~FALSE; + IF NEXT ! ID THEN BEGIN FLOG(105); GO TO ERROR END; + FX1 ~ IF SINGLETOG THEN -FNEXT ELSE FNEXT; %109- + IF TYPE } DOUBTYPE THEN % FIX ARRAY TYPE OFR + PUT(FX1,GET(FX1)&TYPE[TOSUBCL]); % BOUNDS ROUTINE + IF XREF THEN BEGIN INFA ~ 0&GET(FX1)[15:15:9]; + IF TYPE>0 THEN INFA.SUBCLASS~TYPE; + END; + XTA ~ INFB ~ NAME; + SCAN; + IF XREF THEN + BEGIN IF INFA.CLASS = UNKWOWN THEN + INFA.CLASS~IF NEXT=LPAREN THEN ARRAYID ELSE VARID; + ENTERX(INFB,INFA); + END; + IF NEXT=LPAREN THEN BEGIN SCAN; DOUBLED~BOUNDS(FX1) END ELSE + IF TYPE = -1 THEN FLOG(103); + GETALL(FX1, INFA, XTA, INFC); + IF TYPE > 0 THEN + IF BOOLEAN(INFA.TYPEFIXED) THEN FLAG(31) ELSE + BEGIN + IF TYPE > LOGTYPE THEN + IF GET(FX1+2) <0 THEN + BEGIN + IF NOT DOUBLED AND INFA.CLASS=1 THEN + BEGIN + BUMPLOCALS; + LENGTH~LOCALS + 1536; + PUT(FX1+2,INFC & LENGTH[TOSIZE]); + END + END ELSE IF NOT DOUBLED THEN + BEGIN IF INFC.SIZE > 16383 THEN FLAG(99); + PUT(FX1+2,INFC & (2 | INFC.SIZE)[TOSIZE]); + END; + PUT (FX1,INFA & 1[TOTYPE] & TYPE[TOSUBCL]); + END; + IF INFA < 0 THEN FLAG(39) ELSE + IF TYPE = -2 THEN + BEGIN + BAPC(INFA&FX1[TOLINK]&1[TOCE]&ROOT[TOLASTC]); + IF BOOLEAN(INFA.CE) THEN FLAG(2); + IF BOOLEAN(INFA.EQ) THEN + BEGIN + COM(NEXTCOM.IR,NEXTCOM.IC].LASTC ~ A ~ INFA.ADDR; + B~GETC(ROOT).ADDR ; + SETLINK(A); + IF NOT RINGCHECK THEN + BEGIN + COM[PWROOT].ADDR~GETC(A).ADDR ; + PUTC(A,GETC(A)&B[TOADDR]&7[TOSUBCL]) ; + END + END ELSE + PUT(FX1, INFA & 1[TOCE] & ROOT[TOADDR]); + IF BOOLEAN(INFA.FORMAL) THEN FLAG(10); + END; + IF ERRORTOG THEN + ERROR: + WHILE NEXT ! COMMA AND NEXT ! SEMI AND NEXT ! SLASH DO SCAN; + IF NEXT = COMMA THEN BEGIN SCAN; GO TO LOOP END; +IF DEBUGTOG THEN FLAGROUTINE(" DIMEN","SION ",FALSE ); +END DIMENSION; +PROCEDURE FORMALPP(PARMSREQ, CLASS); VALUE PARMSREQ, CLASS; + BOOLEAN PARMSREQ; REAL CLASS; +BEGIN + LABEL LOOP, XIT; +IF DEBUGTOG THEN FLAGROUTINE(" FORM","ALPP ",TRUE ) ; + PARMS ~ 0; + SCAN; + IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; + IF CLASS = FUNID THEN + IF FUNVAR = 0 THEN + BEGIN + IF TYPE > 0 THEN + IF FUNVAR ~ GLOBALSEARCH(NAME) ! 0 THEN + IF BOOLEAN((T ~ GET(FUNVAR)).TYPEFIXED) AND TYPE ! T.SUBCLASS + THEN FLAG(31); + PUT(FUNVAR ~ FNEXT,GET(FNEXT) & VARID[TOCLASS]); + END; + FNEW ~ NEED(NNEW ~ NAME, CLASS); + ENTERX(NAME,IF CLASS = FUNID THEN + 1&GET(FNEW)[15:15:9] ELSE 1&GET(FNEW)[15:15:5]); + SCAN; + IF NEXT ! LPAREN THEN + IF PARMSREQ THEN FLOG(106) ELSE ELSE + BEGIN + LOOP: + SCAN; + IF NEXT = ID THEN PARMLINK[PARMS ~ PARMS+1] ~ FNEXT ELSE + IF NEXT=STAR AND CLASS!FUNID THEN PARMLINK[PARMS~PARMS+1]~0ELSE + FLOG(107); + IF XREF THEN ENTERX(NAME,IF NEXT = STAR THEN 0 ELSE + 0&GET(FNEXT)[15:15:9]); + SCAN; + IF NEXT = COMMA THEN GO TO LOOP; + IF NEXT ! RPAREN THEN FLOG(108); + SCAN; + END; + IF NOT ERRORTOG THEN DECLAREPARMS(FNEW); + XIT: +IF DEBUGTOG THEN FLAGROUTINE(" FORM","ALPP ",FALSE) ; +END FORMALPP; + +PROCEDURE ENDS; FORWARD; + +PROCEDURE FUNCTION ; +BEGIN + REAL A,B,C,I; LABEL FOUND ; + IF SPLINK NEQ 0 THEN BEGIN FLAG(5); ENDS; SEGMENTSTART; END; + LABL ~ BLANKS; + FORMALPP(TRUE, FUNID); + GETALL(FNEW, INFA, INFB, INFC); + B~NUMINTM1 ; + WHILE A+1SUPERMAXCOM THEN + BEGIN ROOT~0; FATAL(124) END + ELSE ROOT~NEXTCOM ; + PUTC(ROOT,0&HEADER[TOCLASS]&1[TOCE]&ROOT[TOADDR]) ; + BAPC(Z); + END ELSE + BEGIN + ROOT ~ T.ADINFO; + COM[(T~GETC(ROOT).LASTC).IR,T.IC].LINK~NEXTCOM+1 ; + IF COM[PWROOT]<0 THEN FLAG(2) ; + END; + DIMENSION; + BAPC(0&ENDCOM[TOCLASS]) ; + COM[PWROOT].LASTC~NEXTCOM ; + PUT(T~GETC(ROOT+1)+2,GET(T)&ROOT[TOADINFO]) ; + IF NEXT ! SEMI THEN GO TO LOOP; +END COMMON; +PROCEDURE ENDS; +BEGIN + IF SPLINK=0 THEN FLAG(184) ELSE %112- + BEGIN %112- + EODS~FALSE ; + IF LOGIFTOG THEN FLAG(101); + LABL ~ BLANKS; + IF SPLINK < 0 THEN EMIT0(XIT) ELSE EMITPAIR(0, KOM); + SEGMENT((ADR+4) DIV 4, NSEG, TRUE, EDOC); + END; %112- +END ENDS; +PROCEDURE ENTRY; +BEGIN + REAL SP; + IF SPLINK = 0 THEN FLAG(111) ELSE + IF SPLINK = 1 THEN BEGIN ELX ~ 0; FLAG(4) END; + LABL ~ BLANKS; + ADJUST ; + SP ~ GET(SPLINK); + FORMALPP( (T~SP.CLASS) = FUNID, T); + GETALL(FNEW, INFA, INFB, INFC); + IF INFA.CLASS = FUNID THEN + PUT(FNEW, INFA & 1[TOTYPF] & (SP.SUBCLASS)[TOSUBCL]); + PUT(FNEW+2, INFC & (ADR+1)[TOBASE]); +END ENTRY; +PROCEDURE EQUIVALENCE; +COMMENT THIS PROCEDURE MAKES THE COM ENTRY FOR EQUIV ITEMS AND SETS + THE EQ BIT IN BOTH THE COM AND INFO TABLES AND LINKS + THE HEADS OF CHAINS; +BEGIN + REAL P, Q, R, S; + BOOLEAN FIRST,PCOMM; + LABEL XIT; + IF LOGIFTOG THE FLAG(101); + LABL ~ BLANKS; + DO + BEGIN + FIRST ~ FALSE; + SCAN; + IF NEXT ! LPAREN THEN BEGIN FLOG(106); GO TO XIT END; + IF NEXTCOM~NEXTCOM+1>SUPERMAXCOM THEN + BEGIN ROOT~0; FATAL(124) END + ELSE ROOT~NEXTCOM ; + PUTC(ROOT,0&HEADER[TOCLASS]&ROOT[TOADDR]) ; + BAPC(0); Q~0 ; + DO + BEGIN + SCAN; + IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; + IF XREF THEN ENTERX(NAME,0&GET(FNEXT)[15:15:9]); + FX1 ~ FNEXT; + LENGTH ~ 0; + SCAN; + IF NEXT = LPAREN THEN + BEGIN + IF GET(FX1).CLASS ! ARRAYID THEN + BEGIN XTA ~ GET(FX1+1); FLOG(112) END; + R ~ 0; P ~ 1; + S ~ GET(FX1+2).ADINFO; + DO + BEGIN + SCAN; + IF NEXT ! NUM OR NUMTYPE ! INTYPE THEN FLAG(113); + LENGTH ~ LENGTH + P|(FNEXT-1); + P ~ P|EXTRAINFO[(S+R).IR,(S+R).IC] ; + R ~ R-1; + SCAN; + END UNTIL NEXT ! COMMA; + IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; + IF R!-1 THEN IF R~R+GET(FX1+2).NEXTRA!0 THEN + BEGIN XTA~GET(FX1+1); FLAG(IF R>0 THEN 23 ELSE 24) END ; + SCAN; + END; + IF INFA.SUBCLASS > LOGTYPE THEN LENGTH ~ 2|LENGTH ; + BAPC(INFA&FX1[TOLINK]&LENGTH[TORELADD]&1[TOEQ]&ROOT[TOLASTC]); + IF(PCOMM~BOOLEAN(INFA.CE)) OR BOOLEAN(INFA.EQ) THEN + BEGIN + IF FIRST AND PCOMM THEN BEGIN XTA~GET(FX1+1); FLAG(2) END + ELSE IF NOT FIRST THEN FIRST ~ PCOMM; + PUT(FX1,INFA & 1[TOEQ]); + COM[NEXTCOM.IR,NEXTCOM.IC].LASTC ~ A ~ INFA.ADDR; + B~GETC(ROOT).ADDR ; + SETLINK(A); + IF NOT RINGCHECK THEN + BEGIN + COM[PWROOT].ADDR~GETC(A).ADDR ; + PUTC(A,GETC(A)&B[TOADDR]&7[TOSUBCL]) ; + END + END ELSE + PUT(FX1,INFA & 1[TOEQ] & ROOT[TOADDR]); + IF LENGTH > Q THEN Q ~ LENGTH; + IF BOOLEAN(INFA.FORMAL) THEN + BEGIN XTA ~ GET(FX1+1); FLAG(11) END; + END; + END UNTIL NEXT ! COMMA; + IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; + SCAN; + PUTC(ROOT+1,Q); + BAPC(0&ENDCOM[TOCLASS]) ; + COM[PWROOT].LASTC~NEXTCOM ; + END UNTIL NEXT ! COMMA; + XIT: +END EQUIVALENCE; +PROCEDURE EXTERNAL; +BEGIN + IF SPLINK < 0 THEN FLAG( 12); + IF LOGIFTOG THEN FLAG(101); + LABL ~ BLANKS; + DO + BEGIN + SCAN; + IF NEXT ! ID THEN FLOG(105) ELSE + BEGIN T ~ NEED(NAME,EXTID); + IF XREF THEN ENTERX(NAME,0&GET(T)[15:15:9]); + SCAN; + END; + END UNTIL NEXT ! COMMA; +END EXTERNAL; +PROCEDURE CHAIN; +BEGIN + LABEL AGN, XIT; + REAL T1; + DEFINE FLG(FLG1) = BEGIN FLOG(FLG1); GO TO XIT END#; + EXECUTABLE; + SCAN; + T1 ~ 2; + IF FALSE THEN + AGN: IF GLOBALNEXT ! COMMA THEN FLG(28); + SCAN; + IF EXPR(TRUE) > REALTYPE THEN FLG(102); + IF (T1 ~ T1 - 1) ! 0 THEN GO TO AGN; + IF GLOBALNEXT ! RPAREN THEN FLG(3); + EMITPAIR(37,KOM); + SCAN; + IF GLOBALNEXT ! SEMI THEN FLOG(117); + XIT: WHILE GLOBALNEXT ! SEMI DO SCAN; +END CHAIN; +PROCEDURE GOTOS; +BEGIN LABEL XIT; + REAL ASSIGNEDID; + EODS~TRUE ; + EXECUTABLE; + SCAN; + IF NEXT = NUM THEN + BEGIN + LABELBRANCH(NAME, FALSE); + SCAN; + GO TO XIT; + END; + IF NEXT = ID THEN + BEGIN + ASSIGNEDID ~ FNEXT; + IF XREF THEN ENTERX(XTA,0&GET(FNEXT)[15:15:9]); + SCAN; + IF NEXT ! COMMA THEN FLOG(114); + SCAN; + IF NEXT ! LPAREN THEN FLOG(106); + DO + BEGIN + SCAN; + IF NEXT ! NUM THEN FLOG(109); + EMITV(ASSIGNEDID); + EMITNUM(FNEXT); + EMIT0(NEQL); + LABELBRANCH(NAME, TRUE); + SCAN; + END UNTIL NEXT ! COMMA; + IF NEXT ! RPAREN THEN FLOG(108); + SCAN; + EMITPAIR(1, SSN); % CAUSE INVALID INDEX TERMINATION + EMITDESCLIT(10); + GO TO XIT; + END; + IF NEXT ! LPAREN THEN FLOG(106); + P ~ 0; + DO + BEGIN + SCAN; + IF NEXT ! NUM THEN BEGIN FLOG(109); GO TO XIT END; + LSTT[P~P+1] ~ NAME; + SCAN; + END UNTIL NEXT ! COMMA; + IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; + SCAN; + IF NEXT ! COMMA THEN BEGIN FLOG(114); GO TO XIT END; + SCAN; + IT ~ P+1; % DONT LET EXPR WIPE OUT LSTT + IF EXPR(TRUE) > REALTYPE THEN FLOG(102); + EMITPAIR(JUNK, ISN); + EMITPAIR(1,LESS); + EMIT0PDCLIT(JUNK); + EMIT0(LOR); + EMIT0PDCLIT(JUNK); + EMITL(3); + EMIT0(MUL); + IF ADR+3|P > 4085 THEN BEGIN ADR~ADR+1; SEGOVF END; + EMIT0(BFC); + EMITPAIR(1, SSN); + EMITDESCLIT(10); + FOR I ~ 1 STEP 1 UNTIL P DO + BEGIN + J ~ ADR; LABELBRANCH(LSTT[I], FALSE); + IF ADR-J = 2 THEN EMIT0(NOP); + END; + XIT: + IT ~ 0; +END GOTOS; +PROCEDURE IFS; +BEGIN REAL TYPE, LOGIFADR, SAVELABL; + EODS~TRUE; + EXECUTABLE; + SCAN; + IF NEXT ! LPAREN THEN FLOG(106); + SCAN; + IF TYPE ~ EXPR(TRUE) = COMPTYPE THEN FLAG(89); + IF NEXT ! RPAREN THEN FLOG(108); + IF TYPE = LOGTYPE THEN + BEGIN + EMITB(-1, TRUE); + LOGIFADR ~ LAX; + LOGIFTOG ~ TRUE; EOSTOG ~ TRUE; + SAVELABL ~ LABL; LABL ~ BLANKS; + STATEMENT; + LABL ~ SAVELABL; + LOGIFTOG ~ FALSE; EOSTOG ~ FALSE; + FIXB(LOGIFADR); + END ELSE + BEGIN + IF TYPE = DOUBTYPE THEN + BEGIN EMIT0(XCH); EMIT0(DEL) END; + SCAN; + IF NEXT ! NUM THEN FLOG(109); + FX1 ~ FNEXT; NX1 ~ NAME; + SCAN; + IF NEXT ! COMMA THEN FLOG(114); + SCAN; + IF NEXT ! NUM THEN FLOG(109); + FX2 ~ FNEXT; NX2 ~ NAME; + SCAN; + IF NEXT ! COMMA THEN FLOG(114); + SCAN; + IF NEXT ! NUM THEN FLOG(109); + FX3 ~ FNEXT; NX3 ~ NAME; + SCAN; + IF FX2 = FX3 THEN + BEGIN + EMITPAIR(0,GEQL); + LABELBRANCH(NX1, TRUE); + LABELBRANCH(NX3, FALSE); + IF XREF THEN ENTERX(NX2,0&LABELID[TOCLASS]); + END ELSE + IF FX1 = FX3 THEN + BEGIN + EMITPAIR(0,NEQL); + LABELBRANCH(NX2, TRUE); + LABELBRANCH(NX1, FALSE); + IF XREF THEN ENTERX(NX3,0&LABELID[TOCLASS]); + END ELSE + IF FX1 = FX2 THEN + BEGIN + EMITPAIR(0,LEQL); + LABELBRANCH(NX3, TRUE); + LABELBRANCH(NX1, FALSE); + IF XREF THEN ENTERX(NX2,0&LABELID[TOCLASS]); + END ELSE + BEGIN + EMIT0(DUP); + EMITPAIR(0,NEQL); + EMITB(-1,TRUE); + EMITPAIR(0,LESS); + LABELBRANCH(NX3, TRUE); + LABELBRANCH(NX1, FALSE); + FIXB(LAX); + EMIT0(DEL); + LABELBRANCH(NX2, FALSE); + END; + END; +END IFS; +PROCEDURE NAMEL; +BEGIN LABEL NIM,XIT,ELMNT,WRAP; + IF SPLINK < 0 THEN FLAG(12); + IF LOGIFTOG THEN FLAG(101); + LABL ~ BLANKS; + SCAN; IF NEXT ! SLASH THEN FLOG(110); +NIM: SCAN; IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; + IF J ~ (INFA ~ GET(LADR2 ~ FNEXT)).CLASS = UNKNOWN THEN + PUT(LADR2,INFA&NAMELIST[TOCLASS]) + ELSE IF J ! NAMELIST THEN + BEGIN XTA ~ GET(LADR2 + 1); + FLAG(20); + END; + LSTT[LSTS ~ LADR1 ~ 0] ~ NAME; + IF XREF THEN ENTERX(NAME,0&NAMELIST[TOCLASS]); + SCAN; IF NEXT ! SLASH THEN FLOG(110); +ELMNT: SCAN; IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; + LADR1 ~ LADR1 + 1; + IF (T ~ GET(FNEW ~ GETSPACE(FNEXT)).CLASS) > VARID THEN FLAG(48); + GETALL(FNEW,INFA,INFB,INFC); + IF XREF THEN ENTERX(INFB,0&INFA[15:15:9]); + IF LSTS ~ LSTS+1 = LSTMAX THEN BEGIN FLOG(78); GO TO XIT END ELSE + LSTT[LSTS] ~ NAME&INFA.CLASNSUB[2:38:10]&0[8:47:1]; + IF T = ARRAYID THEN + BEGIN J ~ INFC.ADINFO; + I ~ INFC.NEXTRA; + IF LSTS + I + 1 > LSTMAX THEN + BEGIN FLOG(78); GO TO XIT END; + LSTT[LSTS ~ LSTS + 1] ~ 0&I[1:42:6] % # DIMENSIONS + &INFA.ADDR[7:37:11] % REL ADR + &INFC.BASE[18:33:15] % BASE + &INFC.SIZE[33:33:15]; % SIZE + FOR T ~ J STEP -1 UNTIL J - I + 1 DO + LSTT[LSTS ~ LSTS + 1] ~ EXTRAINFO[T.IR,T.IC]; + END ELSE BEGIN LSTT[LSTS~LSTS+1]~0&(INFA.ADDR)[7:37:11]; + IF BOOLEAN(INFA.CE) THEN LSTT[LSTS]~LSTT[LSTS]&INFC.BASE[18:33:15] + &INFC.SIZE[33:33:15] END; + SCAN; IF NEXT = COMMA THEN GO TO ELMNT; + IF NEXT ! SEMI AND NEXT ! SLASH THEN FLOG(115); + LSTT[LSTS + 1] ~ 0; + LSTT[0].[2:10] ~ LADR1; + PRTSAVER(LADR2,LSTS + 2,LSTT); + IF NEXT ! SEMI THEN GO TO NIM; +XIT: +END NAMEL; +PROCEDURE PAUSE; +IF DCINPUT THEN BEGIN XTA~"PAUSE "; FLOG(151) END ELSE +BEGIN + EODS~TRUE ; + IF TSSEDITOG THE TSSED("PAUSE ",2) ; + EXECUTABLE; + SCAN; + IF NEXT = SEMI THEN EMITL(0) ELSE + IF NEXT = NUM THEN + BEGIN + EMITNUM(NAME); + SCAN; + END; + EMITPAIR(33, KOM); + EMIT0(DEL); +END PAUSE; +PROCEDURE TYPIT(TYP,TMPNXT); VALUE TYP; REAL TYP,TMPNXT ; + BEGIN + TYPF~TYP; SCAN ; + IF NEXT=16 THEN BEGIN TMPNXT~16; FUNCTION END ELSE DIMENSION ; + END OF TYPIT ; +DEFINE COMPLEX =TYPIT(COMPTYPE,TEMPNEXT) #, + LOGICAL =TYPIT(LOGTYPE ,TEMPNEXT) #, + DOUBLEPRECISION =TYPIT(DOUBTYPE,TEMPNEXT) #, + INTEGERS =TYPIT(INTYPE ,TEMPNEXT) #, + REALS =TYPIT(REALTYPE,TEMPNEXT) #; +PROCEDURE STOP; +BEGIN + RETURNFOUND ~ TRUE; + EODS~TRUE; + EXECUTABLE; + COMMENT INITIAL SCAN ALREADY DONE; + EMITL(1); + EMITPAIR(16,STD); + EMITPAIR(10, KOM); + EMITPAIR(5, KOM); + WHILE NEXT ! SEMI DO SCAN; +END STOP; +PROCEDURE RETURN; +BEGIN LABEL EXIT; + REAL T, XITCODE; + RETURNFOUND ~ TRUE; + EODS~TRUE ; + EXECUTABLE; + SCAN; + IF SPLINK=0 OR SPLINK=1 THEN + BEGIN XTA~"RETURN"; FLOG(153); GO EXIT END ; + IF NEXT = SEMI THEN + BEGIN + IF (T ~ GET(SPLINK)).CLASS = FUNID THEN + BEGIN + EMITV(FUNVAR); + IF T.SUBCLASS > LOGTYPE THEN EMITPAIR(JUNK, STD); + XITCODE ~ RTN; + END ELSE XITCODE ~ XIT; + IF ADR } 4077 THEN + BEGIN ADR ~ ADR+1; SEGOVF END; + EMIT0PDCLIT(1538); % F+2 + EMITPAIR(3, BFC); + EMITPAIR(10, KOM); + EMIT0(XITCODE); + EMIT0PDCLIT(16); + EMITPAIR(1, SUB); + EMITPAIR(16, STD); + EMIT0(XITCODE); + GO TO EXIT; + END; + IF LABELMOM = 0 THEN FLOG(145); + IF EXPR(TRUE) > REALTYPE THEN FLAG(102); + IF EXPRESULT = NUMCLASS THEN + BEGIN IF XREF THEN ENTERX(EXPVALUE,0&LABELID[TOCLASS]); + ADR ~ ADR-1;EMITL(EXPVALUE-1) + END ELSE + EMITPAIR(1, SUB); + EMIT0PDCLIT(LABELMOM); + EMIT0(MKS); + EMITL(9); + EMIT0PDCLIT(5); + EXIT: +END RETURN; +PROCEDURE IMPLICIT ; + BEGIN + REAL R1,R2,R3,R4 ; + LABEL R,A,X,L ; + IF NOT(LASTNEXT=42 OR LASTNEXT=1000 OR LASTNEXT=30 %110- + OR LASTNEXT=16 OR LASTNEXT = 11) %110- + THEN BEGIN FLOG(181); FILETOG~TRUE; GO X END ; +R: EOSTOG~ERRORTOG~TRUE; FILETOG~FALSE ; + MOVEW(ACCUM[3],ACCUM[2],0,3); SCAN; ERRORTOG~FALSE; FILETOG~TRUE ; + IF R1~IF R2~NEXT=18 THEN INTID ELSE IF R3=26 THEN REALID ELSE 0& + (IF R3=10 THEN DOUBTYPE ELSE IF R3=19 THEN LOGTYPE ELSE IF R3= + 6 THEN COMPTYPE ELSE 0)[TOSUBCL]=0 THEN + BEGIN FLOG(182); GO X END ; + SCN~2; SCAN ; + IF NEXT = STAR THEN IF R3!10 THEN + BEGIN SCAN ; + IF NEXT=NUM AND NUMTYPE=INTYPE THEN + BEGIN + IF FNEXT=4 THEN BEGIN IF R3=6 THEN FLAG(176); GO L END ; + IF FNEXT=8 THEN + BEGIN + IF R3=26 THEN R1~0&DOUBTYPE[TOSUBCL] + ELSE IF R3!6 THEN FLAG(177) ; + GO L; + END ; + END ; + FLAG(IF R3=26 THEN 178 ELSE 177-REAL(R3=6)) ; +L: NCR~REAL(NCR.[30:3]!0)+3"677777"+NCR; SCN~1; SCAN ; + END ; + IF NEXT!LPAREN THEN BEGIN FLOG(106); GO X END ; +A: SCAN; R4~ERRORCT ; + IF R2~NAME.[12:6]<17 OR (R2>25 AND R2<33) OR (R2>41 AND R2<50) + OR R2>57 OR NAME.[18:30]!" " THEN FLAG(179) ; + SCAN ; + IF NEXT!MINUS THEN + BEGIN IF ERRORCT=R4 THEN TIPE[IF R2!"0" THEN R2 ELSE 12]~R1 END + ELSE BEGIN + SCAN ; + IF R3~NAME.[12:6]<17 OR (R3>25 AND R3<33) OR (R3>41 AND R3<50) + OR R3>57 OR NAME.[18:30]!" " THEN FLAG(179) ; + IF R3 LEQ R2 THEN FLAG(180) ; + IF ERRORCT=R4 THEN FOR R2~R2 STEP 1 UNTIL R3 DO + BEGIN + IF R2>25 AND R2<33 THEN R2~33 ELSE IF R2>41 AND R2<50 + THEN R2~50 ; + TIPE[IF R2!"0" THEN R2 ELSE 12]~R1 ; + END ; + SCAN ; + END ; + IF NEXT=COMMA THEN GO A ; + IF NEXT!RPAREN THEN BEGIN FLOG(108); GO X END ; + SCAN; IF NEXT=COMMA THEN GO R ; + IF NEXT!SEMI THEN BEGIN FLOG(117); GO X END ; + IF SPLINK > 1 THEN + BEGIN + IF BOOLEAN(TYPE.[2:1]) THEN IF GET(SPLINK).CLASS=FUNID THEN + BEGIN + INFO[SPLINK.IR,SPLINK.IC].SUBCLASS~R3~TIPE[IF R3~GET( + SPLINK+1).[12:6]!"0" THEN R3 ELSE 12].SUBCLASS ; + INFO[FUNVAR.IR,FUNVAR.IC].SUBCLASS~R3 ; + END ; + IF R1~GET(SPLINK+2)<0 THEN + FOR R2~R1.NEXTRA-1+R1~R1.ADINFO STEP -1 UNTIL R1 DO + IF R3~PARMLINK[R2-R1+1]!0 THEN + BEGIN + EXTRAINFO[R2.IR,R2.IC].SUBCLASS~R4~TIPE[IF R4~ + GET(R3+1).[12:6]!"0" THEN R4 ELSE 12] + .SUBCLASS ; + INFO[R3.IR,R3.IC].SUBCLASS~R4 ; + END ; + END ; +X: WHILE NEXT!SEMI DO SCAN; FILETOG~FALSE ; + END OF IMPLICIT ; + +PROCEDURE SUBROUTINE; +BEGIN + IF SPLINK NEQ 0 THEN BEGIN FLAG(5); ENDS; SEGMENTSTART; END; + LABL ~ BLANKS; + FORMALPP(FALSE, SUBRID); + SPLINK ~ FNEW; +END SUBROUTINE; +PROCEDURE MEMHANDLER(N); VALUE N; REAL N ; + BEGIN + REAL A ; + LABEL L1,L2,L3,XIT ; + IF DEBUGTOG THEN FLAGROUTINE(" MEMHA","NDLER ",TRUE) ; + IF N LEQ 2 THEN + BEGIN % FIXED=1, VARYING=2. + N~IF N=1 THEN 6 ELSE 0 ; +L1: SCAN; + IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; + IF (A~GET(GETSPACE(FNEXT))).CLASS!ARRAYID THEN + BEGIN FLOG(35); GO XIT END ; + IF XREF THEN ENTERX(XTA,0&A[15:15:9]) ; + IF BOOLEAN(A.EQ) OR BOOLEAN(A.FORMAL) THEN FLAG(169) + ELSE BEGIN + EMIT0(MKS); EMITPAIR(A.ADDR,LOD); EMITL(N) ; + EMITV(NEED(".MEMHR",INTRFUNID)) ; + END ; + SCAN; IF NEXT=COMMA THEN GO L1 ; + END + ELSE IF N=3 THEN + BEGIN % AUXMEMED FUNCTION OR SUBROUTINE. + SCAN ; + IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; + IF GET(FNEXT+1)!GET(SPLINK+1) THEN + BEGIN FLOG(170); GO XIT END ; + PUT(SPLINK,GET(SPLINK)&1[TOADJ]) ; + IF XREF THEN ENTERX(XTA,0&GET(FNEXT)[15:15:9]); SCAN ; + END + ELSE BEGIN % RELEASE. +L2: SCAN ; + IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; + IF (A~GET(GETSPACE(FNEXT))).CLASS=ARRAYID THEN + BEGIN + IF BOOLEAN(A.EQ) OR BOOLEAN(A.FORMAL) THEN FLAG(169) + ELSE BEGIN + EMIT0(MKS); EMITPAIR(A.ADDR,LOD) ; + EMITPAIR(1,SSN) ; + EMITV(NEED(".MEMHR",INRFUNID)) ; + END ; + IF XREF THEN ENTERX(XTA,0&A[15:15:9]) ; + END + ELSE IF A.CLASS}BLOCKID OR A.CLASS{LABELID THEN + BEGIN FLOG(171); GO XIT END + ELSE BEGIN + EMITPAIR(A.ADDR,LOD); EMITPAIR(38,KOM) ; + EMIT0(DFL); GO L3 ; + END ; + SCAN; IF NEXT=COMMA THEN GO L2 ; + END ; +XIT:IF DEBUGTOG THEN FLAGROUTINE(" MEMHA","NDLER ",FALSE) ; + END OF MEMHANDLER ; +PROCEDURE STATEMENT; +BEGIN LABEL DOL1, XIT; + REAL TEMPNEXT ; + BOOLEAN ENDTOG; %112- + DO SCAN UNTIL NEXT ! SEMI; + IF NEXT=ID THEN ASSIGNMENT ELSE IF NEXT LEQ RSH1 THEN + CASE(TEMPNEXT~NEXT) OF + BEGIN + FLOG(16); + ASSIGN; + IOCOMMAND(4) %BACKSPACE + BLOCKDATA; + CALL; + COMMON; + COMPLEX; + BEGIN EXECUTABLE; SCAN END; % CONTINUE + IOCOMMAND(7); % DATA + BEGIN SCAN; TYPE ~ -1; DIMENSION END; + DOUBLEPRECISION; + BEGIN ENDS; ENDTOG:=TRUE; SCAN END; %112- + FILECONTROL(1); %ENDFILE + ENTRY; + EQUIVALENCE; + EXTERNAL; + BEGIN TYPE ~ -1; FUNCTION END; + GOTOS; + INTEGERS; + LOGICAL; + NAMEL; + PAUSE; + IOCOMMAND(2); %PRINT + ; + IOCOMMAND(3); %PUNCH + IOCOMMAND(0); %READ + REALS; + RETURN; + FILECONTROL(0); %REWIND + BEGIN SCAN; STOP END; + SUBROUTINE; + IOCOMMAND(1); %WRITE + FILECONTROL(7); %CLOSE + FILECONTROL(6); %LOCK + FILECONTROL(4); %PURGE + IFS; + FORMATER; + CHAIN; + MEMHANDLER(1) ; %FIXED + MEMHANDLER(2) ; %VARYING + MEMHANDLER(3) ; %AUXMEM FOR SUBPROGRAMS + MEMHANDLER(4) ; %RELEASE + IMPLICIT ; + END ELSE IF NEXT=EOF THEN GO XIT ELSE BEGIN NEXT~0; FLOG(16) END ; + LASTNEXT.[33:15]~TEMPNEXT ; + IF NOT ENDTOG THEN IF SPLINK=0 THEN SPLINK:=1; %112- + ENDTOG:=FALSE; %112- + IF LABL ! BLANKS THEN + BEGIN + IF DT ! 0 THEN + BEGIN + DOL1: IF LABL = DOLAB[TEST ~ DT] THEN + BEGIN + EMITB(DOTEST[DT], FALSE); + FIXB(DOTEST[DT].ADDR); + IF DT ~ DT-1 > 0 THEN GO TO DOL1; + END ELSE + WHILE TEST ~ TEST-1 > 0 DO + IF DOLAB[TEST] = LABL THEN FLAG(14); + END; + LABL ~ BLANKS; + END; + IF NEXT ! SEMI THEN + BEGIN + FLAG(117); + DO SCAN UNTIL NEXT=SEMI OR NEXT=EOF ; + END; + ERRORTOG ~ FALSE; + EOSTOG ~ TRUE; + XIT: +END STATEMENT; + +BOOLEAN STREAM PROCEDURE FLAGLAST(BUFF,ERR) ; + BEGIN + LOCAL A; SI~ERR; 8(IF SC!" " THEN JUMP OUT;SI~SI+1;TALLY~TALLY+1); + A~TALLY; SI~LOC A; SI~SI+7 ; + IF SC<"8" THEN + BEGIN TALLY~1; FLAGLAST~TALLY ; + DI~BUFF;DS~46 LIT"LAST SYNTAX ERROR OCCURRED AT SEQUENCE NUMBER "; + DS~LIT"""; SI~ERR; DS~8 CHR; DS~LIT"""; + DS~32 LIT " "; %510- + DS~32 LIT " "; %510- + END + END FLAGLAST ; +INTEGER PROCEDURE FIELD(X); VALUE X; INTEGER X; +FIELD~IF X<10 THEN 1 ELSE IF X<100 THEN 2 ELSE IF X<1000 THEN 3 ELSE IF +X<10000 THEN 4 ELSE IF X<100000 THEN 5 ELSE IF X<1000000 THEN 6 ELSE 7; +FORMAT EOC1(/ "NUMBER OF SYNTAX ERRORS DETECTED = ",I*,".",X*, + "NUMBER OF SEQUENCE ERRORS DETECTED = ",I*,"."), + EOC2("PRT SIZE = ",I*,"; TOTAL SEGMENT SIZE = ",I*, + " WORDS; DISK SIZE = ",I*," SEGS; NO. PRGM. SEGS = ",I*, + "."), + EOC3("ESTIMATED CORE STORAGE REQUIREMENT = ",I*," WORDS;", + " COMPILATION TIME = ",I*," MIN, ",I*," SECS;", + " NO. CARDS = ",I*,"."), + EOC4("ESTIMATED CORE STORAGE REQUIREMENT = ",I*," WORDS;" + " COMPILATION TIME = ",I*," SECS; NO. CARDS = ",I*,"."), + EOC5("NUMBER OF TSS WARNINGS DETECTED = ",I*,".") ; +COMMENT MAIN DRIVER FOR FORTRAN COMPILER BEGINS HERE; +RTI ~ TIME(1); +INITIALIZATION; + DO STATEMENT UNTIL NEXT = EOF; + IF NOT ENDSEGTOG THEN IF SPLINK NEQ 0 %112- + THEN BEGIN XTA:=BLANKS; FLAG(5); ENDS END; %112- + WRAPUP; +POSTWRAPUP: +IF TIMETOG THEN IF FIRSTCALL THE DATIME; +IF NOT FIRSTCALL THEN + BEGIN + WRITE(RITE,EOC1,FIELD(ERRORCT),ERRORCT,IF SEQERRCT=0 THEN 99 ELSE + 5,FIELD(SEQERRCT-1),SEQERRCT-1) ; + IF WARNED AND NOT DCINPUT THEN WRITE(RITE,EOC5,FIELD(WARNCOUNT), + WARNCOUNT) ; + WRITE(RITE,EOC2,FIELD(PRTS),PRTS,FIELD(TSEGSZ),TSEGSZ,FIELD(DALOC-1), + DALOC-1,FIELD(NXAVIL),NXAVIL) ; + IF C1~(TIME(1)-RTI)/60 > 59 THEN WRITE(RITE,EOC3,FIELD(64|ESTIMATE), + 64|ESTIMATE,FIELD(C1 DIV 60),C1 DIV 60,FIELD(C1 MOD 60),C1 MOD 60, + FIELD(CARDCOUNT-1),CARDCOUNT-1) ELSE WRITE(RITE,EOC4,FIELD(ESTIMATE + |64),ESTIMATE|64,FIELD(C1),C1,FIELD(CARDCOUNT-1),CARDCOUNT-1) ; + IF ERRORCT>0 THEN IF FLAGLAST(ERRORBUFF,LASTERR) THEN WRITE(RITE,15, + ERROBUFF[*]) ; + END ; +END INNER BLOCK; +END.