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 | 00001010 | FILE ID: SYMBOL/FORTRAN TAPE ID: SYMBOL1/FILE000 | 00001011 | THIS MATERIAL IS PROPRIETARY TO BURROUGHS CORPORATION | 00001012 | AND IS NOT TO BE REPRODUCED, USED, OR DISCLOSED | 00001013 | EXCEPT IN ACCORDANCE WITH PROGRAM LICENSE OR UPON | 00001014 | WRITTEN AUTHORIZATION OF THE PATENT DIVISION OF | 00001015 | BURROUGHS CORPORATION, DETROIT, MICHIGAN 48232 | 00001016 | | 00001017 | COPYRIGHT (C) 1971, 1972, 1974 | 00001018 | BURROUGHS CORPORATION | 00001019 | AA320206 AA393180 AA332366 |; 00001020 % BEWARE ALL YE WHO SEEK HEREIN: %997-00001100 % THIS COMPILER IS A MESS. THE CONCEPTS OF CHARACTER CONVERSION FROM 00001105 % HOLLERITH (= EBCDIC), SCANNING, AND PARSING ARE NOT CLEARLY SEPARATED 00001110 % IN THE CODE, FOR EXAMPLE, PROCEDURE "SCAN" TRIES TO DO ALL 3 AT ONCE.00001115 % DAN ROSS UCSC APRIL 12, 1977 %997-00001120 COMMENT 00001900 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 INCONSISTENT USE OF IDENTIFIER 00037000 035 ARRAY IDENTIFIER EXPECTED 00038000 036 EXPRESSION VALUE 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 ILLEGAL 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 00143001 142 RETURN, STOP OR CALL EXIT REQUIRED IN SUBPROGRAM 00143002 143 FORMAT NUMBER USED PREVIOUSLY AS LABEL 00143003 144 LABEL USED PREVIOUSLY AS FORMAT NUMBER 00143004 145 NON-STANDARD RETURN REQUIRES LABEL PARAMETERS 00143005 146 DOUBLE OR COMPLEX REQUIRES EVEN OFFSET 00143006 147 FORMAL PARAMETER ILLEGAL IN DATA STATEMENT 00143007 148 TOO MANY LOCAL VARIABLES IN SOURCE PROGRAM 00143008 149 A $FREEFORM SOURCE LINE MUST HAVE < 67 COLS 00143009 150 A HOL/STRING UNDER $FREEFORM MUST BE ON ONE LINE 00143010 151 THIS CONSTRUCT IS ILLEGAL IN TSS FORTRAN 00143011 152 ILLEGAL FILE CARD PARAMETER VALUE 00143012 153 RETURN IN MAIN PROGRAM NOT ALLOWED 00143013 154 NON-POSITIVE SUBSCRIPTS ARE ILLEGAL 00143014 155 NON-IDENTIFIER USED FOR NAME OF LIBRARY ROUTINE 00143015 156 HYPHEN EXPECTED 00143016 157 SEQUENCE NUMBER EXPECTED 00143017 158 TOO MANY RECURSIVE CALLS ON LIBRARY ROUTINES 00143018 159 ASTERISK NOT ALLOWED IN READ STATEMENT 00143019 160 ASTERISK ONLY ALLOWED IN FREE FIELD OUTPUT 00143020 161 TOO MANY *-ED LIST ELEMENTS IN OUTPUT 00143021 162 HOL OR QUOTED STRING GREATER THAN 7 CHARACTERS IN EXPRESSION 00143022 164 PLUS NOT ALLOWED IN THIS FORMAT PHRASE 00143023 165 K NOT ALLOWED IN THIS FORMAT PHRASE 00143024 166 $ NOT ALLOWED IN THIS FORMAT PHRASE 00143025 167 INTRINSICS-NAMED FUNCT MUST HAVE PREVIOUS EXTERNAL REFERENCE. 00143026 168 DATA STMT COMMON ELEM MUST BE IN BLK DATA SUBPRM 00143027 169 VARIABLE CANNOT BE A FORMAL PARAMETER OR IN COMMON 00143028 170 CURRENT SUBPROGRAM ID EXPECTED 00143029 171 SUBPROGRAM, EXTERNAL, OR ARRAY ID EXPECTED 00143030 172 REPEAT, WIDTH, AND DECIMAL PARTS MUST BE LESS THAN 4091 00143031 173 REPEAT PART MUST BE EMPTY OR >0 AND < 4091 00143032 174 IN SUBPRGM:VARBL IS USED PRIOR TO USE IN DATSTMT 00143033 175 SYNTATICAL TOKEN CONTAINS TOO MANY CHARACTERS 00143034 176 INTEGER VALUE OF 8 EXPECTED 00143035 177 INTEGER VALUE OF 4 EXPECTED 00143036 178 INTEGER VALUE OF 4 OR 8 EXPECTED 00143037 179 AN ALPHABETIC LETTER (A,B,C,...,Z) IS REQUIRED 00143038 180 SECOND RANGE LETTER MUST BE GREATER THAN FIRST 00143039 181 IMPLICIT MUST BE FIRST STATEMENT IN PROGRAM UNIT 00143040 182 REAL/INTEGER/LOGICAL/COMPLEX/DOUBLEPRECISION REQ 00143041 183 ILLEGAL USE OF ASTERISK FOR RUN-TIME EDITING %111-00143042 184 NO PROGRAM UNIT FOR THIS END STATEMENT %112-00143043 ; 00143999 BEGIN 00144000 INTEGER ERRORCT; COMMENT MUST BE FIRST DECLARED VARIABLE; 00145000 INTEGER SAVETIME; COMMENT MUST BE 2 ND DECLARED VARIABLE; 00146000 INTEGER CARDCOUNT,ESTIMATE,SEQERRCT ; 00147000 INTEGER SWARYCT; 00147500 REAL TWODPRTX; 00148000 REAL INITIALSEGNO; 00149000 REAL NEXT, FNEXT, NAME, NUMTYPE; 00150000 REAL A, B, I, J, P, T, TS, Z; 00151000 REAL RTI; % START COMPILE TIME 00152000 REAL EXPVALUE, EXPRESULT, EXPLINK; 00153000 REAL SPLINK, FUNVAR; 00155000 REAL DATAPRT,DATASTRT,DATALINK,DATASKP; 00155100 BOOLEAN SCANENTER ; % TRUE IFF SCAN JUST DID AN ENTER ON AN ID. 00155110 DEFINE NUMINTM1= 00155210 83 00155211 #;% NUMINTM1 IS THE NUMBER OF INTRINSICS MINUS 1; FOR EACH NEW INTRINSIC00155212 % WHICH IS ADDED, ADD 1 TO THE VALUE ON SEQ# 00155211. 00155213 DEFINE MAXEL=15#; 00156000 REAL ARRAY ENTRYLINK[0:MAXEL]; 00157000 REAL ELX; 00158000 ALPHA FNEW, NNEW; 00159000 REAL LABELMOM; 00160000 INTEGER LOCALS,PARMS,PRTS,FLAGROUTINECOUNTER ; 00161000 REAL LIMIT, VOIDTSEQ; 00161010 REAL IDINFO, TYPE, NSEG; 00162000 REAL FX1, FX2, FX3, NX1, NX2, NX3; 00163000 INTEGER LENGTH, LOWERBOUND, GROUPPRT; 00164000 ALPHA EQVID, INTID, REALID; 00165000 INTEGER ROOT, ADR; 00166000 INTEGER LASTMODE ; %%% = 1 FOR $CARD; = 2 FOR $TAPE. 00166100 BOOLEAN ERRORTOG,%PREVIOUS LISTED RECORD. 00167000 EOSTOG,%END OF STMT TOGGLE. 00168000 CODETOG,%LIST CODE GENERATED.. 00168200 TAPETOG,%MERGE TAPE INPUT. 00168400 EODS,%END OF DECLRSTMTS, RESET BY ENDS. 00168500 FILETOG,%PROCESSING FILE CARDS. 00168600 DEBUGTOG,%TO LIST OUT ENTRING AND EXITING PROCEDURES. 00169000 DESCREQ,%DESCRIPTOR REQUIRED. 00169020 XREF,%TO CREATE XREF OF PROGRAM. 00169030 SAVETOG;%VARIOUS BOOLEANS. 00169050 DEFINE LIBTAPE = SAVETOG.[47:1]#,%USE TO SAVE NEW WHILE INCLUDE. 00169053 SAVEDEBUGTOG = SAVETOG.[46:1]#,%SAVE DEBUGTOG WHILE IN $INCLUDE.00169054 SAVECODETOG = SAVETOG.[45:1]#,%SAVE CODETOG WHILE IN $INCLUDE. 00169055 SAVEPRTTOG = SAVETOG.[44:1]#,%SAVE PRTOG WHILE IN $INCLUDE. 00169056 SAVELISTOG = SAVETOG.[43:1]#,%SAVE LISTOG WHILE IN $INCLUDE. 00169057 VOIDTOG = SAVETOG.[42:1]#,%TO VOID CARDS OR TAPE 00169058 DATASTMTFLAG = SAVETOG.[41:1]#,%WHILE IN DATA STMTS, 00169059 F2TOG = SAVETOG.[40:1]#,%ADDR REL TO F+2, 00169060 CHECKTOG = SAVETOG.[39:1]#,%SEQ # CHECK, 00169061 LISTOG = SAVETOG.[38:1]#,%TO LIST OUTPUT, 00169062 LISTLIBTOG = SAVETOG.[37:1]#,%TO LIST LIBRARY OUTPUT, 00169063 SEQTOG = SAVETOG.[36:1]#,%TO RESEQ INPUTS, 00169064 SEQERRORS = SAVETOG.[35:1]#,%IF SEQUENCE ERRORS. 00169065 TIMETOG = SAVETOG.[34:1]#,%TO LIST WRAPUP INFO ONLY. 00169066 PRTOG = SAVETOG.[33:1]#,%TO LIST STORAGE MAP. 00169067 NEWTPTOG = SAVETOG.[32:1]#,%CREATE NEW SYMBOLIC TAPE. 00169068 SINGLETOG = SAVETOG.[31:1]#,%TO LIST OUTPUT SINGLE SPACED. 00169069 SEGOVFLAG = SAVETOG.[30:1]#,%SEGMENT OVERFLOW. 00169070 FIRSTCALL = SAVETOG.[29:1]#,%TO LIST COMPILER HEADING. 00169071 RETURNFOUND = SAVETOG.[28:1]#,%RETURN,CALL EXIT,STOP FOUND. 00169072 ENDSEGTOG = SAVETOG.[27:1]#,%END OF SEGMENT. 00169073 LOGIFTOG = SAVETOG.[26:1]#,%PROCESSING LOGICAL IF STMT. 00169074 NOTOPIO = SAVETOG.[25:1]#, 00169075 DATATOG = SAVETOG.[24:1]#,%WHILE IN DATA STMTS. 00169076 FREEFTOG = SAVETOG.[23:1]#,%FREE FIELD INPUT. 00169077 SEGPTOG = SAVETOG.[22:1]#,%DONT PAGE AFTER SUBPRGM 00169078 GLOBALNAME = SAVETOG.[21:1]#,%TO WRITE ALL IDENTIFIERS. 00169079 NAMEDESC = SAVETOG.[20:1]#,%IF GLOBALNAME OR LOCALNAME TRUE 00169080 LOCALNAME = SAVETOG.[19:1]#,%TO WRITE AN IDENTIFIER. 00169081 TSSEDITOG = SAVETOG.[18:1]#,%TSSEDIT. 00169082 UNPRINTED = SAVETOG.[17:1]#,%TO LIST CARD,FALSE IF LISTED. 00169083 DCINPUT = SAVETOG.[16:1]#,%IF USING TSS FORTRAN. 00169084 SEGSW = SAVETOG.[15:1]#,%TO MAINTAIN LINEDICT/LINESEG. 00169085 TSSMESTOG = SAVETOG.[14:1]#,%TSSMES(ERRMES). 00169086 WARNED = SAVETOG.[13:1]#,%IS TSSEDIT WAS EVER EVOKED. 00169087 SEGSWFIXED = SAVETOG.[12:1]#,%IF SEGSW IS NOT TO BE ALTERED. 00169088 REMFIXED = SAVETOG.[11:1]#,%IF REMOTETOG ISNT TO BE ALTERED 00169089 REMOTETOG = SAVETOG.[10:1]#,%PRINT & READ STMTS = REMOTE 00169090 RANDOMTOG = SAVETOG.[10:1]#,%IF EXPR USED FOR RANDOM I/O. 00169091 VOIDTTOG = SAVETOG.[ 9:1]#,%TO VOID TAPE RECORDS ONLY. 00169092 DOLIST = SAVETOG.[ 8:1]#,%LIST DOLLAR CARDS. 00169093 HOLTOG = SAVETOG.[ 7:1]#,%INPUT IN HOLLERITH. 00169094 LISTPTOG = SAVETOG.[ 6:1]#,%LIST PATCHES ONLY. 00169095 PXREF = SAVETOG.[ 5:1]#,%TO LIST XREF OF PROGRAM. 00169096 LASTLINE = SAVETOG.[ 4:1]#,%TO DETR TO SKIP XREF. 00169097 XGLOBALS = SAVETOG.[ 3:1]#,%TO LET XREF KNOW OF DOING GLOBAL00169098 NTAPTOG = SAVETOG.[ 2:1]#,%TO CLOSE NEWTAPE IF EVER OPENED 00169099 SEENADOUB = SAVETOG.[40:1]#,%ARRAYDEC WONT BE USING THIS 00169100 %WHILE WE FIX DP COMMON ARRAY SZ 00169102 ENDSAVTOGDEF=#; 00169199 ARRAY SSNM[0:18] ; % THESE WORDS ARE USED FOR TEMP STORAGE AND STORING 00169200 % PERMANENT FLAGGED DATA. 00169201 DEFINE LASTSEQ=SSNM[0]#, LASTERR=SSNM[1]#, LINKLIST=SSNM[2]# ; 00169210 DEFINE VOIDSEQ=SSNM[3] # ; 00169220 ALPHA ARRAY ERRORBUFF,PRINTBUFF[0:14] ; 00169300 ARRAY INLINEINT[0:35] ; 00169310 DEFINE XRBUFF = 150#, XRBUFFDIV3=50 #; 00169320 ARRAY XRRY[0:XRBUFF-1] ; 00169330 INTEGER SEQBASE,SEQINCR; 00170000 INTEGER SCN,LABL,NEXTSCN,NEXTCARD; 00174000 INTEGER SAVECARD; % TO SAVE NEXTCART WHILE IN $ INCLUDE 00174100 INTEGER RESULT,INSERTDEPTH; 00174200 REAL INCLUDE; % CONTAINS "INCLUDE" 00174300 REAL DEBUGADR ; 00174310 ALPHA ACR0, CHR0, INITIALNCR; 00175000 ALPHA ACR, NCR ; 00176000 SAVE ARRAY TIPE[0:63] ; 00176500 REAL LASTNEXT ; 00176502 ALPHA NEXTACC, NEXTACC2; 00177000 ALPHA BLANKS; 00178000 ALPHA XTA; 00179000 ALPHA ARRAY EDOC[0:7, 0:127]; COMMENT HOLDS CODE EMITTED; 00180000 ALPHA ARRAY HOLDID[0:2]; 00181000 REAL NXAVIL,STRTSEG; 00182000 ALPHA ARRAY WOP[0:139]; % HOLDS NAME AND CODE OF WORD MODE OPERATORS 00183000 SAVE ALPHA ARRAY DB,TB,CB[0:9], 00184000 CRD[0:14]; 00185000 ALPHA ARRAY XR[0:32]; INTEGER XRI; 00185100 SAVE ARRAY ACCUM, EXACCUM[0:20] ; 00186000 REAL ACCUMSTOP, EXACCUMSTOP ; 00186100 REAL DBLOW; 00187000 REAL MAX; 00188000 ALPHA ACR1, CHR1; 00189000 ALPHA ARRAY PERIODWORD[0:10]; 00190000 REAL ARRAY MAP[0:7]; 00191000 REAL F1, F2; 00192000 INTEGER C1, C2; 00193000 DEFINE 00194000 RSP=14 #, RSP1=15 #, RWP=29 #, 00194020 RSH=41 #, RSH1=42 #, RWS=83 #; 00194040 ALPHA ARRAY RESERVEDWORDSLP[0:RWP], RESLENGTHLP,LPGLOBAL[0:RSP], 00195000 RESERVEDWORDS [0:RWS], RESLENGTH [0:RSH] ; 00195010 SAVE REAL ARRAY PR, OPST [0:25]; % USED IN EXPR ONLY 00196000 DEFINE PARMLINK = LSTT#; 00197000 ALPHA BUFF, BUFL, SYMBOL; 00198000 INTEGER TV, % INDEX INTO INFO FOR PRT OF LIST NAMES 00199100 SAVESUBS, % MAX NUMBER OF SUBSCRIPTS FOR NAMELIST IDENTIFIERS 00199120 NAMEIND ; % INDEX INTO NAMLIST IDENTIFIERS ARRAY 00199130 ARRAY NAMLIST[0:256]; % ARRAY TO STOKE NAMELIST IDENTIFIERS 00199200 ALPHA LISTID; 00199300 REAL ARRAY BDPRT[0:20]; REAL BDX; 00200000 DEFINE MAXSTRING = 49#; 00201000 ALPHA ARRAY STRINGARRAY[0:MAXSTRING]; 00202000 REAL STRINGSIZE; % NUMBER OF WORDS IN STRING 00203000 DEFINE LSTMAX = 256#; 00204000 REAL ARRAY LSTT, LSTP[0:LSTMAX]; 00205000 INTEGER LSTI,LSTS,LSTA; 00206000 DEFINE MAXOPFILES = 63#, BIGGESTFILENB = 99#; 00207000 ARRAY FILEINFO[0:3,0:MAXOPFILES]; 00208000 DEFINE % SOME FILE STUFF 00208100 SLOWV = 2#, 00208110 FASTV = 1#, 00208120 SENSPDEUNF= [1:8]#, 00208130 SENSE= [1:1]#, 00208135 SPDF = [2:2]#, 00208140 EUNF = [4:5]#, 00208150 FPBVERSION= 1#, 00208160 FPBVERSF = [1:8]#, 00208170 DKAREASZ = [9:39]#, 00208180 ENDFILDEF=#; 00208490 INTEGER MAXFILES; 00209000 ARRAY TEN[0:137]; 00210000 DEFINE LBRANCH = 50#; 00211000 REAL ARRAY BRANCHES[0:LBRANCH]; REAL LAX, BRANCHX; 00212000 INTEGER INXFIL,FILEARRAYPRT; 00213000 DEFINE MAXCOM=15 # ; 00214000 INTEGER SUPERMAXCOM; %%% SUPERMAXCOM = 128|(MAXCOM+1). 00214100 ALPHA ARRAY COM[0:MAXCOM,0:127] ; 00215000 REAL NEXTCOM; 00216000 ALPHA ARRAY INFO[0:31, 0:127]; 00217000 REAL ARYSZ; 00218000 ALPHA ARRAY EXTRAINFO[0:31, 0:127]; 00219000 REAL EXPT1, EXPT2, EXPT3; 00220000 DEFINE IR = [36:5]#, IC = [41:7]#; 00221000 REAL INFA,INFB,INFC; 00222000 INTEGER NEXTINFO, GLOBALNEXTINFO, NEXTEXTRA; 00223000 INTEGER NEXTSS; 00224000 DEFINE SHX=189#, GHX=61#; 00225000 REAL ARRAY STACKHEAD[0:SHX]; 00226000 REAL ARRAY GLOBALSTACKHEAD[0:GHX]; 00227000 REAL LA, DT, TEST; 00228000 ALPHA LADR1,LADR2,LADR3,LADR4,LADR5,LINFA; INTEGER LINDX,LADDR; 00229000 DEFINE MAXDOS=20#; 00230000 ALPHA ARRAY DOTEST, DOLAB[0:MAXDOS]; 00231000 ALPHA LISTART; 00232000 ALPHA ARRAY INT[0:NUMINTM1+NUMINTM1+2]; 00233000 ALPHA ARRAY TYPES[0:6], KLASS[0:14]; 00234000 INTEGER OP, PREC, IP, IT; 00235000 DEFINE DUMPSIZE=127 #; 00237000 ARRAY FNNHOLD[0:DUMPSIZE]; 00238000 INTEGER FNNINDEX,FNNPRT; 00239000 DEFINE MAXNBHANG = 30#; 00240000 ARRAY FNNHANG[0:MAXNBHANG]; 00241000 DEFINE INTCLASS=[6:3]#, INTPARMCLASS=[9:3]#, INTINLINE=[12:6]#, 00241010 INTPRT =[24:6]#, INTPARMS =[30:6]#, INTNUM =[36:12]#, 00241020 INAM =[12:36]#, INTX =[2:10]#, INTSEEN =[2:1]# ; 00241030 DEFINE 00241200 INSERTMAX = 20 #, % MAX NO OF RECURSIVE CALL ALLOW ON LIB ROUT 00241220 INSERTCOP = INSERTINFO[INSERTDEPTH,4] #, 00241240 INSERTMID = INSERTINFO[INSERTDEPTH,0] #, 00241260 INSERTFID = INSERTINFO[INSERTDEPTH,1] #, 00241280 INSERTINX = INSERTINFO[INSERTDEPTH,2] #, 00241300 INSERTSEQ = INSERTINFO[INSERTDEPTH,3] #; 00241320 ARRAY INSERTINFO[0:INSERTMAX,0:4]; 00241360 DEFINE MSRW=11 #; 00241900 ALPHA ARRAY MESSAGE[0:MSRW,0:96] ; 00242000 BOOLEAN ARRAY MSFL[0:MSRW]; 00242050 ALPHA ARRAY LINEDICT[0:7,0:127]; % LINE DICTIONARY ARRAY 00242100 ALPHA ARRAY LINESEG [0:11,0:127]; % LINE SEGMENT ARRAY 00242200 ARRAY TSSMESA[0:15] ; %%% BIT FLAGS PRNTD ERR MESSGS ({748). 00242220 INTEGER NOLIN; % NUMBER OF ENTRIES IN LINE SEGMENT 00242300 REAL LASTADDR; %%% STORES LAST ADR. 00242700 INTEGER WARNCOUNT; %%% COUNTS NUMBER OF TSS WARNINGS. 00242750 DEFINE CE = [2:1]#, %INFA %996-00243000 LASTC = [3:12]#, %INFA %996-00244000 SEGNO = [3:9]#, %INFA %996-00245000 CLASS = [15:5]#, %INFA %996-00246000 EQ = [20:1]#, %INFA %996-00246100 SUBCLASS = [21:3]#, %INFA %996-00247000 CLASNSUB = [14:10]#, %INFA %996-00248000 ADJ = [14:1]#, %INFA %996-00249000 TWOD = [14:1]#, %INFA %996-00250000 FORMAL = [13:1]#, %INFA %996-00251000 TYPEFIXED= [12:1]#, %INFA %996-00252000 ADDR = [24:12]#, %INFA %996-00253000 LINK = [36:12]#, %INFC %996-00254000 BASE = [18:15]#, %INFC %996-00255000 SIZE = [33:15]#, %INFC %996-00256000 BASENSIZE= [18:30]#, %INFC %996-00257000 NEXTRA = [2:6]#, %INFC %996-00258000 ADINFO = [8:10]#, %INFC %996-00259000 RELADD = [21:15]#, %INFA %996-00260000 TOCE = 2:47:1#, %INFA %996-00261000 TOSEGNO = 3:39:9#, %INFA %996-00262000 TOLASTC = 3:36:12#, %INFA %996-00262100 TOCLASS = 15:43:5#, %INFA %996-00263000 TOEQ = 20:47:1#, %INFA %996-00263100 TOSUBCL = 21:45:3#, %INFA %996-00264000 TOADJ = 14:47:1#, %INFA %996-00265000 TOFORMAL = 13:47:1#, %INFA %996-00266000 TOTYPE = 12:47:1#, %INFA %996-00267000 TOADDR = 24:36:12#, %INFA %996-00268000 TOLINK = 36:36:12#, %INFC %996-00269000 TOBASE = 18:33:15#, %INFC %996-00270000 TOSIZE = 33:33:15#, %INFC %996-00271000 TONEXTRA = 2:42:6#, %INFC %996-00272000 TOADINFO = 8:38:10#, %INFC %996-00273000 TORELADD = 21:33:15#, %INFA %996-00274000 %THE FOLLOWING CLASSES APPEAR IN THE 1ST WORD OF EACH 3-WORD ENTRY 00274998 %OF THE "INFO" ARRAY, AND MAY BE COPIED TO INFA.CLASS. %996-00274999 UNKNOWN = 0#, 00275000 ARRAYID = 1#, 00276000 VARID = 2#, 00277000 STMTFUNID= 3#, 00278000 NAMELIST = 4#, 00279000 FORMATID = 5#, 00280000 LABELID = 6#, 00281000 FUNID = 7#, 00282000 INTRFUNID= 8#, 00283000 EXTID = 9#, 00284000 SUBRID = 10#, 00285000 BLOCKID = 11#, 00286000 FILEID = 12#, 00287000 SUBSVAR = 13#, 00288000 EXPCLASS = 14#, 00289000 SBVEXP = 15#, 00290000 LISTSID = 16#, 00290050 JUNK = 17#, % NOT A GENUINE CLASS %996-00290055 DUMMY = 27#, 00290100 NUMCLASS = 28#, 00291000 RESERVED = 29#, 00292000 HEADER = 30#, 00293000 ENDCOM = 31#, 00294000 %THE FOLLOWING SUBCLASSES APPEAR IN THE 1ST WORD OF SOME 3-WORKD%996-00294998 %ENTRIES OF THE "INFO" ARRAY, AND MAY BE COPIED TO INFA.SUBCLASS. 00294999 INTYPE = 1#, 00295000 STRINGTYPE=2#, 00296000 REALTYPE = 3#, 00297000 LOGTYPE = 4#, 00298000 DOUBTYPE = 5#, 00299000 COMPTYPE = 6#; 00300000 DEFINE EOF= 500#, ID= 501#, NUM= 502#, PLUS= 503#, MINUS= 504#, 00301000 STAR= 505#, SLASH= 506#, LPAREN= 507#, RPAREN= 508#, 00302000 EQUAL= 509#, COMMA= 510#, SEMI= 511#, DOLLAR=0#, UPARROW=0# ; 00303000 DEFINE THRU = STEP 1 UNTIL #; %996-00316000 DEFINE 00317000 ADD = 16#, BBC = 22#, BBW = 534#, BFC = 38#, BFW = 550# 00318000 ,CDC =168#, CHS =134#, COC = 40#, KOM =130#, DEL = 10# 00319000 ,DUP =261#, EQUL=581#, GBC = 278#, GBW =790#, GEQL= 21# 00320000 ,GFC =294#, GFW =806#, GRTR= 37#, IDV =384#, INX = 24# 00321000 ,ISD =532#, ISN =548#, LEQL= 533#, LND = 67#, LNG = 19# 00322000 ,LOD =260#, LOR = 35#, LQV = 131#, LESS=549#, MDS = 515# 00323000 ,MKS = 72#, MUL = 64#, NEQL= 69#, NOP = 11#, PRL = 18# 00324000 ,XRT = 12#, RDV =896#, RTN = 39#, RTS =167#, SND = 132# 00325000 , SSN = 70#, SSP = 582#, STD = 68#, SUB = 48#, XCH = 133# 00326000 ,XIT = 71#, ZP1 =322#, DIU =128#, STN =132# 00327000 ,DIA = 45#, DIB = 49#, TRB = 53#, ISO = 37# 00328000 ,AD2 =17#, SB2 = 49#, ML2 = 65#, DV2 =129#, FTC = 197# 00329000 ,SSF =280#, FTF =453#, CTC =709#, CTF = 965# 00330000 ,TOP=262# 00330010 ; 00331000 FORMAT FD(X100,"NEXT = ",I3,X2,2A6) ; 00332000 FORMAT SEGSTRT(X63, " START OF SEGMENT **********", I4), 00333000 FLAGROUTINEFORMAT(X41,A6,A2,X1,2A6," (",A1,I*,")"), 00333010 XHEDM(X40,"CROSS REFERENCE LISTING OF MAIN PROGRAM",X41,/, 00333050 X40,"----- --------- ------- -- ---- -------",X41), 00333055 XHEDS(X38, "CROSS REFERENCE LISTING OF SUBROUTINE ",A6,X38,/, 00333060 X38, "----- --------- ------- -- ---------- ",A6,X38), 00333065 XHEDF(X35,"CROSS REFERENCE LISTING OF ",A6,A1," FUNCTION ",A6, 00333070 X35,/,X35,"----- --------- ------- -- ",A6,A1," -------- ",A6, 00333075 X35), 00333076 XHEDG(X43,"CROSS REFERENCE LISTING OF GLOBALS",X43,/, 00333080 X43,"----- --------- ------- -- -------",X43), 00333085 XHEDB(X34,"CROSS REFERENCE LISTING OF BLOCK DATA SUBPROGRAM",X35,00333090 /,X34,"----- --------- ------- -- ----- ---- ----------",X35), 00333095 SEGEND (X70," SEGMENT",I5," IS",I5," LONG"); 00334000 ARRAY PDPRT [0:31,0:63]; 00335000 REAL PDINX; % INDEX OF LAST ENTRY IN PDPRT 00336000 REAL TSEGSZ; % RUNNING COUNT OF TOTAL SEGMENT SIZE; 00337000 COMMENT FORMAT OF PRT&SEGMENT ENTRIES, IN PDPRT; 00338000 DEFINE STYPF= [1:2]#, % 0 = PROGRAM SEGMENT-SEGMENT ENTRY ONLY 00339000 STYPC= 1:46:2#, % 1 = MCP INTRINSIC 00340000 % 2 = DATA SEGMENT 00341000 DTYPF= [4:2]#, % 0 = THUNK - PRT ENTRY ONLY 00342000 DTYPC= 4:46:2 #,% 1 = WORD MODE PROGRAM DESCRIPTOR 00343000 % 2 = LABEL DESCRIPTOR 00344000 % 3 = CHARACTER MODE PROGRAM DESCRIPTOR 00345000 PRTAF= [8:10]#, % ACTUAL PRT ADDRESS - PRT ENTRY 00346000 PRTAC= 8:38:10#, 00347000 RELADF = [18:10]#, % ADDRESS WITHIN SEGMENT -PRT ONLY 00348000 RELADC= 18:38:10#, 00349000 SGNOF= [28:10]#, % SEGMENT NUMBER - BOTH 00350000 SGNOC= 28:38:10#, 00351000 DKAI = [13:15]#, % RELATIVE DISK ADDRESS - SEGMENT ENTRY 00352000 DKAC = 13:33:15#, 00353000 SEGSZF =[38:10]#, % SEGMENT SIZE - SEGMENT ENTRY 00354000 SEGSZC =38:38:10#;% MUST BE 0 IF PRT ENTRY 00355000 DEFINE % SOME EXTERNAL CONSTANTS 00355100 BLKCNTRLINT = 5#, 00355110 FPLUS2 = 1538#, 00355120 ENDEXTCONDEF=#; 00355990 DEFINE PDIR = PDINX.[37:5]#, 00356000 PDIC = PDINX.[42:6]#; 00357000 DEFINE CIS = CRD[0]#, % CARD 00358000 TIS = CRD[1]#, % TAPE 00359000 TOS = CRD[2]#, % NEW TAPE 00360000 LOS = CRD[3]#; % PRINTER 00361000 DEFINE PWROOT=ROOT.IR,ROOT.IC #,PWI=I.IR,I.IC # ; 00362000 DEFINE GLOBALNEXT=NEXT#; 00363000 BEGIN % SCAN FPB TO SEE IF VARIOUS FILES ARE DISK OR TAPE 00364000 INTEGER STREAM PROCEDURE GETFPB(Q); VALUE Q; 00365000 BEGIN 00366000 SI ~ LOC GETFPB; SI ~ SI - 7; DI ~ LOC Q; DI ~ DI + 5; 00367000 SKIP 3 DB; 9(IF SB THEN DS ~ SET ELSE DS ~ RESET; 00368000 SKIP SB); 00369000 DI ~ LOC Q; SI ~ Q; DS ~ WDS; SI ~ Q; GETFPB ~ SI; 00370000 END; 00371000 INTEGER STREAM PROCEDURE GNC(Q); VALUE Q; 00372000 BEGIN SI ~ Q; SI ~ SI + 7; DI ~ LOC GNC; DI ~ DI +7; DS ~CHR END; 00373000 INTEGER FPBBASE; 00374000 FPBBASE ~ GETFPB(3); 00375000 TIS ~ TOS ~ 50; CIS ~ LOS ~ 0; 00376000 IF GNC(FPBBASE+3) =12 THEN CIS ~ 150; % CARD 00377000 IF GNC(FPBBASE+8) =12 THEN LOS ~ 150; % PRINTER 00378000 IF GNC(FPBBASE+13) = 12 THEN TOS ~ 150; % NEW TAPE; 00379000 IF GNC(FPBBASE+18) =12 THEN TIS ~ 150; % TAPE 00380000 END; 00381000 BEGIN COMMENT INNER BLOCK; 00382000 % *** DO NOT DECLARE ANY FILES PRIOR TO THIS POINT, DO NOT ALTER 00383000 % SEQUENCE OF FOLLOWING FILE DECLARATIONS 00384000 FILE CARD (5,10,CIS); 00385000 DEFINE LINESIZE = 900 #; 00386000 SAVE FILE LINE DISK SERIAL [20:LINESIZE] (2,15,LOS,SAVE 10); 00387000 SAVE FILE NEWTAPE DISK SERIAL [20:LINESIZE] "FORSYM" (2,10,TOS,SAVE 10);00388000 FILE TAPE "FORSYM" (2,10,TIS); 00389000 FILE REMOTE 19(2,10) ; 00389500 DEFINE CHUNK = 180#; 00390000 DEFINE PTR=LINE#,RITE=LINE#,CR=CARD#,TP=TAPE#; %515-00391000 FILE CODE DISK RANDOM [20:CHUNK] (4,30,SAVE ABS(SAVETIME)); 00392000 FILE LIBRARYFIL DISK RANDOM (2,10,150); 00392400 DEFINE LF = LIBRARYFIL#; 00392600 FILE XREFF DISK SERIAL[20:1500](2,XRBUFF) ; 00392700 FILE XREFG DISK SERIAL[20:1500](2,3,XRBUFF); 00392800 REAL DALOC; % DISK ADDRESS 00393000 LABEL POSTWRAPUP; 00393100 PROCEDURE EMITNUM(N); VALUE N; REAL N; FORWARD; 00394000 REAL PROCEDURE LOOKFORINTRINSIC(L); VALUE L; REAL L; FORWARD ; 00394500 PROCEDURE SEGOVF; FORWARD; 00395000 DEFINE BUMPADR= IF (ADR~ADR+1)=4089 THEN SEGOVF#; 00396000 DEFINE BUMPLOCALS = BEGIN IF LOCALS~LOCALS+1>255 THEN BEGIN FLAG(148); 00396500 LOCALS~2 END END#; 00396510 DEFINE BUMPPRT=BEGIN IF PRTS~PRTS+1>1023 THEN BEGIN FLAG(46); 00396600 PRTS~40 END END#; 00396610 DEFINE EDOCI = ADR.[36:3], ADR.[39:7]#; 00397000 DEFINE TWODPRT=IF TWODPRTX=0 THEN(TWODPRTX~PRTS~PRTS+1)ELSE TWODPRTX#; 00398000 REAL PROCEDURE SEARCH(E); VALUE E; REAL E; FORWARD; 00399010 PROCEDURE PRINTCARD; FORWARD; 00400000 INTEGER PROCEDURE FEELD(X); VALUE X; INTEGER X; FORWARD ; 00400010 ALPHA PROCEDURE NEED(T, C); VALUE T, C; ALPHA T, C; FORWARD; 00401000 ALPHA PROCEDURE GETSPACE(S); VALUE S; ALPHA S; FORWARD; 00402000 PROCEDURE EQUIV(R); VALUE R; REAL R; FORWARD; 00403000 PROCEDURE EXECUTABLE; FORWARD; 00403100 ALPHA PROCEDURE B2D(B); VALUE B; REAL B; FORWARD; 00404000 PROCEDURE DEBUGWORD (N); VALUE N; REAL N; FORWARD; 00405000 PROCEDURE EMITL(N); VALUE N; REAL N; FORWARD; 00406000 PROCEDURE ADJUST;FORWARD; 00407000 PROCEDURE DATIME; FORWARD; 00407500 PROCEDURE EMITB(A,C); VALUE A,C; REAL A; BOOLEAN C; FORWARD; 00408000 PROCEDURE FIXB(N); VALUE N; REAL N; FORWARD; 00408100 PROCEDURE EMITO(N); VALUE N; REAL N; FORWARD; 00409000 PROCEDURE EMITOPDCLIT(N); VALUE N; REAL N; FORWARD; 00410000 PROCEDURE EMITDESCLIT(N); VALUE N; REAL N; FORWARD; 00411000 PROCEDURE EMITPAIR(L,OP); VALUE L,OP; INTEGER L,OP; FORWARD; 00412000 PROCEDURE EMITN(N); VALUE N; REAL N; FORWARD; 00413000 PROCEDURE ARRAYDEC(I); VALUE I; REAL I; FORWARD; 00414000 INTEGER PROCEDURE ENTER(W, E); VALUE W, E; ALPHA W, E; FORWARD; 00415000 REAL PROCEDURE PRGDESCBLDR(A,B,C,D); VALUE A,B,C,D; REAL A,B,C,D; 00416000 FORWARD; 00417000 PROCEDURE WRITEDATA(A,B,C); VALUE A,B; REAL A,B; 00418000 ARRAY C[0]; FORWARD; 00419000 PROCEDURE SCAN; FORWARD; 00420000 PROCEDURE SEGMENT(A,B,C,D); VALUE A,B,C; 00421000 REAL A,B; BOOLEAN C; ARRAY D[0,0]; FORWARD; 00422000 STREAM PROCEDURE MOVESEQ(OLD,NEW); BEGIN DI~OLD; SI~NEW; DS~WDS END ; 00422010 PROCEDURE WRITAROW(N,ROW); VALUE N; INTEGER N; REAL ARRAY ROW[0] ; 00422100 IF SINGLETOG THEN WRITE(LINE,N,ROW[*]) ELSE WRITE(RITE,N,ROW[*]) ; 00422110 PROCEDURE WRITALIST(FMT,N,L1,L2,L3,L4,L5,L6,L7,L8); 00422120 VALUE N,L1,L2,L3,L4,L5,L6,L7,L8; INTEGER N; 00422130 REAL L1,L2,L3,L4,L5,L6,L7,L8; FORMAT FMT; 00422140 BEGIN 00422150 PRINTBUFF[1]~L1; 00422160 L1~1 ; 00422170 FOR L2~L2,L3,L4,L5,L6,L7,L8 DO PRINTBUFF[L1~L1+1]~L2 ; 00422180 IF SINGLETOG THEN WRITE(LINE,FMT,FOR L1~1 THRU N DO PRINTBUFF[L1]) 00422190 ELSE WRITE(RITE,FMT,FOR L1~1 THRU N DO PRINTBUFF[L1]) ; 00422200 END WRITALIST ; 00422210 STREAM PROCEDURE BLANKIT(A,N,P); VALUE N,P; 00422220 BEGIN DI~A; N(DS~8 LIT" "); P(DS~8 LIT"99999999") END ; 00422230 BOOLEAN STREAM PROCEDURE TSSMES(A,B); VALUE B; 00422235 BEGIN SI~A; SKIP B SB; IF SB THEN ELSE BEGIN TALLY~1; TSSMES~TALLY ; 00422240 DI~A; SKIP B DB; DS~SET END END OF TSSMES ; 00422250 STREAM PROCEDURE TSSEDIT(X,P1,P2,P3,P,N); VALUE P1,P2,P3,N ; 00422255 BEGIN DI~P;DS~16LIT"TSS WARNING: ";SI~X;SI~SI+2; DS~6CHR; DS~4LIT" ";00422260 P1(DS~48LIT"A TSS HOL OR QUOTED STRING MUST BE ON 1 LINE ") ; 00422262 P2(DS~48LIT"THIS CONSTRUCT IS ILLEGAL IN TSS FORTRAN ") ; 00422264 P3(DS~48LIT"THIS CONSTRUCT IS UNRESERVED IN TSS FORTRAN ") ; 00422266 DS~26LIT" "; DS~8LIT"*"; DS~LIT" "; SI~LOC N; DS~3DEC END TSSEDIT ; 00422268 PROCEDURE TSSED(X,N); VALUE X,N; ALPHA X; INTEGER N ; 00422270 BEGIN IF NOT (LISTOG OR SEQERRORS) THEN PRINTCARD ; UNPRINTED~FALSE ; 00422275 TSSEDIT(X,N=1,N=2,N=3,PRINTBUFF,WARNCOUNT~WARNCOUNT+1) ; 00422280 WRITAROW(14,PRINTBUFF) END OF TSSED; 00422285 PROCEDURE ERRMESS(N); VALUE N; INTEGER N; 00423000 BEGIN 00424000 00425000 STREAM PROCEDURE PLACE(D,N,X,S,E,L); VALUE N,E ; 00426000 BEGIN DI ~ D; DS ~ 6 LIT "ERROR "; 00427000 SI ~ LOC N; DS ~ 3 DEC; DS ~ 5 LIT ": "; 00428000 SI ~ X; SI ~ SI + 2; DS ~ 6 CHR; DS ~ 4 LIT " "; 00429000 SI~S; DS~6 WDS; DS~6 LIT" "; SI~L; DS~8 CHR; DS~14 LIT" " ; 00430000 DS ~ 8 LIT "X"; DS ~ LIT " "; 00431000 SI ~ LOC E; DS ~ 3 DEC; 00432000 END PLACE; 00433000 STREAM PROCEDURE DCPLACE(D,N,X,S,M,P); VALUE N,P; 00433100 BEGIN DI~D; DS~4LIT"ERR#"; SI~LOC N; DS~3 DEC; DS~3LIT" @ "; 00433200 SI~S; DS~8CHR; DS~2LIT": "; SI~X; SI~SI+2; DS~6CHR; DS~54LIT" " ; 00433300 END OF DCPLACE ; 00433400 ERRORCT~ERRORCT+1; 00433500 IF NOT MSFL[N DIV 16] THEN 00434000 BEGIN 00434020 MSFL[N DIV 16]~TRUE ; 00434030 CASE(N DIV 16)OF 00434040 BEGIN 00435000 FILL MESSAGE[0,*] WITH 00436000 "SYNTAX E","RROR "," "," "," "," ", %000 00437000 "MISSING ","OPERATOR"," OR PUNC","TUATION "," "," ", %001 00438000 "CONFLICT","ING COMM","ON AND/O","R EQUIVA","LENCE AL","LOCATION", %002 00439000 "MISSING ","RIGHT PA","RENTHESI","S "," "," ", %003 00440000 "ENTRY ST","MT ILLEG","AL IN MA","IN PGM O","R BLOCK ","DATA ", %004 00441000 "MISSING ","END STAT","EMENT "," "," "," ", %005 00442000 "ARITHMET","IC EXPRE","SSION RE","QUIRED "," "," ", %006 00443000 "LOGICAL ","EXPRESSI","ON REQUI","RED "," "," ", %007 00444000 "TOO MANY"," LEFT PA","RENTHESE","S "," "," ", %008 00445000 "TOO MANY"," RIGHT P","ARENTHES","ES "," "," ", %009 00446000 "FORMAL P","ARAMETER"," ILLEGAL"," IN COMM","ON "," ", %010 00447000 "FORMAL P","ARAMETER"," ILLEGAL"," IN EQUI","VALENCE "," ", %011 00448000 "THIS STA","TEMENT I","LLEGAL I","N BLOCK ","DATA SUB","PROGRAM ", %012 00449000 "INFO ARR","AY OVERF","LOW "," "," "," ", %013 00450000 "IMPROPER"," DO NEST"," "," "," "," ", %014 00451000 "DO LABEL"," PREVIOU","SLY DEFI","NED "," "," ", %015 00452000 0; 00453000 FILL MESSAGE[1,*] WITH 00454000 "UNRECOGN","IZED STA","TEMENT T","YPE "," "," ", %016 00455000 "ILLEGAL ","DO STATE","MENT "," "," "," ", %017 00456000 "FORMAT S","TATEMENT"," MUST HA","VE LABEL"," "," ", %018 00457000 "UNDEFINE","D LABEL "," "," "," "," ", %019 00458000 "MULTIPLE"," DEFINIT","ION "," "," "," ", %020 00459000 "ILLEGAL ","IDENTIFI","ER CLASS"," IN THIS"," CONTEXT"," ", %021 00460000 "UNPAIRED"," QUOTES ","IN FORMA","T "," "," ", %022 00461000 "NOT ENOU","GH SUBSC","RIPTS "," "," "," ", %023 00462000 "TOO MANY"," SUBSCRI","PTS "," "," "," ", %024 00463000 "FUNCTION"," OR SUBR","OUTINE P","REVIOUSL","Y DEFINE","D ", %025 00464000 "FORMAL P","ARAMETER"," MULTIPL","Y DEFINE","D IN HEA","DING ", %026 00465000 "ILLEGAL ","USE OF N","AMELIST "," "," "," ", %027 00466000 "NUMBER O","F PARAME","TERS INC","ONSISTEN","T "," ", %028 00467000 "CANNOT B","RANCH TO"," FORMAT ","STATEMEN","T "," ", %029 00468000 "SUBROUTI","NE OR FU","NCTION N","OT DEFIN","ED IN PR","OGRAM ", %030 00469000 "IDENTIFI","ER ALREA","DY GIVEN"," TYPE "," "," ", %031 00470000 0; 00471000 00472000 479000 FILL MESSAGE[2,*] WITH 00472000 "ILLEGAL ","FORMAT S","YNTAX "," "," "," ", %032 00473000 "INCORREC","T USE OF"," FILE "," "," "," ", %033 00474000 "INCONSIS","TENT USE"," OF IDEN","TIFIER "," "," ", %034 00475000 "ARRAY ID","ENTIFIER"," EXPECTE","D "," "," ", %035 00476000 "EXPRESSI","ON VALUE"," REQUIRE","D "," "," ", %036 00477000 "ILLEGAL ","FILE CAR","D SYNTAX"," "," "," ", %037 00478000 "ILLEGAL ","CONTROL ","ELEMENT "," "," "," ", %038 00479000 "DECLARAT","ION MUST"," PRECEDE"," FIRST R","EFERENCE"," ", %039 00480000 "INCONSIS","TENT USE"," OF LABE","L AS PAR","AMETER "," ", %040 00481000 "NO. OF P","ARAMS. D","ISAGREES"," WITH PR","EV. REFE","RENCE ", %041 00482000 "ILLEGAL ","USE OF F","ORMAL PA","RAMETER "," "," ", %042 00483000 "ERROR IN"," HOLLERI","TH LITER","AL CHARA","CTER COU","NT ", %043 00484000 "ILLEGAL ","ACTUAL P","ARAMETER"," "," "," ", %044 00485000 "TOO MANY"," SEGMENT","S IN SOU","RCE PROG","RAM "," ", %045 00486000 "TOO MANY"," PRT ASS","IGNMENTS"," IN SOUR","CE PROGR","AM ", %046 00487000 "LAST BLO","CK DECLA","RATION H","AD LESS ","THAN 102","4 WORDS ", %047 00488000 0; 00489000 FILL MESSAGE[3,*] WITH 00490000 "ILLEGAL ","I/O LIST"," ELEMENT"," "," "," ", %048 00491000 "LEFT SID","E MUST B","E SIMPLE"," OR SUBS","CRIPTED ","VARIABLE", %049 00492000 "VARIABLE"," EXPECTE","D "," "," "," ", %050 00493000 "ILLEGAL ","USE OF .","OR. "," "," "," ", %051 00494000 "ILLEGAL ","USE OF .","AND. "," "," "," ", %052 00495000 "ILLEGAL ","USE OF .","NOT. "," "," "," ", %053 00496000 "ILLEGAL ","USE OF R","ELATIONA","L OPERAT","OR "," ", %054 00497000 "ILLEGAL ","MIXED TY","PES "," "," "," ", %055 00498000 "ILLEGAL ","EXPRESSI","ON STRUC","TURE "," "," ", %056 00499000 "ILLEGAL ","PARAMETE","R "," "," "," ", %057 00500000 "RECORD B","LOCK GRE","ATER THA","N 1023 "," "," ", %058 00501000 "TOO MANY"," OPTIONA","L FILES "," "," "," ", %059 00502000 "FILE CAR","DS MUST ","PRECEDE ","SOURCE D","ECK "," ", %060 00503000 "BINARY W","RITE STA","TEMENT H","AS NO LI","ST "," ", %061 00504000 "UNDEFINE","D FORMAT"," NUMBER "," "," "," ", %062 00505000 "ILLEGAL ","EXPONENT"," IN CONS","TANT "," "," ", %063 00506000 0; 00507000 FILL MESSAGE[4,*] WITH 00508000 "ILLEGAL ","CONSTANT"," IN DATA"," STATEME","NT "," ", %064 00509000 "MAIN PRO","GRAM MIS","SING "," "," "," ", %065 00510000 "PARAMETE","R MUST B","E ARRAY ","IDENTIFI","ER "," ", %066 00511000 "PARAMETE","R MUST B","E EXPRES","SION "," "," ", %067 00512000 "PARAMETE","R MUST B","E LABEL "," "," "," ", %068 00513000 "PARAMETE","R MUST B","E FUNCTI","ON IDENT","IFIER "," ", %069 00514000 "PARAMETE","R MUST B","E FUNCTI","ON OR SU","BROUTINE"," ID ", %070 00515000 "PARAMETE","R MUST B","E SUBROU","TINE IDE","NTIFIER "," ", %071 00516000 "PARAMETE","R MUST B","E ARRAY ","IDENTIFI","ER OR EX","PRESSION", %072 00517000 "ARITHMET","IC - LOG","ICAL CON","FLICT ON"," STORE "," ", %073 00518000 "ARRAYID ","MUST BE ","SUBSCRIP","TED IN T","HIS CONT","EXT ", %074 00519000 "MORE THA","N ONE MA","IN PROGR","AM "," "," ", %075 00520000 "ONLY COM","MON ELEM","ENTS PER","MITTED "," "," ", %076 00521000 "TOO MANY"," FILES "," "," "," "," ", %077 00522000 "FORMAT O","R NAMELI","ST TOO L","ONG "," "," ", %078 00523000 "FORMAL P","ARAMETER"," MUST BE"," ARRAY I","DENTIFIE","R ", %079 00524000 0; 00525000 FILL MESSAGE[5,*] WITH 00526000 "FORMAL P","ARAMETER"," MUST BE"," SIMPLE ","VARIABLE"," ", %080 00527000 "FORMAL P","ARAMETER"," MUST BE"," FUNCTIO","N IDENTI","FIER ", %081 00528000 "FORMAL P","ARAMETER"," MUST BE"," SUBROUT","INE IDEN","TIFIER ", %082 00529000 "FORMAL P","ARAMETER"," MUST BE"," FUNCTIO","N OR SUB","ROUTINE ", %083 00530000 "DO OR IM","PLIED DO"," INDEX M","UST BE I","NTEGER O","R REAL ", %084 00531000 "ILLEGAL ","COMPLEX ","CONSTANT"," "," "," ", %085 00532000 "ILLEGAL ","MIXED TY","PE STORE"," "," "," ", %086 00533000 "CONSTANT"," EXCEEDS"," HARDWAR","E LIMITS"," "," ", %087 00534000 "PARAMETE","R TYPE C","ONFLICTS"," WITH PR","EVIOUS U","SE ", %088 00535000 "COMPLEX ","EXPRESSI","ON ILLEG","AL IN IF"," STATEME","NT ", %089 00536000 "COMPLEX ","EXPRESSI","ON ILLEG","AL IN RE","LATION "," ", %090 00537000 "TOO MANY"," FORMATS"," REFEREN","CED BUT ","NOT YET ","FOUND ", %091 00538000 "VARIABLE"," ARRAY B","OUND MUS","T BE FOR","MAL VARI","ABLE ", %092 00539000 "ARRAY BO","UND MUST"," HAVE IN","TEGER OR"," REAL TY","PE ", %093 00540000 "COMMA OR"," RIGHT P","ARENTHES","IS EXPEC","TED "," ", %094 00541000 "ARRAY AL","READY GI","VEN BOUN","DS "," "," ", %095 00542000 0; 00543000 FILL MESSAGE[6,*] WITH 00544000 "ONLY FOR","MAL ARRA","YS MAY B","E GIVEN ","VARIABLE"," BOUNDS ", %096 00545000 "MISSING ","LEFT PAR","ENTHESIS"," IN IMPL","IED DO "," ", %097 00546000 "SUBSCRIP","T MUST B","E INTEGE","R OR REA","L "," ", %098 00547000 "ARRAY SI","ZE CANNO","T EXCEED"," 32767 W","ORDS "," ", %099 00548000 "COMMON O","R EQUIV ","BLOCK CA","NNOT EXC","EED 3276","7 WORDS ", %100 00549000 "THIS STA","TEMENT I","LLEGAL I","N LOGICA","L IF "," ", %101 00550000 "REAL OR ","INTEGER ","TYPE REQ","UIRED "," "," ", %102 00551000 "ARRAY BO","UND INFO","RMATION ","REQUIRED"," "," ", %103 00552000 "REPLACEM","ENT OPER","ATOR EXP","ECTED "," "," ", %104 00553000 "IDENTIFI","ER EXPEC","TED "," "," "," ", %105 00554000 "LEFT PAR","ENTHESIS"," EXPECTE","D "," "," ", %106 00555000 "ILLEGAL ","FORMAL P","ARAMETER"," "," "," ", %107 00556000 "RIGHT PA","RENTHESI","S EXPECT","ED "," "," ", %108 00557000 "STATEMEN","T NUMBER"," EXPECTE","D "," "," ", %109 00558000 "SLASH EX","PECTED "," "," "," "," ", %110 00559000 "ENTRY ST","ATEMENT ","CANNOT B","EGIN PRO","GRAM UNI","T ", %111 00560000 0; 00561000 FILL MESSAGE[7,*] WITH 00562000 "ARRAY MU","ST BE DI","MENSIONE","D PRIOR ","TO EQUIV"," STMT ", %112 00563000 "INTEGER ","CONSTANT"," EXPECTE","D "," "," ", %113 00564000 "COMMA EX","PECTED "," "," "," "," ", %114 00565000 "SLASH OR"," END OF ","STATEMEN","T EXPECT","ED "," ", %115 00566000 "FORMAT, ","ARRAY OR"," NAMELIS","T EXPECT","ED "," ", %116 00567000 "END OF S","TATEMENT"," EXPECTE","D "," "," ", %117 00568000 "IO STATE","MENT WIT","H NAMELI","ST CANNO","T HAVE I","O LIST ", %118 00569000 "COMMA OR"," END OF ","STATEMEN","T EXPECT","ED "," ", %119 00570000 "STRING T","OO LONG "," "," "," "," ", %120 00571000 "MISSING ","QUOTE AT"," END OF ","STRING "," "," ", %121 00572000 "ILLEGAL ","ARRAY BO","UND "," "," "," ", %122 00573000 "TOO MANY"," HANGING"," BRANCHE","S "," "," ", %123 00574000 "TOO MANY"," COMMON ","OR EQUIV","ALENCE E","LEMENTS "," ", %124 00575000 "ASTERISK"," EXPECTE","D "," "," "," ", %125 00576000 "COMMA OR"," SLASH E","XPECTED "," "," "," ", %126 00577000 "DATA SET"," TOO LAR","GE "," "," "," ", %127 00578000 0; 00579000 FILL MESSAGE[8,*] WITH 00580000 "TOO MANY"," ENTRY S","TATEMENT","S IN THI","S SUBPRO","GRAM ", %128 00581000 "DECIMAL ","WIDTH EX","CEEDS FI","ELD WIDT","H "," ", %129 00582000 "UNSPECIF","IED FIEL","D WIDTH "," "," "," ", %130 00583000 "UNSPECIF","IED SCAL","E FACTOR"," "," "," ", %131 00584000 "ILLEGAL ","FORMAT C","HARACTER"," "," "," ", %132 00585000 "UNSPECIF","IED DECI","MAL FIEL","D "," "," ", %133 00586000 "DECIMAL ","FIELD IL","LEGAL FO","R THIS S","PECIFIER"," ", %134 00587000 "ILLEGAL ","LABEL "," "," "," "," ", %135 00588000 "UNDEFINE","D NAMELI","ST "," "," "," ", %136 00589000 "MULTIPLY"," DEFINED"," ACTION ","LABELS "," "," ", %137 00590000 "TOO MANY"," NESTED ","DO STATE","MENTS "," "," ", %138 00591000 "STMT FUN","CTION ID"," AND EXP","RESSION ","DISAGREE"," IN TYPE", %139 00592000 "ILLEGAL ","USE OF S","TATEMENT"," FUNCTIO","N "," ", %140 00593000 "UNRECOGN","IZED CON","STRUCT "," "," "," ", %141 00593001 "RETURN, ","STOP OR ","CALL EXI","T REQUIR","ED IN SU","BPROGRAM", %142 00593002 "FORMAT N","UMBER US","ED PREVI","OUSLY AS"," LABEL "," ", %143 00593003 0; 00594000 FILL MESSAGE[9,*] WITH 00595000 "LABEL US","ED PREVI","OUSLY AS"," FORMAT ","NUMBER "," ", %144 00595001 "NON-STAN","DARD RET","URN REQU","IRES LAB","EL PARAM","ETERS ", %145 00595002 "DOUBLE O","R COMPLE","X REQUIR","ES EVEN ","OFFSET "," ", %146 00595003 "FORMAL P","ARAMETER"," ILLEGAL"," IN DATA"," STATEME","NT ", %147 00595004 "TOO MANY"," LOCAL V","ARIABLES"," IN SOUR","CE PROGR","AM ", %148 00596000 "A $FREEF","ORM SOUR","CE LINE ","MUST HAV","E < 67 C","OLS ", %149 00596001 "A HOL/ST","RING UND","ER $FREE","FORM MUS","T BE ON ","ONE LINE", %150 00596002 "THIS CON","STRUCT I","S ILLEGA","L IN TSS","FORTRAN "," ", %151 00596003 "ILLEGAL ","FILE CAR","D PARAME","TER VALU","E "," ", %152 00596004 "RETURN I","N MAIN P","ROGRAM N","OT ALLOW","ED "," ", %153 00596005 "NON-POSI","TIVE SUB","SCRIPTS ","ARE ILLE","GAL "," ", %154 00596006 "NON-IDEN","TIFIER U","SED FOR ","NAME OF ","LIBRARY ","ROUTINE ", %155 00596007 "HYPHEN E","XPECTED "," "," "," "," ", %156 00596008 "SEQUENCE"," NUMBER ","EXPECTED"," "," "," ", %157 00596009 "TOO MANY"," RECURSI","VE CALLS"," ON LIBR","ARY ROUT","INE ", %158 00596010 "ASTERISK"," NOT ALL","OWED ID ","READ STA","TEMENT "," ", %159 00596011 0; 00596500 FILL MESSAGE[10,*] WITH 00596501 "ASTERISK"," ONLY AL","LOWED IN"," FREE FI","ELD OUTP","UT ", %160 00596510 "TOO MANY"," *-ED LI","ST ELEME","NTS IN O","UTPUT "," ", %161 00596511 "HOL OR Q","UOTED ST","RING > 7"," CHARACT","ERS IN E","XPRESSN ", %162 00596512 "DECIMAL ","FIELD GR","EATER TH","AN FIELD"," WIDTH-5"," ", %163 00596513 "PLUS NOT"," ALLOWED"," IN THIS"," FORMAT ","PHRASE "," ", %164 00596514 "K NOT AL","LOWED IN"," THIS FO","RMAT PHR","ASE "," ", %165 00596515 "$ NOT AL","LOWED IN"," THIS FO","RMAT PHR","ASE "," ", %166 00596516 "INTRNSCS","-NAMD FU","NCT MUST"," HAV PRE","V EXTRNL"," REFERNC", %167 00596517 "DATA STM","T COMMON"," ELEM MU","ST BE IN"," BLK DAT","A SUBPRG", %168 00596518 "VARIABLE"," CANNOT ","BE A FOR","MAL PARA","METER OR"," IN CMMN", %169 00596519 "CURRENT ","SUBPROGR","AM ID EX","PECTED "," "," ", %170 00596520 "SUBPROGR","AM, EXTE","RNAL, OR"," ARRAY I","D EXPECT","ED ", %171 00596521 "REPEAT, ","WIDTH, A","ND DECIM","AL PARTS"," MUST BE"," < 4091 ", %172 00596522 "REPEAT P","ART MUST"," BE EMPT","Y OR > 0"," AND < 4","091 ", %173 00596523 "IN SUBPR","GM:VARBL"," IS USED"," PRIOR T","O USE IN"," DATSTMT", %174 00596524 "SYNTATIC","AL TOKEN"," CONTAIN","S TOO MA","NY CHARA","CTERS. ", %175 00596525 0; 00596526 FILL MESSAGE[11,*] WITH 00596527 "INTEGER ","VALUE OF"," 8 EXPEC","TED "," "," ", %176 00596528 "INTEGER ","VALUE OF"," 4 EXPEC","TED "," "," ", %177 00596529 "INTEGER ","VALUE OF"," 4 OR 8 ","EXPECTED"," "," ", %178 00596530 "AN ALPHA","BETIC LE","TTER (A,","B,C,...,","Z) IS RE","QUIRED ", %179 00596531 "SECOND R","ANGE LET","TER MUST"," BE GREA","TER THAN"," FIRST ", %180 00596532 "IMPLICIT"," MUST BE"," FIRST S","TATEMENT"," IN PROG","RAM UNIT", %181 00596533 "REAL/INT","EGER/LOG","ICAL/COM","PLEX/DOU","BLEPRECI","SION REQ", %182 00596534 "ILLEGAL ","USE OF A","STERISK ","FOR RUN-","TIME EDI","TING ",%111-00596535 "NO PROGR","AM UNIT ","FOR THIS"," END STA","TEMENT "," ",%112-00596536 0; 00596599 00596538 END FILL STATEMENTS; 00597000 END ; 00597950 IF DCINPUT THEN 00598000 BEGIN 00598020 DCPLACE(ERRORBUFF,N,XTA,LASTSEQ,MESSAGE[N DIV 16,6|(N MOD 16)], 00598040 IF TSSMESTOG THEN TSSMES(TSSMESA[(N-1)DIV 48], 00598050 ENTIER((N-1) MOD 48)) ELSE FALSE) ; 00598060 WRITE(REMOTE,9,ERRORBUFF[*]) ; 00598080 END ; 00598100 IF LISTOG OR NOT DCINPUT THEN 00598120 BEGIN 00598140 PLACE(ERRORBUFF,N,XTA,MESSAGE[N DIV 16,6|(N MOD 16)],ERRORCT, 00598160 LASTERR) ; 00598180 WRITAROW(14,ERRORBUFF) ; 00598200 END; 00599000 MOVESEQ(LASTERR,LINKLIST) ; 00599500 END ERRMESS; 00600000 PROCEDURE FLAGROUTINE(NAME1,NAME2,ENTERING) ; 00600010 VALUE NAME1,NAME2,ENTERING ; 00600020 ALPHA NAME1,NAME2; 00600030 BOOLEAN ENTERING; 00600040 IF ENTERING THEN WRITALIST(FLAGROUTINEFORMAT,7,"ENTERI","NG",NAME1, 00600050 NAME2,"+",FEELD(FLAGROUTINECOUNTER~FLAGROUTINECOUNTER+1), 00600060 FLAGROUTINECOUNTER,0) ELSE 00600065 BEGIN 00600070 WRITALIST(FLAGROUTINEFORMAT,7,"LEAVIN","G ",NAME1,NAME2,"-", 00600080 FEELD(FLAGROUTINECOUNTER),FLAGROUTINECOUNTER,0) ; 00600090 FLAGROUTINECOUNTER~FLAGROUTINECOUNTER-1 ; 00600100 END ; 00600110 %END OF FLAGROUTINE 00600120 PROCEDURE FLAG(N); VALUE N; INTEGER N; 00601000 IF NOT ERRORTOG OR DEBUGTOG THEN 00602000 BEGIN 00603000 IF NOT (LISTOG OR SEQERRORS OR DCINPUT) THEN PRINTCARD ; 00604000 ERRMESS(N); 00606000 IF ERRORCT } LIMIT THEN GO TO POSTWRAPUP; 00606500 END; 00607000 PROCEDURE FLOG(N); VALUE N; INTEGER N; 00608000 IF NOT ERRORTOG OR DEBUGTOG THEN 00609000 BEGIN ERRORTOG ~ TRUE; 00610000 IF NOT (LISTOG OR SEQERRORS OR DCINPUT) THEN PRINTCARD; 00611000 ERRMESS(N); 00613000 IF ERRORCT } LIMIT THEN GO TO POSTWRAPUP; 00613500 END; 00614000 PROCEDURE FATAL(N); VALUE N; INTEGER N; 00615000 BEGIN 00616000 FORMAT FATALERR("XXXXXXXX", X18, 00617000 "PREVIOUS ERROR IS FATAL - REMAINDER OF SUBPROGRAM IGNORED", 00618000 X17, "XXXXXXXX"); 00619000 ERRORTOG ~ FALSE; 00620000 FLAG(N); 00621000 WRITALIST(FATALERR,0,0,0,0,0,0,0,0,0) ; 00622000 WHILE NEXT ! 11 DO % LOOK FOR END STMT 00623000 BEGIN 00624000 WHILE NEXT ! SEMI DO SCAN; 00625000 EOSTOG ~ TRUE; 00626000 SCAN; 00627000 END; 00628000 SEGMENT((ADR+4) DIV 4, NSEG, FALSE, EDOC); 00629000 SCAN; 00630000 END FATAL; 00631000 REAL STREAM PROCEDURE D2B(BCL); BEGIN SI~BCL; DI~LOC D2B; DS~8OCT END;00631100 REAL PROCEDURE GET(I); VALUE I; INTEGER I ; 00632000 BEGIN 00633000 GET ~ INFO[(I~I).IR,I.IC]; 00634000 END GET; 00635000 PROCEDURE PUT(I,VLU); VALUE I,VLU; INTEGER I; REAL VLU; 00636000 BEGIN 00637000 INFO[(I~I).IR,I.IC] ~ VLU; 00638000 END PUT; 00639000 PROCEDURE GETALL(I,INFA,INFB,INFC); 00640000 VALUE I; INTEGER I; REAL INFA,INFB,INFC; 00641000 BEGIN 00642000 INFA ~ INFO[(I~I).IR,I.IC] ; 00643000 INFB ~ INFO[(I~I+1).IR,I.IC]; 00644000 INFC ~ INFO[(I~I+1).IR,I.IC]; 00645000 END; 00646000 PROCEDURE PUTC(I,V); VALUE I,V; INTEGER I; REAL V; 00646100 IF I~I>SUPERMAXCOM THEN FATAL(124) ELSE COM[I.IR,I.IC]~V; 00646200 REAL PROCEDURE GETC(I); VALUE I; INTEGER I ; 00646300 GETC~COM[(I~I).IR,I.IC]; 00646400 PROCEDURE BAPC(V); VALUE V; REAL V; 00646500 IF NEXTCOM~NEXTCOM+1 > SUPERMAXCOM THEN FATAL(124) 00646600 ELSE COM[NEXTCOM.IR,NEXTCOM.IC]~V ; 00646700 STREAM PROCEDURE MOVEW(F,T,D,M); VALUE D,M; 00647000 BEGIN SI ~ F; DI ~ T; D(DS ~32 WDS; DS ~ 32 WDS); DS ~ M WDS; END; 00648000 PROCEDURE CALLEQUIV(I,B,G); VALUE I,B,G; INTEGER I; REAL G; BOOLEAN B ; 00649000 BEGIN REAL A,T,R,INFA,INFC; 00650000 REAL LAST,D; LABEL L; 00650100 PROCEDURE CORRECTINFO(R,A); VALUE R,A; INTEGER R,A; 00651000 COMMENT THIS PROCEDURE CORRECTS THE INFO TABLE FOR COMMON AND 00651010 EQUIVALENCE ELEMENTS. 00651020 IF ITEMS ARE IN COMMON THE INFA[EQ] BIT IS SET 00651030 THIS BIT IS USED TO TELL DATA STATEMENTS THAT THIS IS A 00651040 COMMON ELEMENT AND IF NOT IN BLOCK DATA SUBPROGRAM EMIT 00651050 SYNTAX ERROR 168. 00651060 THE INFA[CE] BIT IS SET TO TELL THAT IF THE CLASS IS VARID 00651070 EMIT CODE AS IF THIS ITEM WERE ARRAYID BUT DO NOT 00651080 ALLOW SUBSCRIPTING; 00651090 BEGIN 00652000 REAL T,I,LAST,L,REL,TWODBIT,INFA,INFB,INFC; 00653000 REAL CEBIT; 00654000 DEFINE LB = LOWERBOUND#; 00655000 TWODBIT ~ REAL(LENGTH > 1023); 00656000 CEBIT ~ REAL(LENGTH > 1); 00657000 T ~ R; 00658000 DO 00659000 BEGIN 00660000 LAST~GETC(T).LASTC-1 ; 00661000 FOR I ~ T+2 STEP 1 UNTIL LAST DO 00662000 BEGIN 00663000 IF GETC(I).CLASS = ENDCOM THEN I~GETC(I).LINK ; 00664000 INFA~GET(L~GETC(I).LINK); INFC~GET(L+2) ; 00665000 IF INFC > 0 AND LB ! 0 THEN 00666000 BEGIN 00667000 IF BOOLEAN(INFA.ADJ) THEN 00668000 REL ~ -INFC.BASE ELSE REL~INFC.BASE; 00669000 PUT(L+2,-(INFC&(REL-LB)[TOBASE])); 00670000 END; 00671000 PUT(L,INFA&TWODBIT[TOADJ]&CEBIT[TOCE]&A[TOEQ]); 00672000 END; 00673000 END UNTIL T~GETC(T).ADDR=R ; 00674000 END CORRECTINFO; 00675000 LABEL XIT; 00676000 IF DEBUGTOG THEN FLAGROUTINE(" CALLE","QUIV ",TRUE ); 00676010 COMMENT THIS PROCEDURE MAKES THE DETERMINATION IF THIS GROUP 00676100 IS EQUIVALENCE OR COMMON IF BOTH TREATED AS COMMON; 00676110 T ~ I; 00677000 GROUPPRT ~ LENGTH ~ A ~ 0; 00678000 LOWERBOUND ~ 32000; 00679000 DO BEGIN IF GETC(T).CE=1 THEN 00680000 BEGIN IF GROUPPRT ! 0 THEN 00681000 BEGIN XTA~G; 00682000 FLAG(2); 00683000 END; 00684000 GROUPPRT~GET(A~GETC(T+1)).ADDR; 00685000 END; 00686000 IF T > R THEN R ~ T; 00687000 END UNTIL T~GETC(T).ADDR=I ; 00688000 IF GROUPPRT = 0 THEN 00689000 IF B THEN BEGIN BUMPPRT;GROUPPRT~PRTS END ELSE %OWN 00689100 BEGIN BUMPLOCALS; GROUPPRT~LOCALS + 1536 END; 00690000 T ~ R; 00691000 SWARYCT ~0; 00691500 SSNM[6]~LOCALS ; SSNM[7]~PARMS ; SSNM[8]~PRTS ; 00691510 SSNM[9]~LSTS ; SSNM[10]~LSTA ; SSNM[11]~TV ; 00691520 SSNM[12]~SAVESUBS; SSNM[13]~NAMEIND ; SSNM[14]~LSTI ; 00691530 SSNM[15]~FX1 ; SSNM[16]~FX2 ; SSNM[17]~FX3 ; 00691540 SSNM[18]~NX1 ; 00691550 SEENADOUB~FALSE;% 00691800 DO IF GETC(T+1) ! 0 THEN BEGIN EQUIV(T); T~R; END 00691900 ELSE T~GETC(T).ADDR UNTIL T = R; 00691950 IF GETC(T) > 0 THEN EQUIV(T); 00692000 LOCALS~SSNM[6]; PARMS~SSNM[7]; PRTS~SSNM[8]; LSTS~SSNM[9] ; 00692010 LSTA~SSNM[10]; TV~SSNM[11]; SAVESUBS~SSNM[12]; NAMEIND~SSNM[13] ;00692020 LSTI~SSNM[14]; FX1~SSNM[15]; FX2~SSNM[16]; FX3~SSNM[17]; 00692030 NX1~SSNM[18] ; 00692040 LENGTH ~ LENGTH - LOWERBOUND; 00693000 IF SEENADOUB THEN LENGTH~LENGTH+LENGTH.[47:1];% EVEN UP LENGTH 00693500 SEENADOUB~FALSE; 00693600 IF A = 0 THEN 00694000 BEGIN COMMENT THIS IS AN EQUIVALENCE GROUP; 00694100 IF SWARYCT } 1 AND LENGTH = 1 THEN LENGTH ~ 2; 00694150 IF LENGTH > 1 THEN 00694200 BEGIN 00694300 A ~ ENTER(-0 & ARRAYID[TOCLASS] & GROUPPRT[TOADDR], 00695000 EQVID ~ EQVID+1); 00696000 PUT(A+2,0 & LENGTH[TOSIZE]); 00696100 END; 00696200 CORRECTINFO(R,0); 00697100 GO TO XIT; 00697200 END; 00697300 COMMENT THIS IS A COMMON BLOCK; 00697400 IF T ~ (INFC ~ GET(A+2)).SIZE ! 0 THEN 00700000 IF T { 1023 AND LENGTH > 1023 THEN 00701000 BEGIN XTA ~ GET(A+1); FLAG(47) END; 00702000 IF T < LENGTH THEN PUT(A+2, INFC&LENGTH[TOSIZE]) ELSE LENGTH ~ T; 00702100 IF LENGTH = 1 THEN LENGTH ~ 2; 00703000 CORRECTINFO(R,1); 00704000 XIT: 00705000 IF LENGTH > 32767 THEN BEGIN XTA ~ GET(A+1); FLAG(100) END; 00705100 IF DEBUGTOG THEN FLAGROUTINE(" CALLE","QUIV ",FALSE) ; 00705110 END CALLEQUIV; 00706000 STREAM PROCEDURE STOSEQ(XR,SEQ,ID); VALUE ID; 00706010 BEGIN LOCAL T; LABEL L1,L2 ; 00706015 SI ~ LOC ID; DI ~ XR; DS ~ 7LIT"0"; DS ~ CHR; SI ~ SI+1; 00706020 IF SC } "0" THEN 00706025 BEGIN SI~SI+4; DI~DI-2; 00706030 5(IF SC= " " THEN SI~SI-1 00706035 ELSE BEGIN DS~CHR; SI~SI-2; DI~DI-2; END); 00706040 END ELSE 00706045 BEGIN DI~DI-6; 00706050 6(IF SC=" " THEN BEGIN TALLY~TALLY+1; SI~SI+1 END 00706055 ELSE DS~CHR); 00706060 T~TALLY; 00706065 END; 00706070 DI~XR; DI~DI+8; SI~SEQ; 00706075 8(IF SC=" " THEN SI~SI+1 ELSE JUMP OUT TO L1); DS~8LIT"BLANKSEQ";00706080 GO L2; L1: SI~SEQ; DS~WDS; L2: 00706085 DI~DI+4; SI~LOC T; SI~SI+7; DS~CHR; 00706090 END; 00706095 PROCEDURE ENTERX(IDENT,ADINFO); VALUE IDENT, ADINFO; 00706120 REAL IDENT,ADINFO; 00706150 BEGIN REAL R,S; 00706200 IF ADINFO.CLASS>LABELID THEN 00706220 BEGIN 00706240 XR[2]~ADINFO; STOSEQ(XR,LINKLIST,IDENT); 00706260 IF ADINFO.CLASS=FUNID THEN XR[2].[26:1]~S~1 ; 00706280 WRITE(XREFG,3,XR[*]); XGLOBALS~TRUE; 00706300 END ; 00706320 IF R~XRI MOD XRBUFFDIV3=0 THEN 00706340 IF XRI!0 THEN WRITE(XREFF,XRBUFF,XRRY[*]) ; 00706350 XRRY[(R~R+R+R)+2]~ADINFO&S[26:47:1] ; 00706360 STOSEQ(XRRY[R],LINKLIST,IDENT) ; 00706380 IF XRI~XRI+1=1 THEN BEGIN XR[3]~IDENT; XR[4]~XRRY[2] END; 00706450 END ENTERX; 00706500 STREAM PROCEDURE TRANSFER(W2,B,K); VALUE K; 00706525 BEGIN DI~W2; SI~B; SI~SI+8; K(DS~WDS; SI~SI+16) END ; 00706530 BOOLEAN STREAM PROCEDURE CMPA(F,S); 00706560 BEGIN SI~F; DI ~ S; IF 8 SC { DC THEN TALLY ~ 1; CMPA~TALLY; END; 00706570 BOOLEAN PROCEDURE CMP(A,B); ARRAY A,B[0]; 00706600 BEGIN 00706610 CMP ~ IF A[0] < B[0] THEN TRUE ELSE IF A[0] = B[0] THEN 00706640 IF A[2].[26:4] < B[2].[26:4] THEN TRUE ELSE 00706650 IF A[2].[26:4] = B[2].[26:4] THEN CMPA(A[1],B[1]) ELSE FALSE 00706660 ELSE FALSE; 00706670 END; 00706680 PROCEDURE HV(V); ARRAY V[0]; 00706700 FILL V[*] WITH OCT777777777777777,OCT777777777777777,OCT777777777777777;00706720 BOOLEAN PROCEDURE INP(XR); ARRAY XR[0]; 00706730 BEGIN LABEL EOF; REAL R ; 00706733 IF EODS THEN READ(XREFG,3,XR[*])[EOF] ELSE 00706735 IF IT ~ IT+1 > XRI THEN 00706750 BEGIN EOF: INP~TRUE; IT~XRI~0; END 00706760 ELSE BEGIN 00706770 IF R~(IT-1) MOD XRBUFFDIV3=0 THEN READ(XREFF,XRBUFF,XRRY[*]) ; 00706780 XR[0]~XRRY[R~R+R+R]; XR[2]~XRRY[R+2]; TRANSFER(XR[1],XRRY[R],1) ; 00706800 END ; 00706810 END OF INP ; 00706820 PROCEDURE VARIABLEDIMS(A,C); VALUE A, C; REAL A, C; 00707000 BEGIN 00708000 REAL NSUBS, BDLINK, BOUND, I; 00709000 LABEL XIT; 00710000 IF DEBUGTOG THEN FLAGROUTINE("VARIAB","LEDIMS",TRUE); 00710010 IF NSUBS ~ C.NEXTRA = 1 AND A.SUBCLASS < DOUBTYPE THEN GO TO XIT; 00711000 BDLINK ~ C.ADINFO; 00712000 FOR I ~ 1 STEP 1 UNTIL NSUBS DO 00713000 BEGIN 00714000 IF BOUND ~ EXTRAINFO[BDLINK.IR,BDLINK.IC] < 0 THEN 00715000 EMITOPDCLIT(BOUND) ELSE EMITNUM(BOUND); 00716000 BDLINK ~ BDLINK -1; 00717000 IF I > 1 THEN EMITO(MUL); 00718000 END; 00719000 IF A.SUBCLASS } DOUBTYPE THEN EMITPAIR(2, MUL); 00720000 EMITPAIR( C.SIZE,STD); 00721000 XIT: 00722000 IF DEBUGTOG THEN FLAGROUTINE("VARIAB","LEDIMS",FALSE); 00722010 END VARIABLEDIMS; 00723000 PROCEDURE EMITD(R,OP); VALUE R,OP; REAL R,OP; FORWARD; 00723100 STREAM PROCEDURE SETPNT(W1,W2,PNT,CL,SUBC,STAR,POS,F,S,Q) ; 00723140 VALUE CL,SUBC,STAR,POS,F,S,Q ; 00723150 BEGIN F(SI~W1; SI~SI+2; DI~PNT ; 00723160 IF SC}"0" THEN 00723170 BEGIN DS~5CHR; DS~LIT" "; DI~DI-6; DS~5FILL ; 00723180 END ELSE BEGIN DS~6LIT" "; DI~PNT; DS~Q CHR END); 00723200 S(DI~PNT; DI~DI+6; DS~LIT" "; 00723210 SI ~ LOC SUBC; SI ~ SI+2; DS ~ 6 CHR; DS ~ LIT " "; 00723230 SI~LOC CL; SI~SI+2; DS~6CHR; DS~LIT" "); 00723240 DI~PNT; DI~DI+21; 00723250 POS(DI~DI+11); 00723255 SI ~ LOC STAR; SI ~ SI+7; DS ~ CHR; 00723265 SI ~ W2; DS~8CHR ; 00723280 SI ~ LOC STAR; SI ~ SI+7; DS ~ CHR; 00723295 END OF SETPNT; 00723325 PROCEDURE PT(EOF,REC); VALUE EOF; BOOLEAN EOF; ARRAY REC[0]; 00723450 BEGIN LABEL L6; REAL L; 00723470 IF EOF THEN WRITE(LINE,15,PRINTBUFF[*]) 00723520 ELSE 00723595 IF BOOLEAN(L~REAL(REC[0]~REC[0]&REC[2] [1:26:1]=XTA)) THEN 00723610 BEGIN 00723620 IF IT~IT+1=9 THEN 00723630 BEGIN LASTLINE~FALSE; WRITE(LINE,15,PRINTBUFF[*]) ; 00723640 L6: BLANKIT(PRINTBUFF,15,IT~0) ; 00723650 END; 00723660 SETPNT(REC[0],REC[1],PRINTBUFF,KLASS[REC[2].CLASS],TYPES[REC[2]00723670 .SUBCLASS],IF BOOLEAN(REC[2]) THEN "*" ELSE " ",IT,L-1, 00723680 LASTLINE,6-REC[2].[27:3]) ; 00723690 END 00723700 ELSE BEGIN 00723710 LASTLINE~TRUE; WRITE(RITE,15,PRINTBUFF[*]); XTA~REC[0] ;00723720 GO L6 ; 00723730 END ; 00723740 END OF PT ; 00723800 01868000 PROCEDURE CHECKINFO; 00724000 BEGIN REAL I, T, A; 00725000 REAL LASTF; 00725100 REAL INFB,INFC; 00726000 LABEL NXT; ALPHA N; 00727000 FORMAT INFOF( 3(A6, X2), 00728000 " ADDRESS = ", A2, A4, 00729000 ", LENGTH = ", I5, 00730000 ", OFFSET = ", I5), 00731000 INFOT( / "LOCAL IDENTIFIERS:"), 00732000 LABF(A6,X10,"LABEL REL-ADR = ",I6,", SEGMNT = ",I5); 00733000 IF PRTOG THEN 00734000 WRITALIST(INFOT,0,0,0,0,0,0,0,0,0) ; 00735000 IF I ~ SEARCH("ERR ") ! 0 THEN 00736000 IF GET(I).CLASS = UNKNOWN THEN PUT(I+1, "......"); 00737000 IF I ~ SEARCH("END ") ! 0 THEN 00738000 IF GET(I).CLASS = UNKNOWN THEN PUT(I+1, "......"); 00739000 IF NOT DCINPUT THEN IF I~SEARCH("ZIP ") ! 0 THEN 00739100 IF GET(I).CLASS=UNKNOWN THEN PUT(I+1,"......") ; 00739200 FOR I ~ 0 STEP 1 UNTIL NEXTCOM DO 00740000 IF GETC(I).CLASS=HEADER THEN 00741000 00742000 IF GETC(I).CE=1 THEN 00743000 PUT((T~GETC(I+1).LINK+2),GET(T)&0[TOADINFO]) ; 00744000 00745000 T ~ 2; WHILE T < NEXTINFO DO 00746000 BEGIN 00747000 GETALL(T,A,INFB,INFC); 00748000 IF I ~ A.CLASS > FILEID THEN GO TO NXT; 00749000 IF N ~ INFB = "......" THEN GO TO NXT; 00750000 XTA ~ N; 00751000 IF I = LABELID THEN 00752000 BEGIN 00753000 IF A > 0 THEN FLAG(19) ELSE 00754000 IF PRTOG THEN WRITALIST(LABF,3,N,A.ADDR DIV 4,A.SEGNO,0,0,0,0, 00755000 0) ; 00755010 GO TO NXT; 00756000 END; 00757000 IF I = FORMATID THEN 00758000 IF A > 0 THEN BEGIN FLAG(62); GO TO NXT END ; 00759000 IF I = NAMELIST THEN 00760000 IF A > 0 THEN BEGIN FLAG(136); GO TO NXT END; 00761000 IF I = ARRAYID THEN 00762000 IF BOOLEAN(A.CE) THEN BEGIN IF A>0 THEN T~GETSPACE(T) END 00763000 ELSE IF A<0 THEN 00764000 IF BOOLEAN(A.FORMAL) THEN 00764020 BEGIN IF SPLINK > 1 AND ELX > 1 THEN 00764040 BEGIN % THIS IS A FORMAL PARAMETER FOR A SUBROUTINE OR A 00764060 % FUNCTION THAT HAS ONE OR MORE ENTRY STATEMENT. THIS 00764070 % PARAMETER WILL BE INITIALIZED TO AN ARRAY DESCRIPTOR00764080 % TO 0 SO THAT IF THE PARAMETERS ARE NOT SET UP BY THE00764090 % CALL ANY REFERENCE TO THEM WILL CAUSE AN INVALID 00764100 % ADDRESS 00764110 IF LASTF = 0 THEN % FIRST TIME THRU 00764150 BEGIN LASTF ~ A.ADDR; 00764200 EMITDESCLIT(2); EMITL(1); 00764220 EMITD(50,DIA); EMITD(10,DIB); EMITD(10,TRB); 00764240 END ELSE EMITPAIR(LASTF,LOD); 00764260 EMITPAIR(A.ADDR,SND); 00764280 END 00764300 END 00764320 ELSE ARRAYDEC(T); 00765000 IF PRTOG THEN 00766000 WRITALIST(INFOF,7,INFB, 00767000 IF BOOLEAN(A.TYPEFIXED) THEN TYPES[A.SUBCLASS] ELSE " ", 00768000 KLASS[A.CLASS], 00769000 IF A.ADDR < 1024 AND A < 0 THEN "R+" ELSE " ", 00770000 IF A < 0 THEN B2D(A.[26:10]) ELSE "NULL", 00771000 INFC.SIZE, 00772000 INFC.BASE,0); 00773000 IF BOOLEAN(A.CE) THEN IF A.SUBCLASS } DOUBTYPE THEN 00773100 IF BOOLEAN(INFC.BASE) THEN FLAG(146); 00773200 NXT: 00774000 T ~ T+3; 00775000 END; 00776000 END CHECKINFO; 00777000 PROCEDURE SEGMENTSTART; 00778000 BEGIN 00779000 NSEG ~ NXAVIL ~ NXAVIL + 1; 00780000 IF LISTOG THEN WRITALIST(SEGSTRT,1,NSEG,0,0,0,0,0,0,0) ; 00781000 DEBUGADR~ADR~-1; 00782000 IF NOT SEGOVFLAG THEN 00783000 BEGIN 00784000 DATAPRT~DATASTRT~DATALINK~DATASKP~ 00784100 LABELMOM ~ BRANCHX ~ FUNVAR ~ 00785000 DT ~ SPLINK ~ NEXTCOM ~ ELX ~ 0; 00786000 NEXTSS ~ 1022; 00787000 INITIALSEGNO ~ NSEG; 00788000 FOR I ~ 0 STEP 1 UNTIL LBRANCH DO BRANCHES[I] ~ I+1; 00789000 FOR I~0 STEP 1 UNTIL SHX DO STACKHEAD[I] ~ 0; 00790000 NEXTINFO ~ LOCALS ~ 2; 00791000 F2TOG ~ FALSE; RETURNFOUND ~ FALSE; 00792000 END; 00793000 ENDSEGTOG ~ FALSE; 00794000 IF SEGSW THEN LINESEG[NOLIN~0,0]~0 & D2B(LASTSEQ)[10:20:28] ; 00794400 END SEGMENTSTART; 00795000 PROCEDURE FIXPARAMS(I); VALUE I; INTEGER I; 00796000 BEGIN 00797000 REAL FMINUS, NPARMS, ELINK, LABX; 00798000 REAL PLINKX, PLINK; 00799000 REAL PTYPEX, PTYPE; 00800000 REAL CL, INF; 00801000 LABEL ARRY, LOAD, INDX; 00802000 REAL EWORD; 00803000 IF DEBUGTOG THEN FLAGROUTINE(" FIXP","ARMS ",TRUE); 00803010 EWORD ~ ENTRYLINK[I]; 00804000 ELINK ~ EWORD.LINK; 00805000 IF LABX ~ EWORD.CLASS > 0 THEN 00806000 BEGIN 00807000 EMITO(MKS); 00808000 EMITDESCLIT(LABELMOM); 00809000 EMITL(LABX); 00810000 EMITL(1); EMITL(1); EMITL(0); 00811000 EMITOPDCLIT(BLKCNTRLINT); 00812000 EMITL(1); EMITPAIR(FPLUS2,STD);% F+2~TRUE FOR BLKXIT CALL 00812400 END; %106-00813000 FMINUS ~ 1920; 00814000 NPARMS ~ (J~GET(ELINK+2)).NEXTRA; 00815000 IF NPARMS > 0 THEN %106-00816000 BEGIN 00817000 PLINKX ~ EWORD.ADDR-NPARMS+1; 00818000 PTYPEX ~ J.ADINFO + NPARMS-1; 00819000 FOR J ~ 1 STEP 1 UNTIL NPARMS DO 00820000 BEGIN 00821000 PLINK ~ EXTRAINFO[PLINKX.IR,PLINKX.IC]; 00822000 PTYPE ~ EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS; 00823000 FMINUS ~ FMINUS+1; 00824000 IF PLINK = 0 THEN 00825000 BEGIN 00826000 EMITOPDCLIT(FMINUS); 00827000 EMITL(LABX ~ LABX-1); 00828000 EMITDESCLIT(LABELMOM); 00829000 EMITO(STD); 00830000 END ELSE 00831000 BEGIN 00832000 IF CL ~ (INF ~ GET(PLINK)).CLASS = UNKNOWN THEN CL ~ VARID; 00833000 XTA ~ GET(PLINK+1); 00834000 IF PTYPE = 0 THEN EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS 00835000 ~ PTYPE ~ CL; 00836000 CASE PTYPE OF 00837000 BEGIN ; 00838000 IF CL ! ARRAYID THEN FLAG(79) ELSE 00839000 ARRY: 00840000 BEGIN 00841000 FMINUS ~ FMINUS+1; 00842000 IF INF < 0 THEN 00843000 BEGIN 00844000 EMITPAIR(FMINUS, LOD); 00845000 EMITPAIR(T~INF.ADDR, STD); 00846000 EMITOPDCLIT(FMINUS-1); 00847000 EMITPAIR(T-1, STD); 00848000 END; 00849000 END; 00850000 IF CL ! VARID THEN FLAG(80) ELSE 00851000 LOAD: 00852000 BEGIN 00854000 IF INF.SUBCLASS}DOUBTYPE AND CL=VARID THEN FMINUS~FMINUS+1; 00854100 IF INF<0 THEN 00854200 BEGIN 00854300 EMITPAIR(FMINUS, LOD); 00855000 EMITPAIR(T~INF.ADDR,STD); 00856000 IF INF.SUBCLASS}DOUBTYPE AND CL=VARID THEN %105-10856100 BEGIN EMITOPDCLIT(FMINUS-1); 00856200 EMITPAIR(T+1,STD); 00856300 END; 00856400 END ; 00856500 END; 00857000 ; ; ; ; 00858000 IF CL = FUNID THEN GO TO LOAD ELSE FLAG(81); 00859000 00859100 00859200 00859300 00859400 00859500 ; 00860000 IF CL = FUNID OR CL = SUBRID OR CL = EXTID THEN GO TO LOAD 00861000 ELSE FLAG(83); 00861100 IF CL = SUBRID THEN GO TO LOAD ELSE FLAG(82); 00862000 ; ; 00863000 BEGIN 00864000 IF CL = ARRAYID THEN 00865000 BEGIN 00866000 EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS ~ CL; 00867000 GO TO ARRY; 00868000 END; 00869000 INDX: 00870000 IF CL ! VARID THEN FLAG(80); 00871000 FMINUS ~ FMINUS+1; 00872000 IF INF < 0 THEN 00873000 BEGIN 00874000 EMITOPDCLIT(FMINUS-1); 00875000 EMITDESCLIT(FMINUS); 00876000 EMITPAIR(INF.ADDR, STD); 00877000 END; 00878000 END; 00879000 IF CL = VARID THEN GO TO LOAD ELSE FLAG(80); 00880000 GO TO INDX; 00892000 END CASE STATEMENT; 00893000 A ~ INF.SUBCLASS; 00894000 IF T ~ EXTRAINFO[PTYPEX.IR,PTYPEX.IC].SUBCLASS = 0 OR 00895000 T = INTYPE AND A = REALTYPE THEN 00896000 EXTRAINFO[PTYPEX.IR,PTYPEX.IC].SUBCLASS ~ A ELSE 00897000 IF T ! A THEN 00898000 BEGIN XTA ~ GET(PLINK+1); FLAG(88) END; 00899000 END; 00900000 PLINKX ~ PLINKX+1; 00901000 PTYPEX ~ PTYPEX-1; 00902000 END; 00903000 PLINKX ~ PLINKX-NPARMS; 00904000 FOR J ~ 1 STEP 1 UNTIL NPARMS DO 00905000 BEGIN 00906000 PLINK ~ EXTRAINFO[PLINKX.IR,PLINKX.IC]; 00907000 IF PLINK ! 0 THEN 00908000 IF (A~GET(PLINK)).CLASS = ARRAYID THEN 00909000 IF T~GET(PLINK+2) <0 THEN VARIABLEDIMS(A, T); 00910000 PLINKX ~ PLINKX+1; 00911000 END; 00912000 END; 00913000 EMITB(GET(ELINK+2).BASE & (GET(ELINK).SEGNO)[TOSEGNO], FALSE); 00914000 IF DEBUGTOG THEN FLAGROUTINE(" FIXP","ARMS ",FALSE) ; 00914010 END FIXPARAMS; 00915000 PROCEDURE XREFCORESORT ; 00915100 BEGIN 00915120 REAL F,G,H,J,K,L,T,TT,IJ,M,TN ; 00915140 SAVE ARRAY A[0:XRI-1], IL,IU[0:8]; 00915160 ARRAY W2,W3[0:XRI-1] ; 00915180 LABEL L1,L2,L3,L4,L5,L6,L11,L12,L13,L14 ; 00915200 DEFINE CMPARGT(A) = A.NAME=TN THEN IF (IF G~W3[H~A.[2:10]].[26:4] 00915220 =TT~W3[F~T.[2:10]].[26:4] THEN NOT CMPA(W2[H], 00915240 W2[F]) ELSE G>TT) #, 00915260 CMPARLS(A) = A.NAME=TN THEN IF (IF G~W3[H~T.[2:10]].[26:4] 00915280 =TT~W3[F~A.[2:10]].[26:4] THEN NOT CMPA(W2[H], 00915300 W2[F]) ELSE G>TT) #, 00915320 NAME = [12:36] # ; 00915340 J~XRI-1; G~XRI DIV K~XRBUFFDIV3; H~XRBUFF ; 00915360 FOR L~1 STEP 1 UNTIL G DO 00915380 BEGIN 00915400 L11: READ(XREFF,H,XRRY[*]); TRANSFER(W2[T~(L-1)|50],XRRY,K) ; 00915420 IJ~T+K-1; TN~-3; 00915440 FOR F~T STEP 1 UNTIL IJ DO 00915460 BEGIN A[F]~XRRY[TN~TN+3]&F[2:38:10]; W3[F]~XRRY[TN+2] END;00915480 END; 00915500 IF H=XRBUFF THEN IF K~XRI MOD K DIV 1!0 THEN BEGIN H~3|K;GO L11 END;00915520 GO L4 ; 00915540 L1: IF A[K~I].NAME>TN~(T~A[IJ~((L~J)+I+1).[37:10]]).NAME THEN 00915560 L12: BEGIN A[IJ]~A[I]; A[I]~T; TN~(T~A[IJ]).NAME END 00915580 ELSE IF CMPARGT(A[I]) THEN GO L12 ; 00915600 IF A[J].NAMETN THEN GO L2; IF CMPARGT(A[L]) THEN GO L2; 00915780 L3: IF A[K~K+1].NAMEJ+I THEN BEGIN IL[M]~I; IU[M]~L; I~K END 00915840 ELSE BEGIN IL[M]~K; IU[M]~J; J~L END ; 00915860 M~M+1 ; 00915880 L4: IF I+10TN~(T~A[I]).NAME THEN 00915960 BEGIN 00915980 L5: A[K+1]~A[K]; IF A[K~K-1].NAME>TN THEN GO L5 ; 00916000 IF CMPARGT(A[K]) THEN GO L5 ; 00916020 A[K+1]~T ; 00916040 END 00916060 ELSE IF CMPARGT(A[K]) THEN GO L5 ; 00916080 IF (M~M-1) GEQ 0 THEN BEGIN I~IL[M]; J~IU[M]; GO L4 END ; 00916100 G~XRI-1 ; 00916120 FOR I~ 0 STEP 1 UNTIL G DO 00916140 IF BOOLEAN(L~REAL(A[I]~A[I].NAME&(TN~W3[J~A[I].[2:10]])[1:26:1]00916160 =XTA)) THEN 00916180 BEGIN 00916200 IF IT~IT+1=9 THEN 00916220 BEGIN LASTLINE~FALSE; WRITE(LINE,15,PRINTBUFF[*]) ; 00916240 L6: BLANKIT(PRINTBUFF,15,IT~0) ; 00916260 END ; 00916280 SETPNT(A[I],W2[J],PRINTBUFF,KLASS[TN.CLASS],TYPES[TN. 00916300 SUBCLASS],IF BOOLEAN(TN) THEN "*" ELSE " ",IT,L-1, 00916320 LASTLINE,6-TN.[27:3]) ; 00916340 END 00916360 ELSE BEGIN 00916380 LASTLINE~TRUE; WRITE(RITE,15,PRINTBUFF[*]); XTA~A[I]; 00916400 GO L6; 00916420 END ; 00916440 WRITE(LINE,15,PRINTBUFF[*]); XRI~0; 00916460 END OF XREFCORESORT ; 00916480 PROCEDURE SETUPSTACK ; 00916900 BEGIN 00917000 REAL I; 00918000 EMITOPDCLIT(16); 00919000 EMITL(1); 00920000 EMITO(ADD); 00921000 EMITL(16); 00922000 EMITO(SND); 00923000 FOR I ~ 1 STEP 1 UNTIL LOCALS DO EMITL(0); 00924000 CHECKINFO; 00925000 IF DATAPRT ! 0 THEN 00925010 BEGIN ADJUST; EMITOPDCLIT(DATAPRT); EMITO(LNG); EMITB(-1,TRUE);00925020 DATASKP~LAX; EMITB(DATASTRT,FALSE); FIXB(DATALINK); 00925030 EMITL(1); EMITPAIR(DATAPRT,STD); FIXB(DATASKP); 00925040 END; 00925050 ADJUST; 00925060 END SETUPSTACK; 00926000 PROCEDURE BRANCHLIT(X,Y); VALUE X,Y; REAL X; BOOLEAN Y; 00927000 BEGIN 00928000 IF ADR } 4075 THEN 00929000 BEGIN ADR ~ ADR+1; SEGOVF END; 00930000 ADJUST; 00931000 IF X.SEGNO!NSEG THEN BEGIN 00932000 IF(PRTS+1).[37:2]=1 AND Y THEN 00932300 EMITOPDCLIT(PRGDESCBLDR(2,0,(ADR+5) DIV 4+1,NSEG)) 00932700 ELSE EMITOPDCLIT(PRGDESCBLDR(2,0,(ADR+5) DIV 4,NSEG)) END 00933000 ELSE 00934000 EMITL((ADR+5) DIV 4 - X.LINK DIV 4) ; 00935000 END BRANCHLIT; 00936000 PROCEDURE SEGMENT(SZ,CURSEG,SEGTYP,EDOC); % WRITES OUT EDOC AS SEGMENT 00937000 VALUE SZ,CURSEG,SEGTYP; % UPDATES PDPRT WITH PSUEDO 00938000 REAL SZ,CURSEG; % UPDATES PDPRT WITH PSUEDO 00939000 BOOLEAN SEGTYP; % TRUE TO WRAP UP A SUBROUTINE BLOCK 00940000 % FALSE TO WRAP UP A SPLIT BLOCK 00941000 ARRAY EDOC[0,0]; % CONTAINS DATA TO WRITE; 00942000 BEGIN 00943000 STREAM PROCEDURE M1(F,T); BEGIN DI ~ T; SI ~ F; DS ~ 2 WDS END;00944000 REAL T; 00945000 REAL BEGINSUB, ENDSUB, HERE; 00946000 LABEL WRITEPGM; 00947000 INTEGER I, CNTR; 00948000 IF DEBUGTOG THEN FLAGROUTINE(" SEGM","ENT ",TRUE ); 00948010 IF NOT SEGTYP THEN GO TO WRITEPGM; 00949000 IF SPLINK > 1 AND NOT RETURNFOUND THEN 00949100 BEGIN XTA ~ BLANKS; FLAG(142) END; 00949200 IF SPLINK < 0 THEN 00950000 BEGIN 00951000 ADJUST; 00952000 BDPRT[BDX~BDX+1] ~ PRGDESCBLDR(1, 0, (ADR+1) DIV 4, NSEG); 00953000 FOR I ~ 1 STEP 1 UNTIL LOCALS DO EMITL(0); 00954000 CHECKINFO; 00955000 00955500 EMITB(0&INITIALSEGNO[TOSEGNO], FALSE); 00956000 END 00957000 ELSE 00958000 IF SPLINK = 1 THEN % MAIN PROGRAM 00959000 BEGIN 00960000 ADJUST; 00961000 IF STRTSEG ! 0 THEN FLAG(75); 00962000 STRTSEG ~ NSEG & 00963000 PRGDESCBLDR(1, 0, (ADR+1) DIV 4, NSEG)[18:33:15]; 00964000 SETUPSTACK; 00965000 00965500 EMITB(0&INITIALSEGNO[TOSEGNO], FALSE); 00966000 END 00967000 ELSE 00968000 IF ELX { 1 THEN 00969000 BEGIN 00970000 ADJUST; 00971000 T ~ PRGDESCBLDR(1, GET(SPLINK).ADDR, (ADR+1) DIV 4, NSEG); 00972000 SETUPSTACK; 00973000 FIXPARAMS(0); 00974000 INFO[SPLINK.IR, SPLINK.IC].SEGNO ~ NSEG; 00975000 END 00976000 ELSE 00977000 BEGIN 00978000 ADJUST; 00979000 BEGINSUB ~ (ADR+1) & NSEG[TOSEGNO]; 00980000 EMITL(17); EMITO(STD); 00981000 SETUPSTACK; 00982000 EMITOPDCLIT(17); EMITO(GFW); 00982100 ENDSUB ~ ADR & NSEG[TOSEGNO]; 00983000 FOR I ~ 0 STEP 1 UNTIL ELX-1 DO 00984000 BEGIN 00985000 ADJUST; 00986000 HERE ~ (ADR+1) DIV 4; 00988000 T ~ ENTRYLINK[I].LINK; 00989000 %VOID 00990000 T ~ PRGDESCBLDR(1, GET(T).ADDR, HERE, NSEG); 00991000 BRANCHLIT(ENDSUB,FALSE); 00992000 EMITB(BEGINSUB, FALSE); 00993000 ADJUST; 00994000 FIXPARAMS(I); 00995000 INFO[(ENTRYLINK[I].LINK).IR,(ENTRYLINK[I].LINK).IC].SEGNO~NSEG;00995500 END; 00996000 END; 00997000 SZ ~ (ADR+4) DIV 4; 00998000 CNTR ~ 0; 00999000 CURSEG ~ NSEG; 00999100 WRITEPGM: 01000000 NSEG ~ ((T ~ SZ) + 29) DIV 30; 01001000 IF DALOC DIV CHUNK < I ~ (DALOC+NSEG) DIV CHUNK 01002000 THEN DALOC ~ CHUNK | I; % INSURE SEGMENT DONT BREAK 01003000 % ACROSS ROW 01004000 IF LISTOG THEN WRITALIST(SEGEND,2,CURSEG,T,0,0,0,0,0,0) ; 01005000 PDPRT[PDIR,PDIC] ~ % PDPRT ENTRY FOR SEGMENT 01006000 SZ&DALOC[DKAC] 01007000 & GET(SPLINK)[12:14:1] 01007100 &CURSEG[SGNOC]; 01008000 IF ERRORCT = 0 THEN 01009000 DO BEGIN 01010000 FOR I~0 STEP 2 WHILE I < 30 AND CNTR < SZ DO 01011000 BEGIN M1(EDOC[CNTR.[38:3],CNTR.[41:7]],CODE(I)); 01012000 CNTR ~ CNTR + 2; 01013000 END; 01014000 WRITE(CODE[DALOC]); 01015000 DALOC ~ DALOC +1; 01016000 END UNTIL CNTR } SZ; 01017000 PDINX ~ PDINX +1; 01018000 IF NOT SEGOVFLAG THEN 01018025 IF PXREF THEN 01018100 IF(EODS~(NEXT=EOF))AND NOT XGLOBALS THEN ELSE 01018110 BEGIN KLASS[6]~ "LABEL "; 01018120 WRITE(XREFF,XRBUFF,XRRY[*]) ; 01018125 IF FIRSTCALL THEN DATIME ELSE WRITE(PTR[PAGE]); 01018130 IF SPLINK<0 THEN 01018135 BEGIN WRITE(PTR,XHEDB);REWIND(XREFF);END 01018140 ELSE 01018145 IF EODS THEN BEGIN WRITE(PTR,XHEDG); REWIND(XREFG) END 01018150 ELSE BEGIN REWIND(XREFF); C2~(XR[4].SUBCLASS|2+5); 01018160 IF IT~XR[4].CLASS=FUNID THEN WRITE(PTR,XHEDF, 01018170 XR[C2],XR[C2+1],XR[3],XR[C2+12], 01018180 XR[C2+13],"------") 01018190 ELSE IF IT=SUBRID THEN WRITE(PTR,XHEDS,XR[3], 01018200 "------") ELSE WRITE(PTR,XHEDM); 01018210 END; 01018220 IT~XTA~0; 01018260 LASTLINE ~ FALSE; 01018280 BLANKIT(PRINTBUFF,15,0); 01018320 IF XRI>1023 OR EODS THEN SORT(PT,INP,0,HV,CMP,3,4000) 01018330 ELSE XREFCORESORT ; 01018340 REWIND(XREFF); 01018350 PXREF~IF XREF THEN TRUE ELSE FALSE; 01018355 KLASS[6] ~ "ERROR "; 01018360 IF (NOT SEGTYP AND EODS) OR (SEGTYP AND LISTOG AND 01018370 NOT SEGPTOG) THEN WRITE (PTR[PAGE]); 01018375 END; 01018380 IF LISTOG AND SEGTYP AND SEGPTOG THEN WRITE(PTR[PAGE]); 01019000 IF SEGTYP THEN 01019100 BEGIN 01019110 FOR I~12,17 STEP 1 UNTIL 24,39 STEP 1 UNTIL 41, 01019150 50 STEP 1 UNTIL 57 DO TIPE[I]~REALID ; 01019160 FOR I~25,33 STEP 1 UNTIL 37 DO TIPE[I]~INTID ; 01019170 LASTNEXT ~ 1000; 01019190 END; 01019200 ENDSEGTOG ~ TRUE; 01020000 TSEGSZ ~ TSEGSZ + SZ; 01021000 COMMENT IF SEGSW THEN LETS ALSO WRITE OUT THE LINE SEGMENTS 01021010 THAT WE VE GONE TO SUCH TROUBLE BUILDING. LINESEG 01021150 CONTAINS A CARD SEQUENCE NUMBER(BINARY) IN [10:28] 01021200 AND THE WORD BOUNDARY ADDRESS OF THE FIRST CODE 01021250 SYLLABLE IN [38:10]; 01021300 IF SEGSW THEN 01021350 IF NOLIN > 0 THEN 01021360 BEGIN 01021400 LINEDICT[CURSEG.IR,CURSEG.IC] ~ % UPDATE LINE DICTIONARY 01021450 0 & NOLIN[18:33:15] & DALOC[33:33:15];%FOR THIS SEGMENT 01021500 CNTR ~ 0; DO BEGIN 01021550 FOR I ~ 0 STEP 2 WHILE I<30 AND CNTR 30 THEN 30 ELSE (SZ-I)); 01046000 WRITE(CODE[DALOC]); 01047000 DALOC ~ DALOC +1; 01048000 END; 01049000 IF LISTOG THEN WRITALIST(SEGEND,2,SEG,T,0,0,0,0,0,0) ; 01050000 TSEGSZ ~ TSEGSZ + SZ; 01051000 END WRITEDATA; 01052000 REAL PROCEDURE PRGDESCBLDR(DT,PRT,RELADR,SGNO); 01053000 VALUE DT,PRT,RELADR,SGNO; 01054000 REAL DT,PRT,RELADR,SGNO; 01055000 BEGIN 01056000 FORMAT FMT("PRT=",A4,", REL-ADR=",A4,", SEG=",I4,", TYPE=",A2); 01057000 IF PRT=0 THEN BEGIN BUMPPRT; PRT~PRTS END; 01058000 PDPRT[PDIR,PDIC] ~ 01059000 0&DT[DTYPC] 01060000 &PRT[PRTAC] 01061000 &RELADR[RELADC] 01062000 &SGNO[SGNOC]; 01063000 PDINX ~ PDINX +1; 01064000 IF CODETOG THEN WRITALIST(FMT,4,B2D(PRT),B2D(RELADR),SGNO, 01065000 IF DT=0 THEN "AE" ELSE IF DT=1 THEN "PD" ELSE "LD",0,0,0,0) ; 01066000 PRGDESCBLDR ~ PRT; 01067000 END PRGDESCBLDR; 01068000 PROCEDURE EQUIV(R); VALUE R; REAL R; 01069000 COMMENT THIS PROCEDURE FIXES UP THE INFO TABLE FOR THE EQUIV OR 01069100 COMMON RING. THE FIRST ELEMENT PAST HAS AN OFFSET (DO NOT 01069110 ALTER THIS) THE TYPE IS FIXED. THE OFFSET IS DETERMINED 01069120 FROM THE FIRST. CORRECTINFO ADJUST THE OFFSET IF THERE 01069130 IS A NEGATIVE OFFSET ON ANY ELEMENT. THE INFA[ADJ] BIT IS 01069140 SET IF THE ELEMENT HAS A NEGATIVE OFFSET. IF THE ELEMENT 01069150 APPEARED IN MORE THAN ONE EQUIVALENCE STATEMENT OR AN 01069160 EQUIVALENCE STATEMENT AND A COMMON STATEMENT THE ELEMENTS 01069170 ARE LINKED BY COM[LASTC] WHICH POINTS TO THE HEADER 01069180 OF THAT STATEMENT; 01069190 BEGIN 01070000 DEFINE BASS = LOCALS #, % THESE DEFINES ARE USED TO REDUCE THE01071000 REL = PARMS #, % STACKSIZE OF EQUIV FOR RECURSION 01071100 I = PRTS #, 01071200 T = LSTS #, 01071250 Q = LSTA #, 01071400 LAST = TV #, 01071500 B = SAVESUBS #, 01071600 P = NAMEIND #, 01071700 PRTX = LSTI #, 01071800 C = FX1 #, 01071900 INFA = FX2 #, 01072000 INFB = FX3 #, 01072100 INFC = NX1 #; 01072200 LABEL XIT, CHECK; 01073000 IF DEBUGTOG THEN FLAGROUTINE(" EQU","IV ",TRUE) ; 01073010 IF GETC(R)<0 THEN GO TO XIT ; 01074000 PUTC(R,-GETC(R)) ; 01075000 PRTX ~ GROUPPRT; 01076000 C~REAL(GETC(R).CE=1) ; 01077000 LAST~GETC(R).LASTC-1 ; 01078000 BASS~GETC(R+1); P~0 ; 01079000 FOR I ~ R+2 STEP 1 UNTIL LAST DO 01080000 BEGIN IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; 01081000 GETALL(T~GETC(I).LINK,INFA,INFB,INFC) ; 01082000 IF Q~INFC.SIZE=0 THEN % A SIMPLE VARIABLE 01083000 INFC.SIZE ~ Q ~ IF INFA.SUBCLASS { LOGTYPE THEN 1 ELSE 2; 01084000 PUT(T+2,INFC); 01085000 IF INFA.SUBCLASS>LOGTYPE THEN SEENADOUB~TRUE; 01085500 IF BOOLEAN(C) THEN 01086000 BEGIN COM[PWI].RELADD~REL~P ; 01087000 P ~ P + Q; 01088000 END ELSE COM[PWI].RELADD~REL~BASS-GETC(I).RELADD ; 01089000 IF INFA < 0 THEN IF INFA .ADJ = 1 THEN 01090000 B ~ -INFC.BASE - REL ELSE B ~ INFC.BASE - REL; 01091000 END; 01092000 FOR I ~ R+2 STEP 1 UNTIL LAST DO 01093000 BEGIN IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; 01094000 GETALL(T~GETC(I).LINK,INFA,INFB,INFC) ; 01095000 IF INFA.CLASS = 1 THEN SWARYCT ~ 1; 01095500 P~B+GETC(I).RELADD ; 01096000 Q ~ INFC .SIZE; 01097000 IF INFA < 0 THEN 01098000 BEGIN IF INFA .ADJ = 1 THEN BASS ~ -INFC .BASE ELSE 01099000 BASS ~ INFC.BASE; 01100000 IF P ! BASS THEN 01101000 BEGIN XTA ~ INFB ; FLAG(2) END; 01102000 GO TO CHECK; 01104000 END; 01105000 INFA ~ -INFA & PRTX[TOADDR]; 01108000 IF INFA .CLASS = UNKNOWN THEN INFA .CLASS ~ VARID; 01109000 INFA .TYPEFIXED ~ 1; 01110000 INFC.BASE ~ P; 01111000 PUT(T+2,INFC); 01112000 IF P < 0 THEN INFA .ADJ ~ 1; 01113000 PUT(T,INFA); 01114000 CHECK: 01115000 IF P+Q > LENGTH THEN LENGTH ~ P+Q; 01116000 IF P < LOWERBOUND THEN LOWERBOUND ~ P; 01117000 END; 01118000 FOR I ~ R+2 STEP 1 UNTIL LAST DO 01119000 BEGIN 01120000 IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; 01121000 IF T~GETC(I).LASTC!R THEN 01122000 IF GETC(T)}0 THEN 01122500 BEGIN R~R&LAST[3:33:15]&I[18:33:15] ; 01122550 EQUIV(T); LAST~R.[3:15]; I~R.[18:15]; R~R.[33:15] ; 01122600 END; 01122650 END; 01123000 XIT: 01124000 IF DEBUGTOG THEN FLAGROUTINE(" EQU","IV ",FALSE) ; 01124010 END EQUIV; 01125000 ALPHA PROCEDURE GETSPACE(S); VALUE S; ALPHA S; 01126000 BEGIN LABEL RPLUS, FMINUS, XIT; 01127000 LABEL DONE; 01128000 REAL A; 01129000 BOOLEAN OWNID; 01129100 IF OWNID ~ S < 0 THEN S~ -S; % IN DATA STMT, THUS OWN 01129200 IF A ~ GET(GETSPACE~S) < 0 THEN GO TO DONE; 01130000 IF A.CLASS GEQ 13 THEN FLAG(34) ELSE %104-01130500 CASE A.CLASS OF 01131000 BEGIN 01132000 BEGIN 01133000 PUT(S,A~A&VARID[TOCLASS]); 01134000 PUT(S+2,(GET(S+2) &(IF A.SUBCLASS { LOGTYPE 01135000 THEN 1 ELSE 2 )[TOSIZE])); 01136000 END; 01137000 IF BOOLEAN(A.FORMAL) THEN BUMPLOCALS; 01138000 ; 01139000 BEGIN A.TYPEFIXED ~ 1; GO TO RPLUS END; 01140000 GO TO RPLUS; 01141000 GO TO RPLUS; 01142000 GO TO DONE; 01143000 BEGIN A.TYPEFIXED ~ 1; IF BOOLEAN(A.FORMAL) THEN GO TO FMINUS 01144000 ELSE GO TO RPLUS; 01145000 END; 01146000 BEGIN A.TYPEFIXED ~ 1; GO TO RPLUS END; 01147000 IF BOOLEAN(A.FORMAL) THEN GO TO FMINUS ELSE GO TO RPLUS; 01148000 IF BOOLEAN(A.FORMAL) THEN GO TO FMINUS ELSE GO TO RPLUS; 01149000 GO TO RPLUS; 01150000 GO TO RPLUS; 01151000 END OF CASE STATEMENT; 01152000 A.TYPEFIXED ~ 1; 01153000 IF BOOLEAN(A.FORMAL) THEN 01154000 GO TO FMINUS; 01155000 IF BOOLEAN(A.CE) OR BOOLEAN(A.EQ) THEN 01156000 BEGIN 01157000 PUT(S,A); 01158000 CALLEQUIV(A.ADDR,OWNID,GET(S+1)) ; 01159000 GO TO DONE; 01160000 END; 01161000 A.TWOD ~ REAL(GET(S+2).SIZE > 1023); 01162000 FMINUS: 01163000 IF OWNID THEN BEGIN BUMPPRT; A.ADDR~PRTS END ELSE 01163100 BEGIN BUMPLOCALS; A.ADDR ~ LOCALS +1536 END; 01164000 IF A.CLASS = VARID THEN IF A.SUBCLASS } DOUBTYPE THEN 01165000 IF OWNID THEN BUMPPRT ELSE 01165100 BUMPLOCALS; 01166000 GO TO XIT; 01167000 RPLUS: 01168000 BUMPPRT; A.ADDR~PRTS; 01169000 XIT: 01170000 PUT(S, -A); 01171000 DONE: 01172000 END GETSPACE; 01173000 INTEGER STREAM PROCEDURE LBLSHFT(S); VALUE S; 01174000 BEGIN 01175000 LOCAL T; 01176000 LABEL L; 01177000 DI ~ LOC LBLSHFT; DS ~ 8 LIT "00 "; 01178000 DI ~ DI - 6; SI ~LOC S; SI ~ SI + 2; 01179000 TALLY ~ 1; T ~ TALLY; 01180000 5(T(IF SC="0" THEN BEGIN SI~SI+1; JUMP OUT 1 TO L END 01181000 ELSE TALLY~0; T~TALLY); 01182000 IF SC}"0" THEN DS~CHR ELSE IF SC=" " THEN SI~SI+1 01183000 ELSE JUMP OUT; L: ) ; 01183100 IF SC ! " " THEN BEGIN DI ~ LOC LBLSHFT; DS ~ LIT "+" END; 01184000 END LBLSHFT; 01185000 COMMENT EMITTERS AND CODE CONTROL; 01186000 ALPHA PROCEDURE B2D(B); VALUE B; REAL B; 01187000 B2D ~ 0&B[45:45:3]&B[39:42:3]&B[33:39:3]&B[27:36:3]; 01188000 PROCEDURE DEBUG(S); % PRINTS OUT DEBUG CODE 01189000 VALUE S; REAL S; % IF S<0 THEN S IS FIELD TYPE OPERATOR 01190000 BEGIN 01191000 FORMAT FF(X35,*(33(".")),A4,":",A1,2(X2,A4),X4,A4) ; 01192000 ALPHA CODE,MNM,SYL; 01193000 REAL T; 01194000 PROCEDURE SEARCH(CODE,S); VALUE S; REAL S,CODE; 01195000 BEGIN % SEARCHS WOP TO FIND CODE FOR S 01196000 REAL N,I; 01197000 LABEL L; 01198000 N ~ 64; 01199000 FOR I ~ 66 STEP IF WOP[I] < S THEN N ELSE -N 01200000 WHILE N ~ N DIV 2 } 1 DO 01201000 IF WOP[I] =S THEN GO TO L; 01202000 I ~ 0; % NOT FOUND 01203000 L: CODE ~ WOP[I+1]; 01204000 END SEARCH; 01205000 IF S < 0 THEN 01206000 BEGIN % FIELD TYPE OPERATOR 01207000 SYL ~ S; 01208000 MNM ~ B2D(S.[36:6]); 01209000 IF (S ~ S.[42:6]) = 37 THEN CODE ~ "ISO " ELSE 01210000 IF S = 45 THEN CODE ~ "DIA " ELSE 01211000 IF S = 49 THEN CODE ~ "DIB " ELSE 01212000 IF S = 53 THEN CODE ~ "TRB "; 01213000 END 01214000 ELSE 01215000 BEGIN 01216000 IF (T ~ S.[46:2]) ! 1 THEN 01217000 BEGIN 01218000 SYL ~ S; 01219000 MNM ~ B2D(S.[36:10]); 01220000 IF T = 0 THEN CODE ~ "LITC" 01221000 ELSE IF T =2 THEN CODE ~ "OPDC" 01222000 ELSE CODE ~ "DESC"; 01223000 END 01224000 ELSE 01225000 BEGIN % SEARCH WOP FOR OPERATOR NAME 01226000 SYL ~ S; 01227000 MNM ~ " "; 01228000 SEARCH(CODE,S.[36:10]); 01229000 END; 01230000 END; 01231000 WRITALIST(FF,6,IF ADR{DEBUGADR THEN 1 ELSE -1,B2D(ADR.[36:10]),01232000 B2D(ADR.[46:2]),CODE,MNM,B2D(SYL),0,0) ; 01233000 IF DEBUGADR0 THEN S~GET(GETSPACE(P)); 01276000 IF S.CLASS = VARID THEN IF BOOLEAN(S.CE) THEN 01277000 IF BOOLEAN(S.TWOD) THEN 01278000 BEGIN 01279000 EMITL( (T~GET(P+2).BASE).[33:7]); 01280000 EMITDESCLIT(S.ADDR); 01281000 EMITO(LOD); 01282000 EMITL(T.[40:8]); 01283000 EMITO(CDC); 01284000 GO TO XIT; 01285000 END ELSE 01286000 EMITNUM(GET(P+2).BASE) 01287000 ELSE 01288000 IF NOT BOOLEAN(S.FORMAL) THEN IF NOT DESCREQ THEN 01289000 BEGIN 01290000 EMITL(S~S.ADDR); 01291000 IF S.[37:2]=1 THEN %REFERENCING 2ND HALF OF PRT; 01292000 BEGIN 01293000 IF ADR } 4087 THEN 01294000 BEGIN ADR ~ ADR+1; SEGOVF END; 01295000 EMITO(XRT); 01296000 END; 01297000 GO TO XIT; 01298000 END; 01299000 EMITDESCLIT(S.ADDR); 01300000 XIT: 01301000 END EMITN; 01302000 PROCEDURE EMITV(P); VALUE P; ALPHA P; 01303000 BEGIN 01304000 ALPHA S; 01305000 IF S~ GET(P) > 0 THEN S ~ GET(GETSPACE(P)); 01306000 IF S.CLASS = VARID THEN 01307000 IF BOOLEAN(S.CE) THEN 01308000 IF BOOLEAN(S.TWOD) THEN 01309000 BEGIN 01310000 EMITL( (T~GET(P+2).BASE).[33:7]); 01311000 EMITDESCLIT(S.ADDR); 01312000 EMITO(LOD); 01313000 IF S.SUBCLASS } DOUBTYPE THEN 01314000 BEGIN 01315000 EMITO(DUP); 01316000 EMITPAIR(T.[40:8]+1, COC); 01317000 EMITO(XCH); 01318000 EMITPAIR(T.[40:8], COC); 01319000 END ELSE EMITPAIR(T.[40:8], COC); 01320000 END 01321000 ELSE 01322000 IF S.SUBCLASS } DOUBTYPE THEN 01323000 BEGIN 01324000 EMITNUM( (T~GET(P+2).BASE)+1); 01325000 EMITOPDCLIT(S.ADDR); 01326000 EMITNUM(T); 01327000 EMITOPDCLIT(S.ADDR); 01328000 END ELSE 01329000 BEGIN 01330000 EMITNUM(GET(P+2).BASE); 01331000 EMITOPDCLIT(S.ADDR); 01332000 END 01333000 ELSE 01334000 IF S.SUBCLASS } DOUBTYPE THEN 01335000 IF BOOLEAN(S.FORMAL) THEN 01336000 BEGIN 01337000 EMITDESCLIT(S.ADDR); 01338000 EMITO(DUP); 01339000 EMITPAIR(1, XCH); 01340000 EMITO(INX); 01341000 EMITO(LOD); 01342000 EMITO(XCH); 01343000 EMITO(LOD); 01344000 END ELSE 01345000 BEGIN 01346000 EMITOPDCLIT(S.ADDR+1); 01347000 EMITOPDCLIT(S.ADDR); 01348000 END 01349000 ELSE EMITOPDCLIT(S.ADDR) 01350000 ELSE EMITOPDCLIT(S.ADDR); 01351000 END EMITV; 01352000 PROCEDURE EMITL(N); VALUE N; REAL N; 01353000 BEGIN 01354000 BUMPADR; 01355000 PACK(EDOC[EDOCI],(N~0&N[36:38:10]),ADR.[46:2]); 01356000 IF CODETOG THEN DEBUG(N); 01357000 END EMITL; 01358000 PROCEDURE EMITD(R, OP); VALUE R, OP; REAL R, OP; 01359000 BEGIN 01360000 BUMPADR; 01361000 PACK(EDOC[EDOCI], (R ~ OP & R[36:42:6]), ADR.[46:2]); 01362000 IF CODETOG THEN DEBUG(-R); 01363000 END EMITD; 01364000 PROCEDURE EMITDDT(B,A,X); VALUE B,A,X; INTEGER B,A,X ; 01364010 BEGIN % DOES DIB B, DIA A, TRB X; HANDLES [B:A:X]. 01364020 EMITD(B~B MOD 6+B DIV 6|8,DIB); EMITD(A~A MOD 6+A DIV 6|8,DIA) ; 01364030 EMITD(X~X,TRB); 01364035 END OF EMITDDT ; 01364040 PROCEDURE EMITPAIR(L, OP); VALUE L, OP; INTEGER L, OP; 01365000 BEGIN 01366000 EMITL(L); 01367000 IF L.[37:2] = 1 THEN 01368000 BEGIN 01369000 IF ADR } 4087 THEN 01370000 BEGIN ADR ~ ADR+1; SEGOVF END; 01371000 EMITO(XRT); 01372000 END; 01373000 EMITO(OP); 01374000 END EMITPAIR; 01375000 PROCEDURE ADJUST; 01376000 WHILE ADR.[46:2] ! 3 DO EMITO(NOP); 01377000 PROCEDURE EMITNUM(N); VALUE N; REAL N; 01378000 BEGIN 01379000 DEFINE CPLUS = 1792#; 01380000 IF N.[3:6] =0 AND ABS(N) < 1024 THEN 01381000 BEGIN 01382000 EMITL(N); 01383000 IF N < 0 THEN EMITO(SSN); 01384000 END ELSE 01385000 BEGIN 01386000 IF ADR } 4079 THEN 01387000 BEGIN ADR ~ ADR+1; SEGOVF END; 01388000 EMITOPDCLIT(CPLUS + (ADR+1).[46:1] + 1); 01389000 EMITL(2); 01390000 EMITO(GFW); 01391000 ADJUST; 01392000 BUMPADR; 01393000 PACK(EDOC[EDOCI],N.[1:11],ADR.[46:2]); 01394000 BUMPADR; 01395000 PACK(EDOC[EDOCI],N.[12:12],ADR.[46:2]); 01396000 BUMPADR; 01397000 PACK(EDOC[EDOCI],N.[24:12],ADR.[46:2]); 01398000 BUMPADR; 01399000 PACK(EDOC[EDOCI],N.[36:12],ADR.[46:2]); 01400000 IF N.[36:12]=49 THEN %%% IF C-REL CONSTANT LOOKS LIKE AN XRT 01400400 EMITO(NOP); %%% THEN INSURE AGAINST P-BIT INTERRUPT. 01400600 IF CODETOG THEN DEBUGWORD(N); 01401000 END; 01402000 END EMITNUM; 01403000 PROCEDURE EMITNUM2(HI,LO);VALUE HI,LO; REAL HI,LO; 01404000 BEGIN 01405000 BOOLEAN B; REAL I,N; 01406000 LABEL Z,X; 01407000 DEFINE CPLUS = 1792#; 01408000 IF HI=0 OR LO=0 THEN BEGIN EMITNUM(LO); EMITNUM(HI); GO Z END; 01408100 ADJUST; 01409000 IF ADR } 4077 THEN 01410001 BEGIN ADR~ADR+1; SEGOVF; ADR~-1 END; 01411000 EMITOPDCLIT(CPLUS + 2); EMITOPDCLIT(CPLUS + 1); 01412000 EMITPAIR(3,GFW); 01413000 X: FOR I ~ 0 STEP 1 UNTIL 3 DO 01415000 BEGIN 01416000 CASE I OF BEGIN 01417000 N ~ HI.[ 1:11]; 01418000 N ~ HI.[12:12]; 01419000 N ~ HI.[24:12]; 01420000 N ~ HI.[36:12]; 01421000 END CASE; 01422000 BUMPADR; PACK(EDOC[EDOCI],N,ADR.[46:2]); 01423000 END; 01424000 IF CODETOG THEN DEBUGWORD(HI); 01425000 IF NOT B THEN BEGIN B~TRUE; HI~LO; GO TO X; END; 01426000 IF N=49 THEN %%% IF C-REL CONSTANT LOOKS LIKE AN XRT 01426400 EMITO(NOP) ; %%% THEN INSURE AGAINST P-BIT INTERRUPT. 01426600 Z: 01426650 END EMITNUM2; 01427000 PROCEDURE EMITLINK(N); VALUE N; REAL N; % EMITS LINKS 01428000 BEGIN 01429000 FORMAT FF(X35,*(33(".")),A4,":",A1," LINK",X10,A4,"******") ; 01430000 BUMPADR; 01431000 PACK(EDOC[EDOCI],N,ADR.[46:2]); 01432000 IF CODETOG THEN 01433000 WRITALIST(FF,4,IF ADR{DEBUGADR THEN 1 ELSE -1,B2D(ADR.[36:10]),01434000 B2D(ADR.[46:2]),B2D(N),0,0,0,0) ; 01435000 IF DEBUGADRLBRANCH THEN FATAL(123); 01530000 BRANCHX ~ BRANCHES[LAX~BRANCHX]; 01531000 BRANCHES[LAX] ~ -(ADR+1); 01532000 EMITLINK(0); 01533000 EMITO(IF C THEN BFC ELSE BFW); 01534000 EMITO(NOP); 01534100 END ELSE 01535000 BEGIN 01536000 SEG ~ A.SEGNO; 01537000 A ~ A.LINK; 01538000 BEOREF ~ ADR > A; 01539000 IF A.[46:2] =0 THEN 01540000 BEGIN 01541000 IF SEG > 0 AND SEG ! NSEG THEN 01542000 EMITOPDCLIT(PRGDESCBLDR(2, 0, A.[36:10], SEG)) 01543000 ELSE 01544000 EMITL(ABS((ADR+2).[36:10] - A.[36:10])); 01545000 IF BEOREF THEN 01546000 EMITO( IF C THEN GBC ELSE GBW) ELSE 01547000 EMITO( IF C THEN GFC ELSE GFW); 01548000 END ELSE 01549000 BEGIN 01550000 EMITL(ABS(ADR + 3 - A)); 01551000 IF BEOREF THEN 01552000 EMITO(IF C THEN BBC ELSE BBW) ELSE 01553000 EMITO(IF C THEN BFC ELSE BFW); 01554000 END; 01555000 END; 01556000 END EMITB; 01557000 PROCEDURE EMITDESCLIT(N); VALUE N; REAL N; 01558000 BEGIN 01559000 IF N.[37:2] = 1 THEN 01560000 BEGIN 01561000 IF ADR } 4087 THEN 01562000 BEGIN ADR ~ ADR+1; SEGOVF END; 01563000 EMITO(XRT); 01564000 END; 01565000 BUMPADR; 01566000 PACK(EDOC[EDOCI],(N~3&N[36:38:10]),ADR.[46:2]); 01567000 IF CODETOG THEN DEBUG(N); 01568000 END EMITDESCLIT; 01569000 PROCEDURE EMITOPDCLIT(N); VALUE N; REAL N; 01570000 BEGIN 01571000 IF N.[37:2] = 1 THEN 01572000 BEGIN 01573000 IF ADR } 4087 THEN 01574000 BEGIN ADR ~ ADR+1; SEGOVF END; 01575000 EMITO(XRT); 01576000 END; 01577000 BUMPADR; 01578000 PACK(EDOC[EDOCI],(N~2&N[36:38:10]),ADR.[46:2]); 01579000 IF CODETOG THEN DEBUG(N); 01580000 END EMITOPDCLIT; 01581000 PROCEDURE EMITLABELDESC(N); VALUE N; ALPHA N; 01582000 BEGIN 01583000 LABEL XIT; 01584000 REAL T,B,C,D ; 01585000 IF N ~ LBLSHFT(XTA~N) = 0 OR N = BLANKS THEN 01586000 BEGIN FLAG(135); GO TO XIT END; 01587000 IF T ~ SEARCH(N) = 0 THEN 01588000 T ~ ENTER(0 & LABELID[TOCLASS], N) ELSE 01588100 IF GET(T).CLASS ! LABELID THEN 01588200 BEGIN FLAG(144); GO TO XIT END; 01588300 IF XREF THEN ENTERX(N,0&LABELID[TOCLASS]); 01588400 IF B ~(C~GET(T+2)).BASE =0 THEN 01589000 IF (D~GET(T)).SEGNO!0 THEN C.BASE~B~PRGDESCBLDR(2,0,D.ADDR DIV 4, 01589010 D.SEGNO) ELSE 01589020 BEGIN BUMPPRT; C.BASE~B~PRTS END; PUT(T+2,C); 01590000 EMITL(B); EMITO(MKS); 01591000 EMITDESCLIT(1536); % F+0 01592000 EMITOPDCLIT(1537); % F+1 01593000 EMITV(NEED(".LABEL", INTRFUNID)); 01594000 XIT: 01595000 END EMITLABELDESC; 01596000 COMMENT TRACEBACK, OFLOWHANGERS, AND PRTSAVER ARE 01597000 PROCEDURES USED TO ACCUMULATE FORMAT AND NAMELIST ARRAYS; 01598000 PROCEDURE TRACEBACK(M,DEX,PRT); VALUE M,DEX,PRT; INTEGER M,DEX,PRT; 01599000 BEGIN INTEGER I,J; REAL C; 01600000 IF (C~GET(M+2)).BASE ! 0 THEN 01601000 BEGIN I ~ ADR; ADR ~ C.BASE; 01602000 DO BEGIN J ~ GIT(ADR); 01603000 ADR ~ ADR - 1; 01604000 EMITL(DEX); 01605000 EMITPAIR(PRT,LOD); 01606000 END UNTIL ADR ~ J = 0; 01607000 ADR ~ I; 01608000 END; 01609000 INFO[M.IR,M.IC].ADDR ~ PRT; PUT(M+2,0&DEX[TOBASE]); 01610000 END TRACEBACK; 01611000 PROCEDURE OFLOWHANGERS(I); VALUE I; INTEGER I; 01612000 BEGIN INTEGER J; LABEL XIT; 01613000 FOR J ~ 1 STEP 1 UNTIL MAXNBHANG DO 01614000 IF FNNHANG[J] = 0 THEN % MAKE AN ENTRY 01615000 BEGIN FNNHANG[J] ~ I; 01616000 PUT(I+2,J); 01617000 GO TO XIT; 01618000 END; 01619000 XTA ~ MAXNBHANG; % IF WE REACH HERE WERE HURTIN 01620000 FLAG(91); 01621000 XIT: 01622000 END OFLOWHANGERS; 01623000 PROCEDURE PRTSAVER(M,SZ,ARY); VALUE M,SZ; 01624000 INTEGER M,SZ; ARRAY ARY[0]; 01625000 BEGIN INTEGER I; REAL INFA; 01626000 LABEL SHOW,XIT; 01626100 IF (INFA~GET(M)) < 0 THEN % PREVIOUSLY DEFINED 01627000 BEGIN XTA ~ GET(M+1); 01628000 FLAG(20); GO TO XIT; 01629000 END; 01630000 IF I ~ INFA .ADDR ! 0 THEN % PRT ASSIGNED AT OFLOW TIME 01631000 SHOW: 01631100 BEGIN I ~ PRGDESCBLDR(1,I,0,NXAVIL ~ NXAVIL + 1); 01632000 WRITEDATA(SZ,NXAVIL,ARY); 01633000 FNNHANG[GET(M+2).SIZE] ~ 0; 01634000 END ELSE % ADD THIS ARRAY TO HOLD 01635000 BEGIN IF FNNPRT=0 THEN BEGIN BUMPPRT; FNNPRT~PRTS END; 01636000 IF FNNINDEX + SZ > DUMPSIZE THEN % ARRAY WONT FIT 01637000 IF SZ > DUMPSIZE THEN % ARRAY WILL NEVER FIT 01638000 BEGIN BUMPPRT;FNNHANG[GET(M+2).SIZE]~0; TRACEBACK(M,0,I~PRTS); 01639000 GO TO SHOW; 01640000 END ELSE % DUMP OUT CURRENT HOLDINGS 01641000 BEGIN FNNPRT ~ PRGDESCBLDR(1,FNNPRT,0,NXAVIL ~ NXAVIL + 1); 01642000 WRITEDATA(FNNINDEX,NXAVIL,FNNHOLD); 01643000 FNNINDEX ~ 0; BUMPPRT; FNNPRT ~PRTS; 01644000 END; 01645000 FNNHANG[GET(M + 2).SIZE] ~0; 01646000 TRACEBACK(M,FNNINDEX,FNNPRT); 01647000 MOVEW(ARY,FNNHOLD[FNNINDEX],SZ.[36:6],SZ); 01648000 FNNINDEX ~ FNNINDEX + SZ; 01649000 END; 01650000 PUT(M,-GET(M)); % ID NOW ASSIGNED 01651000 XIT: 01651100 END PRTSAVER; 01652000 PROCEDURE SEGOVF; 01653000 BEGIN 01654000 REAL I, T, A, J, SADR, INFC, LABPRT; 01655000 REAL SAVINS; 01655100 FOR T ~ 1 STEP 1 UNTIL MAXNBHANG DO 01656000 IF J~FNNHANG[T]!0 THEN BEGIN BUMPPRT;TRACEBACK(J,FNNHANG[T]~0,PRTS) END;01657000 SEGOVFLAG ~ TRUE; 01661000 BUMPPRT; 01662000 IF PRTS.[37:2]=1 THEN BEGIN 01662300 PACK(EDOC[EDOCI],(T~1&XRT[36:38:10]),ADR.[46:2]); 01662500 IF CODETOG THEN DEBUG(T); ADR~ADR+1 END; 01662700 PACK(EDOC[EDOCI], (T~2&PRTS[36:38:10]), ADR.[46:2]); 01663000 IF CODETOG THEN DEBUG(T); 01664000 ADR ~ ADR+1; 01665000 PACK(EDOC[EDOCI], (T~1&BFW [36:38:10]), ADR.[46:2]); 01666000 IF CODETOG THEN DEBUG(T); 01667000 SADR ~ ADR; 01668000 T ~ PRGDESCBLDR(2, PRTS, 0, NXAVIL+1); 01669000 FOR I ~ 0 STEP 1 UNTIL SHX DO 01670000 BEGIN T ~ STACKHEAD[I]; 01671000 WHILE T ! 0 DO 01672000 BEGIN IF (A~ GET(T)).CLASS = LABELID THEN 01673000 IF A > 0 THEN 01674000 BEGIN 01675000 ADR ~ A.ADDR; 01676000 IF LABPRT ~ (INFC~GET(T+2)).BASE = 0 THEN 01677000 BEGIN 01678000 BUMPPRT; LABPRT~PRTS; 01679000 PUT(T+2, INFC & PRTS[TOBASE]); 01680000 END; 01681000 WHILE ADR ! 0 DO 01682000 BEGIN J ~ GIT(ADR); ADR ~ ADR-1; 01683000 SAVINS~GIT(ADR+2).[36:10]; 01683100 EMITOPDCLIT(LABPRT); 01684000 EMITO(SAVINS); 01684100 ADR ~ J; 01685000 END; 01686000 INFO[T.IR,T.IC].ADDR ~ 0; 01687000 END; 01688000 T ~ A.LINK; 01689000 END; 01690000 END; 01691000 FOR I ~ 0 STEP 1 UNTIL LBRANCH DO 01692000 IF T ~ - BRANCHES[I] > 0 AND T < 4096 THEN 01693000 BEGIN 01694000 ADR ~ T-1; 01695000 SAVINS~GIT(ADR+2).[36:10]; 01695100 BUMPPRT; EMITOPDCLIT(PRTS); 01696000 EMITO(SAVINS); 01696100 BRANCHES[I] ~ - (PRTS+4096); 01697000 END; 01698000 SEGMENT((SADR+4) DIV 4,NSEG,FALSE,EDOC); 01699000 SEGMENTSTART; 01700000 EMITO(NOP); EMITO(NOP); 01701000 SEGOVFLAG ~ FALSE; 01702000 END SEGOVF; 01703000 PROCEDURE ARRAYDEC(I); VALUE I; REAL I; 01704000 BEGIN % DECLARES ARRAYS WHOSE INFO INDEX IS I 01705000 REAL PRT,LNK,J; 01706000 LABEL XIT; 01706010 BOOLEAN OWNID; REAL X; 01706100 IF DEBUGTOG THEN FLAGROUTINE(" ARRA","YDEC ",TRUE ); 01706110 PRT ~ GET(I).ADDR; 01707000 IF LNK ~ GET(I+2).SIZE = 0 THEN GO TO XIT ; 01708000 IF (OWNID ~ PRT < 1536 AND DATAPRT ! 0) THEN 01708100 BEGIN 01708200 EMITOPDCLIT(DATAPRT); EMITO(LNG); 01708300 EMITB(-1, TRUE); X ~ LAX; 01708400 END; 01708500 EMITO(MKS); 01709000 EMITDESCLIT(PRT); % STACK OR PRT ADDRESS 01710000 IF LNK { 1023 THEN 01711000 BEGIN 01712000 IF OWNID THEN EMITL(0); % LOWER BOUND 01712100 EMITL(LNK); % ARRAY SIZE 01713000 EMITL(1); % ONE DIMENSION 01714000 END 01715000 ELSE 01716000 BEGIN 01717000 J ~ (LNK + 255) DIV 256; 01718000 LNK := 256; %INCLUDE ENTIRE ARRAY SIZE IN ESTIMATE %512-01719000 IF OWNID THEN EMITL(0); % FIRST LOWER BOUND 01719100 EMITL(J); % NUMBER OF ROWS 01720000 IF OWNID THEN EMITL(0); % SECOND LOWER BOUND 01720100 EMITL(256); % SIZE OF EACH ROW 01721000 EMITL(2); % TWO DIMENSIONS 01722000 END; 01723000 EMITL(1); % ONE ARRAY 01724000 EMITL(IF OWNID THEN 2 ELSE 0); %OWN OR LOCAL 01725000 EMITOPDCLIT(5); % CALL BLOCK 01726000 ARYSZ ~ ARYSZ + J + LNK; 01727000 IF NOT(F2TOG OR OWNID) THEN 01728000 BEGIN 01729000 F2TOG ~ TRUE; 01730000 EMITL(1); 01731000 EMITPAIR(FPLUS2,STD);% F+2~TRUE 01732000 END; 01733000 IF OWNID THEN FIXB(X); 01733100 XIT: 01733105 IF DEBUGTOG THEN FLAGROUTINE(" ARRA","YDEC ",FALSE) ; 01733200 END ARRAYDEC; 01734000 REAL PROCEDURE SEARCH(E); VALUE E; REAL E; 01735000 BEGIN REAL T; LABEL XIT; 01736000 T ~ STACKHEAD[E MOD SHX]; 01737000 WHILE T ! 0 DO 01738000 IF INFO[(T+1).IR,(T+1).IC] = E THEN GO TO XIT 01739000 ELSE T ~ INFO[T.IR,T.IC].LINK; 01740000 XIT: SEARCH ~ T; 01741000 END SEARCH; 01742000 INTEGER PROCEDURE GLOBALSEARCH(E); VALUE E; REAL E; 01743000 BEGIN REAL T; LABEL XIT; 01744000 T ~ GLOBALSTACKHEAD[E MOD GHX]; 01745000 WHILE T ! 0 DO 01746000 IF INFO[(T+1).IR,(T+1).IC] = E THEN GO TO XIT 01747000 ELSE T ~ INFO[T.IR,T.IC].LINK; 01748000 XIT: GLOBALSEARCH ~ T; 01749000 END GLOBALSEARCH; 01750000 PROCEDURE PURGEINFO; 01751000 BEGIN REAL J; 01752000 FLAG(13); 01753000 FOR J ~ 0 STEP 1 UNTIL SHX DO STACKHEAD[J] ~ 0; 01754000 NEXTINFO ~ 2; 01755000 NEXTCOM ~ 0; 01756000 END; 01757000 INTEGER PROCEDURE ENTER(W, E); VALUE W, E; ALPHA W, E; 01758000 BEGIN REAL J; 01759000 IF GLOBALNEXTINFO { NEXTINFO THEN PURGEINFO; 01760000 W.LINK ~ STACKHEAD[J ~ E MOD SHX]; 01761000 STACKHEAD[J] ~ ENTER ~ J ~ NEXTINFO; 01762000 INFO[J.IR,J.IC] ~ W; 01763000 INFO[(J~J+1).IR,J.IC] ~ E; 01764000 INFO[(J~J+1).IR,J.IC] ~ 0; 01765000 NEXTINFO ~ NEXTINFO + 3; 01766000 END ENTER; 01767000 INTEGER PROCEDURE GLOBALENTER(W, E); VALUE W, E; ALPHA W, E; 01768000 BEGIN REAL J; 01769000 IF GLOBALNEXTINFO { NEXTINFO THEN PURGEINFO; 01770000 W.LINK ~ GLOBALSTACKHEAD[J ~ E MOD GHX]; 01771000 GLOBALSTACKHEAD[J] ~ GLOBALENTER ~ J ~ GLOBALNEXTINFO; 01772000 INFO[J.IR,J.IC] ~ W; 01773000 INFO[(J~J+1).IR,J.IC] ~ E; 01774000 INFO[(J~J+1).IR,J.IC] ~ 0; 01775000 GLOBALNEXTINFO ~ GLOBALNEXTINFO - 3; 01776000 END GLOBALENTER; 01777000 PROCEDURE LABELBRANCH(K, C); VALUE K, C; REAL K; BOOLEAN C; 01778000 BEGIN REAL TS,T,I,X; 01779000 DEFINE LABL = K#; 01780000 COMMENT LABELBRANCH GENERATES A "LITC ..." AND "BRANCH" FROM THE 01781000 CURRENT ADDRESS TO LABEL K. IF THE BOOLEAN C IS TRUE 01782000 THE BRANCH IS CONDITIONAL. IF THE LABEL HAS NOT BEEN ENCOUNTERED 01783000 THEN THE APPROPRIATE LINKAGE IS MADE; 01784000 LABEL XIT; 01785000 IF ADR } 4086 THEN 01786000 BEGIN ADR ~ ADR+1; SEGOVF END; 01787000 IF LABL ~ LBLSHFT(XTA~LABL) { 0 OR LABL = BLANKS THEN 01788000 BEGIN FLAG(135); GO TO XIT END; 01789000 IF T ~ SEARCH(LABL) ! 0 THEN 01790000 BEGIN TS ~ (I ~ GET(T)).ADDR; 01791000 IF I.CLASS ! LABELID THEN BEGIN FLAG(144); GO TO XIT END; 01791100 IF I > 0 THEN 01792000 BEGIN EMITLINK(TS); 01793000 EMITO(IF C THEN BFC ELSE BFW); 01794000 PUT(T,I&(ADR-1)[TOADDR]); 01795000 EMITO(NOP); 01795100 END ELSE 01796000 IF I.SEGNO = NSEG THEN EMITB(TS, C) ELSE 01799000 BEGIN IF TS~(X~GET(T+2)).BASE = 0 THEN 01800000 X.BASE ~ TS ~ PRGDESCBLDR(2,0,(I.ADDR).[36:10],I.SEGNO); 01801000 PUT(T+2,X); 01802000 EMITOPDCLIT(TS); 01803000 EMITO(IF C THEN BFC ELSE BFW); 01804000 END; 01805000 END ELSE 01806000 BEGIN 01807000 IF ADR < 0 THEN EMITO(NOP); 01808000 EMITLINK(0); 01809000 EMITO( IF C THEN BFC ELSE BFW); 01810000 T ~ ENTER(0 & LABELID[TOCLASS] & (ADR-1)[TOADDR], LABL); 01811000 EMITO(NOP); 01811100 END; 01812000 IF XREF THEN ENTERX(LABL,0&LABELID[TOCLASS]); 01812100 XIT: 01813000 END LABELBRANCH; 01814000 PROCEDURE DATASET; % SCANS CONSTANTS IN BLOCK DATA 01815000 BEGIN 01816000 REAL LST,CUR,LTYP,CTYP,SIZ,RPT; 01817000 REAL CUD; 01818000 BOOLEAN SGN; 01819000 01820000 01821000 DEFINE TYP = GLOBALNEXT#, 01822000 TYPC = 18:33:15#; 01823000 LABEL XIT,ERROR,DPP,SPP,CPP,COMM,S; 01824000 IF DEBUGTOG THEN FLAGROUTINE(" DATA","SET ",TRUE) ; 01825000 DATATOG ~ TRUE; FILETOG ~ TRUE; 01826000 SCAN; 01827000 LSTS ~ -1; LTYP ~77; 01828000 S: IF TYP = PLUS OR (SGN ~ TYP = MINUS ) THEN SCAN; 01829000 IF TYP = NUM THEN 01830000 BEGIN 01831000 IF NUMTYPE = STRINGTYPE AND STRINGSIZE > 1 THEN 01832000 BEGIN 01833000 IF LTYP ! 77 THEN 01834000 BEGIN % NOT FIRST ENTRY-PUSH DOWN PRIOR NUMBER 01835000 IF LSTS+2 > LSTMAX THEN 01836000 BEGIN FLAG(127); GO TO ERROR END; 01837000 LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 01838000 LSTT[LSTS~LSTS+1] ~ LST; 01839000 LTYP ~ 77; 01840000 END; 01841000 01841100 IF LSTS + STRINGSIZE > LSTMAX THEN 01842000 BEGIN FLAG(127); GO TO ERROR END; 01843000 LSTT[LSTS~LSTS+1] ~ STRINGSIZE & STRINGTYPE[TYPC] 01844000 & SIZ[3:33:15]; 01844100 MOVEW(STRINGARRAY,LSTT[LSTS~LSTS+1], 01845000 STRINGSIZE.[36:6],STRINGSIZE); 01846000 LSTS ~ LSTS + STRINGSIZE -1; 01846100 SCAN; 01847000 GO TO COMM; 01848000 END; 01849000 % GOT NUMBER 01850000 IF NUMTYPE = STRINGTYPE THEN 01851000 BEGIN 01851100 FNEXT ~ STRINGARRAY[0]; 01851200 NUMTYPE ~ INTYPE; 01851300 IF SIZ = 0 THEN SIZ ~ 1; 01851400 END; 01851500 CUR ~ IF SGN THEN -FNEXT ELSE FNEXT; 01852000 CTYP ~ NUMTYPE; CUD ~ DBLOW; 01853000 01854000 SCAN; 01855000 IF TYP = COMMA OR TYP = SLASH THEN 01856000 BEGIN 01857000 IF SIZ = 0 THEN SIZ ~ 1; 01857100 IF CTYP = DOUBTYPE THEN 01858000 BEGIN 01859000 DPP: IF LTYP ! 77 THEN 01860000 BEGIN 01861000 IF LSTS+2 > LSTMAX THEN 01862000 BEGIN FLAG(127); GO TO ERROR END; 01863000 LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 01864000 LSTT[LSTS~LSTS+1] ~ LST; 01865000 LTYP ~ 77; 01866000 END; 01867000 IF LSTS+3 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END; 01868000 LSTT[LSTS~LSTS+1] ~ SIZ&DOUBTYPE[TYPC]; 01869000 LSTT[LSTS~LSTS+1] ~ CUR; 01870000 LSTT[LSTS~LSTS+1] ~ CUD; 01871000 GO TO COMM; 01872000 END; 01873000 % SINGLE PRECISION 01874000 SPP: 01875000 IF LTYP = 77 THEN 01876000 BEGIN 01877000 LST ~ CUR; 01878000 LTYP ~ CTYP; 01879000 RPT ~ SIZ; 01880000 GO TO COMM; 01881000 END; 01882000 IF LTYP = CTYP THEN 01883000 IF REAL(BOOLEAN(CUR) EQV BOOLEAN(LST)) = REAL(NOT FALSE) THEN 01883100 BEGIN 01884000 RPT ~ RPT + SIZ; 01885000 GO TO COMM; 01886000 END; 01887000 IF LSTS+2 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END; 01888000 LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 01889000 LSTT[LSTS~LSTS+1] ~ LST; 01890000 RPT ~ SIZ; 01891000 LST ~ CUR; LTYP ~ CTYP; 01892000 GO TO COMM; 01893000 END; 01894000 % TYP ! COMMA - CHECK FOR * 01895000 IF TYP ! STAR THEN BEGIN FLAG(125); GO TO ERROR END; 01896000 IF CTYP ! INTYPE THEN BEGIN FLAG(113); GO TO ERROR END; 01897000 IF SIZ ! 0 OR SIZ ~ CUR { 0 THEN 01898000 BEGIN FLAG(64); GO TO ERROR END; 01899000 SCAN; GO TO S; 01900000 END; 01912000 % TYP ! NUM AT LABEL S 01913000 IF SIZ = 0 THEN SIZ ~ 1; 01913050 IF NAME = "T " OR NAME = "F " THEN 01913100 BEGIN 01913200 CUR ~ REAL(NAME = "T "); 01913300 CTYP ~ LOGTYPE; 01913400 SCAN; GO TO SPP; 01913500 END; 01913600 IF TYP ! LPAREN THEN BEGIN FLAG(64); GO TO ERROR END; 01914000 01915000 CPP: % COMPLEX 01916000 IF LTYP ! 77 THEN 01917000 BEGIN 01918000 IF LSTS+2 > LSTMAX THEN 01919000 BEGIN FLAG(127); GO TO ERROR END; 01920000 LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 01921000 LSTT[LSTS~LSTS+1] ~ LST; 01922000 LTYP ~ 77; 01923000 END; 01924000 SCAN; 01925000 IF TYP = PLUS OR (SGN~TYP=MINUS) THEN SCAN; 01926000 IF TYP ! NUM OR NUMTYPE > REALTYPE THEN 01927000 BEGIN FLAG(64); GO TO ERROR END; 01928000 IF LSTS+2 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END;01929000 LSTT[LSTS~LSTS+1] ~ SIZ&COMPTYPE[TYPC]; 01930000 LSTT[LSTS~LSTS+1] ~ IF SGN THEN -FNEXT ELSE FNEXT; 01931000 SCAN; 01932000 IF TYP ! COMMA THEN BEGIN FLAG(114); GO TO ERROR END; 01933000 SCAN; 01934000 IF TYP = PLUS OR (SGN ~ TYP = MINUS) THEN SCAN; 01935000 IF TYP ! NUM OR NUMTYPE > REALTYPE THEN 01936000 BEGIN FLAG(64); GO TO ERROR END; 01937000 LSTT[LSTS~LSTS+1]~IF SGN THEN - FNEXT ELSE FNEXT ; 01938000 SCAN; 01939000 IF TYP ! RPAREN THEN BEGIN FLAG(108); GO TO ERROR END; 01940000 SCAN; 01941000 COMM: 01942000 SIZ ~ 0; 01942100 IF TYP = COMMA THEN BEGIN SCAN; GO TO S; END; 01943000 IF TYP = SLASH THEN GO TO XIT; 01944000 FLAG(126); 01945000 ERROR: 01946000 LSTS ~ 0; 01947000 WHILE TYP ! COMMA AND TYP ! SLASH AND TYP ! SEMI DO SCAN;01948000 IF TYP = COMMA THEN GO TO COMM; 01949000 XIT: 01950000 IF LTYP ! 77 THEN 01951000 BEGIN 01952000 IF LSTS+2>LSTMAX THEN BEGIN FLAG(127); LSTS~0 END;01953000 LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 01954000 LSTT[LSTS~LSTS+1] ~ LST; 01955000 END; 01956000 IF LSTS+1 > LSTMAX THEN BEGIN FLAG(127); LSTS~0 END; 01957000 LSTT[LSTS~LSTS+1]~0; 01958000 IF DEBUGTOG THEN FLAGROUTINE(" DATA","SET ",FALSE); 01959000 DATATOG ~ FALSE; FILETOG ~ FALSE; 01960000 END DATASET; 01961000 ALPHA PROCEDURE CHECKDO; 01962000 BEGIN ALPHA X, T; INTEGER N; 01963000 STREAM PROCEDURE CKDO(A, ID, LAB); 01964000 BEGIN 01965000 SI ~ A; SI ~ SI+4; DI ~ LAB; DI ~ DI+2; 01966000 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); 01967000 DI ~ ID; DI ~ DI+2; 01968000 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); 01969000 END CKDO; 01970000 IF (XTA~HOLDID[0]).[12:24] = "FILE" THEN FLOG(37) ELSE 01971000 IF XTA.[12:12] ! "DO" THEN FLOG(17) ELSE 01971010 BEGIN 01972000 X ~ T ~ BLANKS; 01973000 CKDO(HOLDID[0], X, T); 01974000 IF X=BLANKS THEN FLOG(105); 01974500 IF T ~ LBLSHFT(T) < 0 OR T = BLANKS THEN FLOG(17) ELSE 01975000 TEST ~ NEED(T, LABELID); 01976000 DOLAB[DT]~ T; 01977000 IF XREF THEN ENTERX(T,0&LABELID[TOCLASS]); 01977100 IF GET(TEST) < 0 THEN % TEST FOR PREV DEFINITION 01978000 BEGIN 01979000 XTA ~ GET(TEST+1); 01980000 FLAG(15); 01981000 DT ~ DT-1; 01982000 END; 01983000 IF N ~ SEARCH(X) = 0 THEN 01984000 N~ENTER(TIPE[IF T~X.[12:6]!"0" THEN T ELSE 12],X); 01985000 CHECKDO ~ GETSPACE(N); 01987000 IF XREF THEN ENTERX(X,1&GET(N) [15:15:9]); 01987100 IF (X~GET(N)).SUBCLASS > REALTYPE OR X.CLASS ! VARID THEN 01988000 BEGIN XTA ~ GET(N+1); FLAG(84) END; 01989000 IF GET(FX1).CLASS = UNKNOWN THEN PUT(FX1+1, "......"); 01990000 END; 01991000 END CHECKDO; 01992000 PROCEDURE FIXB(N); VALUE N; REAL N; 01993000 BEGIN 01994000 REAL T, U, FROM; 01995000 LABEL XIT, BIGJ; 01996000 IF DEBUGTOG THEN FLAGROUTINE(" FI","XB ",TRUE); 01996010 IF N } 10000 THEN FROM ~ N-10000 ELSE 01997000 IF FROM ~ - BRANCHES[N] > 4095 THEN 01998000 BEGIN 01999000 ADJUST; 02000000 T ~ PRGDESCBLDR(2, FROM.LINK, (ADR+1).[36:10], NSEG); 02001000 GO TO XIT; 02002000 END; 02003000 T ~ ADR; ADR ~ FROM - 1; 02004000 IF (T + 1).[46:2] = 0 THEN GO TO BIGJ; 02005000 IF (U ~ T - 2 - ADR) { 1023 THEN EMITL(U) ELSE 02006000 BEGIN ADR ~ T; ADJUST; T ~ ADR; ADR ~ FROM - 1; 02007000 BIGJ: EMITL((T+1).[36:10] - (ADR+2).[36:10]); 02008000 EMITO(IF BOOLEAN(GIT(FROM + 1).[36:1]) THEN GFW ELSE GFC); 02009000 END; 02010000 ADR ~ T; 02011000 XIT: 02012000 IF N < 10000 THEN BEGIN 02013000 BRANCHES[N] ~ BRANCHX; 02014000 BRANCHX ~ N; 02015000 END; 02016000 IF DEBUGTOG THEN FLAGROUTINE(" FI","XB ",FALSE); 02016010 END FIXB; 02017000 PROCEDURE DATIME; % PRODUCES HEADING LINE FOR LISTING. 02018000 BEGIN 02019000 INTEGER D; 02020000 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 ",02021000 "XVI.0" 02022000 ,".",A2,".",A8,"DAY, ",2(A2,"/"),A2,",",A2,":",A2," H."/); 02022500 WRITALIST(T,7, 02024000 "16" %999-02025000 ,TIME(6),(D~TIME(5)).[12:12],D.[24:12],D.[36:12], 02026000 D~(D~RTI DIV 216000) MOD 10+D DIV 10|64, 02027000 D~(D~RTI DIV 3600 MOD 60) MOD 10+D DIV 10|64,0) ; 02028000 IF D~LINE.TYPE=10 OR D=12 OR D=13 THEN 02029000 BEGIN 02030000 LOCK(LINE); LINE.AREAS~0; LINE.AREASIZE~0 ; 02031000 IF D ! 12 THEN LINE.TYPE~12; SPACE(LINE,2) ; 02032000 END; 02033000 FIRSTCALL~FALSE ; 02034000 END DATIME; 02039000 PROCEDURE PRINTCARD; 02040000 BEGIN 02041000 STREAM PROCEDURE MOVE(P, Q, A); VALUE A, Q; 02042000 BEGIN 02043000 SI ~ Q; DI ~ P; 02044000 DS ~ CHR; 02045000 DI ~ DI+11; SI ~ LOC A; 02046000 DS ~ 4 DEC; 02047000 END MOVE; 02048000 STREAM PROCEDURE MOVEBACK(P); 02049000 BEGIN DI ~ P; DS ~ LIT "]" END; 02050000 MOVE (CRD[9],BUFL,(ADR+1).[36:10]); 02051000 IF FIRSTCALL THEN DATIME; 02052000 IF UNPRINTED THEN WRITAROW(15,CRD) ; 02053000 MOVEBACK(CRD[9]); 02054000 IF SEQERRORS THEN WRITAROW(14,ERRORBUFF) ; 02054010 END PRINTCARD; 02055000 BOOLEAN PROCEDURE READACARD; FORWARD; 02056000 PROCEDURE FILEOPTION; FORWARD; 02058000 BOOLEAN PROCEDURE LABELR; 02059000 BEGIN 02060000 LABEL XIT, LOOP; 02061000 02062000 BOOLEAN STREAM PROCEDURE CHECK(CD, LAB); 02063000 BEGIN LABEL XIT; LOCAL T1; 02064000 SI ~ CD; 02065000 IF SC ! " " THEN IF SC < "0" THEN 02066000 BEGIN DI ~ LAB; DI ~ DI + 2; 02067000 DS ~ 6 CHR; GO TO XIT; 02068000 END; 02069000 DI ~LOC T1; DS ~ 6 LIT " "; DI ~ DI - 6; 02070000 5(IF SC } "0" THEN DS ~ CHR ELSE SI ~ SI+1); 02071000 DI ~LAB; DI ~DI + 2; SI ~ LOC T1; 02072000 5(IF SC ! "0" THEN JUMP OUT; SI ~ SI + 1); 02073000 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); 02074000 TALLY ~ 1; 02075000 XIT: CHECK ~ TALLY; 02076000 END CHECK; 02077000 BOOLEAN STREAM PROCEDURE BLANKCARD(CD); 02077100 BEGIN LABEL XIT; 02077200 SI ~ CD; 02077300 2(36( IF SC ! " " THEN JUMP OUT 2 TO XIT ELSE SI ~ SI + 1)); 02077400 TALLY ~ 1; 02077600 XIT: BLANKCARD ~ TALLY; 02077700 END BLANKCARD; 02077800 LOOP: 02078000 LABL ~ BLANKS; 02079000 IF LABELR ~ NOT READACARD THEN GO TO XIT; 02080000 IF NOT CHECK(CRD[0],LABL) THEN 02081000 BEGIN IF LABL = "FILE " THEN FILEOPTION ELSE 02082000 BEGIN IF LISTOG THEN PRINTCARD; 02083000 IF (XTA ~ LABL).[12:6] ! "C" THEN FLAG(135); 02083100 END; 02083200 GO TO LOOP; 02084000 END; 02085000 IF ENDSEGTOG THEN IF BLANKCARD(CRD) THEN 02086000 BEGIN IF LISTOG THEN PRINTCARD; GO TO LOOP END ELSE 02086500 BEGIN SEGMENTSTART; 02087000 IF LISTOG THEN PRINTCARD; 02088000 IF LABL = BLANKS THEN GO TO XIT; 02089000 END ELSE 02090000 BEGIN 00091000 IF LABL = BLANKS THEN 02092000 BEGIN IF LISTOG THEN PRINTCARD; GO TO XIT END; 02093000 IF ADR > 0 THEN ADJUST; 02094000 IF LISTOG THEN PRINTCARD; 02095000 END; 02096000 XIT: 02116000 END LABELR; 02117000 PROCEDURE FILEOPTION; 02118000 BEGIN COMMENT THIS PROCEDURE PROCESSES THE OPTIONAL FILE CONTROL CARD. 02119000 THE WORD "FILE" APPEARS IN COL. 1 - 4. COL. 5 AND 6 ARE BLANK. 02120000 #1 BELOW IS REQUIRED, OTHER ENTRIES MAY BE AS SPARSE AS DESIRED. 02121000 1. FILE = / 02122000 OR 02123000 FILE = 02124000 THE FOLLOWING "/" IS A DOCUMMENTARY OR. 02125000 THE SEQUENCE OF RESERVED WORDS MUST BE MAINTAINED. 02126000 2. UNIT=PRINT/READER/PUNCH/DISK/TAPE7/TAPE9/REMOTE (UNIT DESIGNATE). 02127000 3. UNLABELED (FOR UNLABELED TAPES) 02128000 4. ALPHA (FOR ALPHA RECORDING MODE) 02129000 5. BCL (IGNORED, FOR 3500 USE) 02130000 6. FIXED (IGNORED, FOR 3500 USE) 02131000 7. SAVE = (SAVE FACTOR IN DAYS) 02132000 8. LOCK (LOCK FILE AT EOJ) 02133000 9. RANDOM/SERIAL/UPDATE (DISK USE) 02134000 10. AREA = (DISK RECORDS/ROW) 02135000 11. BLOCKING = (RECORD PER BLOCK) 02136000 12. RECORD = (RECORD SIZE) 02137000 13. BUFFER = (# OF BUFFERS) 02138000 14. WORKAREA (IGNORED, FOR 3500) ; 02139000 ALPHA P,KEEP; BOOLEAN TOG,CA,TS; LABEL XIT; 02140000 COMMENT INXFIL = INFC.ADINFO, MULTI FILE ID = FILEINFO[1,INXFIL], 02141000 FILE ID = FILEINFO[2,INXFIL], DISK RECORDS = FILEINFO[3,INXFIL],02142000 FILEINFO[0,INXFIL] FROM RIGHT TO LEFT IS; 02143000 INTEGER % NAME USE BITS 02144000 BUFF, % # BUFFERS 6 02145000 RECORD, % RECORD SIZE 12 02146000 BLOCK, % BLOCK SIZE 12 02147000 SAVER, % SAVE FACTOR 12 02148000 SPIN, % REW & LOCK @ EOJ 2 02149000 ALPH; % RECORDING MODE 1 02150000 PROCEDURE FETCH; 02151000 BEGIN SCAN; XTA ~ SYMBOL; 02152000 IF NEXT=COMMA OR NEXT=MINUS THEN 02153000 BEGIN SCAN; XTA ~ SYMBOL; 02154000 IF NEXT ! ID THEN FLOG(37); 02155000 END; 02156000 END FETCH; 02157000 INTEGER STREAM PROCEDURE MAKEINT(XTA); 02158000 BEGIN LABEL LOOP; LOCAL T; 02159000 SI ~ XTA; SI ~ SI + 2; 02160000 LOOP: IF SC } "0" THEN 02161000 BEGIN TALLY ~ TALLY + 1; SI ~ SI + 1; GO TO LOOP END; 02162000 T ~ TALLY; SI ~ XTA; SI ~ SI + 2; DI ~ LOC MAKEINT; DS ~ T OCT; 02163000 END MAKEINT; 02164000 INTEGER PROCEDURE REPLACEMENT; 02165000 BEGIN 02166000 FETCH; IF NEXT = EQUAL THEN 02167000 BEGIN FETCH; IF XTA.[12:6] { 11 THEN BEGIN REPLACEMENT ~ MAKEINT(XTA); 02168000 FETCH END ELSE FLOG(37); 02169000 END ELSE FLOG(37); 02170000 END REPLACEMENT; 02171000 INTEGER STREAM PROCEDURE SRI7(S); 02172000 BEGIN SI ~ S; DI ~ LOC SRI7; 02173000 SI ~ SI + 2; DI ~ DI + 1; DS ~ 7 CHR; 02174000 END SRI7; 02175000 COMMENT * * * * * START OF CODE * * * * ; 02176000 IF DEBUGTOG THEN FLAGROUTINE(" FILEO","PTION ", TRUE); 02176010 ERRORTOG ~ FALSE; 02176100 IF LISTOG THEN PRINTCARD; 02177000 XTA ~ "FILE "; 02178000 IF NSEG ! 0 THEN FLAG(60); 02179000 IF INXFIL ~ INXFIL + 1 > MAXOPFILES THEN 02180000 BEGIN FLAG(59); GO TO XIT END; 02181000 BUMPPRT; 02182000 MAXFILES ~ MAXFILES + 1; 02183000 FILETOG ~ TRUE; SCN ~ 1; % START SCAN MAINTAINENCE 02184000 FETCH; IF XTA.[12:6] > 11 THEN BEGIN FLAG(37); GO TO XIT END; 02185000 IF XTA.[12:6] = 0 THEN BEGIN FLOG(037); GO TO XIT END; 02185010 IF T ~ GLOBALSEARCH(P ~ 0&"."[12:42:6]&XTA[18:12:30]) ! 0 THEN FLAG(20) 02186000 ELSE BEGIN P~ GLOBALENTER(-0&PRTS[TOADDR]&FILEID[TOCLASS],P); 02187000 PUT(P+2,GET(P+2)&INXFIL[TOADINFO]); 02188000 IF XREF THEN ENTERX(XTA &1[TOCE],1&FILEID[TOCLASS]); 02188100 END; 02189000 INFC ~ GET(P + 2); 02190000 FETCH; IF NEXT = EQUAL THEN FETCH ELSE 02191000 BEGIN FLOG(37); GO TO XIT; END; 02192000 IF NEXT = SEMI THEN 02193000 BEGIN FLAG(37); GO TO XIT END 02194000 ELSE FILEINFO[2,INXFIL] ~ SRI7(ACCUM[1]); 02195000 FETCH; IF NEXT = SLASH THEN 02196000 BEGIN FILEINFO[1,INXFIL] ~ FILEINFO[2,INXFIL]; % MULTI FILE ID 02197000 FETCH; 02198000 IF NEXT = SEMI THEN BEGIN FLAG(37); GO TO XIT; END 02199000 ELSE FILEINFO[2,INXFIL] ~ SRI7(ACCUM[1]); 02200000 FETCH; 02201000 END; 02202000 IF XTA = "UNIT " THEN 02203000 BEGIN 02204000 FETCH; 02205000 IF NEXT = EQUAL THEN FETCH ELSE FLOG(37); 02206000 INFC.LINK ~ KEEP ~ (IF TOG ~ XTA = "PRINT " 02207000 OR XTA = "PRINTE" THEN 18 ELSE 02208000 IF CA ~ TOG ~ XTA = "READ " 02209000 OR XTA = "READER" THEN 2 ELSE 02210000 IF CA ~ TOG ~ XTA = "PUNCH " THEN 0 ELSE 02211000 IF TOG ~ XTA = "DISK " THEN 12 ELSE 02212000 IF TOG ~ XTA = "TAPE " 02213000 OR XTA = "TAPE7 " THEN 2 ELSE 02214000 IF TOG ~ XTA = "PAPER " THEN 8 ELSE 02214100 IF CA ~TOG~XTA= "REMOTE" THEN 19 ELSE 02214500 IF TOG ~ XTA = "TAPE9 " THEN 2 ELSE 2); 02215000 IF TOG THEN FETCH ELSE FLOG(37) 02216000 END ELSE INFC.LINK~KEEP~IF DCINPUT THEN 12 ELSE 2 ; 02217000 TS~KEEP=12 ; 02217050 IF XTA="BACKUP" THEN 02217100 BEGIN 02217150 FETCH; IF KEEP!0 AND KEEP!18 THEN FLAG(37); 02217200 IF TOG~XTA="DISK " THEN KEEP~IF KEEP=0 THEN 22 ELSE 15 02217250 ELSE IF TOG~XTA="TAPE " THEN KEEP~IF KEEP=0 THEN 20 ELSE 6 02217275 ELSE BEGIN 02217300 TOG~XTA="ALTERN"; KEEP~IF KEEP=0 THEN 25 ELSE 16 ; 02217350 END; 02217400 IF TOG THEN FETCH; INFC.LINK~KEEP ; 02217450 END ; 02217500 IF XTA = "UNLABE" THEN % FOR UNLABELED TAPES 02218000 BEGIN IF KEEP = 2 THEN INFC .LINK ~ 9; FETCH; END; 02219000 IF XTA = "ALPHA " THEN FETCH ELSE IF KEEP = 2 THEN ALPH ~ 1; % MODE 02220000 IF XTA = "BCL " THEN FETCH; % FOR B3500 02221000 IF XTA = "FIXED " THEN FETCH; % FOR B3500 02222000 IF XTA = "SAVE " THEN SAVER ~ REPLACEMENT; 02223000 IF XTA = "LOCK " THEN BEGIN SPIN ~ 2; FETCH END; % REW & LOCK AT EOJ 02224000 IF TOG ~ XTA = "RANDOM" THEN T ~ 10 ELSE 02225000 IF TOG ~ XTA = "SERIAL" THEN T ~ 12 ELSE 02226000 IF TOG ~ XTA = "UPDATE" THEN T ~ 13; 02227000 IF TOG THEN 02228000 BEGIN IF KEEP=12 THEN INFC.LINK~T ELSE FLAG(37); FETCH END; 02229000 IF XTA="AREA " THEN 02230000 BEGIN 02230010 IF KEEP!12 THEN FLAG(37); 02230020 T~REPLACEMENT; 02230030 IF XTA="EU " THEN 02230040 IF I~REPLACEMENT>19 THEN FLAG(37) 02230045 ELSE T.EUNF~I+1;% 0 MEANS EU NOT SPECIFIED 02230050 IF XTA="SPEED " THEN 02230060 BEGIN 02230070 FETCH; 02230080 IF NEXT=EQUAL THEN 02230090 BEGIN 02230100 FETCH; 02230110 IF XTA.[12:6]{SLOWV THEN 02230115 IF I~MAKEINT(XTA)>SLOWV THEN FLAG(37) 02230120 ELSE 02230125 ELSE IF XTA="FAST " THEN T.SPDF~FASTV 02230130 ELSE IF XTA="SLOW " THEN T.SPDF~SLOWV 02230140 ELSE FLOG(37); 02230150 FETCH; 02230160 END 02230170 ELSE FLOG(37); 02230180 END; 02230190 IF XTA="SENSIT" THEN 02230200 BEGIN 02230210 T.SENSE~1; 02230220 FETCH; 02230230 END; 02230240 FILEINFO[3,INXFIL]~T; 02230300 END; 02230400 IF XTA = "BLOCKI" THEN BLOCK ~ REPLACEMENT & 1[2:47:1]; 02231000 RECORD ~ IF XTA="RECORD" THEN REPLACEMENT ELSE IF CA THEN 10 ELSE IF TS 02232000 AND NOT (BOOLEAN(BLOCK.[2:1])) THEN 10 & 1[2:47:1] ELSE 17; 02232010 BUFF ~ IF XTA = "BUFFER" THEN REPLACEMENT ELSE 2; 02233000 IF XTA = "WORKAR" THEN FETCH; % IGNORED, FOR 3500 02234000 IF BUFF<1 OR BUFF>32 THEN BEGIN XTA~"BUFFER"; FLAG(152) END ; 02236000 IF RECORD<1 THEN BEGIN XTA~"RECORD"; FLAG(152)END ; 02236010 IF SAVER>999 THEN BEGIN XTA~"SAVE "; FLAG(152) END ; 02236020 IF T~INFC.LINK=10 OR T=12 OR T=13 THEN %%% ARE IN DISK FILE 02237000 BEGIN 02237010 IF BOOLEAN(RECORD.[2:1])THEN BLOCK ~ 300 02237012 ELSE 02237015 IF BLOCK~BLOCK|RECORD>1890 OR RECORD>1023 THEN 02237020 BEGIN XTA~"BK/REC"; FLAG(152) END 02237021 END 02237030 ELSE IF BLOCK~BLOCK|RECORD>1023 OR RECORD>1023 THEN IF KEEP ! 2 THEN 02237040 BEGIN XTA~"BK/REC"; FLAG(58 ) END ELSE BEGIN RECORD~257; BLOCK~0END;02237050 FILEINFO[0,INXFIL] ~ 0&BUFF[42:42:6]&RECORD[30:36:12]&BLOCK[18:36:12] 02238000 &SAVER[6:36:12]&SPIN[4:46:2]&ALPH[3:47:1]; 02239000 XIT: IF NEXT ! SEMI THEN 02240000 BEGIN FLOG(37); DO SCAN UNTIL NEXT = SEMI; END; 02241000 FILETOG ~ FALSE; % END SCAN MAINTAINENCE 02242000 PUT(P+2,INFC); 02243000 IF DEBUGTOG THEN FLAGROUTINE(" FILEO","PTION ",FALSE) ; 02243100 END FILEOPTION; 02244000 PROCEDURE DOLOPT; 02245000 BEGIN 02245300 REAL STREAM PROCEDURE SCAN(BUF,ID); VALUE BUF; 02245600 BEGIN LABEL LP,LA,LE,XIT; 02245900 SI ~ BUF; DI ~ ID; DS ~ 2 LIT "0"; 02246200 LP: IF SC = " " THEN BEGIN SI~SI+1; GO TO LP; END; 02246500 IF SC = "," THEN BEGIN SI~SI+1; GO TO LP; END; 02246800 IF SC = "+" THEN BEGIN DS~CHR; GO TO XIT; END; 02246900 IF SC = "-" THEN BEGIN DS~CHR; GO TO XIT; END; 02247000 IF SC < "A" THEN BEGIN DI ~ ID; DS ~ 8 LIT "+0000001"; 02247100 LE: SI~SI+1; 02247200 GO TO XIT; 02247400 END; 02247700 IF SC="|" THEN GO TO LE;% THIS IS > "A" 02247800 IF SC="!" THEN GO TO LE;% THIS IS > "A" 02247900 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); 02248000 LA: IF SC = ALPHA THEN BEGIN SI~SI+1; GO TO LA; END; 02248300 XIT: 02248600 SCAN ~ SI; 02248900 END SCAN; 02249200 REAL STREAM PROCEDURE GETVOID(BUF,VOIDSEQ,FR); VALUE BUF,FR; 02249500 BEGIN LABEL L,LC,LD,LE,XIT; LOCAL TA; 02249800 SI ~ BUF; DI~VOIDSEQ; DS~8LIT" "; DI~VOIDSEQ; 02250100 L: IF SC = " " THEN BEGIN SI~SI+1; GO TO L; END; 02250400 TA ~ SI; 02250500 IF SC = """ THEN 02250700 BEGIN 9(SI~SI+1; 02251000 IF SC = """ THEN BEGIN SI~SI+1; JUMP OUT TO LC; END 02251300 ELSE TALLY ~ TALLY + 1); 02251600 TALLY~TALLY+63; SI~TA; SI~SI+1; GO TO LE; 02251900 END; 02252200 IF SC < "0" THEN GO TO LD; 02252500 DS:=8LIT"0"; %115-02252600 8(SI:=SI+1; DI:=DI-1; TALLY:=TALLY+1; %115-02252800 IF SC LSS "0" THEN JUMP OUT); %115-02252850 LC: SI ~ TA; 02252900 LE: TA~TALLY; DS~TA CHR; GETVOID~SI; GO TO XIT; 02253100 LD: GETVOID~SI; 02253400 FR(DS~8LIT"9"); 02253700 XIT: 02254000 END GETVOID; 02254300 REAL STREAM PROCEDURE SEQNUM(BUF,VLU); VALUE BUF; 02254600 BEGIN LABEL L,LA,LC; LOCAL TA,TB; 02254900 SI ~ BUF; 02255200 L: IF SC = " " THEN BEGIN SI~SI+1; GO TO L; END; 02255500 IF SC = "," THEN BEGIN SI~SI+1; GO TO L; END; 02255800 TA ~ SI; 02256100 IF SC = "+" THEN 02256400 BEGIN SI~SI+1; 02256700 LA: IF SC = " " THEN BEGIN SI~SI+1; GO TO LA;END; 02257400 TB ~ SI; 02257300 IF SC < "0" THEN BEGIN SI~TA; GO TO LC; END; 02257600 DI~TB;TA~DI; 02257900 END; 02258200 8(IF SC < "0" THEN JUMP OUT TO LC; 02258500 TALLY~TALLY+1; SI~SI+1;); 02258800 LC: TB ~ TALLY; SEQNUM ~ SI; 02259100 SI ~ TA; DI ~ VLU; DS ~ TB OCT; 02259400 END SEQNUM; 02259700 REAL STREAM PROCEDURE MKABS(S); 02260000 BEGIN SI ~ S; SI~SI+1; MKABS ~ SI; 02260300 DI ~ S; 9(DI ~ DI + 8); DS ~ LIT "["; 02260600 END MKABS; 02260900 STREAM PROCEDURE MOVEW(P,Q); VALUE Q; 02260925 BEGIN SI~P; DI ~ Q; DS~CHR; END ; 02260950 REAL BUF,ID; 02261200 BOOLEAN VAL, SAVELISTOG; %511-02261500 LABEL LP,SET,RESET; 02261800 FORMAT WARN(X18,A6," ILLEGAL CONSTRUCT ON DOLLAR CARD XXXX",X39, 02262100 "WARNING"); 02262400 DEFINE GETID = BEGIN ID~ " "; BUF ~ SCAN(BUF,ID) END#; 02262700 SAVELISTOG ~ LISTOG; %511- 02262775 MOVEW(CRD[9],BUFL); 02262800 BUF ~ MKABS(CRD[0]); 02263000 GETID; 02263300 IF ID = "VOID " THEN 02263600 BEGIN BUF ~ GETVOID(BUF, VOIDSEQ,0); VOIDTOG ~ TRUE 02263900 END ELSE 02264200 IF ID = "VOIDT " THEN 02264500 BEGIN BUF ~ GETVOID(BUF, VOIDTSEQ,0); VOIDTTOG ~ TRUE 02264800 END ELSE 02265100 BEGIN 02265400 TAPETOG.[47:1] ~ LASTMODE = 2; %517-02265700 IF ID = "SET " OR ID = "+ " THEN 02267200 SET: BEGIN GETID; VAL~ TRUE END 02267500 ELSE 02267800 IF ID = "RESET " OR ID = "- " THEN 02268100 RESET: BEGIN GETID; VAL ~ FALSE END 02268400 ELSE 02268700 BEGIN 02269000 TSSMESTOG ~ VAL; TSSEDITOG ~ VAL; CHECKTOG ~ VAL; %501-02269300 SINGLETOG~NOT VAL; HOLTOG~VAL; %501-02269600 LISTOG~VAL; CODETOG ~ DEBUGTOG ~ VAL; NEWTPTOG ~ VAL; 02269900 PRTOG~VAL; DOLIST~VAL; LIBTAPE~VAL; SEGPTOG~VAL; %501-02270200 LISTPTOG ~ VAL; FREEFTOG ~ XREF ~ VAL ; 02270500 VAL ~ TRUE; 02270800 END; 02271100 LP: IF ID > 0 THEN 02271400 BEGIN 02271700 IF ID = "TRACE " THEN 02272000 BEGIN PRTOG~VAL; LISTOG~VAL; CODETOG~DEBUGTOG~VAL; 02272300 END ELSE 02272400 IF ID = "CARD " THEN 02272500 BEGIN TAPETOG.[47:1]~NOT VAL; LASTMODE~2-REAL(VAL) END ELSE 02272510 IF ID = "TAPE " THEN 02272550 BEGIN TAPETOG.[47:1] ~ VAL; LASTMODE ~ REAL(VAL)+1; END ELSE02272560 IF ID = "NOSEQ " THEN SEQTOG ~ FALSE ELSE 02272600 IF ID = "SET " OR ID = "+ " THEN GO TO SET ELSE 02272900 IF ID = "RESET " OR ID = "- " THEN GO TO RESET ELSE 02273200 IF ID = "ONSITE" AND NOT REMFIXED THEN REMOTETOG ~ FALSE ELSE 02273500 IF ID = "REMOTE" AND NOT REMFIXED THEN REMOTETOG ~ VAL ELSE 02273800 IF ID = "FREEFO" THEN FREEFTOG ~ VAL ELSE 02274100 IF ID = "SINGLE" OR ID = "SGL " THEN 02274400 BEGIN SINGLETOG ~ VAL; LISTOG ~ TRUE; END ELSE 02274700 IF ID = "NEW " OR ID = "NEWTAP" THEN 02275000 BEGIN LIBTAPE~VAL; NEWTPTOG~VAL; NTAPTOG~TRUE; %501-02275100 IF ID = "NEW " THEN %501-02275120 BEGIN %501-02275140 GETID; %501-02275160 IF ID ! "TAPE " THEN %501-02275180 GO TO LP; %501-02275200 END; %501-02275220 END ELSE %501-02275240 IF ID = "LIST " THEN LISTOG ~ VAL ELSE 02275300 IF ID = "SEQXEQ" AND NOT SEGSWFIXED THEN SEGSW ~ VAL ELSE 02275600 IF ID = "PRT " THEN PRTOG ~ VAL ELSE 02275900 IF ID = "DEBUGN" THEN 02276200 BEGIN LISTOG~VAL; CODETOG~VAL; PRTOG ~ VAL END ELSE 02276500 IF ID = "TIME " THEN TIMETOG ~ VAL ELSE 02276800 IF ID = "ERRMES" THEN TSSMESTOG ~ VAL ELSE 02277100 IF ID = "TSSEDI" THEN TSSEDITOG ~ VAL ELSE 02277400 IF ID = "LISTLI" THEN LISTLIBTOG ~ VAL ELSE 02277700 IF(ID = "SEGMEN" OR ID = "SEG ") AND VAL THEN 02278000 BEGIN ADR~ADR+1; SEGOVF; END ELSE 02278300 IF ID = "PAGE " AND VAL THEN WRITE(LINE[PAGE]) ELSE 02278600 IF ID = "VOID " THEN 02278900 BEGIN VOIDTOG ~ VAL; 02279200 IF VAL THEN BUF ~ GETVOID(BUF,VOIDSEQ,1); 02279300 END ELSE 02279500 IF ID = "VOIDT " THEN 02279800 BEGIN VOIDTTOG ~ VAL; 02280100 IF VAL THEN BUF ~ GETVOID(BUF,VOIDTSEQ,1); 02280300 END ELSE 02280400 IF ID = "LIMIT " THEN 02280700 BEGIN LIMIT ~ IF VAL THEN 0 ELSE @60; 02281000 BUF ~ SEQNUM(BUF,LIMIT); 02281300 IF LIMIT LEQ ERRORCT THEN GO TO POSTWRAPUP; 02281600 END ELSE 02282500 IF ID = "XREF " THEN 02282800 BEGIN 02282850 PXREF ~ TRUE; XREF ~ VAL; 02282900 END ELSE 02282950 IF ID = "SEQ " THEN 02283100 BEGIN SEQTOG ~ VAL; 02283200 IF VAL THEN 02283300 BEGIN SEQBASE ~ SEQINCR ~ 0; 02283400 BUF ~ SEQNUM(BUF,SEQBASE); 02283700 BUF ~ SEQNUM(BUF,SEQINCR); 02284000 IF SEQINCR { 0 THEN SEQINCR ~ 1000; 02284600 END END ELSE 02284900 IF ID = "LISTDO" THEN DOLIST ~ VAL ELSE 02285200 IF ID = "HOL " THEN HOLTOG ~ VAL ELSE 02285500 IF ID = "CHECK " THEN CHECKTOG ~ VAL ELSE 02285800 IF ID = "NEWPAG" THEN SEGPTOG ~ VAL ELSE %501-02286100 IF ID = "LISTP " THEN LISTPTOG ~ VAL ELSE 02286400 BEGIN IF FIRSTCALL THEN DATIME; 02286700 IF UNPRINTED THEN BEGIN PRINTCARD; UNPRINTED~FALSE END; 02287000 IF SINGLETOG THEN WRITE(LINE,WARN,ID) 02287300 ELSE WRITE(RITE,WARN,ID); 02287600 END 02287900 ; 02288200 GETID; 02288500 GO TO LP; 02288800 END; 02289100 END; 02289400 IF DOLIST OR LISTOG OR SAVELISTOG THEN %511-02289450 IF UNPRINTED THEN PRINTCARD; %517-02289500 UNPRINTED ~ TRUE; 02289600 END DOLOPT; 02289700 STREAM PROCEDURE NEWSEQ(A,B); VALUE B; 02317000 BEGIN 02318000 SI ~ LOC B; DI ~ A; DS ~ 8 DEC; 02319000 END NEWSEQ; 02320000 INTEGER STREAM PROCEDURE SEQCHK(T,C); 02321000 BEGIN 02322000 SI ~ T; DI ~ C; 02323000 IF 8 SC < DC THEN TALLY ~ 4 ELSE 02324000 BEGIN 02325000 SI ~ SI - 8; DI ~ DI - 8; 02326000 IF 8 SC =DC THEN TALLY ~ 2 02327000 ELSE TALLY ~ 3; 02328000 END; 02329000 SEQCHK ~ TALLY; 02330000 END SEQCHK; 02331000 BOOLEAN PROCEDURE READACARD; 02332000 BEGIN 02333000 DEFINE FLAGI(FLAGI1) = BEGIN FLAG(FLAGI1); GO TO E4A;END #; 02333050 REAL STREAM PROCEDURE SCANINC(BUF,ID,RESULT,N,M); 02333100 VALUE BUF,M,N; 02333120 BEGIN 02333140 LOCAL TA; 02333160 LABEL LP,LQ,XIT; 02333180 DI := RESULT; DI := DI +7; 02333200 SI := BUF; 02333210 LP: IF SC = " " THEN BEGIN SI := SI + 1; GO TO LP; END; 02333220 IF SC = ALPHA THEN ELSE BEGIN DS:=LIT "1"; DI:=ID; DS:=2LIT"0";02333240 DS := CHR; DS := 5LIT" ";GO TO XIT; END; 02333260 IF SC LSS "0" THEN DS:=LIT "2" ELSE DS:=LIT "3"; %400-02333270 N (DI:=ID; DS:=8 LIT "0 "; DI:=DI-7; %400-02333280 7(IF SC=ALPHA THEN DS~CHR ELSE JUMP OUT 2 TO XIT); 02333300 JUMP OUT TO XIT); 02333320 M ( 8 ( IF SC LSS "0" THEN JUMP OUT 2 TO LQ; %400-02333360 IF SC GTR "9" THEN JUMP OUT 2 TO LQ; %400-02333370 SI:=SI+1; TALLY:=TALLY+1)); %400-02333380 LQ: TA := TALLY; 02333400 SI := SI - TA; 02333420 DI := ID; 02333440 DS := TA OCT; 02333460 XIT: SCANINC := SI; 02333500 END SCANINC; 02333520 REAL STREAM PROCEDURE MKABS(S); 02333540 BEGIN SI := S; SI := SI + 1; MKABS := SI; END; 02333550 STREAM PROCEDURE MOVE(P, Q); VALUE Q; 02334000 BEGIN SI ~ P; DI ~ Q; DS ~ CHR; 02335000 DI ~ P; DS ~ LIT "]"; 02336000 END MOVE; 02337000 STREAM PROCEDURE MOVEC(C,B); VALUE B; 02337100 BEGIN SI~B; DI~C; DS~CHR; END; 02337200 BOOLEAN STREAM PROCEDURE GETCOL1(BUF); 02338000 BEGIN 02339000 SI ~ BUF; IF SC = "$" THEN TALLY ~ 1; 02340000 GETCOL1 ~ TALLY; 02341000 END; 02342000 STREAM PROCEDURE TSSEDITS(C,P); BEGIN SI~C; DI~P; DS~10WDS; SI~C ; 02342010 IF SC="C" THEN BEGIN DI~P; DI~DI+1; DS~LIT"-" END ELSE 02342020 IF SC!"$" THEN BEGIN SI~SI+5; IF SC!" " THEN IF SC!"0" THEN BEGIN DI~P;02342030 DS~6LIT"- " END END END OF TSSEDITS ; 02342040 STREAM PROCEDURE MOVEW(F,T,B,R); VALUE B, R; 02343000 BEGIN 02344000 LABEL XIT; 02345000 SI ~ F; DI ~ T; 02346000 B( 02347000 2(40( IF SC = ALPHA THEN DS ~ CHR ELSE 02348000 IF SC = " " THEN DS ~ CHR ELSE 02349000 IF SC = "%" THEN BEGIN DS ~ LIT "("; SI ~ SI+1 END ELSE 02350000 IF SC = "[" THEN BEGIN DS ~ LIT ")"; SI ~ SI+1 END ELSE 02351000 IF SC = "#" THEN BEGIN DS ~ LIT "="; SI ~ SI+1 END ELSE 02352000 IF SC = "&" THEN BEGIN DS ~ LIT "+"; SI ~ SI+1 END ELSE 02353000 IF SC = "@" THEN BEGIN DS ~ LIT """; SI ~ SI+1 END ELSE 02354000 IF SC = ":" THEN BEGIN DS ~ LIT """; SI ~ SI+1 END ELSE 02354100 IF SC = "<" THEN BEGIN DS ~ LIT "+"; SI ~ SI+1 END ELSE 02355000 IF SC = ">" THEN BEGIN DS ~ LIT "="; SI ~ SI+1 END ELSE 02356000 DS ~ CHR )); JUMP OUT TO XIT); 02357000 DS ~ 10 WDS; 02358000 XIT: 02359000 SI~LOC R; SI~SI+7; DI~DI+1 ; 02360000 DS~CHR ; 02361000 END MOVEW; 02362000 ALPHA STREAM PROCEDURE DCMOVEW(F,T,B,FIL,R); VALUE B,FIL,R; 02362010 BEGIN LOCAL C; LABEL L1,L2,L3,L4 ; 02362020 SI~F; DI~T; 2(SI~SI+36; DS~36LIT" "); C~SI; DS~8CHR ; 02362030 SI~LOC R; SI~SI+6; DS~2CHR; DI~C; DS~8LIT"]";TALLY~33;SI~F; 02362033 IF SC = " " THEN %%% IT MIGHT BE A FILES CARD. 02362034 BEGIN SI~SI+1; IF SC="F" THEN 02362035 BEGIN DI~LOC FIL; DI~DI+2; IF 5SC=DC THEN 02362036 BEGIN DI~F; SI~LOC FIL; SI~SI+2; DS~6CHR ; GO TO L1; END 02362037 ELSE SI~F END ELSE SI~F END 02362038 ELSE IF SC = "F" THEN BEGIN DI~LOC FIL;DI~DI+2;IF 6SC=DC THEN GO L1 02362040 ELSE SI~F;END 02362041 ELSE IF SC="-" THEN 02362042 BEGIN %%% IT IS A CONTINUATION CARD. 02362044 SI~SI+1; DI~T; DS~6LIT" *" ; 02362050 5(IF SC=" " THEN SI~SI+1 ELSE JUMP OUT); GO TO L2 ; 02362060 END 02362063 ELSE IF SC="C" THEN 02362066 BEGIN %%% IT MIGHT BE A COMMENT CARD. 02362070 SI~SI+1; IF SC="-" THEN GO TO L1 ELSE SI~F ; 02362080 END ; 02362090 IF SC!"$" THEN %%% IT IS NOT A COMMENT CARD, NOR IS IT A $ CARD, 02362100 BEGIN %%% NOR A CONTINUATION CARD, NOR A FILES CARD. 02362110 2(33(IF SC=" " THEN SI~SI+1 ELSE JUMP OUT 2 TO L3)); L3: DI~T;02362120 5(IF SC=" " THEN SI~SI+1 ELSE IF SC}"0" THEN IF SC{"9" 02362130 THEN DS~CHR ELSE JUMP OUT ELSE JUMP OUT) ; 02362140 DI~T; DI~DI+6; IF SC=" " THEN SI~SI+1 ; 02362150 END 02362160 ELSE 02362170 BEGIN 02362180 L1: SI~F; DI~T; TALLY~36 ; 02362190 END ; 02362200 L2: C~TALLY ; 02362210 B(2(C(IF SC>">" THEN DS~CHR ELSE IF SC<"[" THEN DS~CHR ELSE 02362220 IF SC="%" THEN BEGIN DS~LIT"("; SI~SI+1 END ELSE 02362230 IF SC="#" THEN BEGIN DS~LIT"="; SI~SI+1 END ELSE 02362235 IF SC="&" THEN BEGIN DS~LIT"+"; SI~SI+1 END ELSE 02362240 IF SC="@" THEN BEGIN DS~LIT"""; SI~SI+1 END ELSE 02362245 IF SC=":" THEN BEGIN DS~LIT"""; SI~SI+1 END ELSE 02362250 IF SC="<" THEN BEGIN DS~LIT"+"; SI~SI+1 END ELSE 02362255 IF SC=">" THEN BEGIN DS~LIT"="; SI~SI+1 END ELSE 02362260 IF SC="[" THEN BEGIN DS~LIT")"; SI~SI+1 END ELSE 02362265 IF SC="]" THEN JUMP OUT 3 TO L4 ELSE DS~CHR));JUMP OUT TO L4);02362270 2(C(IF SC="]" THEN JUMP OUT 2 TO L4 ELSE DS~CHR)) ; 02362275 L4: DI~LOC DCMOVEW; DS~8LIT"00 "; DI~DI-6 ; 02362280 6(IF SC="]" THEN JUMP OUT ELSE DS~CHR) ; 02362285 END OF DCMOVEW ; 02362290 STREAM PROCEDURE SEQERR(BUFF, NEW, OLD); 02362300 BEGIN 02362400 DI ~ BUFF; DS ~ 18 LIT "SEQUENCE ERROR "; 02362450 SI ~ NEW; DS ~ LIT"""; 02362500 DS ~ 8 CHR; DS ~ LIT """; 02362550 DS ~ 3 LIT " < "; 02362600 SI ~ OLD; DS ~ LIT """; 02362650 DS ~ 8 CHR; DS ~ LIT """; 02362700 DS ~ 59 LIT " "; 02362750 DS ~ 8 LIT "X"; DS ~ 4 LIT " "; 02362800 END SEQERR; 02362850 STREAM PROCEDURE DCMOVE(E,C,A,N); VALUE A,N; 02362855 BEGIN SI~C; DI~E; DS~10WDS; DS~4CHR; SI~LOC A; DS~4DEC; 02362860 N(DS~8LIT" PATCH"); END; 02362865 REAL BUF,ID; 02362900 BOOLEAN NOWRI; LABEL ENDPB, E4B; 02362902 LABEL LIBADD, ENDPA, E4A, E4, STRTA; 02362950 LABEL E1,E2,E3,STRT,ENDP,XIT; 02363000 UNPRINTED~TRUE; 02363100 GO TO STRT; 02364000 LIBADD: 02364100 XTA := BLANKS; 02364130 IF INSERTDEPTH = -1 THEN SAVECARD ~ NEXTCARD; 02364160 MOVE (CRD[9],BUFL); 02364240 02364280 IF (INSERTDEPTH ~ INSERTDEPTH + 1) GTR INSERTMAX THEN 02364300 FLAG(158); 02364320 NEWTPTOG ~ FALSE; 02364330 INSERTINX ~ -1; 02364340 INSERTCOP ~ 0; 02364350 BLANKIT(SSNM[5],1,0); 02364360 BUF ~ SCANINC(BUF,INSERTMID,RESULT,1,0); 02364380 IF RESULT = 1 AND INSERTMID = "+ "THEN 02364381 BEGIN BUF~SCANINC(BUF,ID,RESULT,1,0); 02364382 IF ID = "COPY " THEN INSERTCOP ~ 1 02364383 ELSE FLAG(155); 02364384 BUF~SCANINC(BUF,INSERTMID,RESULT,1,0); 02364385 END; 02364386 IF RESULT NEQ 2 THEN FLAGI (155); 02364400 BUF := SCANINC(BUF,ID,RESULT,0,1); %107-02364420 IF RESULT = 1 THEN IF ID = "/ " THEN 02364440 BEGIN BUF := SCANINC(BUF,INSERTFID,RESULT,1,0); 02364460 IF RESULT NEQ 2 THEN FLAGI(155); 02364480 BUF := SCANINC(BUF,ID,RESULT,0,1); 02364500 END ELSE INSERTFID := TIME(-1) ELSE INSERTFID := TIME(-1); 02364520 IF RESULT = 3 THEN 02364540 BEGIN NEWSEQ(SSNM[5],ID); 02364560 BUF := SCANINC(BUF,ID,RESULT,0,1); 02364580 IF RESULT NEQ 1 THEN FLAGI(156); 02364600 IF ID = "] " THEN NEWSEQ (INSERTSEQ,99999999) %400-02364605 ELSE BEGIN %400-02364610 BUF ~ SCANINC(BUF,ID,RESULT,0,1); 02364620 IF RESULT NEQ 3 THEN FLAGI(157); 02364640 NEWSEQ (INSERTSEQ,ID); 02364660 END %400-02364670 END ELSE IF ID = "] " THEN NEWSEQ(INSERTSEQ,999999999) 02364680 ELSE FLAGI(157); 02364700 IF INSERTDEPTH > 0 THEN CLOSE (LF,RELEASE); 02364720 FILL LF WITH INSERTMID,INSERTFID; 02364740 DO BEGIN 02364760 READ (LF[INSERTINX ~ INSERTINX+1],10,DB[*])[E4]; 02364780 END UNTIL SEQCHK(SSNM[5],DB[9]) NEQ 3; 02364800 NEWTPTOG ~ BOOLEAN(INSERTCOP); 02364810 IF NOT NEWTPTOG THEN 02364811 BEGIN 02364815 IF SEQTOG THEN 02364820 BEGIN NEWSEQ(CRD[9],SEQBASE); MOVE(CRD[9],BUFL); 02364830 SEQBASE~SEQBASE+SEQINCR; 02364840 END; MOVEC(CRD[9],BUFL); 02364850 IF LIBTAPE AND(INSERTDEPTH = 0 ) THEN WRITE(NEWTAPE,10,CRD[*]); 02364860 END; %511- 02364885 IF LISTOG OR DOLIST THEN PRINTCARD; %511- 02364890 NEXTCARD:=7; 02364900 GO TO STRT; 02364910 E1: IF NEXTCARD=1 THEN IF TAPETOG THEN 02365000 BEGIN 02366000 NEXTCARD~5; READ(TP,10,TB[*])[E2]; GO TO STRT ; 02367000 END 02368000 ELSE 02369000 BEGIN 02370000 NEXTCARD:=6; 02371000 IF GETCOL1(CRD[0]) THEN BEGIN BUF := MKABS(CRD[0]); 02371002 BUF:=SCANINC(BUF,ID,RESULT,1,0); IF ID NEQ INCLUDE 02371004 THEN BLANKIT(CRD,9,1); END; 02371006 GO TO ENDP ; 02371010 END ; 02371020 NEXTCARD ~ 5; GO TO ENDP; 02372000 E2: IF NEXTCARD = 5 THEN 02372010 BEGIN 02372020 NEXTCARD:=6; 02372030 IF GETCOL1(CRD[0]) THEN BEGIN BUF := MKABS(CRD[0]); 02372040 BUF:=SCANINC(BUF,ID,RESULT,1,0); IF ID NEQ INCLUDE 02372050 THEN BLANKIT(CRD,9,1); END; 02372060 END 02373000 ELSE IF NEXTCARD!2 THEN NEXTCARD~1 ELSE 02373010 BEGIN 02373020 NEXTCARD~1; TAPETOG~BOOLEAN(2); READ(CR,10,CB[*])[E1] ; 02373030 END ; 02373040 IF VOIDTTOG THEN IF SEQCHK(CRD[0],VOIDTSEQ) < 4 %114-02373045 THEN VOIDTTOG~FALSE %114-02373100 ELSE BEGIN VOIDTTOG~FALSE; GO TO STRT; END; %114-02373200 GO TO ENDP ; 02374000 E4B: NOWRI ~TRUE; 02374050 IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); 02374053 IF NEWTPTOG THEN IF TSSEDITOG THEN 02374055 BEGIN TSSEDITS(CRD,PRINTBUFF); WRITE(NEWTAPE,10,PRINTBUFF[*]); 02374060 END ELSE WRITE(NEWTAPE,10,CRD[*]); 02374065 E4: CLOSE (LF,RELEASE); 02374100 NEWTPTOG~ SAVETOG; 02374110 IF (INSERTDEPTH := INSERTDEPTH - 1) = -1 THEN 02374150 BEGIN NEXTCARD ~ SAVECARD; GO TO ENDPA; END 02374200 ELSE NEWTPTOG ~ BOOLEAN(INSERTCOP); 02374300 FILL LF WITH INSERTMID,INSERTFID; 02374450 READ(LF[INSERTINX := INSERTINX + 1],10,DB[*])[E4]; 02374470 IF SEQCHK(INSERTSEQ,DB[9]) = 4 THEN GO TO E4; 02374500 GO TO ENDP; 02374520 E4A: 02374560 NEWTPTOG~SAVETOG; 02374580 IF (INSERTDEPTH ~ INSERTDEPTH-1) = -1 THEN NEXTCARD~SAVECARD 02374600 ELSE NEWTPTOG ~ BOOLEAN(INSERTCOP); 02374680 STRT: 02375000 STRTA: 02375600 IF NEXTCARD=6 THEN GO XIT ; 02376000 CARDCOUNT ~ CARDCOUNT+1; 02377000 IF NEXTCARD = 1 THEN 02378000 BEGIN % CARD ONLY 02379000 IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG 02380000 THEN MOVEW(CB,CRD,HOLTOG,IF DCINPUT THEN "D" ELSE "R") 02380100 ELSE IF SSNM[4]~DCMOVEW(CB,CRD,HOLTOG,"FILE ",IF FREEFTOG 02380125 THEN " R" ELSE " D") ! " " THEN 02380150 BEGIN XTA~SSNM[4] ; 02380175 MOVESEQ(SSNM[4],LASTSEQ); MOVESEQ(LASTSEQ,CRD[9]) ; 02380200 IF LISTOG THEN 02380210 BEGIN IF FIRSTCALL THEN DATIME ; 02380220 DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],0); 02380230 WRITAROW(11,PRINTBUFF); UNPRINTED~FALSE ; 02380240 END ; 02380250 FLOG(149); MOVESEQ(LASTSEQ,SSNM[4]) ; 02380300 END ; 02380400 IF GETCOL1(CRD[0]) THEN 02381000 BEGIN 02382000 BUF := MKABS(CRD[0]); 02382200 BUF := SCANINC(BUF,ID,RESULT,1,0); 02382300 IF ID NEQ INCLUDE THEN 02382400 BEGIN 02382500 DOLOPT; 02383000 IF REAL(TAPETOG)=3 THEN READ(TP) ; 02383010 READ(CR,10,CB[*])[E1]; 02384000 IF NOT TAPETOG THEN GO TO STRT; 02385000 READ(TP,10,TB[*])[E2]; 02386000 NEXTCARD ~ SEQCHK(TB[9], CB[9]); 02387000 GO TO STRT; 02388000 END; 02389000 END; 02389100 IF LISTPTOG THEN 02389200 BEGIN IF FIRSTCALL THEN DATIME; 02389300 IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); 02389400 DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],1); 02389500 WRITAROW (12,PRINTBUFF); UNPRINTED ~ FALSE; 02389600 END; 02389700 READ(CR,10,CB[*])[E1]; 02390000 GO TO ENDP; 02391000 END; 02392000 IF NEXTCARD = 5 THEN 02393000 BEGIN 02394000 MOVEW(TB,CRD,HOLTOG,"T") ; 02395000 READ(TP, 10, TB[*])[E2]; 02396000 IF VOIDTTOG THEN IF SEQCHK(CRD[9],VOIDTSEQ) < 4 THEN 02396100 VOIDTTOG ~ FALSE ELSE GO TO STRT; 02396200 GO TO ENDP; 02397000 END; 02398000 IF NEXTCARD { 3 THEN 02399000 BEGIN % CARD OVER TAPE 02400000 IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG 02401000 THEN MOVEW(CB,CRD,HOLTOG,IF DCINPUT THEN "D" ELSE "R") 02401100 ELSE IF SSNM[4]~DCMOVEW(CB,CRD,HOLTOG,"FILE ",IF FREEFTOG 02401125 THEN " R" ELSE " D") ! " " THEN 02401150 BEGIN XTA~SSNM[4] ; 02401175 MOVESEQ(SSNM[4],LASTSEQ); MOVESEQ(LASTSEQ,CRD[9] ); 02401200 IF LISTOG THEN 02401210 BEGIN IF FIRSTCALL THEN DATIME; 02401220 DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],0); 02401230 WRITAROW(11,PRINTBUFF); UNPRINTED~FALSE ; 02401240 END; 02401250 FLOG(149); MOVESEQ(LASTSEQ,SSNM[4]) ; 02401300 END; 02401400 IF NEXTCARD =2 THEN READ(TP,10,TB[*])[E2]; 02402000 IF GETCOL1(CRD) THEN 02403000 BEGIN 02404000 BUF ~ MKABS(CRD[0]); 02404200 BUF ~ SCANINC(BUF,ID,RESULT,1,0); 02404300 IF ID NEQ INCLUDE THEN 02404400 BEGIN 02404500 DOLOPT; 02405000 READ(CR,10,CB[*])[E3]; 02406000 NEXTCARD ~ SEQCHK(TB[9], CB[9]); 02407000 GO TO STRT; 02408000 E3: NEXTCARD~5; GO TO STRT; 02408500 END; 02409000 END; 02409100 IF LISTPTOG THEN 02409200 BEGIN IF FIRSTCALL THEN DATIME; 02409300 IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); 02409400 DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],1); 02409500 WRITAROW (12,PRINTBUFF); UNPRINTED ~ FALSE; 02409600 END; 02409700 READ(CR,10,CB[*])[E1]; 02410000 NEXTCARD ~ SEQCHK(TB[9], CB[9]); 02411000 GO TO ENDP; 02412000 END; 02413000 % TAPE BEFORE CARD 02414000 IF NEXTCARD = 7 THEN 02414100 BEGIN 02414150 IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG 02414175 THEN MOVEW(DB,CRD,HOLTOG,"L") ELSE IF XTA~DCMOVEW(DB,CRD, 02414200 HOLTOG,"FILE ",IF FREEFTOG THEN " R" ELSE " D") 02414225 ! " " THEN FLOG(149); 02414250 IF GETCOL1(CRD[0]) THEN 02414260 BEGIN 02414270 BUF ~ MKABS(CRD[0]); 02414280 BUF ~ SCANINC(BUF,ID,RESULT,1,0); 02414290 IF ID = INCLUDE THEN GO TO LIBADD; 02414300 END; 02414310 READ(LF[INSERTINX~INSERTINX+1],10,DB[*])[E4B]; 02414370 IF SEQCHK(INSERTSEQ,DB[9]) = 4 THEN GO TO E4B; 02414380 IF GETCOL1(CRD[0]) THEN BEGIN DOLOPT; GO TO STRT; END; 02414382 GO TO ENDP; 02414390 END; 02414400 MOVEW(TB,CRD,HOLTOG,"T") ; 02415000 READ(TP,10,TB[*])[E2]; 02416000 IF VOIDTTOG THEN IF SEQCHK(CRD[9],VOIDTSEQ) < 4 THEN 02416100 VOIDTTOG~FALSE ELSE BEGIN NEXTCARD~SEQCHK(TB[9],CB[9]); %114-02416200 GO TO STRT; END; %114-02416300 NEXTCARD ~ SEQCHK(TB[9], CB[9]); 02417000 ENDP: 02418000 IF NEXTCARD NEQ 7 THEN 02418100 IF VOIDTOG THEN IF SEQCHK(CRD[9],VOIDSEQ) < 4 THEN 02419000 VOIDTOG ~ FALSE ELSE GO TO STRT; 02419050 IF GETCOL1(CRD[0]) THEN 02419100 BEGIN 02419150 BUF ~ MKABS(CRD[0]); 02419200 BUF ~ SCANINC(BUF,ID,RESULT,1,0); 02419250 IF ID = INCLUDE THEN GO TO LIBADD ELSE GO TO STRT; 02419300 END; 02419325 SEQERRORS ~ FALSE; 02420000 IF NEXTCARD = 7 THEN 02420010 BEGIN MOVESEQ(LASTSEQ,CRD[9]); GO TO ENDPA; END; 02420011 IF CHECKTOG AND SEQERRCT=0 THEN SEQERRCT~1 ; 02420015 IF CHECKTOG THEN IF SEQCHK(LASTSEQ,CRD[9])=3 THEN 02420020 BEGIN 02420030 SEQERR(ERRORBUFF,CRD[9],LASTSEQ) ; 02420040 MOVESEQ(LASTSEQ,CRD[9]) ; 02420050 IF SEQTOG THEN 02420053 BEGIN NEWSEQ(CRD[9],SEQBASE);SEQBASE~SEQBASE+SEQINCR END;02420057 MOVESEQ(LINKLIST,CRD[9]); 02420060 MOVE(CRD[9],BUFL) ; 02420070 SEQERRCT~SEQERRCT+1 ; 02420080 SEQERRORS~TRUE ; 02420090 IF NOT LISTOG THEN PRINTCARD ; 02420100 END 02420110 ELSE MOVESEQ(LASTSEQ,CRD[9]) ELSE MOVESEQ(LASTSEQ,CRD[9]) ; 02420120 02420150 02420200 02420250 02420300 02420350 02420400 02420450 02420500 ENDPA: 02420550 IF SEQTOG THEN 02421000 BEGIN 02422000 NEWSEQ(CRD[9],SEQBASE); 02423000 SEQBASE ~ SEQBASE + SEQINCR; 02424000 END; 02425000 IF NOWRI THEN GO TO ENDPB; 02425100 IF NEWTPTOG THEN IF TSSEDITOG THEN BEGIN TSSEDITS(CRD,PRINTBUFF) ; 02426000 WRITE(NEWTAPE,10,PRINTBUFF[*]) END ELSE WRITE(NEWTAPE,10,CRD[*]) ; 02426005 ENDPB: 02426008 IF NOT SEQERRORS THEN 02426010 BEGIN 02426020 MOVESEQ(LINKLIST,CRD[9]) ; 02426030 MOVE(CRD[9],BUFL) ; 02426040 END ; 02427000 NCR ~ INITIALNCR; 02428000 READACARD ~ TRUE; 02429000 XIT: 02430000 SEGSWFIXED ~ TRUE ; 02431000 REMFIXED~TRUE ; 02431005 IF TSSEDITOG THEN WARNED~TRUE ; 02431100 IF LISTOG AND FIRSTCALL THEN DATIME; 02432000 IF SEGSW THEN %%% ENTER SEQ# AND ADR TO LINESEG ARRAY. 02432100 BEGIN IF LASTADDR!ADR THEN BEGIN NOLIN~NOLIN+1; LASTADDR~ADR END;02432200 LINESEG[NOLIN.IR,NOLIN.IC]~0 & D2B(LASTSEQ)[10:20:28] & (ADR+3) 02432300 [38:36:10] ; 02432400 END ; 02432500 END READACARD; 02433000 INTEGER STREAM PROCEDURE CONVERT(NUB,SIZE,P,CHAR); VALUE P; 02434000 BEGIN 02435000 LOCAL T; 02436000 SI ~ P; 02437000 8(IF SC < "0" THEN JUMP OUT; 02438000 SI ~ SI + 1; TALLY ~ TALLY + 1); 02439000 CONVERT ~ SI; 02440000 DI ~ CHAR; DS ~ 7 LIT "0"; DS ~ CHR; 02441000 T ~ TALLY; 02442000 SI ~ P; DI ~ NUB; DS ~ T OCT; 02443000 DI ~ SIZE ; SI ~ LOC T; DS ~ WDS; 02444000 END CONVERT; 02445000 PROCEDURE SCAN; 02446000 BEGIN 02447000 BOOLEAN STREAM PROCEDURE ADVANCE(NCR, ACR, CHAR, NCRV, ACRV); 02448000 VALUE NCRV, ACRV, CHAR; 02449000 BEGIN LABEL LOOP; 02450000 LABEL DIG, ALPH, BK1, BK2, SPEC; 02451000 DI ~ ACRV; 02452000 SI ~ CHAR; SI ~ SI+8; 02453000 IF SC ! " " THEN 02454000 IF SC } "0" THEN BEGIN SI ~ NCRV; GO TO BK1 END ELSE 02455000 BEGIN SI ~ NCRV; GO TO BK2 END; 02456000 SI ~ NCRV; 02457000 LOOP: 02458000 IF SC = " " THEN BEGIN SI~SI+1; GO TO LOOP END; 02459000 IF SC } "0" THEN 02460000 BEGIN 02461000 DIG: DS ~ CHR; 02462000 BK1: IF SC = " " THEN BEGIN SI ~ SI+1; GO TO BK1 END; 02463000 IF SC } "0" THEN GO TO DIG; 02464000 GO TO SPEC; 02465000 END; 02466000 IF SC = ALPHA THEN 02467000 BEGIN 02468000 ALPH: DS ~ CHR; 02469000 BK2: IF SC = " " THEN BEGIN SI ~ SI+1; GO TO BK2 END; 02470000 IF SC = ALPHA THEN GO TO ALPH; 02471000 END; 02472000 SPEC: 02473000 ACRV ~ DI; 02474000 DS ~ 6 LIT " "; 02475000 IF SC = "]" THEN 02476000 BEGIN TALLY ~ 1; SI ~ LOC ACRV; 02477000 DI ~ ACR; DS ~ WDS; 02478000 DI ~ CHAR; DS ~ LIT ";"; 02479000 END ELSE 02480000 BEGIN DI ~ CHAR; DS ~ CHR; 02481000 ACRV ~ SI; SI ~ LOC ACRV; 02482000 DI ~ NCR; DS ~ WDS; 02483000 END; 02484000 ADVANCE ~ TALLY; 02485000 END ADVANCE; 02486000 BOOLEAN PROCEDURE CONTINUE; 02487000 BEGIN 02487200 LABEL LOOP; 02487400 BOOLEAN STREAM PROCEDURE CONTIN(CD); 02487600 BEGIN SI~CD; IF SC!"C" THEN IF SC!"$" THEN BEGIN SI~SI+5; IF SC!" " 02488000 THEN IF SC!"0" THEN BEGIN TALLY~1; CONTIN~TALLY END END END OF CONTIN ;02489000 BOOLEAN STREAM PROCEDURE COMNT(CD,T); VALUE T; 02489200 BEGIN LABEL L ; 02489400 SI ~ CD; IF SC = "C" THEN BEGIN T(SI~SI+1; IF SC="-" THEN TALLY~1 02489600 ELSE JUMP OUT TO L); TALLY~1; L: END; COMNT~TALLY ; 02490000 END COMNT; 02490200 BOOLEAN STREAM PROCEDURE DCCONTIN(CD); 02490400 BEGIN 02490500 SI ~ CD; IF SC = "-" THEN TALLY ~ 1; 02490600 DCCONTIN ~ TALLY; 02491000 END DCCONTIN; 02491200 LOOP: IF NOT(CONTINUE ~ 02491400 IF(DCINPUT AND NOT TSSEDITOG)OR FREEFTOG THEN 02491600 IF NEXTCARD < 4 THEN DCCONTIN(CB) 02491650 ELSE IF NEXTCARD = 7 THEN DCCONTIN(DB)ELSE CONTIN(TB) 02491700 ELSE IF NEXTCARD = 7 THEN CONTIN(DB) 02491800 ELSE IF NEXTCARD < 4 THEN CONTIN(DB) ELSE 02492000 CONTIN(TB)) THEN 02492200 IF(IF NEXTCARD < 4 THEN 02492400 COMNT(CB,(DCINPUT AND NOT TSSEDITOG) OR FREEFTOG) 02492450 ELSE IF NEXTCARD = 7 THEN 02492500 COMNT(CB,(DCINPUT AND NOT TSSEDITOG) OR FREEFTOG) 02492550 ELSE COMNT(TB,0) AND NEXTCARD ! 6) THEN 02492600 BEGIN 02493000 IF READACARD THEN IF LISTOG THEN PRINTCARD; 02493200 GO TO LOOP; 02493400 END; 02493600 END CONTINUE; 02494000 PROCEDURE SCANX(EOF1, EOF2, EOS1, EOS2, OK1, OK2); 02495000 VALUE EOF1, EOF2, EOS1, EOS2, OK1, OK2; 02496000 INTEGER EOF1, EOF2, EOS1, EOS2, OK1, OK2; 02497000 BEGIN LABEL LOOP, LOOP0 ; 02498000 LOOP0: 02498100 EXACCUM[1] ~ BLANKS; 02499000 ACR ~ ACR1; 02500000 LOOP: 02501000 IF ADVANCE(NCR, ACR, CHR1, NCR, ACR) THEN 02502000 IF CONTINUE THEN 02503000 % 02504000 IF READACARD THEN 02505000 BEGIN 02506000 IF LISTOG THEN PRINTCARD ; 02506010 IF ACR.[33:15]}EXACCUMSTOP THEN 02506020 BEGIN XTA~BLANKS; FLOG(175); GO LOOP0 END ; 02506030 GO LOOP ; 02506040 END 02506050 ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN EOF1 ELSE EOF2 02507000 ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN EOS1 ELSE EOS2 02508000 ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN OK1 ELSE OK2; 02509000 END SCANX; 02510000 DEFINE CHAR = ACCUM[0]#; 02511000 DEFINE T=SYMBOL#; 02512000 INTEGER N; 02513000 BOOLEAN STREAM PROCEDURE CHECKEXP(NCR, NCRV, A); VALUE NCRV; 02514000 BEGIN 02515000 SI ~ NCRV; 02516000 IF SC = "*" THEN 02517000 BEGIN DI ~ A; DI ~ DI+2; DS ~ 2 LIT "*"; SI ~ SI+1; NCRV ~ SI; 02518000 TALLY ~ 1; CHECKEXP ~ TALLY; 02519000 SI ~ LOC NCRV; DI ~ NCR; DS ~ WDS END; 02520000 END CHECKEXP; 02521000 PROCEDURE CHECKRESERVED; 02522000 BEGIN LABEL RESWD, XIT, FOUND1, FOUND2, DONE; 02523000 BOOLEAN STREAM PROCEDURE COMPLETECHECK(A,B,N); VALUE N ; 02523100 BEGIN LABEL L ; 02523200 SI~A; SI~SI-2; DI~B; N(IF SC!DC THEN JUMP OUT TO L); TALLY~1; 02523300 L: COMPLETECHECK~TALLY ; 02523400 END OF COMPLETECHECK; 02523500 STREAM PROCEDURE XFER(FROM, T1, T2, N, M); VALUE FROM, N, M; 02524000 BEGIN SI ~ FROM; DI ~ T1; DI ~ DI+2; 02525000 DS ~ M CHR; 02526000 SI ~ FROM; SI ~ SI+N; 02527000 DI ~ T2; DI ~ DI+2; 02528000 DS ~ 6 CHR; 02529000 END XFER; 02530000 STREAM PROCEDURE XFERA(FROM, NEXT1, NEXT2); 02531000 VALUE FROM; 02532000 BEGIN SI ~ FROM; SI ~ SI+6; 02533000 DI ~ NEXT1; DI ~ DI+2; 02534000 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); 02535000 SI ~ SI+2; 02536000 DI ~ NEXT2; DI ~ DI+2; 02537000 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); 02538000 END XFERA; 02539000 BOOLEAN STREAM PROCEDURE CHECKFUN(FROM, TOO, N); VALUE FROM, N; 02540000 BEGIN SI ~ FROM; SI ~ SI +N; 02541000 IF SC = "0" THEN 02542000 BEGIN SI ~ SI+1; 02543000 IF SC = "N" THEN 02544000 BEGIN SI ~ SI+1; TALLY ~ 1; 02545000 DI ~ TOO; DI ~ DI+2; 02546000 DS ~ 6 CHR; 02547000 END; 02548000 END; 02549000 CHECKFUN ~ TALLY; 02550000 END CHECKFUN; 02551000 BOOLEAN STREAM PROCEDURE MORETHAN6(P); 02552000 BEGIN SI ~ P; 02553000 IF SC ! " " THEN TALLY ~ 1; 02554000 MORETHAN6 ~ TALLY; 02555000 END MORETHAN6; 02556000 INTEGER I; ALPHA ID; 02557000 INTEGER STOR ; 02557100 IF ACCUM[1] = " " THEN 02558000 BEGIN XTA ~ CHAR; FLOG(16); GO TO XIT END; 02559000 IF CHAR = "= " OR CHAR = "# " THEN GO TO XIT; 02560000 IF CHAR = "~ " THEN GO TO XIT; 02560100 IF CHAR ! "( " AND CHAR ! "% " THEN GO TO RESWD; 02561000 IF MORETHAN6(ACCUM[2]) THEN GO TO RESWD; 02562000 COMMENT AT THIS POINT WE HAVE ( . 02563000 THIS MUST BE ONE OF THE FOLLOWING: 02564000 ASSIGNEMNT STATEMENT WITH SUBSCRIPTED VARIABLE AT THE LEFT. 02565000 STATEMENT FUNCTION DECLARATION. 02566000 CALL, REAL, ENTRY, GO TO, READ, WRITE, FORMAT, IF, DATA, CHAIN, PRINT OR02567000 PUNCH; 02567100 IF I ~ SEARCH(T) > 0 THEN 02568000 IF GET(I).CLASS = ARRAYID THEN GO TO XIT; 02569000 ID ~ T; ID.[36:12] ~ " "; 02570000 FOR I~0 THRU RSP DO IF RESERVEDWORDSLP[I]=ID THEN IF (IF STOR 02571000 ~RESLENGTHLP[I]-4<1 THEN TRUE ELSE COMPLETECHECK(ACCUM[2], 02571100 RESERVEDWORDSLP[I+RSP1],STOR)) THEN GO FOUND1 ; 02572000 GO TO XIT; 02573000 FOUND1: 02574000 NEXT ~ LPGLOBAL[I]; 02575000 T ~ " "; 02576000 XFER(ACR0, T, NEXTACC, I~RESLENGTHLP[I], IF I> 6 THEN 6 ELSE I); 02577000 GO TO DONE; 02578000 RESWD: 02579000 COMMENT AT THIS POINT WE KNOW THE MUST BE A SPECIAL WORD 02580000 TO IDENTIFY THE STATEMENT TYPE; 02581000 ID ~ T; ID.[36:12] ~ " "; 02582000 IF T = "ASSIGN" THEN 02583000 BEGIN 02584000 NEXTSCN ~ SCN; SCN ~ 14; 02585000 NEXTACC ~ NEXTACC2 ~ " "; 02586000 XFERA(ACR0, NEXTACC, NEXTACC2); 02587000 NEXT ~ 1; 02588000 GO TO XIT; 02589000 END; 02590000 FOR I~1 THRU RSH DO IF RESERVEDWORDS[I]=ID THEN IF (IF STOR~ 02591000 RESLENGTH[I]-4<1 THEN TRUE ELSE COMPLETECHECK(ACCUM[2],RESERVEDWORDS02591100 [I+RSH1],IF STOR>8 THEN 8 ELSE STOR)) THEN GO FOUND2 ; 02592000 XTA ~ T; FLOG(16); GO TO XIT; 02593000 FOUND2: 02594000 NEXT ~ I+1; 02695000 T ~ " "; 02696000 XFER(ACR0, T, NEXTACC, I~RESLENGTH [I], IF I> 6 THEN 6 ELSE I); 02697000 DONE: NEXTSCN ~ SCN; 02698000 SCN ~ 6; 02699000 IF NEXTACC = "FUNCTI" THEN 02600000 IF CHECKFUN(ACR0, NEXTACC, I+6) THEN SCN ~ 13; 02601000 XIT: 02602000 EOSTOG~FALSE; 02603000 END CHECKRESERVED; 02604000 BOOLEAN PROCEDURE CHECKOCTAL; 02605000 BEGIN 02606000 INTEGER S, T; LABEL XIT; 02607000 INTEGER STREAM PROCEDURE COUNT(ACRV,T); VALUE ACRV,T ; 02608000 BEGIN 02609000 LOCAL A,B; SI~LOC T; SI~SI+7 ; 02610000 IF SC="1" THEN BEGIN SI~ACRV;IF SC="0" THEN SI~SI+1 END ELSE SI~ACRV;02611000 IF SC!" " THEN 02612000 BEGIN A~SI; 02613000 17(IF SC>"7" THEN BEGIN TALLY~17; JUMP OUT END ELSE IF SC < "0" THEN02614000 BEGIN IF SC!" " THEN TALLY~17; JUMP OUT END; SI~SI+1; 02614010 TALLY~TALLY+1) ; 02614015 B~TALLY; SI~LOC B; SI~SI+7 ; 02614020 IF SC="+" THEN BEGIN SI~A; IF SC>"3" THEN TALLY~17 END; 02614030 END ; 02614040 COUNT~TALLY ; 02614050 END OF COUNT ; 02614060 ALPHA STREAM PROCEDURE CONV(ACRV, S, T); VALUE ACRV, S, T; 02615000 BEGIN SI ~ ACRV; IF SC = "0" THEN SI ~ SI+1; 02616000 DI ~ LOC CONV; SKIP S DB; 02617000 T(SKIP 3 SB; 3(IF SB THEN DS ~ SET ELSE DS ~ RESET; SKIP 1 SB)); 02618000 END CONV; 02619000 IF T~COUNT(ACR0,1) = 0 THEN 02620000 BEGIN S ~ 1; 02620100 IF T ~ CHAR ! "+ " AND T ! "& " THEN 02620200 IF T = "- " THEN S ~ -1 ELSE GO TO XIT; 02621000 SCANX(4, 4, 3, 3, 10, 10); 02621100 IF SCN ! 10 THEN GO TO XIT; 02622000 IF T~COUNT(ACR1,2) = 0 OR T > 16 THEN GO TO XIT ; 02622100 FNEXT ~ CONV(ACR1, (16-T)|3, T); 02622200 IF S < 0 THEN FNEXT ~ -FNEXT; 02623000 END ELSE IF T < 17 THEN FNEXT~CONV(ACR0,(16-T)|3,T) ELSE GO TO XIT ; 02623100 CHECKOCTAL ~ TRUE; 02624000 NEXT ~ NUM; 02625000 NUMTYPE ~ REALTYPE; 02626000 XIT: 02627000 END CHECKOCTAL; 02628000 PROCEDURE HOLLERITH; 02629000 BEGIN 02630000 REAL T, COL1, T2, ENDP; 02631000 LABEL XIT; 02632000 INTEGER STREAM PROCEDURE STRCNT(S,D,SZ); VALUE S,SZ; 02633000 BEGIN 02634000 SI ~ S; DI ~ D;DS ~ 8 LIT "00 "; DI ~ D; 02635000 DI ~ D; DI ~ DI + 2; DS ~SZ CHR; STRCNT ~ SI; 02636000 END STRCNT; 02637000 INTEGER STREAM PROCEDURE RSTORE(S,D,SKP,SZ); 02638000 VALUE S, SKP, SZ; 02639000 BEGIN 02640000 DI ~ D; 02641000 SI ~ S; DI ~DI + SKP; DS ~ SZ CHR; RSTORE ~ SI; 02642000 END RSTORE; 02643000 F1 ~ FNEXT; 02644000 NUMTYPE ~ STRINGTYPE; 02645000 T ~ 0 & NCR[30:33:15] & NCR[45:30:3]; 02646000 COL1 ~ 0 & INITIALNCR[30:33:15]; 02647000 ENDP ~ COL1 + 72; 02648000 STRINGSIZE ~ 0; 02649000 WHILE F1 >0 DO 02650000 BEGIN 02651000 T2 ~ IF F1 > 6 THEN 6 ELSE F1; 02652000 IF STRINGSIZE > MAXSTRING THEN 02653000 BEGIN FLAG(120); STRINGSIZE ~ 0 END; 02654000 IF T+T2> ENDP THEN IF DCINPUT OR FREEFTOG THEN 02655000 BEGIN XTA~BLANKS; FLOG(150); GO TO XIT END 02655500 ELSE BEGIN 02656000 IF TSSEDITOG THEN IF NOT DCINPUT THEN TSSED(BLANKS,1) ; 02656100 NCR ~ STRCNT(NCR, STRINGARRAY[STRINGSIZE], ENDP-T); 02657000 IF NOT CONTINUE THEN 02658000 % 02659000 BEGIN FLOG(43); GO TO XIT END; 02660000 IF READACARD THEN; 02661000 IF LISTOG THEN PRINTCARD; 02662000 NCR ~ RSTORE(NCR,STRINGARRAY[STRINGSIZE],ENDP-T+2,T2-(ENDP-T)); 02663000 STRINGSIZE ~ STRINGSIZE+1; 02664000 F1 ~ F1 - T2; 02665000 T ~ COL1 + 6 + T2 - (ENDP - T); 02666000 END ELSE 02667000 BEGIN 02668000 NCR ~ STRCNT(NCR, STRINGARRAY[STRINGSIZE], T2); 02669000 STRINGSIZE ~ STRINGSIZE +1; 02670000 T ~ T +T2; 02671000 F1 ~ F1 - T2; 02672000 END; 02673000 END; 02674000 NUMTYPE ~ STRINGTYPE; 02675000 SCN ~ 1; 02676000 XIT: 02677000 END HOLLERITH; 02678000 PROCEDURE QUOTESTRING; 02679000 BEGIN 02680000 REAL C; 02681000 LABEL XIT; 02682000 ALPHA STREAM PROCEDURE STRINGWORD(S,D,SKP,SZ,C); 02683000 VALUE S,SKP,SZ; 02684000 BEGIN 02685000 LABEL QT, XIT; 02686000 DI ~ D; SI ~ S; 02687000 DI ~ DI+SKP; DI ~ DI+2; 02688000 TALLY ~ SKP; 02689000 SZ( IF SC = """ THEN JUMP OUT TO QT; 02690000 IF SC = ":" THEN JUMP OUT TO QT; 02691000 IF SC = "@" THEN JUMP OUT TO QT; 02692000 IF SC = "]" THEN JUMP OUT TO XIT; 02693000 DS ~ CHR; TALLY ~ TALLY+1); 02694000 GO TO XIT; 02695000 QT: TALLY ~ TALLY+7; SI ~ SI+1; 02696000 XIT: STRINGWORD ~ SI; S ~ TALLY; 02697000 SI ~ LOC S; DI ~ C; DS ~ WDS; 02698000 END STRINGWORD; 02799000 STRINGSIZE ~ 0; 02700000 DO 02701000 BEGIN 02702000 IF STRINGSIZE > MAXSTRING THEN 02703000 BEGIN FLAG(120); STRINGSIZE ~ 0 END; 02704000 STRINGARRAY[STRINGSIZE] ~ BLANKS; 02705000 NCR ~ STRINGWORD(NCR, STRINGARRAY[STRINGSIZE], 0, 6, C); 02706000 IF C<6 THEN IF DCINPUT OR FREEFTOG 02707000 THEN BEGIN XTA~BLANKS; FLOG(150); GO TO XIT END 02707500 ELSE BEGIN 02708000 IF TSSEDITOG THEN IF NOT DCINPUT THEN TSSED(BLANKS,1) ; 02708100 IF NOT CONTINUE THEN 02709000 % 02710000 BEGIN FLOG(121); GO TO XIT END; 02711000 IF READACARD THEN; 02712000 IF LISTOG THEN PRINTCARD; 02713000 NCR ~ STRINGWORD(NCR, STRINGARRAY[STRINGSIZE ],C,6-C,C); 02714000 END; 02715000 STRINGSIZE ~ STRINGSIZE + 1; 02716000 END UNTIL C } 7; 02717000 IF C = 7 THEN STRINGSIZE ~ STRINGSIZE-1; 02718000 FNEXT ~ STRINGSIZE; 02719000 NEXT ~ NUM; 02720000 SYMBOL ~ NAME ~ STRINGARRAY[0]; 02721000 NUMTYPE ~ STRINGTYPE; 02722000 SCN ~ 1; 02723000 XIT: 02724000 END QUOTESTRING; 02725000 PROCEDURE CHECKPERIOD; 02726000 BEGIN 02727000 LABEL FRACTION, XIT, EXPONENT, EXPONENTSIGN; 02728000 LABEL NUMFINI, FPLP, CHKEXP; 02729000 ALPHA S, T, I, TS; 02730000 INTEGER C2; 02730050 BOOLEAN CON; 02730100 IF T ~ CHAR ! ". " THEN GO TO CHKEXP; 02731000 SCANX(4, 9, 3, 8, 10, 11); 02732000 IF T ~ EXACCUM[1] = " " THEN 02733000 BEGIN IF NUMTYPE ! DOUBTYPE THEN NUMTYPE ~ REALTYPE; GO TO XIT END; 02733500 IF T = "E " OR T = "D " THEN GO TO EXPONENTSIGN; 02734000 IF T.[12:6] { 9 THEN GO TO FRACTION; 02735000 IF T.[18:6] { 9 THEN 02736000 BEGIN 02737000 IF S ~ T.[12:6] ! "E" AND S ! "D" THEN 02738000 BEGIN XTA ~ T; FLOG(63); GO TO XIT END; 02739000 EXACCUM[1].[12:6] ~ 0; 02740000 I ~ 1; GO TO EXPONENT; 02741000 END; 02742000 IF EXACCUM[0] ! ". " THEN GO TO XIT; 02743000 FOR I ~ 0 STEP 1 UNTIL 10 DO 02744000 IF T = PERIODWORD[I] THEN 02745000 BEGIN EXACCUM[2] ~ I; SCN ~ 12; GO TO XIT END; 02746000 GO TO XIT; 02747000 FRACTION: NEXT ~ NUM; 02748000 IF NUMTYPE !DOUBTYPE THEN NUMTYPE ~ REALTYPE; XTA ~ ACR1; 02749000 FPLP: 02750000 F1 ~ 0; 02751000 XTA ~ CONVERT(F1,C1,XTA ,TS); 02752000 C2 ~ C2 + C1; 02753000 IF (F2 ~ FNEXT|TEN[C1]+F1) { MAX 02754000 THEN FNEXT ~ F2 02755000 ELSE BEGIN 02756000 NUMTYPE ~ DOUBTYPE; 02757000 CON ~ TRUE; 02757100 DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|, 02758000 F1,0,+,~,FNEXT,DBLOW); 02759000 END; 02760000 IF TS { 9 THEN GO TO FPLP; 02761000 F1 ~ 0; 02762000 IF T ~ EXACCUM[0] ! "E " AND T ! "D " THEN 02763000 BEGIN IF SCN = 8 THEN SCN ~ 3 ELSE SCN ~ 10; 02764000 GO TO NUMFINI; 02765000 END; 02766000 CHKEXP: FNEXT ~ FNEXT | 1.0; 02767000 F1 ~ 0; 02768000 I ~ 1; 02769000 SCANX(4, 4, 3, 3, 20, 10); 02770000 IF SCN = 20 THEN 02771000 EXPONENTSIGN: 02772000 BEGIN IF S ~ EXACCUM[0] ! "+ " AND S ! "& " THEN 02773000 IF S = "- " THEN I ~ -1 ELSE 02774000 BEGIN XTA ~ S; FLOG(63); SCN ~ 10; GO TO XIT END; 02775000 SCANX(4, 4, 3, 3, 10, 10); 02776000 END; 02777000 IF (S ~ EXACCUM[1]).[12:6] > 9 THEN 02778000 BEGIN XTA ~ IF S ! BLANKS THEN S ELSE T; FLOG(63); GO TO XIT END; 02778100 EXPONENT: 02779000 IF NUMTYPE ! DOUBTYPE THEN NUMTYPE ~ REALTYPE; 02779500 IF T.[12:6] = "D" THEN NUMTYPE ~ DOUBTYPE; 02780000 IF SCN = 8 THEN SCN ~ 3 ELSE IF SCN = 11 THEN SCN ~ 10; 02781000 XTA ~ ACR1; 02782000 XTA ~ CONVERT(F1,C1,XTA ,TS); 02783000 IF I < 0 THEN F1 ~ -F1; 02784000 NUMFINI: 02785000 C1 ~ F1 - C2; 02786000 IF I ~ (ABS(C1+(FNEXT.[3:6]&FNEXT[1:2:1]))) > 63 OR((ABS(C1) = I OR 02787000 FNEXT } 5) AND ABS(F1) } 69) 02787500 THEN BEGIN XTA ~ T; FLOG(87); GO TO XIT; END; 02788000 IF NUMTYPE ! DOUBTYPE THEN 02789000 BEGIN 02790000 IF C1} 0 THEN FNEXT ~ FNEXT | TEN[C1] 02791000 ELSE FNEXT ~ FNEXT / TEN[-C1]; 02792000 END ELSE 02793000 BEGIN 02794000 IF C1 } 0 02795000 THEN DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|,~,FNEXT,DBLOW) 02796000 ELSE DOUBLE(FNEXT,DBLOW,TEN[-C1],TEN[69-C1],/,~,FNEXT,DBLOW); 02797000 IF CON THEN IF DBLOW.[9:33] = MAX.[9:33] THEN 02797100 IF FNEXT.[3:6] LSS 14 02797150 THEN IF BOOLEAN(FNEXT.[2:1]) THEN 02797200 BEGIN DBLOW ~ 0; FNEXT ~ FNEXT + 1&FNEXT[2:2:7]; END; 02797300 END; 02798000 XIT: 02799000 END CHECKPERIOD; 02800000 LABEL LOOP0, NUMBER ; 02801000 LABEL L,XIT; 02802000 LABEL L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15,L16,L17, 02802100 L18,L19,L20,L21,BK ; 02802200 SWITCH CASEL~L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15, 02802300 L16,L17,L18,L19,L20,L21 ; 02802400 LABEL LOOP, CASESTMT; %994-02803000 LABEL CASE0,CASE1,CASE2,CASE3,CASE4,CASE5,CASE6,CASE7; %994-02803100 LABEL CASE8,CASE9,CASE10,CASE11,CASE12,CASE13,CASE14; %994-02803200 PREC~NEXT~FNEXT~REAL(SCANENTER~FALSE) ; 02804000 CASESTMT: 02805000 CASE SCN OF 02806000 BEGIN 02807000 CASE0: %994-02807999 GO TO IF LABELR THEN CASE5 ELSE CASE1; 02808000 CASE1: 02809000 BEGIN 02810000 LOOP0: 02810100 ACR ~ ACR0; 02811000 ACCUM[1] ~ BLANKS; 02812000 LOOP: 02813000 IF ADVANCE(NCR, ACR, CHR0, NCR, ACR) THEN 02814000 IF CONTINUE THEN 02815000 % 02816000 IF READACARD THEN 02817000 BEGIN 02818000 IF LISTOG THEN PRINTCARD ; 02818010 IF ACR.[33:15]}ACCUMSTOP THEN 02818020 BEGIN XTA~BLANKS; FLOG(175); GO LOOP0 END ; 02818030 GO LOOP ; 02818040 END 02818050 ELSE IF T ~ ACCUM[1] = " " THEN GO TO CASE5 ELSE SCN ~ 4 02819000 ELSE IF T ~ ACCUM[1] = " " THEN 02820000 GO TO CASE3 ELSE SCN ~ 3 02821000 ELSE IF T ~ ACCUM[1] = " " THEN GO TO CASE2 ELSE SCN ~ 2; 02822000 END; 02823000 CASE2: 02824000 BEGIN T ~ CHAR; SCN ~ 1 END; 02825000 CASE3: 02826000 BEGIN T ~ "; "; NEXT ~ SEMI; SCN ~ 0; 02827000 IF EOSTOG THEN IF LOGIFTOG THEN BEGIN LOGIFTOG ~ FALSE; XTA ~ T; 02827100 FLAG(101); END; 02827200 GO TO XIT; 02827300 END; 02827400 CASE4: %994-02827999 BEGIN T ~ "; "; NEXT ~ SEMI; SCN ~ 5; GO TO XIT END; 02828000 CASE5: 02829000 BEGIN T ~ " "; NEXT ~ EOF; EOSTOG ~ FALSE; GO TO XIT END; 02830000 CASE6: %994-02830999 BEGIN T ~ ACCUM[1] ~ NEXTACC; SCN ~ NEXTSCN; 02831000 IF T = " " THEN GO TO CASESTMT; 02832000 END; 02833000 CASE7: %994-02833999 BEGIN EOSTOG ~ TRUE; 02834000 IF LABELR THEN GO TO CASE5 ELSE GO TO CASE1; 02835000 END; 02836000 CASE8: %994-02836999 BEGIN T ~ EXACCUM[1]; SCN ~ 3 END; 02837000 CASE9: %994-02837999 BEGIN T ~ EXACCUM[1]; SCN ~ 4 END; 02838000 CASE10: %994-02838999 BEGIN T ~ CHAR ~ EXACCUM[0]; SCN ~ 1 END; 02839000 CASE11: %994-02839999 BEGIN T ~ EXACCUM[1]; SCN ~ 10 END; 02840000 CASE12: %994-02840999 BEGIN T ~ EXACCUM[1]; SCN ~ 1; 02841000 IF N ~ EXACCUM[2] { 1 THEN 02842000 BEGIN NEXT ~ NUM; FNEXT ~ N; GO TO XIT END; 02843000 NEXT ~ 0; 02844000 OP ~ N-1; 02845000 PREC ~ IF N { 4 THEN N-1 ELSE 4; 02846000 GO TO XIT; 02847000 END; 02848000 CASE13: %994-02848999 BEGIN T ~ "FUNCTI"; NEXT ~ 16; SCN ~ 6; GO TO XIT END; 02849000 CASE14: %994-02849999 BEGIN T ~ ACCUM[1] ~ NEXTACC; 02850000 NEXTACC ~ NEXTACC2; SCN ~ 6; 02851000 END; 02852000 END OF CASE STATEMENT; 02853000 IF NOT FILETOG THEN 02854000 IF EOSTOG THEN 02855000 BEGIN 02856000 NEXT ~ 0; 02857000 IF T = "; " THEN GO TO CASESTMT; 02858000 CHECKRESERVED; 02859000 IF NEXT > 0 THEN GO TO XIT; 02860000 END; 02861000 IF (IDINFO~TIPE[T.[12:6]])>0 THEN 02862000 BEGIN 02862100 BK: NEXT~ID ; 02862200 IF NOT FILETOG THEN 02862300 IF SCANENTER~((FNEXT~SEARCH(T))=0) THEN FNEXT~ENTER(IDINFO,T) 02862400 ELSE IF GET(FNEXT).CLASS=DUMMY THEN FNEXT~GET(FNEXT+2).BASE ; 02862500 GO XIT ; 02862600 END ; 02862700 GO CASEL[-IDINFO]; % SEE INITIALIZATION OF "TIPE". LINE 03433100%993-02862800 L1: %DIGITS %993-02863000 BEGIN NUMTYPE ~ INTYPE; NEXT ~ NUM; XTA ~ ACR0; 02864000 FNEXT ~ DBLOW ~ C1 ~ 0; 02865000 XTA ~ CONVERT(FNEXT,C1,XTA ,TS); 02866000 WHILE TS { 9 DO 02867000 BEGIN 02868000 XTA ~ CONVERT(F1,C1,XTA ,TS); 02869000 IF (F2 ~ FNEXT|TEN[C1]+F1) { MAX 02870000 THEN FNEXT ~ F2 02871000 ELSE BEGIN 02872000 NUMTYPE ~ DOUBTYPE; 02873000 DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|, 02874000 F1,0,+,~,FNEXT,DBLOW); 02875000 END; 02876000 END; 02877000 IF CHAR = ". " OR CHAR = "E " OR CHAR = "D " THEN 02878000 CHECKPERIOD 02879000 ELSE IF CHAR = "H " THEN HOLLERITH; 02883000 GO TO XIT; 02884000 END; 02885000 L2: % > %993- 02898100 BEGIN PREC ~ 4; OP ~ 7; GO TO XIT END; 02899000 L3: % } %993- 02899100 BEGIN PREC ~ 4; OP ~ 8; GO TO XIT END; 02900000 L4: % & OR + %993- 02900100 BEGIN PREC ~ 5; OP ~ 10; NEXT ~ PLUS; GO TO XIT END; 02901000 L5: % . %993- 02910100 BEGIN 02911000 FNEXT ~ DBLOW ~ C1 ~ 0; NUMTYPE ~ REALTYPE; 02912000 CHECKPERIOD; 02913000 T ~ EXACCUM[1]; 02914000 IF SCN = 12 THEN 02915000 BEGIN SCN ~ 1; 02916000 IF N ~ EXACCUM[2] { 1 THEN 02917000 BEGIN 02918000 NEXT ~ NUM; FNEXT ~ N; 02919000 NUMTYPE ~ LOGTYPE; GO TO XIT; 02920000 END; 02921000 NEXT ~ 0; 02922000 OP ~ N-1; 02923000 PREC ~ IF N { 4 THEN N-1 ELSE 4; 02924000 GO TO XIT; 02924100 END; 02925000 IF NEXT ! NUM THEN BEGIN NEXT ~ NUM; XTA ~ T; FLOG(141) END; 02925100 GO TO XIT; 02926000 END; 02927000 L6: % % OR ( %993-02929100 BEGIN NEXT ~ LPAREN; GO TO XIT END; 02930000 L7: % < %993-02930100 BEGIN PREC ~ OP ~ 4; GO TO XIT END; 02931000 L8: % LETTER 0 %993-02938100 BEGIN IF DATATOG THEN IF CHECKOCTAL THEN GO TO XIT; 02939000 IDINFO~TIPE[12]; GO BK ; 02939100 END; 02939200 L9: % $ %993-02942100 BEGIN NEXT ~ DOLLAR; GO TO XIT END; 02943000 L10: % * %993-02943100 IF CHECKEXP(NCR, NCR, T) THEN 02944000 BEGIN PREC ~ 9; OP ~ 15; NEXT ~ UPARROW; GO TO XIT END ELSE 02945000 L11: 02945100 BEGIN PREC ~ 7; OP ~ 13; NEXT ~ STAR; GO TO XIT END; 02946000 L12: % - %993-02946100 BEGIN PREC ~ 5; OP ~ 11; NEXT ~ MINUS; GO TO XIT END; 02947000 L13: % ) OR [ %993-02947100 BEGIN NEXT ~ RPAREN; GO TO XIT END; 02948000 L14: % ; %993-02948100 BEGIN NEXT ~ SEMI; GO TO XIT END; 02949000 L15: % { %993-02949100 BEGIN PREC ~ 4; OP ~ 5; GO TO XIT END; 02950000 L16: % / %993-02951100 BEGIN PREC ~ 7; OP ~ 14; NEXT ~ SLASH; GO TO XIT END; 02952000 L17: % , %993-02960100 BEGIN NEXT ~ COMMA; GO TO XIT END; 02961000 L18: % ! %993-02962100 BEGIN PREC ~ 4; OP ~ 9; GO TO XIT END; 02963000 L19: % = OR ~ OR # %993- 02963100 BEGIN NEXT ~ EQUAL; GO TO XIT END; 02964000 L20: % ] %993-02964100 BEGIN XTA ~ T; FLAG(0); GO TO CASESTMT END; 02965000 L21: % " OR : OR @ %993-02965100 BEGIN QUOTESTRING; GO TO XIT END; 02966000 XIT: 02971000 IF DEBUGTOG THEN WRITALIST(FD,3,NEXT,T," ",0,0,0,0,0) ; 02972000 02973000 XTA ~ NAME ~ T; 02974000 END SCAN; 02975000 PROCEDURE WRAPUP; 02976000 COMMENT WRAPUP OF COMPILIATION; 02977000 BEGIN 02978000 ARRAY PRT[0:7,0:127], 02979000 SEGDICT[0:7,0:127], 02980000 SEG0[0:29]; 02981000 ARRAY FILES[0:BIGGESTFILENB]; 02982000 INTEGER THEBIGGEST; 02983000 SAVE ARRAY FPB[0:1022]; % FILE PARAMETER BLOCK 02984000 REAL FPS,FPE; % START AND END OF FPB 02985000 REAL GSEG,PRI,FID,MFID,IDNM,FILTYP,FPBI; 02986000 BOOLEAN ALF; 02987000 REAL PRTADR, SEGMNT, LNK, TSEGSZ, T1, I, FPBSZ; 02988000 DEFINE 02988900 SPDEUN= FPBSZ#, 02988910 ENDDEF=#; 02988990 ARRAY INTLOC[0:150]; 02989000 REAL J; 02990000 FORMAT SEGUS(A6, " IS SEGMENT ", I4, 02991000 ", PRT IS ", A4, "."); 02992000 LIST SEGLS(IDNM,NXAVIL,T1); 02993000 LABEL LA, ENDWRAPUP; 02997000 LABEL QQQDISKDEFAULT; %503-02997010 COMMENT FORMAT OF SEGMENT DICTIONARY -RUN TIME ; 02998000 DEFINE SGTYPF= [1:2]#, %0 = PROGRAM SEGMENTS 02999000 SGTYPC= 1:46:2#,%1 = MCP INTRINSIC 03000000 %2 = DATA SEGMENT 03001000 PRTLINKF= [8:10]#, % LINK TO FIRT PRT ENTRY 03002000 PRTLINKC= 8:38:10#, 03003000 SGLCF = [18:15]#, % SEGMENT SIZE 03004000 SGLCC = 23:38:10#, 03005000 DKADRF = [33:15]#, % RELATIVE DISK ADDRESS OF SEGMENT 03006000 % OR MCP INTRINSIC NUMBER 03007000 DKADRC = 33:13:15#; 03008000 COMMENT FORMAT OF FIRST SEGMENT OF CODE FILE- RUN TIME; 03009000 COMMENT SEGO[0:29] 03010000 WORD CONTENTS 03011000 0 LOCATION OF SEGMENT DICTIONARY 03012000 1 SIZE OF SEGMENT DICTIONARY 03013000 2 LOCATION OF PRT 03014000 3 SIZE OF PRT 03015000 4 LOCATION OF FILE PARAMETER BLOCK 03016000 5 SIZE OF FILE PARAMETER BLOCK 03017000 6 STARTING SEGMENT NUMBER 03018000 7-[2:1] IND FORTRAN FAULT DEC 03018100 7-[18:15] NUMBER OF FILES 03019000 7-[33:15] CORE REQUIRED/64 03020000 ; 03021000 COMMENT FORMAT OF PRT; 03022000 % FLGF = [0:4] = 1101 = SET BY STREAM 03023000 DEFINE MODEF =[4:2]#, % 0 = THUNK 03024000 MODEC=4:46:2#, % 1 = WORD MODE PROGRAM DESCRIPTOR 03025000 % 2 = LABEL DESCRIPTOR 03026000 % 3 = CHARACTER MODE PROGRAM DESCRIPTOR 03027000 STOPF =[6:1]#, % STOPPER = 1 FOR LAST DESCRIPTOR IN 03028000 STOPC=6:47:1#, % CHAIN OF SAME SEGMENT DESCRIPTORS 03029000 LINKF =[7:11]#, % IF STOP = 0 THEN PRTLINK 03030000 LINKC=7:37:11#, % ELSE LINK TO SEGDICT 03031000 FFF =[18:15]#,% INDEX INTO SEGMENT DICTIONARY 03032000 FFC =18:33:15#, 03033000 SINX = [33:15]#;% RELATIVE ADDRESS INTO SEGMENT 03034000 DEFINE PDR = [37:5]#, 03035000 PDC = [42:6]#; 03036000 REAL STREAM PROCEDURE MKABS(F); 03037000 BEGIN 03038000 SI ~ F; MKABS ~ SI; 03039000 END MKABS; 03040000 REAL STREAM PROCEDURE BUILDFPB(DEST,FILNUM,FILTYP,MFID,FID,IDSZ, 03041000 IDNM,SPDEUN); 03042000 VALUE DEST,IDSZ,SPDEUN; 03043000 BEGIN 03044000 DI ~ DEST; 03045000 SI ~ FILNUM; SI ~ SI + 6; DS ~ 2 CHR; 03046000 SI ~ FILTYP; SI ~ SI + 7; DS ~ CHR; 03047000 SI ~ MFID; SI ~ SI + 1; DS ~ 7 CHR; 03048000 SI ~ FID; SI ~ SI + 1; DS ~ 7 CHR; 03049000 SI ~ LOC IDSZ; SI ~ SI + 7; DS ~ CHR; 03050000 SI ~ IDNM; SI ~ SI + 1; DS ~ IDSZ CHR; 03051000 SI~LOC SPDEUN;SI~SI+6;DS~2 CHR;% DISK SPEED & EU NUMBER+1 03051200 BUILDFPB ~ DI; 03052000 DS ~ 2 LIT "0"; 03053000 END BUILDFPB; 03054000 REAL STREAM PROCEDURE GITSZ(F); 03055000 BEGIN 03056000 SI ~ F; SI ~SI + 7; TALLY ~ 7; 03057000 3(IF SC ! " " THEN JUMP OUT; 03058000 SI ~SI - 1; TALLY ~ TALLY + 63;); 03059000 GITSZ ~ TALLY; 03060000 END GITSZ; 03061000 STREAM PROCEDURE MOVE(F,T,SZ); VALUE SZ; 03062000 BEGIN 03063000 SI ~ F; DI ~T; DS ~ SZ WDS; 03064000 END MOVE; 03065000 INTEGER PROCEDURE MOVEANDBLOCK(FROM,SIZE); VALUE SIZE; 03066000 ARRAY FROM[0,0]; INTEGER SIZE; 03067000 BEGIN 03068000 REAL T,NSEGS,J,I; 03069000 STREAM PROCEDURE M2(F,T); BEGIN SI~F; DI~T; DS ~ 2 WDS; END M2; 03070000 NSEGS ~ (SIZE+29) DIV 30; 03071000 IF DALOC DIV CHUNK < T ~ (DALOC + NSEGS) DIV CHUNK 03072000 THEN DALOC ~ CHUNK | T; 03073000 MOVEANDBLOCK ~ DALOC; 03074000 DO BEGIN FOR J ~ 0 STEP 2 WHILE J < 30 AND I 0 THEN 03106100 BEGIN T1 ~ GET(T ~ GLOBALSEARCH(".SUBAR")+2); 03106125 PUT(T,T1~T1&SAVESUBS[TOSIZE]); 03106150 END; 03106175 T1~PRGDESCBLDR(1,23,0,NSEG~NXAVIL~NXAVIL+1) ; % BUILD TPAR 03106200 FILL LSTT[*] WITH 21(0),8(" ") ; % R+23 03106205 WRITEDATA(29,NXAVIL,LSTT) ; 03106210 PDPRT[(PDINX-1).[37:5],(PDINX-1).[42:6]].[6:1]~1 ; % SAVE BIT 03106215 T1 ~ PRGDESCBLDR(1,22,0,NSEG ~ NXAVIL ~ NXAVIL + 1); 03107000 WRITEDATA (138,NXAVIL,TEN); % POWERS OF TEN TABLE 03108000 IF LSTI > 0 THEN 03109000 BEGIN 03110000 WRITEDATA(LSTI, NXAVIL ~ NXAVIL+1, LSTP); 03111000 LSTA ~ PRGDESCBLDR(1, LSTA, 0, NXAVIL); 03112000 END; 03113000 IF TWODPRTX ! 0 THEN 03114000 BEGIN 03115000 FILL LSTT[*] WITH 03116000 OCT0000000421410010, 03117000 OCT0301001301412025, 03118000 OCT2021010442215055, 03119000 OCT2245400320211025, 03120000 OCT0106177404310415, 03121000 OCT1025042112350000; 03122000 T ~ PRGDESCBLDR(0, TWODPRTX, 0, NXAVIL ~ NXAVIL+1); 03123000 WRITEDATA(-6, NXAVIL, LSTT); 03124000 END; 03125000 COMMENT DECLARE GLOBAL FILES AND ARRAYS; 03126000 FPS ~ FPE ~ MKABS(FPB); 03127000 SEGMENTSTART; 03128000 F2TOG ~ TRUE; 03129000 GSEG ~ NSEG; 03130000 FPBI ~ 0; 03131000 EMITL(0); EMITL(2); EMITO(SSF); 03132000 EMITL(1); % SET BLOCK COUNTER TO 1 03133000 EMITL(16); EMITO(STD); 03134000 EMITL(0); EMITOPDCLIT(23); EMITO(DEL); 03138000 EMITL(REAL(HOLTOG)); EMITPAIR(21,STD); 03139000 I ~ GLOBALNEXTINFO; WHILE I < 4093 DO 03140000 BEGIN 03141000 I ~ I+3; 03142000 GETALL(I,INFA,INFB,INFC); 03143000 IF INFA.CLASS = FILEID THEN %SEE COMMENTS ON LINE 02118000 %992-03144000 BEGIN 03145000 FPBI ~ FPBI + 1; 03146000 PRI ~ INFA .ADDR; 03147000 IF (XTA ~ INFB ).[18:6] < 10 THEN 03148000 BEGIN 03149000 IF XTA ~ MAKEINT(XTA) > BIGGESTFILENB THEN FLAG(77) ELSE 03150000 FILES[XTA] ~ PRI; 03151000 IF XTA > THEBIGGEST THEN THEBIGGEST ~ XTA; 03152000 END; 03153000 EMITO(MKS); 03154000 IF J ~ INFC .ADINFO ! 0 THEN % OPTION FILE 03155000 BEGIN FILTYP ~ INFC .LINK; 03156000 IDNM ~ " "&"FILE"[6:24:24]&INFB[30:18:18]; 03157000 T1 ~ GITSZ(IDNM); 03158000 FID ~ FILEINFO[2,J]; 03159000 MFID ~ FILEINFO[1,J]; 03160000 IF FILTYP}10 AND (T~FILEINFO[3,J].DKAREASZ)!0 THEN 03161000 BEGIN %%% SET UP ; 03162000 SPDEUN~FILEINFO[3,J].SENSPDEUNF; 03162005 B~IF (B~((J~FILEINFO[0,J]).[18:12])/(IF A~J.[30:12]{0 THEN03162007 1 ELSE A)){0 THEN 1 ELSE B ; 03162014 %%% B=ORIGINAL "BLOCKING" SIZE = # LOGRECS/PHYSREC. 03162020 A~ENTIER(B|ENTIER(T/(20|B)+.999999999)+.5) ; 03162030 %%% T="AREA" SIZE = # LOGRECS IN TOTAL FILE. 03162040 %%% A=# LOGRECS PER ROW. 03162050 B~ENTIER(T/A+.999999999) ; 03162060 %%% B = # ROWS IN FILE. 03162070 %%% EQUIVALENT ALGOL FILE DESCRIPTION = [B:A]. 03162080 %%% THE ABOVE LOGIC YIELDS: SHORTEST ROW CONTAINING 03162090 %%% AN INTEGER NUMBER OF PHYSICAL RECORDS AND WHICH 03162100 %%% REQUIRES 20 OR FEWER ROWS FOR THE TOTAL AREA, T.03162110 EMITNUM(B); EMITNUM(A) ; 03162120 END ELSE 03162129 BEGIN EMITL(0); EMITL(0); 03163000 J ~ FILEINFO[0,J]; % THIS ONE HAS ALL THE GOODIES 03164000 END; 03164010 QQQDISKDEFAULT: %503-03164045 ESTIMATE~ESTIMATE+(J.[42:6])|(IF A~J.[18:12]=0 THEN J.[30:12] 03164050 ELSE A) ; 03164100 EMITL(J.[4:2]); % LOCK 03165000 EMITL(FPBI); % FILE PARAM INDEX 03166000 03167000 EMITDESCLIT(PRI); % PRT OF FILE 03168000 EMITL(J.[42:6]); % # BUFFERS 03169000 EMITL(J.[3:1]); % RECORDING MODE 03170000 EMITNUM(J.[30:12]) ; % RECORD SIZE 03171000 EMITNUM(J.[18:12]) ; % BLOCK SIZE 03172000 EMITNUM(J.[ 6:12]) ; % SAVE FACTOR 03173000 END ELSE 03174000 BEGIN 03175000 ALF ~TRUE; 03176000 IF(FILTYP~INFC.LINK=2 OR FILTYP=12)AND INFB.[18:6]{9 THEN 03177000 IDNM ~ 0&"FILE"[6:24:24]&INFB[30:18:18] 03178000 ELSE 03179000 BEGIN 03180000 ALF ~ FALSE; 03181000 IF (IDNM ~ " "&INFB[6:18:30]) = "READR " THEN 03182000 IDNM ~ "READER "; 03183000 END; 03184000 IF IDNM="READER " OR IDNM="FILE5 " THEN IDNM~"CARD " ELSE %503-03184010 IF IDNM="FILE6 " THEN BEGIN IDNM~"PRINTER";FILTYP~18;END ELSE %503-03184020 BEGIN %503-03184030 EMITL(20); EMITL(600); FILTYP~12; %20 | 600 REC DISK %503-03184040 J~0&2[42:42:6]&10[30:36:12]&300[18:36:12]; %503-03184050 FID~IDNM; MFID~"FORTEMP"; T1~GITSZ(IDNM); %503-03184054 GO TO QQQDISKDEFAULT; %503-03184060 END; %503-03184070 T1 ~ GITSZ(IDNM); 03185000 FID ~ IDNM; 03186000 MFID ~ 0; 03187000 IF DCINPUT AND ALF THEN BEGIN 03187100 EMITL(20); % DISK ROWS 03187200 EMITL(100); % DISK RECORD PER ROW 03187300 EMITL(2); % REWIND AND LOCK 03187400 EMITL(FPBI); % FILE NUMBER 03187450 EMITDESCLIT(PRI); % PRT OF FILE 03187500 EMITL(2); % NUMBER OF BUFFERS 03187550 EMITL(1); % RECORDING MODE 03187600 EMITL(10); % RECORD SIZE 03187650 EMITL(30); % BLOCK SIZE 03187700 EMITL(1); % SAVE FACTOR 03187750 END ELSE 03187800 BEGIN 03187900 EMITL(0); % DISK ROWS 03188000 EMITL(0); % DISK RECORDS PER ROW 03189000 EMITL(0); % REWIND & RELEASE 03190000 EMITL(FPBI); % FILE NUMBER 03191000 03192000 EMITDESCLIT(PRI); % PRT OF FILE 03193000 EMITL(2); % 2 BUFFERS 03194000 EMITL(REAL(ALF)); 03195000 EMITL(IF FILTYP = 0 THEN 10 ELSE 17); 03196000 EMITL(0); % 15 WORD BUFFERS 03197000 EMITL(0); % SAVE FACTOR (SCRATCH BY DEFAULT) 03198000 END; 03198500 END; 03199000 EMITL(11); % INPUT OR OUTPUT 03200000 EMITL(8); % SWITCH CODE FOR BLOCK 03201000 EMITOPDCLIT(5); % CALL BLOCK 03202000 FPE~BUILDFPB(FPE,FPBI,FILTYP,MFID,FID,T1,IDNM,SPDEUN); 03203000 IF PRTOG THEN WRITALIST(FILEF,3,IDNM.[6:6],IDNM,B2D(PRI), 03204000 0,0,0,0,0) ; 03204010 END 03205000 ELSE 03206000 IF INFA.CLASS = BLOCKID THEN 03207000 BEGIN 03208000 IF PRTOG THEN WRITALIST(BLOKF,3,INFB,B2D(INFA.ADDR), 03209000 INFC.SIZE,0,0,0,0,0) ; 03210000 IF INFA < 0 THEN ARRAYDEC(I); 03211000 END; 03212000 IF (T1 ~ INFA .CLASS) } FUNID 03213000 AND T1 { SUBRID THEN 03214000 BEGIN 03215000 PRI ~ 0; 03216000 IF INFA .SEGNO = 0 THEN 03217000 BEGIN 03218000 A~0; B~NUMINTM1 ; 03219000 WHILE A+1 < B DO 03220000 BEGIN 03221000 PRI ~ REAL(BOOLEAN(A+B) AND BOOLEAN(1022)); 03222000 IF IDNM ~ INT[PRI] = INFB THEN GO TO FOUND; 03223000 IF INFB < IDNM THEN B ~ PRI.[36:11] ELSE A ~ PRI.[36:11]; 03224000 END; 03225000 IF IDNM ~ INT[PRI~(A+B)|2-PRI] = INFB THEN GO TO FOUND; 03226000 XTA ~ INFB; FLAG(30); 03227000 GO TO LA; 03228000 FOUND: 03229000 IF (T1~INT[PRI+1].INTPARMS)!0 03230000 AND INFC < 0 03231000 THEN IF T1 ! INFC.NEXTRA THEN 03232000 BEGIN XTA ~ INFB ; FLAG(28); END; 03233000 IF (FID~INTLOC[MFID~INT[PRI+1].INTNUM])=0 THEN 03234000 BEGIN 03235000 PDPRT[PDIR,PDIC] ~ 03236000 0&1[STYPC] 03237000 &MFID[DKAC] 03238000 &(FID ~ INTLOC[MFID] ~ NXAVIL ~ NXAVIL + 1)[SGNOC] 03239000 &1[SEGSZC]; 03240000 PDINX ~ PDINX + 1; 03241000 END; 03242000 T1 ~ PRGDESCBLDR(1,INFA .ADDR,0,FID); 03243000 IF PRTOG THEN WRITALIST(SEGUS,3,IDNM,FID,B2D(T1),0,0,0,0,0) ; 03244000 IF INT[PRI+1] < 0 THEN 03245000 BEGIN 03246000 T1 ~ PRGDESCBLDR(1,INT[PRI+1].INTPRT,0,FID); 03247000 INT[PRI+1] ~ ABS(INT[PRI + 1]); 03248000 END; 03249000 END 03250000 ELSE IF PRTOG THEN WRITALIST(SEGUS,3,INFB, 03251000 INFA.SEGNO,B2D(INFA.ADDR),0,0,0,0,0) ; 03252000 END; 03253000 LA: 03254000 END; 03255000 COMMENT MUST FOLLOW THE FOR STATEMENT; 03256000 IF FILEARRAYPRT ! 0 THEN 03257000 BEGIN % BUILDING OBJECT TIME FILE SEARCH ARRAY 03258000 J ~ PRGDESCBLDR(1,FILEARRAYPRT,0,NXAVIL ~ NXAVIL + 1); 03259000 WRITEDATA(THEBIGGEST + 1,NXAVIL,FILES); 03260000 END; 03261000 XTA ~ BLANKS; 03262000 IF NXAVIL > 1023 THEN FLAG(45); 03263000 IF PRTS > 1023 THEN FLAG(46); 03264000 IF STRTSEG = 0 THEN FLAG(65); 03265000 PRI ~ 0; 03266000 WHILE (IDNM ~ INT[PRI]) ! 0 DO 03267000 IF INT[PRI+1] } 0 THEN PRI ~ PRI + 2 ELSE 03268000 BEGIN 03269000 IF (FID~INTLOC[MFID~INT[PRI+1].INTNUM])=0 THEN 03270000 BEGIN 03271000 PDPRT[PDIR,PDIC] ~ 03272000 0&1[STYPC] 03273000 &MFID[DKAC] 03274000 &(FID ~ INTLOC[MFID] ~ NXAVIL ~ NXAVIL + 1)[SGNOC] 03275000 &1[SEGSZC]; 03276000 PDINX ~ PDINX + 1; 03277000 END; 03278000 T1 ~ PRGDESCBLDR(1,INT[PRI + 1].INTPRT,0,FID); 03279000 PRI ~ PRI+2; 03280000 END; 03281000 FOR I ~ 1 STEP 1 UNTIL BDX DO 03282000 BEGIN EMITO(MKS); EMITOPDCLIT(BDPRT[I]) END; 03283000 EMITO(MKS); 03284000 EMITOPDCLIT(STRTSEG.[18:15]); 03285000 T ~ PRGDESCBLDR(1,0,0,NSEG); 03288000 SEGMENT((ADR+4) DIV 4,NSEG,FALSE,EDOC); 03289000 IF ERRORCT ! 0 THEN GO TO ENDWRAPUP; 03290000 FILL SEG0[*] WITH 03291000 OCT020005, % BLOCK 03292000 OCT220014, % WRITE 03293000 OCT230015, % READ 03294000 OCT240016; % FILE CONTROL 03295000 COMMENT INTRINSIC FUNCTIONS; 03296000 FOR I ~ 0 STEP 1 UNTIL 3 DO 03297000 BEGIN 03298000 T1 ~ PRGDESCBLDR(1,SEG0[I].[36:12],0, 03299000 NSEG ~ NXAVIL ~ NXAVIL + 1); 03300000 PDPRT[PDIR,PDIC] ~ 03301000 0&1[STYPC] 03302000 &(SEG0[I].[30:6])[DKAC] 03303000 &NXAVIL[SGNOC] 03304000 &1[SEGSZC]; 03305000 PDINX ~ PDINX + 1; 03306000 END; 03307000 COMMENT GENERATE PRT AND SEGMENT DICTIONARY; 03308000 PRT[0,41] ~ PDPRT[0,0] & 63[10:42:6]; % USED FOR FAULT OPTN 03308100 FOR I ~ 1 STEP 1 UNTIL PDINX-1 DO 03309000 IF (T1~PDPRT[I.PDR,I.PDC]).SEGSZF = 0 THEN 03310000 BEGIN % PRT ENTRY 03311000 PRTADR ~T1.PRTAF; 03312000 SEGMNT ~T1.SGNOF; 03313000 LNK ~ SEGDICT[SEGMNT.[36:5], SEGMNT.[41:7]].PRTAF; 03314000 MDESC(T1.RELADF&SEGMNT[FFC] 03315000 &(REAL(LNK=0))[STOPC] 03316000 &(IF LNK=0 THEN SEGMNT ELSE LNK)[LINKC] 03317000 &(T1.DTYPF)[MODEC] 03318000 &5[1:45:3], 03319000 PRT[PRTADR.[36:5],PRTADR.[41:7]]); 03320000 SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]].PRTLINKF ~ PRTADR; 03321000 END 03322000 ELSE 03323000 BEGIN % SEGMENT DICTIONARY ENTRY 03324000 SEGMNT ~ T1.SGNOF; 03325000 SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]]~ 03326000 SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]] 03327000 &T1[SGLCC] 03328000 &T1[DKADRC] 03329000 & T1[4:12:1] 03329100 &T1[6:6:1] 03329200 &T1[1:1:2]; 03330000 TSEGSZ ~ TSEGSZ + T1.SEGSZF; 03331000 END; 03332000 COMMENT WRITE OUT FILE PARAMETER BLOCK; 03333000 FPBSZ ~ ((FPE.[33:15] - FPS) | 8 + FPE.[30:3] + 9) DIV 8; 03334000 I ~ (FPBSZ + 29) DIV 30; 03335000 IF DALOC DIV CHUNK < T1 ~ (DALOC +I) DIV CHUNK 03336000 THEN DALOC ~ CHUNK | T1; 03337000 SEG0[4] ~ DALOC; 03338000 SEG0[5] ~ FPBSZ; 03339000 SEG0[5].FPBVERSF~FPBVERSION; 03340000 FOR I ~ 0 STEP 30 WHILE I < FPBSZ DO 03341000 BEGIN 03342000 MOVE(FPB[I],CODE(0),IF (FPBSZ-I) } 30 03343000 THEN 30 ELSE (FPBSZ-I)); 03344000 WRITE(CODE[DALOC]); 03345000 DALOC ~ DALOC + 1; 03346000 END; 03347000 SEG0[2] ~ MOVEANDBLOCK(PRT,PRTS+1); % WRITES OUT PRT 03348000 % SAVES ADDRESS OF PRT 03349000 SEG0[3] ~ PRTS + 1; % SIZE OF PRT 03350000 SEG0[0] ~ MOVEANDBLOCK(SEGDICT,NXAVIL + 1); % WRITE SEG DICT 03351000 SEG0[1] ~ NXAVIL + 1; % SIZE OF SEGMENT DICTIONARY 03352000 SEG0[6] ~ -GSEG; % FIRST SEGMENT TO EXECUTE 03353000 SEG0[7].[33:15] ~ FPBI; % NUMBER OF FILES 03354000 SEG0[7].[18:15] ~ ESTIMATE ~ IF % CORE ESTIMATE 03355000 ( I ~ 03356000 ESTIMATE+60+ %%% OPTION FILE BUFF SIZES + DEFAULT BUFF SIZES.03356100 PRTS + 512 % PRT AND STACK SIZE 03357000 +TSEGSZ % TOTAL SIZE OF CODE 03358050 + 1022 % FOR INTRINSICS 03358050 +ARYSZ % TOTAL ARRAY SIZE 03359000 + (MAXFILES | 28) % SIZE OF ALL FIBS 03360000 +FPBSZ % SIZE OF FILE PARAMETER BLOCK 03361000 + (IF ESTIMATE = 0 THEN 0 ELSE (ESTIMATE + 1000)) 03361100 + (NXAVIL + 1) % SIZE OF SEGMENT DICTIONARY 03362000 ) > 32768 THEN 510 ELSE (I DIV 64); 03363000 COMMENT IF SEGSW THEN UPDATE LINDICT, SEG0[0] & WRITE IT ; 03363100 SEG0[7].[2:1] ~ 1; % USED FOR FORTRAN FAULT DEC; 03363150 IF SEGSW THEN 03363200 BEGIN 03363300 FOR I ~ NXAVIL + 1 STEP -1 UNTIL 1 DO 03363400 IF LINEDICT[I.IR,I.IC] = 0 THEN % INDICATE NO LINE SEGMENT 03363500 LINEDICT[I.IR,I.IC] ~ -1; % FOR THIS SEGMENT 03363600 SEG0[0] ~ SEG0[0] & (MOVEANDBLOCK(LINEDICT,NXAVIL+1))[TOBASE]; 03363700 END; 03363800 WRITE(CODE[0],30,SEG0[*]); 03364000 IF ERRORCT = 0 AND SAVETIME } 0 THEN LOCK(CODE); 03365000 ENDWRAPUP: 03366000 LOCK(TAPE); %RW/L TAPE FILE OR LOCK DISK %502-03366100 IF NTAPTOG THEN LOCK(NEWTAPE,*); %RW/L TAPE OR CRUNCH DISK%502-03366200 END WRAPUP; 03367000 PROCEDURE INITIALIZATION; 03368000 BEGIN COMMENT INITIALIZATION; 03369000 ALPHA STREAM PROCEDURE MKABS(P); 03370000 BEGIN SI ~ P; MKABS ~ SI END; 03371000 STREAM PROCEDURE BLANKOUT(CRD, N); VALUE N; 03372000 BEGIN DI ~ CRD; N(DS ~ LIT " ") END; 03373000 BLANKOUT(CRD[10], 40); 03374000 BLANKOUT(LASTSEQ, 8); 03374100 BLANKOUT(LASTERR,8) ; 03374200 INITIALNCR ~ MKABS(CRD[0])&6[30:45:3]; 03375000 CHR0 ~ MKABS(ACCUM[0])& 2[30:45:3]; 03376000 ACR0 ~ CHR0+1; 03377000 ACR1 ~ (CHR1~MKABS(EXACCUM[0]) & 2[30:45:3]) +1; 03378000 ACCUMSTOP~MKABS(ACCUM[11]); EXACCUMSTOP~MKABS(EXACCUM[11]) ; 03378100 BUFL ~ MKABS(BUFF) & 2[30:45:3]; 03379000 NEXTCARD ~ 1; 03380000 GLOBALNEXTINFO ~ 4093; 03381000 PDINX ~ 1; 03381100 LASTNEXT~1000 ; 03381200 PRTS ~ 41; % CURRENTLY . . . . . LAST USED PRT 03382000 READ(CR, 10, CB[*]); 03383000 LISTOG~TRUE; SINGLETOG~TRUE; CHECKTOG ~ FALSE; %DEFAULT %501- 03384000 FIRSTCALL ~ TRUE; 03385000 IF BOOLEAN(ERRORCT.[46:1]) THEN LISTOG ~ FALSE; 03385100 IF BOOLEAN(ERRORCT.[47:1]) THEN DCINPUT ~ TRUE; 03385200 ERRORCT ~ 0; 03385300 IF DCINPUT THEN SEGSW ~ TRUE; 03385350 IF DCINPUT THEN REMOTETOG ~ TRUE; 03385355 LIMIT~IF DCINPUT THEN 20 ELSE 100 ; 03385360 IF SEGSW THEN SEGSWFIXED ~ TRUE; 03385400 EXTRAINFO[0,0] ~ 0 & EXPCLASS[TOCLASS]; 03386000 NEXTEXTRA ~ 1; 03387000 LASTMODE ~ 1; 03387100 DALOC ~ 1; 03388000 TYPE ~ -1; 03389000 MAP[0] ~ MAP[2] ~ MAP[4] ~ MAP[7] ~ -10; 03390000 MAP[5] ~ 1; MAP[6] ~ 2; 03391000 FILL XR[*] WITH 0,0,0,0,0,0,0, 03391100 "INTEGE","R R"," "," "," REAL "," ", 03391200 "LOGICA","L L","DOUBLE"," ","COMPLE","X X", 03391300 "------","- -"," "," "," ---- "," ", 03391450 "------","- -","------"," ","------","- -"; 03391450 FILL TYPES[*] WITH " ","INTGER"," ","REAL ", 03392000 "LOGCAL", "DOUBLE", "COMPLX"; 03393000 FILL KLASS[*] WITH 03394000 "NULL ", "ARRAY ", "VARBLE", "STFUN ", 03395000 "NAMLST", "FORMAT", "ERROR ", "FUNCTN", 03396000 "INTRSC", "EXTRNL", "SUBRTN", "COMBLK", 03397000 "FILE "; 03398000 FILL RESERVEDWORDSLP[*] WITH 03399000 "CALL ","ENTR ","FORM ","GOTO ","IF ","READ ", 03400000 "REAL ","WRIT ","DATA ","CLOS ","LOCK ","PURG ","CHAI ", 03401000 "PRIN ","PUNC ", 03401100 0,"Y ","AT ",0,0,0,0,"E ",0,"E ",0,"E ",03401200 "N ","T ","H "; 03401300 FILL RESERVEDWORDS[*] WITH 03402000 "ASSI ","BACK ","BLOC ","CALL ","COMM ","COMP ","CONT ", 03403000 "DATA ","DIME ","DOUB ","END ","ENDF ","ENTR ","EQUI ", 03404000 "EXTE ","FUNC ","GOTO ","INTE ","LOGI ","NAME ","PAUS ", 03405000 "PRIN ","PROG ","PUNC ","READ ","REAL ","RETU ","REWI ", 03406000 "STOP ","SUBR ","WRIT ", 03407000 "CLOS ","LOCK ","PURG ", 03407100 0,0,0, 03407101 "FIXF ","VARY ","AUXM ","RELE ", 03407102 "IMPL ", 03407103 "GN ","SPACE ","KDATA ",0,"ON ","LEX ","INUE ", 03407200 0,"NSION ","LEPRECIS",0,"ILE ","Y ","VALENCE ","RNAL "03407300 ,"TION ",0,"GER ","CAL ","LIST ","E ","T ",03407400 "RAM ","H ",0,0,"RN ","ND ",0,"OUTINE ", 03407500 "E ","E ",0,"E ",0,0,0,"D ","ING ", 03407600 "EM ","ASE " 03407601 ,"ICIT " 03407602 ; 03407990 FILL RESLENGTHLP[*] WITH 03408000 4,5,6,4,2,4,4,5,4,5,4,5,5,5,5; 03409000 FILL LPGLOBAL[*] WITH 03410000 4, 13, 36, 17, 35, 25, 03411000 26, 31, 8, 32, 33, 34, 37, 22, 24; 03411100 FILL RESLENGTH[*] WITH 03412000 0, 9, 9, 4, 6, 03413000 7, 8, 4, 9, 15, 03414000 3, 7, 5, 11, 8, 03415000 8, 4, 7, 7, 8, 03416000 5, 5, 7, 5, 4, 03417000 4, 6, 6, 4, 10, 5, 03418000 5, 4, 5, 0, 0, 0, 5, 7, 6, 7 03418100 ,8 03418101 ; 03418990 FILL WOP[*] WITH 03419000 "LITC"," ", 03420000 "OPDC","DESC", 03421000 10,"DEL ", 11,"NOP ", 12,"XRT ", 16,"ADD ", 17,"AD2 ", 18,"PRL ", 03422000 19,"LNG ", 21,"GEQ ", 22,"BBC ", 24,"INX ", 35,"LOR ", 37,"GTR ", 03423000 38,"BFC ", 39,"RTN ", 40,"COC ", 48,"SUB ", 49,"SB2 ", 64,"MUL ", 03424000 65,"ML2 ", 67,"LND ", 68,"STD ", 69,"NEQ ", 70,"SSN ", 71,"XIT ", 03425000 72,"MKS ", 03426000 128,"DIV ",129,"DV2 ",130,"COM ",131,"LQV ",132,"SND ",133,"XCH ", 03427000 134,"CHS ",167,"RTS ",168,"CDC ",197,"FTC ",260,"LOD ",261,"DUP ", 03428000 278,"GBC ",280,"SSF ",294,"GFC ",322,"ZP1 ",384,"IDV ",453,"FTF ", 03429000 515,"MDS ",532,"ISD ",533,"LEQ ",534,"BBW ",548,"ISN ",549,"LSS ", 03430000 550,"BFW ",581,"EQL ",582,"SSP ",584,"ECM ",709,"CTC ",790,"GBW ", 03431000 806,"GFW ",896,"RDV ",965,"CTF ", 03432000 1023,1023,1023,1023,1023,1023,1023,1023,1023,1023,1023, 1023; 03433000 FILL TIPE[*] WITH 10(-1),-19,-21,OCT300000000,-21,-2,-3,-4, 03433100 8(OCT300000000),OCT100000000,-5,-13,-4,-6,-7,-19,-11, 03433110 5(OCT100000000),-8,3(OCT300000000),-9,-10,-12,-13,-14,03433120 -15,-100,-16,8(OCT300000000),-17,-6,-18,-19,-20,-21 ; 03433130 FILL PERIODWORD[*] WITH 03434000 "FALSE ", "TRUE ", "OR ", "AND ", "NOT ", 03435000 "LT ", "LE ", "EQ ", "GT ", "GE ", "NE "; 03436000 ACCUM[0] ~ EXACCUM[0] ~ "; "; 03437000 INCLUDE := "NCLUDE" & "I"[6:42:6]; 03437100 INSERTDEPTH := -1; 03437110 FILL TEN[*] WITH % POWERS OF TEN TO PRT 22 03438000 OCT1141000000000000, OCT1131200000000000, OCT1121440000000000,03439000 OCT1111750000000000, OCT1102342000000000, OCT1073032400000000,03440000 OCT1063641100000000, OCT1054611320000000, OCT1045753604000000,03441000 OCT1037346545000000, OCT1011124027620000, OCT0001351035564000,03442000 OCT0011643245121000, OCT0022214116345200, OCT0032657142036440,03443000 OCT0043432772446150, OCT0054341571157602, OCT0065432127413542,03444000 OCT0076740555316473, OCT0111053071060221, OCT0121265707274265,03445000 OCT0131543271153342, OCT0142074147406233, OCT0152513201307702,03446000 OCT0163236041571663, OCT0174105452130240, OCT0205126764556310,03447000 OCT0216354561711772, OCT0231004771627437, OCT0241206170175346,03448000 OCT0251447626234640, OCT0261761573704010, OCT0272356132665012,03449000 OCT0303051561442215, OCT0313664115752660, OCT0324641141345435,03450000 OCT0336011371636744, OCT0347413670206535, OCT0361131664625026,03451000 OCT0371360241772234, OCT0401654312370703, OCT0412227375067064,03452000 OCT0422675274304701, OCT0433454553366061, OCT0444367706263475,03453000 OCT0455465667740415, OCT0467003245730520, OCT0501060411731664,03454000 OCT0511274514320241, OCT0521553637404312, OCT0532106607305374,03455000 OCT0542530351166673, OCT0553256443424452, OCT0564132154331565,03456000 OCT0575160607420123, OCT0606414751324147, OCT0621012014361120,03457000 OCT0631214417455344, OCT0641457523370635, OCT0651773450267004,03458000 OCT0662372362344605, OCT0673071057035747, OCT0703707272645341,03459000 OCT0714671151416631, OCT0726047403722377, OCT0737461304707077,03460000 OCT0751137556607071, OCT0761367512350710, OCT0771665435043072,03461000 OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,03462000 OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,03463000 OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,03464000 OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,03465000 OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,03466000 OCT0000000000000000, OCT0000000000000000, OCT0004000000000000,03467000 OCT0001000000000000, OCT0001720000000000, OCT0004304000000000,03468000 OCT0007365000000000, OCT0005262200000000, OCT0004536640000000,03469000 OCT0001666410000000, OCT0000244112000000, OCT0000315134400000,03470000 OCT0000400363500000, OCT0000450046042000, OCT0006562057452400,03471000 OCT0004316473365100, OCT0005402212262320, OCT0006702654737004,03472000 OCT0004463430126605, OCT0007600336154346, OCT0001540425607437,03473000 OCT0004070533151347, OCT0005106662003641, OCT0005033043640461,03474000 OCT0002241654610575, OCT0002712227752734, OCT0001474675745524,03475000 OCT0002014055337051, OCT0004417070626663, OCT0007522706774440,03476000 OCT0003447470573550, OCT0006361406732502, OCT0005005571052122,03477000 OCT0006207127264547, OCT0001650755141700, OCT0006223150372260,03478000 OCT0007670002470733, OCT0007646003207120, OCT0005617404050743,03479000 OCT0001163305063137, OCT0007420166277771, OCT0001732422375777,03480000 OCT0002321127075377, OCT0003005354714677, OCT0005606650100057,03481000 OCT0007150422120072, OCT0003002526544103, OCT0001603254275130,03482000 OCT0004144127354356, OCT0007175155247451, OCT0007034410521363,03483000 OCT0007664351264566, OCT0003641443541723, OCT0004611754472310;03484000 FILL INLINEINT[*] WITH % FILLS MUST BE IN ASCENDING ORDER FOR 03484100 % BINARY SEARCH IN FUNCTION AND DOITINLINE. 03484120 % INLINEINT[I].[1:1] = 1 ONCE CODE FOR INTRINSIC 03484122 % HAS BEEN EMITTED INLINE.03484124 % INLINEINT[I].[2:10]=INDEX INTO 2-ND WORD OF THE03484126 % CORR ENTRY IN INT. 03484128 % INLINEINT[I].[12:36]=NAME OF INTRINSIC. 03484130 %********FIRST FILL MUST BE NUMBER OF INTRINSICS ****************** 03484140 34, 03484160 "00ABS ", 03484180 "00AIMAG ", 03484200 "00AINT ", 03484220 "00AMAX0 ", 03484224 "00AMAX1 ", 03484228 "00AMIN0 ", 03484232 "00AMIN1 ", 03484236 "00AMOD ", 03484240 "00AND ", 03484260 "00CMPLX ", 03484280 "00COMPL ", 03484300 "00CONJG ", 03484320 "00DABS ", 03484340 "00DBLE ", 03484360 "00DIM ", 03484380 "00DSIGN ", 03484400 "00EQUIV ", 03484420 "00FLOAT ", 03484440 "00IABS ", 03484460 "00IDIM ", 03484480 "00IDINT ", 03484500 "00IFIX ", 03484520 "00INT ", 03484540 "00ISIGN ", 03484560 "00MAX0 ", 03484564 "00MAX1 ", 03484568 "00MIN0 ", 03484572 "00MIN1 ", 03484576 "00MOD ", 03484580 "00OR ", 03484600 "00REAL ", 03484620 "00SIGN ", 03484640 "00SNGL ", 03484660 "00TIME ", 03484680 0 ; 03484990 FILL INT [*] WITH 03485000 COMMENT THESE NAMES (1-ST WORD OF EACH TWO-WORD ENTRY) MUST BE IN 03486000 ASCENDING ORDER FOR BINARY LOOKUPS. 03486010 THE SECOND WORD HAS THE FOLLOWING FORMAT: 03486020 .[1:1] = 0 IF THE INTRINSIC DOES NOT HAVE A PERMANENT PRT 03486030 LOCATION, OTHERWISE = 1. MAY BE RESET BY 03486040 WRAPUP. SEE .[18:6] BELOW. 03486050 .[2:1] = .INTSEEN = 1 IFF INTRINSICS FUNCTION HAS BEEN SEEN. 03486055 .[6:3] = .INTCLASS = CLASS OF THE INTRINSIC. 03486060 .[9:3] = .INTPARMCLASS = CLASS OF PARAMETERS. 03486070 .[12:6] = .INTINLINE = INDEX FOR DOITINLINE IF !0, OTHERWISE 03486080 DO IT VIA INTRINSIC CALL. 03486090 .[24:6] = .INTPRT = FIXED PRT LOCATION. SEE .[1:1] ABOVE. 03486100 .[30:6] = .INTPARMS = NUMBER OF PARAMETERS REQUIRED BY THE INT.03486110 .[36:12] = .INTNUM = INTRINSICS NUMBER. 03486120 THE FIELDS .[3:3] AND .[18:6] ARE SO FAR UNUSED. 03486130 ; 03486140 % 03486144 %***********************************************************************03486145 %********* IF YOU ADD AN INTRINSIC, BE SURE TO CHANGE NUMINTM1 *******03486146 %********* AT SEQUENCE NUMBER 00155211.......THANK YOU. *******03486147 %***********************************************************************03486148 % 03486149 "ABS ", OCT0033010000010007, 03487000 "AIMAG ", OCT0036020000010074, 03488000 "AINT ", OCT0033030000010054, 03489000 "ALGAMA", OCT0033000000010127, 03490000 "ALOG10", OCT0033000000010103, 03491000 "ALOG ", OCT2033000035010017, 03492000 "AMAX0 ", OCT0031250000000031, 03493000 "AMAX1 ", OCT0033250000000031, 03494000 "AMIN0 ", OCT0031250000000032, 03495000 "AMIN1 ", OCT0033250000000032, 03496000 "AMOD ", OCT0033040000020063, 03497000 "AND ", OCT0033050000020130, 03498000 "ARCOS ", OCT0033000000010117, 03499000 "ARSIN ", OCT2033000032010116, 03500000 "ATAN2 ", OCT2033000044020114, 03501000 "ATAN ", OCT2033000037010016, 03501500 "CABS ", OCT2036000045010053, 03502000 "CCOS ", OCT0066000000010110, 03503000 "CEXP ", OCT0066000000010100, 03504000 "CLOG ", OCT0066000000010102, 03505000 "CMPLX ", OCT0063060000020075, 03506000 "COMPL ", OCT0033070000010132, 03507000 "CONCAT", OCT0033000000050140, 03508000 "CONJG ", OCT0066110000010076, 03509000 "COSH ", OCT0033000000010121, 03510000 "COS ", OCT0033000000010015, 03511000 "COTAN ", OCT0033000000010112, 03512000 "CSIN ", OCT0066000000010106, 03513000 "CSQRT ", OCT0066000000010124, 03514000 "DABS ", OCT0055010000010052, 03515000 "DATAN2", OCT0055000000020115, 03516000 "DATAN ", OCT2055000041010113, 03517000 "DBLE ", OCT0053120000010062, 03518000 "DCOS ", OCT0055000000010107, 03519000 "DEXP ", OCT2055000047010077, 03520000 "DIM ", OCT0033100000020072, 03521000 "DLOG10", OCT0055000000010104, 03522000 "DLOG ", OCT2055000042010101, 03522500 "DMAX1 ", OCT0055000000000066, 03523000 "DMIN1 ", OCT0055000000000067, 03524000 "DMOD ", OCT2055000046020065, 03525000 "DSIGN ", OCT0055130000020071, 03526000 "DSIN ", OCT2055000043010105, 03527000 "DSQRT ", OCT2055000050010123, 03528000 "EQUIV ", OCT0033140000020133, 03529000 "ERF ", OCT0033000000010125, 03530000 "EXP ", OCT2033000033010020, 03531000 "FLOAT ", OCT0031150000010060, 03532000 "GAMMA ", OCT2033000040010126, 03533000 "IABS ", OCT0011010000010007, 03534000 "IDIM ", OCT0011100000020072, 03535000 "IDINT ", OCT0015240000010057, 03536000 "IFIX ", OCT0013030000010054, 03537000 "INT ", OCT0013030000010054, 03538000 "ISIGN ", OCT0011160000020070, 03539000 ".ERR. ", OCT2000000030000134, 03540000 ".FBINB", OCT0000000000000160, 03540500 ".FINAM", OCT0000000000000154, 03541000 ".FONAM", OCT0000000000000155, 03542000 ".FREFR", OCT0000000000000146, 03543000 ".FREWR", OCT0000000000000153, 03544000 ".FTINT", OCT0000000000000050, 03545000 ".FTNIN", OCT0000000000000156, 03546000 ".FTNOU", OCT0000000000000157, 03547000 ".FTOUT", OCT0000000000000051, 03548000 ".LABEL", OCT0000000000000021, 03549000 ".MATH ", OCT0000000000000055, 03550000 ".MEMHR", OCT0000000000000164, 03550500 ".XTOI ", OCT0000000000000056, 03551000 "MAX0 ", OCT0011250000000135, 03552000 "MAX1 ", OCT0013250000000135, 03553000 "MIN0 ", OCT0011250000000136, 03554000 "MIN1 ", OCT0013250000000136, 03555000 "MOD ", OCT0011170000020137, 03556000 "OR ", OCT0033200000020131, 03557000 "REAL ", OCT0036210000010073, 03558000 "SIGN ", OCT0033160000020070, 03559000 "SINH ", OCT0033000000010120, 03560000 "SIN ", OCT2033000034010014, 03561000 "SNGL ", OCT0035230000010061, 03562000 "SQRT ", OCT2033000031010013, 03563000 "TANH ", OCT0033000000010122, 03563010 "TAN ", OCT2033000036010111, 03563020 "TIME ", OCT0031220000010064, 03563030 0; 03563900 BLANKS~INLINEINT[MAX~0] ; 03563910 FOR SCN~1 STEP 1 UNTIL BLANKS DO 03563920 BEGIN 03563930 EQVID~INLINEINT[SCN]; WHILE INT[MAX]!EQVID DO MAX~MAX+2 ; 03563940 INLINEINT[SCN].INTX~MAX+1 ; 03563950 END ; 03563960 INTID.SUBCLASS ~ INTYPE; 03564000 REALID.SUBCLASS ~ REALTYPE; 03565000 EQVID ~ ".EQ000"; 03566000 LISTID ~ ".LI000"; 03567100 BLANKS ~ " "; 03568000 ENDSEGTOG ~ TRUE; 03569000 SCN ~ 7; 03570000 MAX ~ REAL(NOT FALSE).[9:39]; 03571000 SUPERMAXCOM~128|(MAXCOM+1) ; 03571100 SEGPTOG ~ FALSE; %INHIBIT PAGE SKIP AFTER SUBROUTINES %501- 03571300 END INITIALIZATION; 03572000 ALPHA PROCEDURE NEED(T, C); VALUE T, C; ALPHA T, C; 03573000 BEGIN INTEGER N; REAL ELBAT; 03574000 REAL X; 03574100 LABEL XIT, CHECK; 03575000 ALPHA INFA, INFB, INFC; 03576000 COMMENT NEED RETURNS THE ELBAT WORD FOR THE IDENTIFIER T. 03577000 IF THIS IS THE FIRST OCCURRENCE OF T THEN AN INFO WORD IS BUILT AND 03578000 GIVEN THEN CLASS C; 03579000 ELBAT.CLASS ~ C; 03580000 XTA ~ T; 03581000 IF C { LABELID THEN 03582000 BEGIN 03583000 IF N ~ SEARCH(T) = 0 THEN N ~ ENTER(ELBAT, T) ELSE 03584000 IF ELBAT ~ GET(N).CLASS = UNKNOWN 03585000 THEN PUT(N,GET(N)&C[TOCLASS]) 03586000 ELSE IF ELBAT ! C THEN FLOG(21); 03587000 GO TO XIT; 03588000 END; 03589000 IF N ~ SEARCH(T) = 0 THEN 03590000 BEGIN 03591000 IF N ~ GLOBALSEARCH(T) ! 0 THEN GO TO CHECK; 03592000 N ~ GLOBALENTER(ELBAT, T); 03593000 GO TO XIT; 03594000 END; 03595000 GETALL(N,INFA,INFB,INFC); 03596000 IF INFA.CLASS = DUMMY THEN BEGIN N ~ INFC.BASE; GO TO CHECK END; 03596100 IF BOOLEAN(INFA. FORMAL) THEN GO TO CHECK; 03597000 IF INFA.CLASS ! UNKNOWN THEN 03598000 BEGIN 03599000 IF N ~ GLOBALSEARCH(T) ! 0 THEN GO TO CHECK; 03600000 ELBAT.SUBCLASS ~ INFA.SUBCLASS; 03601000 N ~ GLOBALENTER(ELBAT, T); 03602000 GO TO XIT; 03603000 END; 03604000 PUT(N, INFA & DUMMY[TOCLASS]); 03605000 ELBAT.SUBCLASS ~ INFA .SUBCLASS; 03606000 IF X ~ GLOBALSEARCH(T) = 0 THEN X ~ GLOBALENTER(ELBAT, T); 03607000 PUT(N+2, INFC & X[TOBASE]); N ~ X; 03607100 CHECK: 03608000 INFA ~ GET(N); 03609000 IF ELBAT ~ INFA .CLASS = UNKNOWN THEN 03610000 BEGIN INFO[N.IR,N.IC].CLASS ~ C; GO TO XIT END; 03611000 IF ELBAT ! C THEN 03612000 IF ELBAT = EXTID AND 03613000 (C = SUBRID OR C = FUNID) THEN 03614000 INFO[N.IR,N.IC].CLASS ~ C 03615000 ELSE IF (ELBAT=SUBRID OR ELBAT= FUNID) AND C = EXTID THEN 03616000 ELSE FLOG(21); 03617000 XIT: NEED ~ GETSPACE(N); 03618000 XTA ~ NAME; % RESTORE XTA FOR DIAGNOSTIC PURPOSES 03618100 END NEED; 03619000 INTEGER PROCEDURE EXPR(B); VALUE B; BOOLEAN B; FORWARD; 03620000 PROCEDURE SPLIT(A); VALUE A; REAL A; 03621000 BEGIN 03622000 EMITPAIR(JUNK, ISN); 03623000 EMITD(40, DIA); 03624000 EMITD(18, ISO); 03625000 EMITDESCLIT(A); 03626000 EMITO(LOD); 03627000 EMITOPDCLIT(JUNK); 03628000 EMITPAIR(255,CHS); 03629000 EMITO(LND); 03630000 END SPLIT; 03631000 BOOLEAN PROCEDURE SUBSCRIPTS(LINK,FROM); VALUE LINK,FROM; 03632000 INTEGER LINK, FROM; 03633000 BEGIN INTEGER I, NSUBS, BDLINK; 03634000 LABEL CONSTRUCT, XIT; 03635000 REAL SUM, PROD, BOUND; 03636000 REAL INFA,INFB,INFC; 03637000 REAL SAVENSEG,SAVEADR ; 03637100 INTEGER INDX; 03637200 REAL INFD; 03637300 BOOLEAN TOG, VARF; 03638000 REAL SAVIT; 03639000 DEFINE SS = LSTT#; 03640000 03641000 03642000 IF DEBUGTOG THEN FLAGROUTINE(" SUBSC","RIPTS ",TRUE ) ; 03643000 SAVIT ~ IT; 03644000 LINK ~ GETSPACE(LINK); 03645000 GETALL(LINK,INFA,INFB,INFC); 03646000 IF INFA.CLASS ! ARRAYID THEN 03647000 BEGIN XTA ~ INFB; FLOG(35); GO TO XIT END; 03648000 NSUBS ~ INFC.NEXTRA; 03649000 IF FROM = 4 THEN 03649100 BEGIN IF NSUBS GTR SAVESUBS THEN SAVESUBS ~ NSUBS; 03649200 IF NSUBS GTR NAMLIST[0] THEN NAMLIST[0] ~ NSUBS; 03649230 NAMLIST[NAMEIND].[1:8] ~ NSUBS; 03649250 INFD ~ GET(NEED(".SUBAR",BLOCKID)).ADDR; 03649300 END; 03649400 BDLINK ~ INFC.ADINFO-NSUBS+1; 03650000 VARF ~ INFC < 0; 03651000 FOR I ~ 1 STEP 1 UNTIL NSUBS DO 03652000 BEGIN 03653000 IT~IT+1; SAVENSEG~NSEG; SAVEADR~ADR ; 03654000 IF EXPR(TRUE) > REALTYPE THEN FLAG(98); 03655000 IF ADR=SAVEADR THEN FLAG(36) ; 03655500 IF VARF THEN 03656000 IF EXPRESULT=NUMCLASS AND NSEG=SAVENSEG THEN 03657000 BEGIN 03658000 ADR~SAVEADR ; 03659000 EMITNUM(EXPVALUE-1); 03660000 END ELSE EMITPAIR(1, SUB) 03661000 ELSE 03662000 IF EXPRESULT=NUMCLASS AND NSEG = SAVENSEG AND FROM NEQ 4 THEN 03663000 BEGIN 03664000 ADR~SAVEADR; IF SS[IT]~EXPVALUE{0 THEN FLAG(154) ; 03664100 END 03664200 ELSE SS[IT] ~ @9; 03665000 IF FROM = 4 THEN 03665010 BEGIN IF VARF THEN BEGIN EMITO(DUP); EMITPAIR(1,ADD); END; 03665100 EMITL(INDX); INDX ~ INDX+1; 03665200 EMITDESCLIT(INFD); 03665300 EMITO(IF VARF THEN STD ELSE STN); 03665400 END; 03665500 IF I < NSUBS THEN 03666000 BEGIN 03667000 IF GLOBALNEXT ! COMMA THEN 03668000 BEGIN XTA ~ INFB; FLOG(23) END; 03669000 SCAN; 03670000 END; 03671000 END; 03672000 IF GLOBALNEXT ! RPAREN THEN BEGIN XTA ~ INFB; FLOG(24); END 03673000 ELSE IF FROM < 2 THEN 03673100 BEGIN SCAN; IF PREC > 0 THEN FROM ~ 1; END; 03673200 SUM ~ 0; 03674000 TOG ~ VARF; 03675000 IF VARF THEN 03676000 FOR I ~ NSUBS-1 STEP -1 UNTIL 1 DO 03677000 BEGIN 03678000 IF BOUND ~ EXTRAINFO[(BDLINK~BDLINK+1).IR,BDLINK.IC] < 0 THEN 03679000 EMITOPDCLIT(BOUND) ELSE EMITNUM(BOUND); 03680000 EMITO(MUL); 03681000 EMITO(ADD); 03682000 END 03683000 ELSE 03684000 FOR I ~ NSUBS STEP -1 UNTIL 1 DO 03685000 BEGIN 03686000 IF I = 1 THEN BOUND ~ 1 ELSE 03687000 BOUND ~ EXTRAINFO[(BDLINK~BDLINK+1).IR,BDLINK.IC]; 03688000 IF T ~ SS[SAVIT+I] < @9 THEN 03689000 BEGIN 03690000 SUM ~ (SUM+T-1)|BOUND; 03691000 IF TOG THEN PROD ~ PROD|BOUND; 03692000 END 03693000 ELSE 03694000 BEGIN 03695000 IF TOG THEN BEGIN EMITNUM(PROD); EMITO(MUL); EMITO(ADD) END 03696000 ELSE TOG ~ TRUE; 03697000 PROD ~ BOUND; 03698000 SUM ~ (SUM-1)|BOUND; 03699000 END; 03700000 END; 03701000 IF VARF THEN T ~ @9; 03702000 IF INFA.SUBCLASS } DOUBTYPE THEN 03703000 BEGIN 03704000 IF TOG THEN 03705000 BEGIN 03706000 IF T < @9 THEN EMITNUM(2|PROD) ELSE EMITL(2); 03707000 EMITO(MUL); 03708000 END; 03709000 SUM ~ SUM|2; 03710000 END ELSE 03711000 IF T < @9 AND TOG THEN BEGIN EMITNUM(PROD); EMITO(MUL) END; 03712000 IF BOOLEAN(INFA.CE) THEN 03713000 SUM ~ SUM + INFC.BASE ELSE 03714000 IF BOOLEAN(INFA.FORMAL) THEN 03715000 BEGIN EMITOPDCLIT(INFA.ADDR-1); 03716000 IF TOG THEN EMITO(ADD) ELSE TOG ~ TRUE; 03717000 END; 03718000 IF BOOLEAN(INFA.TWOD) AND FROM > 0 THEN 03719000 BEGIN 03720000 IF SUM = 0 THEN 03721000 IF TOG THEN ELSE 03722000 BEGIN 03723000 EMITL(0); 03724000 EMITDESCLIT(INFA.ADDR); 03725000 EMITO(LOD); 03726000 EMITL(0); 03727000 GO TO CONSTRUCT; 03728000 END 03729000 ELSE 03730000 IF TOG THEN 03731000 BEGIN 03732000 EMITNUM(ABS(SUM)); 03733000 IF SUM < 0 THEN EMITO(SUB) ELSE EMITO(ADD); 03734000 END ELSE 03735000 BEGIN 03736000 EMITL(SUM.[33:7]); 03737000 EMITDESCLIT(INFA.ADDR); 03738000 EMITO(LOD); 03739000 EMITL(SUM.[40:8]); 03740000 GO TO CONSTRUCT; 03741000 END; 03742000 SPLIT(INFA.ADDR); 03743000 CONSTRUCT: 03744000 IF BOOLEAN(FROM) THEN 03745000 BEGIN 03746000 IF INFA.SUBCLASS } DOUBTYPE THEN 03747000 BEGIN 03748000 EMITO(CDC); 03749000 EMITO(DUP); 03750000 EMITPAIR(1, XCH); 03751000 EMITO(INX); 03752000 EMITO(LOD); 03753000 EMITO(XCH); 03754000 EMITO(LOD); 03755000 END ELSE EMITO(COC); 03756000 END ELSE EMITO(CDC); 03757000 END ELSE 03758000 BEGIN 03759000 IF SUM = 0 THEN IF NOT TOG THEN EMITL(0) ELSE 03760000 ELSE 03761000 BEGIN 03762000 IF TOG THEN 03763000 BEGIN 03764000 EMITNUM(ABS(SUM)); 03765000 IF SUM < 0 THEN EMITO(SUB) ELSE EMITO(ADD); 03766000 END 03767000 ELSE EMITNUM(SUM); 03768000 END; 03769000 IF FROM > 0 THEN 03770000 IF BOOLEAN (FROM) THEN 03771000 IF INFA.SUBCLASS } DOUBTYPE THEN 03772000 BEGIN 03773000 EMITDESCLIT(INFA.ADDR); 03774000 EMITO(DUP); 03775000 EMITPAIR(1,XCH); 03776000 EMITO(INX); 03777000 EMITO(LOD); 03778000 EMITO(XCH); 03779000 EMITO(LOD); 03780000 END ELSE EMITV(LINK) ELSE 03781000 BEGIN DESCREQ ~ TRUE; EMITN(LINK); DESCREQ ~ FALSE END; 03782000 END; 03783000 XIT: 03784000 IT ~ SAVIT; 03785000 SUBSCRIPTS ~ BOOLEAN(FROM); 03785100 IF DEBUGTOG THEN FLAGROUTINE(" SUBSC","RIPTS ",FALSE) ; 03786000 END SUBSCRIPTS; 03787000 BOOLEAN PROCEDURE BOUNDS(LINK); VALUE LINK; REAL LINK; 03788000 BEGIN 03789000 COMMENT CALLED TO PROCESS ARRAY BOUNDS; 03790000 BOOLEAN VARF, SINGLETOG; %109-03791000 DEFINE FNEW = LINK#; 03792000 REAL T, NSUBS, INFA, INFB, INFC, FIRSTSS; 03793000 LABEL LOOP; 03794000 03795000 03796000 IF DEBUGTOG THEN FLAGROUTINE(" BOU","NDS ",TRUE ); 03797000 GETALL(FNEW, INFA, INFB, INFC); 03798000 FIRSTSS ~ NEXTSS; 03799000 IF LINK < 0 THEN BEGIN SINGLETOG ~ TRUE; LINK ~ ABS(LINK) END; %109-03799500 LOOP: 03800000 IF NEXT = ID THEN 03801000 BEGIN 03802000 T ~ GET(FNEXT ~ GETSPACE(FNEXT)); 03802100 IF T.CLASS ! VARID OR NOT BOOLEAN(T.FORMAL) THEN FLAG(92) ELSE 03803000 IF T.SUBCLASS > REALTYPE THEN FLAG(93); 03804000 T ~ -T.ADDR; 03805000 VARF ~ TRUE; 03806000 END ELSE 03807000 IF NEXT = NUM THEN 03808000 BEGIN 03809000 IF NUMTYPE!INTYPE THEN FLAG(113); 03810000 IF T~FNEXT=0 THEN FLAG(122) ; 03810010 IF NOT VARF THEN IF NSUBS = 0 THEN LENGTH ~ FNEXT ELSE 03812000 LENGTH ~ LENGTH|FNEXT; 03813000 END ELSE FLOG(122); 03814000 EXTRAINFO[NEXTSS.IR,NEXTSS.IC] ~ T; 03815000 NEXTSS ~ NEXTSS-1; 03816000 NSUBS ~ NSUBS+1; 03817000 SCAN; 03818000 IF NEXT = COMMA THEN BEGIN SCAN; GO TO LOOP END; 03819000 IF NEXT ! RPAREN THEN FLOG(94); 03820000 XTA ~ INFB; 03821000 IF INFA.CLASS = ARRAYID THEN FLAG(95); 03822000 INFA.CLASS ~ ARRAYID; 03823000 IF VARF THEN 03827000 BEGIN 03828000 IF NOT BOOLEAN(INFA.FORMAL) THEN FLAG(96); 03829000 IF NSUBS > 1 OR INFA .SUBCLASS } DOUBTYPE THEN 03830000 BEGIN BUMPLOCALS;LENGTH~LOCALS + 1536;BOUNDS~TRUE END ELSE 03831000 LENGTH ~-EXTRAINFO[FIRSTSS.IR,FIRSTSS.IC]; 03832000 END ELSE 03833000 IF NOT SINGLETOG AND INFA.SUBCLASS > LOGTYPE THEN %109-03834000 BEGIN LENGTH ~ 2 | LENGTH; BOUNDS ~ TRUE END; %109-03834500 IF LENGTH > 32767 THEN FLAG(99); 03835000 INFC ~ LENGTH & NSUBS[TONEXTRA] & FIRSTSS[TOADINFO]; 03836000 IF VARF THEN INFC ~ -INFC; 03837000 PUT(FNEW, INFA); PUT(FNEW+2, INFC); 03838000 SCAN; 03839000 IF DEBUGTOG THEN FLAGROUTINE(" BOU","NDS ",FALSE) ; 03840000 END BOUNDS; 03841000 PROCEDURE PARAMETERS(LINK); VALUE LINK; REAL LINK; 03842000 BEGIN 03843000 03844000 03845000 LABEL LOOP; 03846000 REAL NPARMS, EX, INFC, PTYPE; 03847000 ALPHA EXPNAME; 03848000 BOOLEAN CHECK, INTFID; 03849000 BOOLEAN NOTZEROP; 03850000 REAL SAVIT; 03851000 DEFINE PARMTYPE = LSTT#; 03852000 SAVIT ~ IT ~ IT+1; 03853000 IF DEBUGTOG THEN FLAGROUTINE(" PARAM","ETERS ",TRUE ) ; 03854000 INFC ~ GET(LINK+2); 03855000 IF CHECK ~ BOOLEAN(INFC.[1:1]) THEN 03856000 BEGIN 03857000 EX ~ INFC.ADINFO; 03858000 NOTZEROP ~ INFC.NEXTRA ! 0; 03859000 INTFID ~ INFC.[36:12] = 1; 03859500 END; 03860000 LOOP: 03861000 BEGIN SCAN; 03862000 EXPNAME ~ NAME; 03863000 IF GLOBALNEXT = 0 AND NAME = "$ " THEN 03864000 BEGIN EXPRESULT ~ LABELID; SCAN; 03866000 IF GLOBALNEXT ! NUM THEN FLAG(44); 03867000 EMITLABELDESC(NAME); 03868000 PTYPE ~ 0; 03869000 SCAN; 03870000 END 03871000 ELSE PTYPE ~ EXPR(CHECK AND EXTRAINFO[EX.IR,EX.IC].CLASS 03872000 = EXPCLASS AND INTFID); 03873000 IF EXPRESULT = NUMCLASS THEN 03874000 IF PTYPE = STRINGTYPE THEN 03875000 BEGIN 03876000 ADR ~ ADR - 1; 03876500 PTYPE ~ INTYPE; 03877000 EXPRESULT ~ SUBSVAR; 03878000 IF STRINGSIZE = 1 AND 03879000 (T ~ EXTRAINFO[EX.IR,EX.IC].CLASS = VARID OR 03880000 T = EXPCLASS) THEN 03881000 BEGIN 03882000 EXPRESULT ~ EXPCLASS; 03883000 EMITNUM(STRINGARRAY[0]); 03884000 END ELSE 03885000 BEGIN 03886000 EXPRESULT~ARRAYID; 03887000 EMITPAIR(PRGDESCBLDR(1,0,0,NXAVIL~NXAVIL+1), LOD); 03888000 EMITL(0); 03889000 WRITEDATA(STRINGSIZE, NXAVIL, STRINGARRAY); 03890000 END; 03891000 END ELSE EXPRESULT ~ EXPCLASS; 03892000 PARMTYPE[IT] ~ 0 & EXPRESULT[TOCLASS] & PTYPE[TOSUBCL]; 03893000 XTA ~ EXPNAME; 03894000 IF TSSEDITOG THEN IF (EXPRESULT=FUNID OR EXPRESULT=SUBRID OR 03894050 EXPRESULT=EXTID) AND NOT DCINPUT THEN TSSED(XTA,2); 03894060 IF DCINPUT THEN IF EXPRESULT=FUNID OR EXPRESULT=SUBRID 03894100 OR EXPRESULT=EXTID THEN FLAG(151) ; 03894200 IF CHECK THEN 03895000 BEGIN 03896000 IF T ~ EXTRAINFO[EX.IR,EX.IC].CLASS ! EXPRESULT THEN 03897000 CASE T OF 03898000 BEGIN 03899000 EXTRAINFO[EX.IR,EX.IC] ~ 0 & EXPRESULT[TOCLASS] 03900000 & PTYPE[TOSUBCL]; 03901000 IF EXPRESULT ! SUBSVAR THEN FLAG(66); 03902000 IF EXPRESULT = SUBSVAR THEN 03903000 IF NOT INTFID THEN 03903100 BEGIN EMITO(CDC); 03903150 IF PTYPE } DOUBTYPE THEN EMITL(0); 03903200 END ELSE 03903400 ELSE 03903500 IF EXPRESULT = EXPCLASS THEN 03904000 BEGIN IF PTYPE } DOUBTYPE THEN EMITO(XCH); 03904100 EXTRAINFO[EX.IR,EX.IC].CLASS ~ EXPCLASS 03904200 END ELSE FLAG(67); 03905000 ; ; ; 03906000 FLAG(68); 03907000 IF EXPRESULT = EXTID THEN 03908000 PUT(EXPLINK,GET(EXPLINK)&FUNID[TOCLASS]) ELSE 03909000 FLAG(69); 03910000 ; 03911000 IF EXPRESULT = FUNID OR EXPRESULT = SUBRID THEN 03912000 EXTRAINFO[EX.IR,EX.IC] ~ EXPRESULT ELSE FLAG(70); 03913000 IF EXPRESULT = EXTID THEN 03914000 PUT(EXPLINK,GET(EXPLINK)&SUBRID[TOCLASS]) ELSE 03915000 FLAG(71); 03916000 ; ; 03917000 IF EXPRESULT = ARRAYID THEN EXTRAINFO[EX.IR,EX.IC].CLASS 03918000 ~ ARRAYID ELSE 03919000 IF EXPRESULT = VARID THEN 03920000 BEGIN 03921000 EXTRAINFO[EX.IR,EX.IC].CLASS ~ SBVEXP; 03922000 EMITL(0) 03923000 END ELSE 03924000 IF EXPRESULT = EXPCLASS THEN 03925000 BEGIN 03926000 EXTRAINFO[EX.IR,EX.IC].CLASS ~ SBVEXP; 03927000 IF PTYPE } DOUBTYPE THEN EMITO(XCH) ELSE EMITL(0); 03928000 END ELSE FLAG(72); 03929000 IF EXPRESULT = SUBSVAR THEN 03930000 IF NOT INTFID THEN 03930100 BEGIN EMITO(CDC); 03930200 IF PTYPE } DOUBTYPE THEN EMITL(0) 03930300 END 03930400 ELSE 03930500 ELSE IF EXPRESULT = VARID THEN 03930600 IF NOT INTFID THEN 03930650 IF PTYPE } DOUBTYPE THEN EMITL(0) ELSE ELSE 03930700 ELSE FLAG(67); 03930800 IF EXPRESULT = VARID THEN 03931000 EMITL(0) ELSE 03932000 IF EXPRESULT = EXPCLASS THEN 03933000 IF PTYPE } DOUBTYPE THEN EMITO(XCH) ELSE EMITL(0) 03934000 ELSE IF EXPRESULT ! SUBSVAR THEN FLAG(67); 03935000 END OF CASE STATEMENT 03936000 ELSE IF PTYPE } DOUBTYPE THEN 03936100 IF EXPRESULT = VARID THEN EMITL(0) 03936200 ELSE IF EXPRESULT = EXPCLASS AND NOT INTFID 03936300 THEN EMITO(XCH); 03936400 IF T ~ EXTRAINFO[EX.IR,EX.IC].SUBCLASS = 0 OR 03937000 (T = INTYPE AND PTYPE = REALTYPE AND 03938000 GET(LINK).SEGNO = 0) THEN 03939000 EXTRAINFO[EX.IR,EX.IC].SUBCLASS ~ PTYPE ELSE 03940000 IF NOT(T = PTYPE OR T = REALTYPE AND PTYPE = INTYPE ) THEN 03941000 FLAG(88); 03942000 END OF CHECK 03943000 ELSE IF PTYPE } DOUBTYPE THEN 03943100 IF EXPRESULT = VARID THEN EMITL(0) 03943200 ELSE IF EXPRESULT = EXPCLASS THEN EMITO(XCH); 03943300 IF NOTZEROP THEN EX ~ EX+1; 03944000 IT ~ IT+1; 03945000 END; 03946000 IF GLOBALNEXT = COMMA THEN GO TO LOOP; 03947000 NPARMS ~ IT - SAVIT; 03948000 IF GLOBALNEXT ! RPAREN THEN FLOG(108); 03949000 IF NOT CHECK THEN 03950000 BEGIN 03951000 INFC ~ GET(LINK+2); 03952000 INFC ~ -(INFC & NPARMS[TONEXTRA] 03953000 & NEXTEXTRA[TOADINFO]); 03954000 PUT(LINK+2,INFC); 03955000 FOR I ~ SAVIT STEP 1 UNTIL IT-1 DO 03956000 BEGIN 03957000 EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ PARMTYPE[I]; 03958000 NEXTEXTRA ~ NEXTEXTRA+1; 03959000 END; 03960000 END 03961000 ELSE 03962000 IF T ~ GET(LINK+2).NEXTRA > 0 AND T ! NPARMS OR 03963000 T=0 AND INTFID AND NPARMS < 2 OR 03964000 T = 0 AND NOT INTFID THEN 03964500 BEGIN XTA ~ GET(LINK+1); FLAG(28) END; 03965000 IF DEBUGTOG THEN FLAGROUTINE(" PARAM","ETERS ",FALSE) ; 03966000 IT ~ SAVIT-1; 03967000 END PARAMETERS; 03968000 PROCEDURE STMTFUNREF(LINK); VALUE LINK; REAL LINK; 03969000 BEGIN 03970000 REAL I, PARMLINK, NPARMS, SEG; 03971000 IF DEBUGTOG THEN FLAGROUTINE(" STMTF","UNREF ",TRUE); 03971010 PARMLINK ~ GET(LINK+2).[36:12]; 03972000 DO 03973000 BEGIN 03974000 SCAN; 03975000 IF A~EXPR(TRUE) ! B~GET(PARMLINK).SUBCLASS THEN 03976000 IF A > REALTYPE OR B > REALTYPE THEN %108-03977000 BEGIN XTA ~ NNEW; FLAG(88) END; 03978000 PARMLINK ~ PARMLINK-3; 03979000 NPARMS ~ NPARMS+1; 03980000 END UNTIL NEXT ! COMMA; 03981000 IF NEXT ! RPAREN THEN FLAG(108); 03982000 SCAN; 03983000 GETALL(LINK, INFA, XTA, INFC); 03984000 IF NPARMS ! INFC.NEXTRA THEN FLAG(28); 03985000 SEG ~ INFA.SEGNO; 03986000 BRANCHLIT(INFC.BASE&SEG[TOSEGNO],FALSE); 03987000 EMITB(INFA.ADDR & SEG[TOSEGNO], FALSE); 03988000 ADJUST; 03989000 IF DEBUGTOG THEN FLAGROUTINE(" STMTF","UNREF ",FALSE); 03989010 END STMTFUNREF; 03990000 BOOLEAN PROCEDURE DOITINLINE(LNK); VALUE LNK; REAL LNK ; 03990010 BEGIN 03990020 REAL C,I,C1,C2,C3,C4,C5 ; 03990030 LABEL HUNT,FOUND,XIT,AIMAG,AINT,CMPLX,LOOP,DDT111,SNGL ; 03990040 DEFINE OPTYPE=LSTT#, E0=EMITO#, EP=EMITPAIR#, EOL=EMITOPDCLIT# ;03990045 IF DEBUGTOG THEN FLAGROUTINE("DOITIN","LINE ",TRUE); 03990047 C1~1; C2~INLINEINT[0]; C3~GET(ABS(LNK)+1) ; 03990050 HUNT: 03990060 IF (C~INLINEINT[I~(C1+C2).[36:11]].INAM)C3 THEN C2~I-1 ELSE GO FOUND ; 03990080 IF C10 THEN INLINEINT[I]~-C4; I~0 ; 03990132 IF XREF THEN ENTERX(C3,0&FUNID[TOCLASS]&C[21:6:3]); 03990134 IF GLOBALNEXT!LPAREN THEN BEGIN FLOG(106); GO XIT END ; 03990136 LOOP: SCAN; C5~XTA ; 03990140 IF I=0 THEN 03990145 IF LNK=10 THEN EMITL(0) ELSE IF LNK=21 THEN EMITDESCLIT(2) ; 03990150 IF (C4~EXPR(TRUE))!C1 AND (C1!REALTYPE OR C4!INTYPE) THEN 03990160 BEGIN XTA~C5; FLAG(88); C2~-2 END ; 03990165 I~I+1; IF GLOBALNEXT=COMMA THEN GO LOOP ; 03990170 IF GLOBALNEXT!RPAREN THEN BEGIN FLOG(108); C2~-2 END; SCAN ; 03990180 IF I!C.INTPARMS THEN IF C.INTPARMS!0 OR I<2 THEN 03990190 BEGIN XTA~C3; FLAG(28); C2~-2 END ; 03990195 OPTYPE[IT]~C.INTCLASS; IF C2<0 THEN GO XIT ; 03990200 CASE (LNK-1) OF 03990210 BEGIN 03990220 E0(SSP) ; % @1: ABS, DABS, IABS. 03990230 AIMAG: E0(DEL) ; % @2: AIMAG. 03990240 AINT: EP(1,IDV) ; % @3: AINT, IFIX, INT. 03990250 E0(RDV) ; % @4: AMOD. 03990260 E0(LND) ; % @5: LOGICAL AND. 03990270 CMPLX: E0(XCH) ; % @6: CMPLX. 03990280 E0(LNG) ; % @7: LOGICAL COMPLIMENT (NEGATION). 03990290 03990291 BEGIN % @10: DIM, IDIM. 03990300 E0(SUB); E0(DUP); EP(0,LESS) ; 03990310 IF ADR>4082 THEN BEGIN ADR~ADR+1; SEGOVF END ; 03990315 EP(2,BFC); E0(DEL); EMITL(0) ; 03990320 END ; 03990330 03990331 BEGIN E0(XCH); E0(CHS); GO CMPLX END ; % @11: CONJG. 03990340 ; % @12: DBLE (SOME CODE ALREADY EMITTED ABOVE). 03990350 03990351 BEGIN E0(XCH); E0(DEL) ; % @13: DSIGN. 03990360 DDT111: EMITDDT(1,1,1) ; 03990370 END; 03990380 03990381 E0(LQV) ; % @14: LOGICAL EQUIVALENCE. 03990390 ; % @15: FLOAT. 03990400 GO DDT111 ; % @16: ISIGN, SIGN. 03990410 BEGIN E0(RDV); GO AINT END ; % @17: MOD. 03990420 E0(LOR) ; % @20: LOGICAL OR. 03990430 BEGIN E0(XCH); GO AIMAG END ; % @21: REAL. 03990440 EP(1,KOM) ; % @22: TIME. 03990450 03990460 BEGIN % @23: SNGL. 03990470 SNGL: EP(9,SND); E0(XCH); EMITDDT(47,9,1); EMITL(0) ; 03990480 EMITDDT(9,9,38); EOL(9); EMITO(ADD); IF LNK=20 THEN GO AINT ; 03990490 END ; 03990500 03990510 GO SNGL ; % @24: IDINT. 03990520 03990530 BEGIN % @25: AMAX0,AMAX1,AMIN0,AMIN1,MAX0,MAX1,MIN0,MIN1. 03990535 % SOME CODE ALREADY EMITTED ABOVE. 03990540 IF ADR>4068 THEN BEGIN ADR~ADR+1; SEGOVF END ; 03990542 EP(9,STD); E0(DUP); EOL(9) ; 03990545 E0(IF C3.[24:6]="A" OR C3.[24:6]="X" THEN LESS ELSE GRTR) ; 03990550 EP(2,BFC); E0(DEL); EOL(9); E0(XCH); E0(TOP); E0(LNG) ; 03990555 EP(14,BBC); E0(DEL); IF C3="MIN1 " OR C3="MAX1 " THEN GO AINT03990560 END ; 03990565 03990566 END OF CASE STATEMENT ; 03990800 XIT: 03990810 IF DEBUGTOG THEN FLAGROUTINE("DOITIN","LINE ",FALSE) ; 03990815 END OF DOITINLINE ; 03990820 REAL PROCEDURE LOOKFORINTRINSIC(L); VALUE L; REAL L; 03991000 BEGIN 03992000 ALPHA ID, I, X, NPARMS; 03993000 REAL T; 03994000 LABEL FOUND, XIT; 03995000 IF DEBUGTOG THEN FLAGROUTINE("LOOKFO","RINTRN",TRUE); 03995010 LOOKFORINTRINSIC ~ L ~ NEED(ID ~ GET(L+1),FUNID); 03996000 IF GET(L+2) < 0 THEN GO TO XIT; % PARAMETER INFO KNOWN 03996050 COMMENT B MUST BE SET TO K/2, WHERE K IS THE INDEX OF THE LAST 03996100 INTRINSIC NAME IN THE ARRAY INT; 03996200 A~0; B~NUMINTM1 ; 03997000 WHILE A+1 < B DO 03998000 BEGIN 03999000 I ~ REAL(BOOLEAN(A+B) AND BOOLEAN(1022)); 04000000 IF Z ~ INT[I] = ID THEN GO TO FOUND; 04001000 IF ID < Z THEN B ~ I.[36:11] ELSE A ~ I.[36:11]; 04002000 END; 04003000 IF ID = INT[I~(A+B)|2-I] THEN GO TO FOUND; 04004000 GO TO XIT; 04005000 FOUND: 04006000 NPARMS~(X~INT[I+1]).INTPARMS; INT[I+1].INTSEEN~1 ; 04007000 INFO[L.IR,L.IC].SUBCLASS~X.INTCLASS ; 04008000 PUT(L+2,-(1&NEXTEXTRA[TOADINFO]&NPARMS[TONEXTRA])); 04009000 IF NPARMS = 0 THEN NPARMS ~ 1; 04010000 T~X.INTPARMCLASS ; 04011000 FOR I ~ 1 STEP 1 UNTIL NPARMS DO 04012000 BEGIN 04013000 EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ 04014000 0 & EXPCLASS[TOCLASS] & T[TOSUBCL]; 04015000 NEXTEXTRA ~ NEXTEXTRA + 1; 04016000 END; 04017000 XIT: 04018000 IF DEBUGTOG THEN FLAGROUTINE("LOOKFO","RINTRN",FALSE ) ; 04018010 END LOOKFORINTRINSIC; 04019000 INTEGER PROCEDURE EXPR(VALREQ); VALUE VALREQ; BOOLEAN VALREQ; 04020000 BEGIN LABEL LOOP, STACK, XIT, NOSCAN; REAL T; 04021000 LABEL ARRY; 04022000 LABEL HERE ; 04022010 04023000 04024000 REAL SAVIT, SAVIP; 04025000 BOOLEAN CNSTSEENLAST; %FOR HANDLING CONSTANT %113-04025500 REAL SAVEADR; %EXPONENTS %113-04025600 DEFINE OPTYPE = LSTT#; 04026000 REAL EXPRESLT,EXPLNK; 04027000 REAL EXPV; 04028000 REAL TM ; 04028010 DEFINE E0=EMITO#, EP=EMITPAIR#, EOL=EMITOPDCLIT#, 04028020 ES1(OP)=BEGIN E0(XCH); EP(9,STD); E0(OP) END #, 04028030 ES2=BEGIN EP(9,STD); E0(XCH); EP(17,SND); E0(MUL) END # ; 04028040 LABEL CTYP, DTYP, RLESSC, DLESSC, CLESSD, CLESSC, RPLUSD, DTIMESC, 04028050 CTIMESR, CDIVBYD, CTIMESR1, CTIMESR2, DLESSC1 ; 04028060 LABEL SPECCHAR, RELATION; 04029000 REAL LINK; 04030000 DEFINE T1 = EXPT1#, T2 = EXPT2#, CODE = EXPT3#; 04031000 COMMENT THE FOLLOWING TABLE GIVES THE PRECEDENCE (PREC) AND 04032000 OPERATOR NUMBER (OP) OF THE ARITHMETIC AND LOGICAL OPERATORS. 04033000 OPERATOR PREC OP 04034000 ** 9 15 04035000 UNARY - 8 12 04036000 / 7 14 04037000 * 7 13 04038000 - 5 11 04039000 + 5 10 04040000 .NE. 4 9 04041000 .GE. 4 8 04042000 .GT. 4 7 04043000 .EQ. 4 6 04044000 .LE. 4 5 04045000 .LT. 4 4 04046000 .NOT. 3 3 04047000 .AND. 2 2 04048000 .OR. 1 1 04049000 THE UNARY PLUS IS IGNORED; 04050000 PROCEDURE MATH(D, C, T); VALUE D, C, T; REAL D, C, T; 04051000 BEGIN 04052000 EMITO(MKS); 04053000 EMITL(C); 04054000 EMITV(NEED(".MATH ", INTRFUNID)); 04055000 EMITO(DEL); 04056000 IF D = 2 THEN EMITO(DEL); 04057000 OPTYPE[IT~IT-1] ~ T; 04058000 END MATH; 04059000 NNEW ~ NAME; 04060000 IF DEBUGTOG THEN FLAGROUTINE(" EXPRE","SSION ",TRUE ) ; 04061000 OPTYPE[SAVIT ~IT ~ IT+1] ~ 04062000 PR[SAVIP~IP~IP+1] ~ OPST[IP] ~ 0; 04063000 IF GLOBALNEXT = PLUS THEN GO TO LOOP; 04064000 IF GLOBALNEXT = MINUS THEN 04065000 BEGIN PREC ~ 8; OP ~ 12; GO TO STACK END; 04066000 IF PREC > 0 THEN GO TO STACK; 04067000 LINK~(EXPLNK~FNEXT)&REAL(SCANENTER)[2:47:1] ; 04068000 GO TO NOSCAN; 04069000 LOOP: SCAN; 04070000 LINK ~ FNEXT; 04071000 NOSCAN: 04072000 CNSTSEENLAST~FALSE; %113-04072500 IF GLOBALNEXT = ID THEN 04073000 BEGIN 04074000 IF IP ! SAVIP THEN EXPRESLT ~ EXPCLASS; 04074100 OPTYPE[IT~IT+1] ~ (A~GET(LINK)).SUBCLASS; 04075000 SCAN; 04076000 IF NOT RANDOMTOG THEN 04076050 IF NEXT=EQUAL THEN BEGIN NEXT~0; OP~6; PREC~4 END ; 04076100 IF GLOBALNEXT = ID OR GLOBALNEXT = NUM THEN 04077000 BEGIN FLOG(1); GO TO XIT END; 04078000 IF NOT VALREQ AND PREC > 0 THEN VALREQ ~ TRUE; 04078100 IF GLOBALNEXT ! LPAREN THEN 04079000 BEGIN 04080000 LINK ~ GETSPACE(LINK); 04081000 T ~ (A~GET(LINK)).CLASS; 04082000 IF XREF THEN ENTERX(GET(LINK+1),0&A[15:15:9]); 04082100 IF EXPRESLT = 0 THEN EXPRESLT ~ T; 04083000 IF VALREQ THEN 04084000 IF T = VARID THEN EMITV(LINK) ELSE 04085000 BEGIN XTA ~ GET(LINK+1); FLAG(50) END 04086000 ELSE 04087000 BEGIN 04088000 IF T = VARID THEN 04089000 IF GLOBALNEXT > SLASH AND EXPRESLT = VARID THEN 04090000 BEGIN 04091000 DESCREQ~TRUE; EMITN(LINK); DESCREQ ~ FALSE; 04092000 GO TO XIT; 04093000 END ELSE EMITV(LINK) 04094000 ELSE 04095000 BEGIN 04096000 IF T = ARRAYID THEN 04097000 BEGIN 04098000 IF BOOLEAN(A.CE) THEN 04099000 EMITNUM(GET(LINK+2).BASE) ELSE 04100000 IF BOOLEAN(A.FORMAL) THEN 04101000 EMITOPDCLIT(A.ADDR-1) ELSE 04102000 EMITL(0); 04103000 GO TO ARRY; 04104000 END ELSE EMITPAIR(A.ADDR,LOD); 04105000 GO TO XIT; 04106000 END; 04107000 END; 04108000 GO TO SPECCHAR; 04109000 END; 04110000 IF A.CLASS ! ARRAYID THEN 04111000 BEGIN COMMENT FUNCTION REFERENCE; 04112000 EXPRESLT ~ EXPCLASS; 04112100 IF A.CLASS = STMTFUNID THEN 04113000 BEGIN 04114000 IF XREF THEN ENTERX(GET(LINK+1),0&A[15:15:9]); 04114050 STMTFUNREF(LINK) ; 04114100 IF NEXT=EQUAL THEN IF NOT RANDOMTOG THEN 04114200 BEGIN NEXT~0; OP~6; PREC~4 END ; 04114300 GO TO SPECCHAR ; 04114400 END ; 04114500 IF A.CLASS=EXTID OR GET(TM~GLOBALSEARCH(GET(LINK+1))).CLASS=04114520 EXTID THEN LINK~REAL(DOITINLINE(-LINK)) ELSE 04114530 IF A.CLASS SLASH AND EXPRESLT = SUBSVAR THEN 04133000 BEGIN 04134000 ARRY: 04135000 IF BOOLEAN((A~GET(LINK)).TWOD) THEN 04136000 BEGIN 04137000 EMITPAIR(TWODPRT, LOD); 04138000 T ~ A.ADDR; 04139000 IF T { 1023 THEN 04140000 BEGIN 04141000 EMITL(T.[38:10]); 04142000 EMITDESCLIT(10); 04143000 END ELSE 04144000 BEGIN 04145000 EMITL(T.[40:8]); 04146000 EMITDESCLIT(1536); 04147000 EMITO(INX); 04148000 END; 04149000 EMITO(CTF); 04150000 END ELSE EMITPAIR(A.ADDR,LOD); 04151000 EMITO(XCH); 04152000 GO TO XIT; 04153000 END; 04154000 IF BOOLEAN((A~GET(LINK)).TWOD) THEN 04155000 BEGIN 04156000 SPLIT(A.ADDR); 04157000 IF A.SUBCLASS } DOUBTYPE THEN 04158000 BEGIN 04159000 EMITO(CDC); 04160000 EMITO(DUP); 04161000 EMITPAIR(1, XCH); 04162000 EMITO(INX); 04163000 EMITO(LOD); 04164000 EMITO(XCH); 04165000 EMITO(LOD); 04166000 END ELSE EMITO(COC); 04167000 END ELSE 04168000 EMITV(LINK); 04169000 END; 04170000 END ARRAY REFERENCE; 04171000 GO TO SPECCHAR; 04172000 END; 04173000 IF GLOBALNEXT = NUM THEN 04174000 BEGIN 04175000 IF NUMTYPE = STRINGTYPE THEN 04176000 IF VALREQ THEN 04177000 BEGIN 04177200 NUMTYPE~INTYPE ; 04177400 IF STRINGSIZE=1 THEN FNEXT~STRINGARRAY[0] 04177500 ELSE BEGIN 04177550 IF STRINGSIZE>2 OR STRINGARRAY[1].[18:30]!" " THEN 04177575 FLAG(162) ; 04177600 IF (FNEXT~STRINGARRAY[1].[12:6]&STRINGARRAY[0][6:12:36]) 04177700 .[6:6]>7 THEN NUMTYPE~REALTYPE ; 04177800 END ; 04177900 END; 04178000 SAVEADR~ADR; CNSTSEENLAST~TRUE; %113-04178500 IF NUMTYPE = DOUBTYPE THEN 04179000 EMITNUM2(FNEXT,DBLOW) ELSE EMITNUM (FNEXT); 04180000 OPTYPE[IT~IT+1] ~ NUMTYPE; 04181000 IF EXPRESLT = 0 THEN 04182000 BEGIN EXPRESLT ~ NUMCLASS; EXPV ~ FNEXT END; 04183000 SCAN; 04184000 IF NOT RANDOMTOG THEN 04184050 IF NEXT=EQUAL THEN BEGIN NEXT~0; OP~6; PREC~4 END; 04184100 IF NOT VALREQ AND PREC > 0 THEN VALREQ ~ TRUE; 04184200 IF GLOBALNEXT = ID OR GLOBALNEXT = NUM THEN 04185000 BEGIN FLOG(1); GO TO XIT END; 04186000 END; 04187000 SPECCHAR: 04188000 IF GLOBALNEXT = LPAREN THEN 04189000 BEGIN 04190000 SCAN; 04191000 OPTYPE[IT~IT+1] ~ EXPR(TRUE); 04192000 04193000 IF GLOBALNEXT = COMMA AND EXPRESULT = NUMCLASS THEN 04194000 BEGIN 04195000 IF OPTYPE[IT] > REALTYPE THEN FLAG(85); 04196000 SCAN; 04197000 IF EXPR(TRUE) > REALTYPE 04198000 OR EXPRESULT ! NUMCLASS THEN FLAG(85); 04198100 EMITO(XCH); 04199000 OPTYPE[IT] ~ COMPTYPE; 04200000 IF EXPRESLT = 0 THEN EXPRESLT ~ NUMCLASS; 04201000 END ELSE EXPRESLT ~ EXPCLASS; 04202000 IF GLOBALNEXT ! RPAREN THEN 04203000 BEGIN FLOG(108); GO TO XIT END; 04204000 GO TO LOOP; 04205000 END; 04206000 WHILE PR[IP] } PREC DO 04207000 BEGIN 04208000 IF IT { SAVIT THEN GO TO XIT; 04208100 CODE ~ MAP[T1~OPTYPE[IT-1]]|3 + MAP[T2~OPTYPE[IT]]; 04209000 CASE OPST[IP] OF 04210000 BEGIN 04211000 GO TO XIT; 04212000 BEGIN 04213000 IF T1 = LOGTYPE AND T2 = LOGTYPE THEN EMITO(LOR) 04214000 ELSE FLAG(51); 04215000 IT ~ IT-1; 04216000 END; 04217000 BEGIN 04218000 IF T1 = LOGTYPE AND T2 = LOGTYPE THEN EMITO(LND) 04219000 ELSE FLAG(52); 04220000 IT ~ IT-1; 04221000 END; 04222000 IF T2 = LOGTYPE THEN EMITO(LNG) ELSE FLAG(53); 04223000 BEGIN T ~ LESS; GO TO RELATION END; 04224000 BEGIN T ~ LEQL; GO TO RELATION END; 04225000 BEGIN T ~ EQUL; GO TO RELATION END; 04226000 BEGIN T ~ GRTR; GO TO RELATION END; 04227000 BEGIN T ~ GEQL; GO TO RELATION END; 04228000 BEGIN T ~ NEQL; 04229000 RELATION: 04230000 IF CODE < 0 THEN FLAG(54) ELSE 04231000 CASE CODE OF 04232000 BEGIN ; 04233000 BEGIN 04234000 E0(CHS); EP(9,STD); E0(XCH); EOL(9); E0(XCH); EP(0,XCH) ;04235000 E0(AD2) ; 04236000 END; 04238000 FLAG(90); 04239000 BEGIN EMITPAIR(0, XCH); EMITO(SB2) END; 04240000 EMITO(SB2); 04241000 FLAG(90); 04242000 FLAG(90); 04243000 FLAG(90); 04244000 IF T! EQUL AND T! NEQL THEN FLAG(54) %103-04245000 ELSE %103-04245100 BEGIN %103-04245200 EP(9,STD); E0(XCH); EOL(9); E0(T); %103-04245300 EP(9,STD ); E0(T); EOL(9); %103-04245400 T~(IF T=EQUL THEN LND ELSE LOR); CODE~0; %103-04245500 END; %103-04245600 END RELATION CASE STATEMENT; 04246000 IF CODE > 0 THEN 04247000 BEGIN EMITO(XCH); EMITO(DEL); EMITL(0) END; 04248000 EMITO(T); 04249000 OPTYPE[IT~IT-1] ~ LOGTYPE; 04250000 END; 04251000 IF CODE < 0 THEN BEGIN FLAG(53); IT ~ IT-1 END ELSE 04252000 CASE CODE OF 04253000 BEGIN 04254000 BEGIN 04255000 EMITO(ADD); 04256000 IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 04257000 OPTYPE[IT~IT-1] ~ REALTYPE; 04258000 END; 04259000 BEGIN TM~AD2 ; 04260000 RPLUSD: EP(9,STD); E0(XCH); EOL(9); E0(XCH); EP(0,XCH); E0(TM) ; 04260010 DTYP: OPTYPE[IT~IT-1]~DOUBTYPE ; 04260020 END ; 04260030 BEGIN TM~ADD; GO RLESSC END ; 04261000 BEGIN 04262000 EMITPAIR(0, XCH); 04263000 EMITO(AD2); 04264000 IT ~ IT-1; 04265000 END; 04266000 BEGIN EMITO(AD2); IT ~ IT-1 END; 04267000 BEGIN TM~ADD; GO DLESSC END ; 04268000 BEGIN EMITO(ADD); IT ~ IT-1 END; 04269000 BEGIN TM~ADD; GO CLESSD END ; 04270000 BEGIN TM~ADD; GO CLESSC END ; 04271000 END ADD CASE STATEMENT; 04272000 IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 04273000 CASE CODE OF 04274000 BEGIN 04275000 BEGIN 04276000 EMITO(SUB); 04277000 IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 04278000 OPTYPE[IT~IT-1] ~ REALTYPE; 04279000 END; 04280000 BEGIN E0(CHS); TM~AD2; GO RPLUSD END; 04281000 BEGIN TM~SUB ; 04282000 RLESSC: ES1(TM); GO DLESSC1 ; 04282010 END ; 04282030 BEGIN 04283000 EMITPAIR(0, XCH); 04284000 EMITO(SB2); 04285000 IT ~ IT-1; 04286000 END; 04287000 BEGIN EMITO(SB2); IT ~ IT-1 END; 04288000 BEGIN TM~SUB ; 04289000 DLESSC: ES1(TM); E0(XCH); E0(DEL) ; 04289005 DLESSC1: EOL(9); IF TM=SUB THEN E0(CHS); GO CTIMESR2 ; 04289007 END ; 04289010 BEGIN EMITO(SUB); IT ~ IT-1 END; 04290000 BEGIN TM~SUB ; 04291000 CLESSD: E0(XCH); E0(DEL); E0(TM) ; 04291010 CTYP: OPTYPE[IT~IT-1]~COMPTYPE ; 04291015 END ; 04291020 BEGIN TM~SUB ; 04292000 CLESSC: ES1(TM); GO CTIMESR1 ; 04292010 END ; 04292020 END SUBTRACT CASE STATEMENT; 04293000 BEGIN % HANDLE NEGATIVE NUMBERS CASE STATEMENT. 04293100 EXPV~-EXPV ; 04293200 IF T2 { REALTYPE THEN EMITO(CHS) ELSE 04294000 IF T2 = LOGTYPE THEN FLAG(55) ELSE 04295000 IF T2 = DOUBTYPE THEN EMITO(CHS) ELSE 04296000 IF T2 = COMPTYPE THEN 04297000 BEGIN 04298000 EMITO(CHS); EMITO(XCH); 04299000 EMITO(CHS); EMITO(XCH); 04300000 END ELSE FLAG(55); 04301000 END OF NEG NUMBERS CASE STATEMNT ; 04301100 IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 04302000 CASE CODE OF 04303000 BEGIN 04304000 BEGIN 04305000 EMITO(MUL); 04306000 IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 04307000 OPTYPE[IT~IT-1] ~ REALTYPE; 04308000 END; 04309000 BEGIN TM~ML2; GO RPLUSD END ; 04310000 BEGIN ES2; GO DTIMESC END ; 04311000 BEGIN 04312000 EMITPAIR(0, XCH); 04313000 EMITO(ML2); 04314000 IT ~ IT-1; 04315000 END; 04316000 BEGIN EMITO(ML2); IT ~ IT-1 END; 04317000 BEGIN ES2; E0(XCH); E0(DEL) ; 04318000 DTIMESC: EOL(9); EOL(17); E0(MUL); GO CTYP ; 04318010 END ; 04318020 BEGIN TM~MUL ; 04319000 CTIMESR: EP(9,SND); E0(TM) ; 04319010 CTIMESR1:E0(XCH); EOL(9); E0(TM) ; 04319020 CTIMESR2:E0(XCH); GO CTYP ; 04319030 END ; 04319040 BEGIN TM~MUL; GO CDIVBYD END ; 04320000 MATH(2, 26, COMPTYPE); 04321000 END MULTIPLY CASE STATEMENT; 04322000 IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 04323000 CASE CODE OF 04324000 BEGIN 04325000 IF T1 = INTYPE AND T2 = INTYPE THEN 04326000 BEGIN EMITO(IDV); IT ~ IT-1 END ELSE 04327000 BEGIN EMITO(DIU); OPTYPE[IT~IT-1] ~ REALTYPE END; 04328000 BEGIN 04329000 EP(9,STD); EP(17,STD); EP(0,XCH); EOL(17); EOL(9); E0(DV2) ; 04329010 GO DTYP ; 04329020 END ; 04329030 MATH(1, 29, COMPTYPE); 04330000 BEGIN 04331000 EMITPAIR(0, XCH); 04332000 EMITO(DV2); 04333000 IT ~ IT-1; 04334000 END; 04335000 BEGIN EMITO(DV2); IT ~ IT-1 END; 04336000 MATH(2, 32, COMPTYPE); 04337000 BEGIN TM~DIU; GO CTIMESR END ; 04338000 BEGIN TM~DIU ; 04339000 CDIVBYD: E0(XCH); E0(DEL); GO CTIMESR ; 04339010 END ; 04339020 MATH(2, 35, COMPTYPE); 04340000 END OF DIVIDE CASE STATEMENT; 04341000 IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 04342000 BEGIN 04343000 IF CODE = 0 AND T2 = INTYPE AND 04344000 CNSTSEENLAST THEN %113-04345000 BEGIN 04346000 IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 04347000 OPTYPE[IT~IT-1] ~ REALTYPE; 04348000 EXPV~LINK; %113- 04349000 A~1; ADR~SAVEADR; %113- 04350000 WHILE EXPV DIV 2 ! 0 DO 04351000 BEGIN 04352000 EMITO(DUP); 04353000 IF BOOLEAN(EXPV) THEN BEGIN A~A+1; EMITO(DUP) END; 04354000 EMITO(MUL); 04355000 EXPV ~ EXPV DIV 2; 04356000 END; 04357000 IF EXPV = 0 THEN BEGIN EMITO(DEL); EMITL(1) END ELSE 04358000 WHILE A ~ A-1 ! 0 DO EMITO(MUL); 04359000 END ELSE 04360000 BEGIN 04361000 EMITO(MKS); 04362000 EMITL(CODE); 04363000 EMITV(NEED(".XTOI ", INTRFUNID)); 04364000 CASE CODE OF 04365000 BEGIN 04366000 BEGIN EMITO(DEL); OPTYPE[IT~IT-1]~IF (T1=INTYPE AND T2=INTYPE)04367000 THEN INTYPE ELSE REALTYPE END; 04367500 BEGIN EMITO(DEL); OPTYPE[IT~IT-1] ~ DOUBTYPE END; 04368000 BEGIN EMITO(DEL); OPTYPE[IT~IT-1]~COMPTYPE END ; 04369000 BEGIN EMITO(DEL); IT ~ IT-1 END; 04370000 BEGIN EMITO(DEL); EMITO(DEL); IT ~ IT-1 END; 04371000 BEGIN EMITO(DEL); EMITO(DEL); OPTYPE[IT~IT-1]~COMPTYPE END ; 04372000 BEGIN EMITO(DEL); IT ~ IT-1 END; 04373000 BEGIN EMITO(DEL); EMITO(DEL); IT ~ IT-1 END; 04374000 BEGIN EMITO(DEL); EMITO(DEL); IT~IT-1 END ; 04375000 END OF POWER CASE STATEMENT; 04376000 END; 04377000 END; 04378000 END; 04379000 IP ~ IP-1; 04380000 END; 04381000 EXPRESLT ~ EXPCLASS; 04381100 STACK: 04382000 PR[IP~IP+1] ~ PREC; 04383000 OPST[IP] ~ OP; 04384000 04385000 IF PREC > 0 AND PREC { 4 THEN 04386000 BEGIN 04387000 SCAN; LINK ~ FNEXT; 04388000 IF NEXT = PLUS THEN GO TO LOOP; 04389000 IF NEXT ! MINUS THEN GO TO NOSCAN; 04390000 PREC ~ 8; OP ~ 12; 04391000 GO TO STACK; 04392000 END; 04393000 GO TO LOOP; 04394000 XIT: IF IP ! SAVIP THEN FLOG(56); 04395000 IP ~ SAVIP-1; 04396000 EXPR ~ OPTYPE[IT]; 04397000 IF OPTYPE[IT-1] ! 0 THEN FLOG(56); 04398000 IT ~ SAVIT-1; 04399000 EXPRESULT ~ EXPRESLT; 04400000 EXPVALUE ~ EXPV; 04401000 EXPLINK ~ EXPLNK; 04402000 IF DEBUGTOG THEN FLAGROUTINE(" EXPRE","SSION ",FALSE) ; 04403000 END EXPR; 04404000 PROCEDURE FAULT (X); 04404050 VALUE X; 04404100 REAL X; 04404125 BEGIN REAL LINK; LABEL XIT; 04404150 SCAN; IF GLOBALNEXT ! LPAREN THEN BEGIN FLAG(106); GO XIT END; 04404200 SCAN; IF GLOBALNEXT ! ID THEN BEGIN FLAG(66); GO TO XIT END; 04404250 IF X = 1 THEN PDPRT[0,0] ~ PDPRT[0,0] & 1[44:47:1] ELSE 04404275 PDPRT[0,0] ~ PDPRT [0,0] & 1[43 :47:1]; 04404300 EMITOPDCLIT(41); EMITO(DUP); 04404325 IF X = 1 THEN BEGIN EMITL(2); EMITO(XCH); EMITL(1) END 04404350 ELSE EMITL(6); 04404375 EMITO(LND); 04404425 IF X = 2 THEN EMITL(3); 04404435 EMITO(SUB); 04404450 IF X = 2 THEN 04404475 BEGIN EMITO(DUP); EMITL(3); EMITO(SSN) ;EMITO(EQUL); EMITL(2)04404500 ;EMITO(BFC) ; EMITO(DEL);EMITL(2); 04404525 END; 04404550 LINK ~ GET(GETSPACE(FNEXT)); EMITPAIR(LINK.ADDR,ISD); 04404570 IF X = 1 THEN EMITL(30) ELSE EMITL(25); 04404600 EMITO(LND); EMITL(41);EMITO(STD); 04404625 SCAN; IF GLOBALNEXT ! RPAREN THEN FLAG(108); 04404650 SCAN; 04404660 XIT: 04404675 END FAULT; 04404700 PROCEDURE SUBREF; 04405000 BEGIN REAL LINK,INFC; 04406000 REAL ACCIDENT; 04406010 LABEL XIT; 04406020 IF DEBUGTOG THEN FLAGROUTINE(" SUB","REF ",TRUE ) ; 04406025 IF TSSEDITOG THEN IF NAME="ZIP " AND NOT DCINPUT THEN TSSED(NAME,3) ; 04406030 IF NAME = "EXIT " THEN 04407000 BEGIN 04408000 RETURNFOUND ~ TRUE; 04408100 EMITL(1); 04409000 EMITPAIR(16,STD); 04410000 EMITPAIR(10,KOM); 04411000 EMITPAIR( 5, KOM); 04412000 PUT(FNEXT+1, "......"); 04413000 SCAN; 04414000 END ELSE IF NAME="ZIP " AND NOT DCINPUT THEN 04415000 BEGIN 04415010 EMITO(MKS); 04415011 EMITL(0); EMITL(0); % DUMMY FILE AND FORMAT 04415020 EMITPAIR(-1,SSN); 04415021 EMITB(-1,FALSE); LADR1~LAX; ADJUST; DESCREQ~FALSE; 04415030 IF ADR } 4085 THEN BEGIN ADR~ADR+1; SEGOVF END; 04415040 ACCIDENT~PRGDESCBLDR(0,0,ADR.[36:10]+1,NSEG); 04415050 EMITOPDCLIT(19); 04415070 EMITO(GFW); 04415080 LISTART ~ ADR&NSEG[TOSEGNO]; ADJUST;SCAN; 04415090 IF GLOBALNEXT!LPAREN THEN BEGIN FLAG(106);GO TO XIT END; 04415100 SCAN; IF GLOBALNEXT!ID THEN BEGIN FLAG(66); GO TO XIT END; 04415110 LINDX ~ FNEXT; SCAN; XTA ~ GET(LINDX+1); 04415120 IF GLOBALNEXT!RPAREN THEN BEGIN FLAG(108); GO TO XIT END; 04415130 LINDX ~ GETSPACE(LINDX); 04415140 IF T~(LINFA~GET(LINDX)).CLASS!ARRAYID THEN 04415150 BEGIN FLAG(66); GO TO XIT END; 04415160 IF XREF THEN ENTERX(XTA,0&LINFA[15:15:9]); 04415165 EMITPAIR(LADDR~LINFA.ADDR,LOD); 04415170 IF BOOLEAN(LINFA.FORMAL) THEN 04415180 BEGIN 04415190 IF T ~ GET(LINDX+2)<0 THEN EMITOPDCLIT(T.SIZE) 04415200 ELSE EMITNUM(T.SIZE); EMITOPDCLIT(LADDR-1); EMITO(CTF) END 04415210 ELSE EMITNUM(GET(LINDX+2).BASENSIZE); EMITL(18); EMITO(STD);; 04415220 EMITL(LINFA.CLASNSUB&0[44:47:1]); EMITL(19); EMITO(STD); 04415230 BRANCHLIT(LISTART,TRUE); EMITL(19); EMITO(STD); 04415240 EMITO(RTS); ADJUST; 04415250 EMITL(1); EMITO(CHS); EMITL(19); EMITO(STD); 04415260 EMITDESCLIT(19); EMITO(RTS); FIXB(LADR1); DESCREQ~FALSE; 04415270 EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 04415280 EMITL(6); % EDITCODE 6 FOR ZIP 04415290 EMITV(NEED(".FTOUT",INTRFUNID)); SCAN 04415300 END ELSE IF NAME = "OVERFL" THEN FAULT(2) 04415310 ELSE IF NAME = "DVCHK " THEN FAULT(1) 04415320 ELSE 04415330 BEGIN 04416000 LINK ~ NEED(NAME, SUBRID); 04417000 IF XREF THEN ENTERX(XTA,0&GET(LINK)[15:15:5]); 04417100 EMITO(MKS); 04418000 SCAN; 04419000 IF GLOBALNEXT = LPAREN THEN 04420000 BEGIN PARAMETERS(LINK); SCAN END ELSE 04421000 IF NOT BOOLEAN((INFC~GET(LINK+2)).[1:1]) THEN 04422000 PUT(LINK+2,-INFC) ELSE 04423000 IF INFC.NEXTRA ! 0 THEN 04424000 BEGIN XTA ~ GET(LINK+1); FLAG(28) END; 04425000 EMITV(LINK); 04426000 04426500 04426700 END; 04427000 XIT: 04427010 IF DEBUGTOG THEN FLAGROUTINE(" SUB","REF ",FALSE) ; 04427025 END SUBREF; 04428000 PROCEDURE DECLAREPARMS(FNEW); VALUE FNEW; REAL FNEW; 04429000 BEGIN 04430000 REAL I, T, NLABELS, INFA, INFB, INFC; 04431000 IF DEBUGTOG THEN FLAGROUTINE("DECLAR","EPARMS",TRUE ) ; 04431010 INFA ~ GET(FNEW); 04432000 IF INFA.SEGNO ! 0 THEN BEGIN XTA ~ NNEW; FLAG(25) END; 04433000 INFA.SEGNO ~ NSEG; PUT(FNEW,INFA); 04434000 ENTRYLINK[ELX] ~ 0 & FNEW[TOLINK] & NEXTSS[TOADDR]; 04435000 FOR I ~ 1 STEP 1 UNTIL PARMS DO 04436000 BEGIN 04437000 EXTRAINFO[NEXTSS.IR,NEXTSS.IC] ~ PARMLINK[I]; 04438000 NEXTSS ~ NEXTSS-1; 04439000 IF T ~ PARMLINK[I] ! 0 THEN 04440000 BEGIN 04441000 GETALL(T,INFA,INFB,INFC); 04442000 IF BOOLEAN(INFA .FORMAL) THEN 04443000 BEGIN 04443100 IF INFA.SEGNO = ELX THEN 04444000 BEGIN XTA ~ INFB ; FLAG(26) END; 04445000 END ELSE IF (INFA < 0 AND INFA.ADDR < 1024) OR BOOLEAN(INFA.CE)04445100 THEN BEGIN XTA ~ INFB; FLAG(107) END; 04445200 INFA ~ INFA & 1[TOFORMAL] & ELX[TOSEGNO]; 04446000 INFC .BASE ~ I; 04447000 PUT(T,INFA); PUT(T+2,INFC); 04448000 END ELSE NLABELS ~ NLABELS+1; 04449000 END; 04450000 IF NLABELS > 0 THEN 04451000 BEGIN ENTRYLINK[ELX ].CLASS ~ NLABELS; 04452000 IF LABELMOM=0 THEN BEGIN BUMPLOCALS; LABELMOM~LOCALS+1536 END; 04453000 END; 04454000 GETALL(FNEW,INFA,INFB,INFC); 04455000 IF BOOLEAN(INFC.[1:1]) THEN 04456000 BEGIN 04457000 IF INFC.NEXTRA ! PARMS THEN 04458000 BEGIN XTA ~ INFB; FLOG(41); 04459000 PARMS ~ INFC.NEXTRA; 04460000 END; 04461000 T ~ INFC.ADINFO; 04462000 FOR I ~ 1 STEP 1 UNTIL PARMS DO 04463000 IF NOT(PARMLINK[I] = 0 EQV 04464000 EXTRAINFO[(T+I-1).IR,(T+I-1).IC].CLASS = LABELID) THEN 04465000 BEGIN IF PARMLINK[I] = 0 THEN XTA ~ "* " 04466000 ELSE XTA ~ GET(PARMLINK[I]+1); 04467000 FLAG(40); 04468000 END; 04469000 END 04470000 ELSE 04471000 BEGIN 04472000 IF PARMS = 0 THEN INFC ~ -INFC ELSE 04473000 INFC ~ -(INFC & PARMS[TONEXTRA] 04474000 & NEXTEXTRA[TOADINFO]); 04475000 PUT(FNEW+2,INFC); 04476000 FOR I ~ 1 STEP 1 UNTIL PARMS DO 04477000 BEGIN 04478000 EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ 0 & 04479000 (IF PARMLINK[I] = 0 THEN LABELID ELSE 0)[TOCLASS]; 04480000 NEXTEXTRA ~ NEXTEXTRA+1; 04481000 END; 04482000 END; 04483000 IF ELX ~ ELX+1 > MAXEL THEN BEGIN FLAG(128); ELX ~ 0 END; 04484000 IF DEBUGTOG THEN FLAGROUTINE("DECLAR","EPARMS",FALSE) ; 04484010 END DECLAREPARMS; 04485000 PROCEDURE IOLIST(LEVEL); REAL LEVEL; 04486000 BEGIN ALPHA LADR2,T; 04487000 BOOLEAN A; 04487050 INTEGER INDX,I,BDLINK,NSUBS; 04487100 LABEL ROUND,XIT,ERROR,LOOP,SCRAM; 04488000 INTEGER STREAM PROCEDURE CNTNAM(IDEN); VALUE IDEN; 04488100 BEGIN LABEL XIT; 04488200 SI ~ LOC IDEN; SI ~ SI + 3; TALLY ~ 1; 04488300 5(IF SC = " " THEN JUMP OUT TO XIT;SI ~ SI+1;TALLY ~ TALLY+1); 04488400 XIT: CNTNAM ~ TALLY; 04488500 END CNTNAM; 04488600 04489000 04490000 IF DEBUGTOG THEN FLAGROUTINE(" IOL","IST ",TRUE ) ; 04491000 ROUND: DESCREQ ~ TRUE; 04492000 LOCALNAME ~ FALSE; 04492100 IF GLOBALNEXT = SEMI THEN GO TO XIT; 04493000 IF GLOBALNEXT = STAR THEN 04493100 BEGIN IF NOT NAMEDESC THEN 04493150 TV ~ ENTER(0&LISTSID[TOCLASS],LISTID~LISTID+1); 04493200 LOCALNAME ~ TRUE; NAMEDESC ~ TRUE; SCAN; 04493300 END; 04493350 IF GLOBALNEXT = ID THEN 04494000 BEGIN LINDX ~ FNEXT; 04495000 SCAN; XTA ~ GET(LINDX+1); 04496000 IF GLOBALNEXT = EQUAL THEN %RETURN TO CALLER 04497000 BEGIN IF (LINFA~GET(GETSPACE(LINDX))).CLASS ! VARID THEN FLAG(50);04498000 SCRAM: IF (LEVEL ~ LEVEL-1) < 0 THEN FLOG(97); 04498100 GO TO XIT; 04498200 END; 04499000 04500000 IF DATASTMTFLAG AND SPLINK } 0 THEN %DECLARE OWN 04500100 BEGIN 04500200 IF BOOLEAN(GET(LINDX).FORMAL) THEN FLAG(147); 04500300 IF SPLINK>1 THEN 04500310 IF GET(LINDX).ADDR>1023 THEN FLAG(174); 04500320 LINDX ~ GETSPACE(-LINDX); 04500400 IF BOOLEAN(GET(LINDX).EQ) THEN FLAG(168); 04500420 END ELSE LINDX ~ GETSPACE(LINDX); 04500500 IF T ~ (LINFA~GET(LINDX)).CLASS > VARID THEN FLAG(50); 04500600 IF XREF THEN ENTERX(XTA,C2&LINFA[15:15:9]); 04500655 IF GLOBALNAME OR LOCALNAME THEN 04500700 IF NAMEIND~ NAMEIND+1 GTR LSTMAX THEN FLOG(161) 04500725 ELSE NAMLIST[NAMEIND] ~ XTA & CNTNAM(XTA)[9:45:3]; 04500750 IF T = ARRAYID THEN 04501000 IF GLOBALNEXT ! LPAREN THEN 04502000 BEGIN IF SPLINK ! 1 THEN 04503000 BEGIN 04503004 EMITL(0); 04503008 EMITPAIR(LADDR ~ LINFA.ADDR,LOD); 04503010 EMITO(FTC); 04503020 EMITDESCLIT(2); 04503030 EMITO(INX); 04503040 EMITO(LOD); 04503050 END ELSE EMITPAIR(LADDR-LINFA.ADDR,LOD); 04503055 NSUBS ~ (T ~ GET (LINDX+2)).NEXTRA; 04503100 IF GLOBALNAME OR LOCALNAME THEN 04503125 BEGIN 04503150 IF NSUBS GTR SAVESUBS THEN SAVESUBS ~ NSUBS; 04503160 IF NSUBS GTR NAMLIST[0] THEN NAMLIST[0] ~ NSUBS; 04503170 NAMLIST[NAMEIND].[1:8] ~ NSUBS; 04503175 INDX ~ -1; 04503180 INFA ~ GET(NEED(".SUBAR",BLOCKID)).ADDR; 04503190 BDLINK ~ T.ADINFO+1; 04503200 END; 04503225 IF BOOLEAN (LINFA.FORMAL) THEN 04504000 BEGIN 04505000 IF T LSS 0 THEN EMITOPDCLIT(T.SIZE) 04505200 ELSE EMITNUM(T.SIZE); 04506000 EMITOPDCLIT(LADDR-1); 04507000 EMITO(CTF); 04508000 END ELSE EMITNUM(T.BASENSIZE); 04509000 IF GLOBALNAME OR LOCALNAME THEN 04509050 FOR I ~ 1 STEP 1 UNTIL NSUBS DO 04509100 BEGIN IF T ~ EXTRAINFO[(BDLINK~BDLINK-1).IR, 04509150 BDLINK.IC] LSS 0 THEN EMITOPDCLIT(T) 04509200 ELSE EMITNUM(T); 04509250 EMITNUM(INDX ~ INDX+1); 04509300 EMITDESCLIT(INFA); 04509350 EMITO(STD); 04509400 END; 04509450 EMITL(18); EMITO(STD); 04510000 END ELSE 04511000 BEGIN SCAN; 04512000 A ~(IF GLOBALNAME OR LOCALNAME 04513000 THEN SUBSCRIPTS(LINDX,4) ELSE SUBSCRIPTS(LINDX,2)); 04513100 SCAN; 04514000 END 04515000 ELSE EMITN(LINDX); 04516000 IF GLOBALNAME OR LOCALNAME THEN 04516100 BEGIN EMITOPDCLIT(18); EMITNUM(NAMEIND); 04516200 EMITD(43,DIA); EMITD(3,DIB); EMITD(15,TRB); 04516300 EMITL(18); EMITO(STD); 04516350 END; 04516400 EMITL(LINFA.CLASNSUB&0[44:47:1]); 04517000 EMITL(20); EMITO(STD); 04518000 IF ADR > 4083 THEN 04518100 BEGIN ADR~ADR+1; SEGOVF END ; 04518200 BRANCHLIT(LISTART,TRUE); 04519000 EMITL(19); EMITO(STD); 04520000 EMITO(RTS); ADJUST; 04521000 GO TO LOOP; 04522000 END; 04523000 IF GLOBALNEXT = LPAREN THEN % RECURSE ON ( 04524000 BEGIN EMITB(-1,FALSE); 04525000 ADJUST; 04526000 LADR2 ~ (ADR + 1)&LAX[TOADDR]&NSEG[TOSEGNO]; 04527000 SCAN; LEVEL ~ LEVEL + 1; 04528000 IOLIST(LEVEL); 04529000 IF GLOBALNEXT ! EQUAL THEN % PHONY IMP DO 04530000 BEGIN BRANCHES[T ~ LADR2.ADDR] ~ BRANCHX; 04531000 BRANCHX ~ T; 04532000 IF GLOBALNEXT ! RPAREN THEN GO TO ERROR; 04533000 SCAN; GO TO LOOP; 04534000 END; 04535000 IF XREF THEN ENTERX(GET(LINDX+1),1&LINFA[15:15:9]); 04535500 IF LINFA.SUBCLASS > REALTYPE THEN 04536000 BEGIN XTA ~ GET(LINDX + 1); 04537000 FLAG(84); 04538000 END; 04539000 EMITB(-1,FALSE); 04540000 LADR3 ~ LAX; 04541000 FIXB(LADR2.ADDR); 04542000 DESCREQ ~ FALSE; 04543000 SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102); % INITIAL VALUE 04544000 EMITN(LINDX); EMITO(STD); 04545000 EMITB(LADR2,FALSE); 04546000 IF GLOBALNEXT ! COMMA THEN GO TO ERROR; 04547000 ADJUST; 04548000 LADR4 ~ (ADR + 1)&NSEG[TOSEGNO]; 04549000 SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102) ELSE EMITO(GRTR); 04550000 EMITB(LADR2,TRUE); 04551000 EMITB(-1,FALSE); 04552000 LADR5 ~ LAX; 04553000 FIXB(LADR3); 04554000 IF GLOBALNEXT ! COMMA THEN EMITL(1) 04555000 ELSE BEGIN SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102); END; 04556000 EMITV(LINDX); EMITO(ADD); 04557000 EMITN(LINDX); EMITO(SND); 04558000 EMITB(LADR4,FALSE); 04559000 FIXB(LADR5); 04560000 IF GLOBALNEXT = RPAREN THEN SCAN ELSE GO TO ERROR; 04561000 LOOP: IF GLOBALNEXT = SEMI OR GLOBALNEXT = SLASH THEN GO TO XIT; 04562000 IF GLOBALNEXT = RPAREN THEN GO TO SCRAM; 04563000 IF GLOBALNEXT = COMMA THEN 04564000 BEGIN SCAN; 04565000 IF GLOBALNEXT = SEMI THEN GO TO ERROR; 04566000 GO TO ROUND; 04567000 END; 04568000 ERROR: XTA ~ NAME; 04569000 FLAG(94); 04570000 IF GLOBALNEXT = SEMI THEN GO TO XIT; 04571000 SCAN; 04572000 IF GLOBALNEXT = ID THEN GO TO ROUND; 04573000 ERRORTOG ~ TRUE; GO TO XIT; 04574000 END; 04575000 IF GLOBALNEXT = RPAREN THEN GO TO SCRAM ELSE 04576000 IF GLOBALNEXT ! SLASH THEN GO TO ERROR; 04577000 XIT: IF DEBUGTOG THEN FLAGROUTINE(" IOL","IST ",FALSE) ; 04578000 END IOLIST; 04579000 INTEGER PROCEDURE FILECHECK(FILENAME,FILETYPE); 04580000 VALUE FILENAME,FILETYPE; ALPHA FILENAME; INTEGER FILETYPE; 04581000 BEGIN COMMENT THIS PROCEDURE RETURNS THE PRT CELL ALLOCATED TO 04582000 THE FILE FILENAME... A CELL IS CREATED IF NONE EXISTS; 04583000 IF DEBUGTOG THEN FLAGROUTINE(" FILEC","HECK ",TRUE); 04583010 EMITL(IF NOTOPIO THEN 2 ELSE 5); % FOR IO DESCRIPTOR 04584000 IF T ~ GLOBALSEARCH(FILENAME) = 0 THEN % FILE UNDECLARED 04585000 BEGIN MAXFILES ~ MAXFILES + 1; 04586000 BUMPPRT; 04586500 I ~ GLOBALENTER(-0&(FILECHECK~PRTS)[TOADDR] 04587000 &FILEID[TOCLASS],FILENAME)+2; 04588000 INFO[I.IR,I.IC]. LINK ~ FILETYPE; 04589000 END ELSE % FILE ALREADY EXISTS 04590000 FILECHECK ~ GET(T).ADDR; 04591000 IF DEBUGTOG THEN FLAGROUTINE(" FILEC","HECK ",FALSE) ; 04591010 END FILECHECK; 04592000 PROCEDURE INLINEFILE; 04593000 BEGIN COMMENT THIS PROCEDURE GENERATES THE CODE TO BRING UP THE FILE...04594000 IF THE FILE IS AN INTEGER THEN FILECHECK IS CALLED, IF THE FILE 04595000 IS NOT AN INTEGER THEN IN-LINE CODE IS GENERATED FOR OBJECT TIME 04596000 ANALYSIS; 04597000 REAL TEST; 04598000 COMMENT IF LAST INSTRUCTION WAS A LIT CALL THEN WE HAVE SEEN REFERENCE 04599000 TO AN INTEGER FILE ID; 04600000 IF DEBUGTOG THEN FLAGROUTINE(" INLIN","EFILE ",TRUE ) ; 04600010 TEST~ADR ; 04601000 IF EXPR(TRUE)>REALTYPE THEN FLAG(102) 04602000 ELSE IF EXPRESULT=NUMCLASS THEN 04602500 BEGIN XTA~NNEW ; 04603000 IF EXPVALUE}1.0@5 OR EXPVALUE{0.5 THEN FLAG(33) 04603500 ELSE BEGIN 04604000 IF ADR LSTMAX THEN GO TO NUL; 04685500 WSA[TOTAL] ~ I ~ 0; GO TO ROUND; 04686000 END ELSE GO TO ROUND ELSE GO TO NUL1; 04686500 END; 04687500 IF NOT STRINGF THEN 04687510 IF SLCNT > 0 THEN 04687520 IF T = "/" THEN BEGIN SLCNT ~ SLCNT+1; GO TO ROUND; END 04687530 ELSE 04687550 BEGIN WSA[TOTAL] ~ 0 & SLCNT[TOREPEAT] & SLASH[TOCODE]; 04687560 IF NOT STR THEN 04687580 IF REPEAT < 16 AND WSA[TOTAL-1].[42:6] = 0 THEN 04687590 WSA[TOTAL~TOTAL-1] ~ WSA[TOTAL] & SLCNT[42:44:4] 04687600 & 1[46:47:1]; 04687620 COMMAS~DOLLARS~BOOLEAN(SLCNT~0); NCR~BACKNCR(NCR) ; 04687650 GO TO NUL1; 04687655 END; 04687660 IF NOT QF THEN IF T = """ THEN IF STRINGF ~ NOT STRINGF THEN 04688000 BEGIN IF CODE > 4 THEN BEGIN STRINGF ~ FALSE; 04688500 NCR ~ BACKNCR(NCR); GO TO ENDER END; 04689000 SAVTOTAL ~ TOTAL; J~0; I~3; QF ~ TRUE; 04689500 WSA[TOTAL] ~ 0 & HPHASE[TOCODE]; 04690000 GO TO ROUND; 04690500 END ELSE 04691000 BEGIN 04691500 WSA[SAVTOTAL] ~ WSA[SAVTOTAL] & J[TOREPEAT]; 04692000 IF I = 0 THEN TOTAL ~ TOTAL - 1; 04693000 CODE ~ HPHASE; 04693200 GO TO ENDER; 04693500 END; 04694000 IF STRINGF THEN 04694500 BEGIN 04695000 STORECHAR(WSA[TOTAL],I,T); 04695550 J ~ J + 1; QF ~ FALSE; 04696000 IF I ~ I+1 = 8 THEN 04696500 BEGIN 04697000 IF TOTAL ~ TOTAL +1> LSTMAX THEN GO TO NUL; 04697500 I ~ WSA[TOTAL] ~ 0; 04698000 END; 04698500 GO TO ROUND; 04699000 END; 04699500 CASE T OF 04707000 BEGIN 04707500 BEGIN ZF ~ TRUE; % 0 04708000 NUM: DECIMAL ~ 10 | DECIMAL + T; 04708500 IF ASK THEN 04708510 BEGIN FLAG(183); %111-04708515 FL: DO BEGIN NCR~GETCHAR(NCR,T); XTA~T&XTA[12:18:30] END 04708520 UNTIL T!"*" AND T>9 AND T!" " ; 04708525 NCR~BACKNCR(NCR); XTA~BLANKS&XTA[18:12:30] ; 04708530 END 04708535 ELSE 04708540 IF DECIMAL>4090 THEN BEGIN FLAG(172); DECIMAL~1 END ; 04708550 IF CODE = 0 THEN REPEAT ~ DECIMAL 04709500 ELSE IF PF THEN BEGIN IF DECIMAL>WIDTH AND WIDTH!0 AND CODE! 04710000 VPHRASE THEN FLAG(129) END ELSE WIDTH~DECIMAL ; 04710500 GO TO ROUND; 04712000 END; 04712500 GO TO NUM; GO TO NUM; GO TO NUM; % 1 2 3 04713000 GO TO NUM; GO TO NUM; GO TO NUM; % 4 5 6 04713500 GO TO NUM; GO TO NUM; GO TO NUM; % 7 8 9 04714000 ; ; ; ; ; ; % # @ Q : > } 04714500 BEGIN PLUSP ~ TRUE; GO TO ROUND; END; % + 04714600 BEGIN CODE ~ APHASE; GO TO NOEND END; % A 04715000 ; % B 04715500 BEGIN CODE ~ CPHASE; GO TO NOEND END; % C 04715600 BEGIN CODE ~ DPHASE; GO TO NOEND END; % D 04716000 BEGIN CODE ~ EPHASE; GO TO NOEND END; % E 04716500 BEGIN CODE ~ FPHASE; GO TO NOEND END; % F 04717000 BEGIN CODE ~ GPHASE; GO TO NOEND END; % G 04717500 BEGIN IF REPEAT = 0 THEN FLOG(130); % H 04718000 IF ASK THEN BEGIN FLOG(32 ); GO SEMIC END ; 04718100 HF ~ TRUE; I ~ 3; CODE ~ HPHASE; 04719000 WSA[TOTAL] ~ 0 & HPHASE[TOCODE] & REPEAT[TOREPEAT]; 04719500 GO TO ROUND; 04720000 END; 04720500 BEGIN CODE ~ IPHASE; GO TO NOEND END; % I 04721000 BEGIN IF CODE < 11 OR CODE=15 THEN FLOG(134); % . 04721500 IF CODE=0 OR PF THEN FLOG(32) ; 04722000 PF~TRUE; DECIMAL~0; ASK~ZF~FALSE ; 04722500 GO TO ROUND; 04723000 END; 04723500 GO TO RP; % [ 04724000 ; % & 04724500 LP: 04725000 BEGIN IF CODE ! 0 THEN FLOG(32); % ( 04725500 IF ASK THEN REPEAT~4095; IF REPEAT=0 AND ZF THEN FLAG(173) ;04725550 NAMLIST[SAVLASTLP ~ PARENCT ~ PARENCT+1] ~ 0 & TOTAL[TOWIDTH]04726000 &(IF REPEAT{0 AND PARENCT>1 THEN 1 ELSE REPEAT)[TOREPEAT] ; 04726500 IF ASK THEN 04726510 BEGIN ASK~VRB~FALSE ; 04726520 WSA[TOTAL]~32&LPPHRASE[TOCODE]&4095[TOREPEAT] ; 04726530 IF (TOTAL~TOTAL+1)>LSTMAX THEN GO NUL ; 04726540 END ; 04726550 ZF~BOOLEAN(REPEAT~DECIMAL~0) ; 04727500 STR ~ TRUE; 04727600 GO TO ROUND1; 04728000 END; 04728500 ; ; ; % < ~ | 04729000 BEGIN CODE~JPHASE; WIDTH~-1; GO NOEND END ; % J 04729500 BEGIN % K 04730000 IF COMMAS OR CODE!0 THEN BEGIN FLAG(32); COMMAS~TRUE END 04730100 ELSE BEGIN COMMAS~TRUE ; 04730110 KK: DO BEGIN NCR~GETCHAR(NCR,T); XTA~T&XTA[12:18:30] END 04730120 UNTIL T!" " ; 04730125 IF (T<17 OR (T>25 AND T<33) OR (T>42 AND T<50) OR T>57) 04730130 THEN BEGIN FLAG(32) ; 04730135 IF T="*" OR T<10 THEN BEGIN DECIMAL~1; GO FL END ; 04730137 END ; 04730139 NCR~BACKNCR(NCR); XTA~BLANKS&XTA[18:12:30] ; 04730140 END ; 04730145 GO ROUND ; 04730150 END OF K ; 04730160 BEGIN CODE ~ LPHASE; GO TO NOEND; END; % L 04730500 ; ; % M N 04731000 BEGIN CODE ~ OPHASE; GO TO NOEND; END; % O 04731500 BEGIN WSA[TOTAL] ~ 0 & PPHASE[TOCODE] % P 04732000 & REAL(VRB)[42:47:1] 04732100 & REAL(MINUSP)[TOSIGN] & REPEAT[TOWIDTH]&1[TOREPEAT]; 04732500 MINUSP ~ PLUSP ~ FALSE; 04733000 IF (DECIMAL = 0 AND NOT ZF) THEN FLOG(131); 04733500 GO TO NUL1; 04734500 END; 04735000 ; ; % Q R 04735500 BEGIN IF DOLLARS OR CODE!0 THEN FLAG(32) % $ 04735600 ELSE BEGIN DOLLARS~TRUE; GO KK END ; 04735610 DOLLARS~TRUE; GO ROUND ; 04735620 END OF DOLLAR SIGN ; 04735630 IF NOT ASK THEN % * 04735700 BEGIN 04735710 IF ZF OR DECIMAL NEQ 0 THEN FLAG(183); DECIMAL:=4095; %111-04735715 IF CODE=0 THEN REPEAT~DECIMAL 04735720 ELSE IF NOT PF THEN WIDTH~DECIMAL ; 04735730 VRB := ASK := LISTEL := TRUE; GO ROUND; %101-04735740 END ELSE BEGIN DECIMAL:=4095; FLAG(183); GO FL END ; %111-04735750 BEGIN MINUSP ~ TRUE; GO TO ROUND; END; % - 04736000 RP: 04736500 BEGIN IF FEELD THEN BEGIN NCR ~ BACKNCR(NCR); % ) 04737000 GO TO ENDER; END; 04737500 IF DECIMAL ! 0 THEN FLAG(32); 04737600 I ~ IF PARENCT = 1 THEN IF SAVLASTLP > 1 THEN 2 ELSE 1 04738500 ELSE PARENCT; 04739000 WSA[TOTAL]~(J~NAMLIST[I])&(TOTAL+1-J~J.[18:12])[TOLINK] 04739500 & (IF PARENCT ~ PARENCT-1 = 0 THEN 77 ELSE 0)[TODECIMAL]; 04740000 IF WSA[J].[1:5]=LPPHRASE AND PARENCT!0 THEN 04740100 BEGIN WSA[J].[18:12]~TOTAL-J; WSA[TOTAL].[18:12]~TOTAL-J ;04740110 END ; 04740115 NAMLIST[I].[6:12] ~ 0; 04740500 CODE ~ HPHASE; 04740600 GO TO NUL1; 04742000 END; 04742500 ; ; % ; LEQ 04743000 GO TO ROUND; % BLANKS 04743500 BEGIN SLCNT ~ 1; % / 04744000 SL: IF CODE=0 THEN IF ASK OR ZF OR DECIMAL!0 THEN 04744100 BEGIN FLAG(32); ASK~ZF~BOOLEAN(DECIMAL~0) END ; 04744110 IF CODE<5 THEN IF T="," THEN GO ROUND1 ELSE GO ROUND ELSE GO 04744500 ENDER ; 04744505 END; 04745000 ; % S 04745500 BEGIN IF REPEAT ! 0 THEN FLAG(32); % T 04746000 CODE ~ TPHASE; 04746050 GO TO NOEND; 04746100 END; 04746150 ; % U 04746500 BEGIN VRB~TRUE; CODE~VPHRASE; WIDTH~-1; GO NOEND END ; % V 04746750 ; % W 04746800 BEGIN IF REPEAT = 0 THEN FLOG(130); % X 04747000 IF STR THEN 04747200 NEWWD: WSA[TOTAL] ~ 0 & XPHASE[TOCODE] & REPEAT[TOWIDTH] 04747400 & 1[TOREPEAT] 04747600 & REAL(VRB)[42:47:1] 04747700 ELSE 04747800 BEGIN 04748000 IF (J~WSA[TOTAL-1]).[42:6]>0 OR (I~J.[1:5])=RTPARN 04748800 OR (REPEAT}32 AND I!XPHASE) THEN GO NEWWD ; 04749000 IF I=XPHASE AND (I~J.[18:12]+REPEAT){4090 THEN 04749200 WSA[TOTAL~TOTAL-1] ~ J & I[TOWIDTH] 04749400 ELSE IF REPEAT } 32 THEN GO TO NEWWD 04749600 ELSE WSA[TOTAL~TOTAL-1] ~ J & REPEAT[TONUM] 04749800 & 1[TOCNTRL]; 04750000 END; 04751000 GO TO NUL1; 04752000 END; 04752500 ; ; % Y Z 04753000 GO SL ; % , 04753500 GO TO LP; % % 04754000 ; ; ; % ! = ] " 04754500 END OF CASE STATEMENT; 04755000 FLOG(132); % ILLEGAL CHARACTER; 04755500 GO TO FALL; 04756000 ENDER: IF CODE > 4 THEN 04756500 BEGIN IF WIDTH=0 THEN FLAG(130) ; 04757000 IF CODE=VPHRASE THEN 04757400 BEGIN 04757410 IF WIDTH=-1 THEN IF PF THEN FLAG(130)ELSE WIDTH~ 04757420 DECIMAL~4094 ELSE 04757425 IF NOT PF THEN DECIMAL~4094 ; 04757430 END 04757440 ELSE 04757450 IF CODE > 10 AND CODE ! 15 THEN 04757500 IF (DECIMAL = 0 AND NOT ZF) OR NOT PF THEN FLAG(133) 04758000 ELSE ELSE DECIMAL ~ 0; 04758100 IF REPEAT=0 THEN REPEAT~1 ; 04758400 IF WIDTH=-1 THEN WIDTH~0 ; 04758410 WSA[TOTAL] ~ 0 & CODE[TOCODE] & WIDTH[TOWIDTH] 04758500 & REPEAT[TOREPEAT] & DECIMAL[TODECIMAL] 04759000 & REAL(COMMAS) [44:47:1] 04759100 & REAL(VRB)[42:47:1] 04759150 & REAL(DOLLARS)[45:47:1]; 04759200 END ELSE IF DECIMAL ! 0 THEN FLAG(32); 04760000 NUL1: IF PLUSP THEN FLAG(164); 04760500 IF CODE!VPHRASE THEN 04760550 BEGIN 04760560 IF DOLLARS AND(CODE < 9 OR CODE > 14) THEN FLAG(166); 04760600 IF COMMAS AND NOT(CODE = 10 OR CODE = 12 OR CODE = 9) 04760700 THEN FLAG(165); 04760800 END; 04760850 VRB~ 04760890 ERRORTOG ~ FEELD ~ PF ~ PLUSP ~ DOLLARS ~ COMMAS ~ STR ~ FALSE; 04760900 IF CODE = HPHASE THEN STR ~ TRUE; 04760940 CODE ~ REPEAT ~ WIDTH ~ 0; 04760980 XTA ~ BLANKS; 04761000 GO TO FALL; 04761500 NOEND: IF FEELD THEN FLAG(32); 04762000 IF CODE ! TPHASE THEN LISTEL ~ TRUE ELSE REPEAT ~ 1; 04762500 IF REPEAT=0 AND ZF THEN FLAG(173) ; 04762510 FEELD ~ TRUE; 04763000 FALL: IF MINUSP THEN BEGIN FLAG(32); MINUSP ~ FALSE END; 04763500 ASK~ZF~FALSE ; 04764000 NUL: DECIMAL ~ 0; 04764500 IF PARENCT = 0 THEN BEGIN SCN ~ 1; GO TO SEMIC END; 04765000 IF CODE < 5 THEN 04765500 IF TOTAL ~ TOTAL+1 > LSTMAX THEN 04766000 BEGIN FLOG(78);TOTAL ~ TOTAL-2; GO TO SEMIC; END; 04766500 GO TO ROUND; 04767000 NOPLACE: IF(DCINPUT OR FREEFTOG) AND (STRINGF OR HF) THEN FLOG(150); 04767500 IF TSSEDITOG THEN IF (STRINGF OR HF) AND NOT DCINPUT 04768000 THEN TSSED(XTA,1); 04769000 IF CONTINUE THEN IF READACARD THEN 04769500 BEGIN IF LISTOG THEN PRINTCARD; GO TO ROUND; END; 04769500 SCN ~ 0; NEXT ~ SEMI; 04770000 SEMIC: 04770500 IF SCN = 1 THEN SCAN; 04771000 IF STRINGF THEN FLAG(22); 04771500 IF NOT LISTEL THEN WSA[0] ~ 0; 04772000 IF PARENCT ! 0 THEN FLAG(IF PARENCT < 0 THEN 9 ELSE 8); 04772500 IF D ! 0 THEN PRTSAVER(D,TOTAL+1,WSA); 04772600 IF DEBUGTOG THEN BEGIN 04772605 WRITE(LINE,FM) ; 04772610 FOR I~0 STEP 1 UNTIL TOTAL DO BEGIN 04772615 WRITE(LINE,[13]//,I,(J~WSA[I]).[1:5],J.[6:12],J.[18:12],J.[30:12], 04772620 J.[41:1],J.[42:4],J.[42:5],J.[44:1],J.[45:1], 04772625 J.[46:1],J.[46:2],J.[47:1]) ; 04772630 IF J.[1:5]=2 THEN I~I+(J.[6:12]+2).[36:9] ; 04772635 END ; 04772640 WRITE(LINE[DBL]) ; 04772645 END OF DEBUGSTUFF ; 04772650 END FORMATER; 04773000 PROCEDURE EXECUTABLE; 04773010 BEGIN LABEL XIT; REAL T, J, TS, P; 04773020 IF SPLINK < 0 THEN FLAG(12); 04773030 IF LABL = BLANKS THEN GO TO XIT; 04773040 IF T ~ SEARCH(XTA ~ LABL) = 0 THEN 04773050 T ~ ENTER(-0 & LABELID[TOCLASS] & (ADR+1)[TOADDR] & 04773060 NSEG[TOSEGNO], LABL) ELSE 04773070 BEGIN IF (P ~ GET(T)).CLASS ! LABELID THEN 04773080 BEGIN FLAG(144); GO TO XIT END; 04773090 IF P < 0 THEN BEGIN FLAG(20); GO TO XIT END; 04773100 TS ~ P.ADDR; 04773110 WHILE TS ! 0 DO 04773120 BEGIN J ~ GIT(TS); FIXB(TS+10000); TS ~ J END; 04773130 PUT(T, P~-P & (ADR+1)[TOADDR] & NSEG[TOSEGNO]); 04773140 IF (T ~ GET(T+2)).BASE ! 0 THEN 04773150 T ~ PRGDESCBLDR(2, T.BASE, (ADR+1).[36:10], NSEG); 04773160 END; 04773170 IF XREF THEN ENTERX(LABL,1&LABELID[TOCLASS]); 04773175 XIT: 04773180 END EXECUTABLE; 04773190 PROCEDURE IOCOMMAND(N); VALUE N; REAL N; 04774000 COMMENT N COMMAND 04775000 0 READ 04776000 1 WRITE 04777000 2 PRINT 04778000 3 PUNCH 04779000 4 BACKSPACE 04780000 04781000 04782000 7 DATA; 04783000 BEGIN LABEL XIT,SUCH,LISTER,NOFORM,FORMER,WRAP,DAAT,NF; 04784000 LABEL LISTER1; 04784200 BOOLEAN SUCHTOG, RDTRIN, FREEREAD; 04785000 BOOLEAN FORMARY, NOFORMT; 04785020 BOOLEAN NAMETOG; 04785050 DEFINE DATATOG = DATASTMTFLAG#; 04785100 REAL T, ACCIDENT, EDITCODE; 04786000 REAL DATAB; 04786100 PROCEDURE ACTIONLABELS(UNSEEN); VALUE UNSEEN; BOOLEAN UNSEEN; 04787000 BEGIN LABEL EOF,ERR,RATA,XIT,ACTION,MULTI; 04788000 BOOLEAN BACK,GOTERR,GOTEOF; 04789000 IF UNSEEN THEN SCAN; 04790000 EOF: IF GOTEOF THEN GO TO MULTI; 04791000 IF BACK ~ NAME = "END " THEN GO TO ACTION; 04792000 ERR: IF GOTERR THEN GO TO MULTI; 04793000 IF NAME ! "ERR " THEN IF GOTEOF THEN 04794000 BEGIN MULTI: XTA ~ NAME; FLOG(137); 04795000 GO TO XIT; 04796000 END ELSE GO TO RATA; 04797000 ACTION: SCAN; 04798000 IF NEXT = EQUAL THEN SCAN ELSE GO TO RATA; 04799000 IF NEXT ! NUM THEN GO TO RATA; 04800000 IF XREF THEN ENTERX(NAME,0&LABELID[TOCLASS]); 04800100 IF BACK THEN NX1 ~ NAME ELSE NX2 ~ NAME; 04801000 SCAN; IF NEXT = RPAREN THEN GO TO XIT; 04802000 IF NEXT = COMMA THEN SCAN ELSE GO TO RATA; 04803000 IF BACK THEN 04804000 BEGIN BACK ~ NOT ( GOTEOF ~ TRUE); 04805000 GO TO ERR; 04806000 END; 04807000 GOTERR ~ TRUE; 04808000 GO TO EOF; 04809000 RATA: XTA ~ NAME; FLOG(0); 04810000 XIT: 04811000 END ACTIONLABELS; 04812000 IF DEBUGTOG THEN FLAGROUTINE(" IOCOM","MAND ",TRUE ); 04812010 EODS~N!7 ; 04812020 C2 ~ IF N = 0 OR N = 7 THEN 1 ELSE 0; 04812050 SCAN; IF NEXT = SEMI THEN BEGIN FLOG(0); GO TO XIT END; 04813000 IF N = 7 THEN 04814000 BEGIN DATATOG ~ TRUE; 04815000 IF LOGIFTOG THEN FLAG(101); 04816000 LABL ~ BLANKS; 04816100 IF SPLINK } 0 THEN %NOT BLOCK DATA STMT 04816110 BEGIN 04816120 IF DATAPRT=0 THEN BEGIN 04816130 DATAPRT~PRTS~PRTS+1; ADJUST; 04816135 DATASTRT~(ADR+1)&NSEG[TOSEGNO] END 04816136 ELSE FIXB(DATALINK); 04816137 EMITOPDCLIT(DATAPRT); EMITO(LNG); 04816140 EMITB(-1, TRUE); DATAB ~ LAX; 04816150 END; 04816160 GO TO DAAT; 04817000 END; 04818000 EXECUTABLE; 04819000 EMITO(MKS); 04820000 IF N = 4 THEN 04825100 BEGIN 04825200 INLINEFILE; 04826000 BEGIN EMITL(0); EMITL(0); EMITL(0); EMITL(0); 04832000 EMITL(5); EMITL(0); EMITL(0); 04833000 EMITV(NEED(".FBINB",INTRFUNID)); 04834000 END; 04835000 GO TO XIT; 04836000 END; 04837000 EDITCODE ~ NX1 ~ NX1 ~ 0; 04838000 IF RDTRIN ~ 04839000 N = 0 THEN IF NEXT = LPAREN THEN GO TO SUCH 04840000 ELSE EMITDESCLIT(FILECHECK(".5 ",2+17|REAL %503-04841000 (REMOTETOG))) 04841100 ELSE IF N = 1 THEN IF NEXT ! LPAREN THEN FLAG(33) 04842000 ELSE GO TO SUCH 04843000 ELSE IF N = 2 THEN %503-04844000 EMITDESCLIT(FILECHECK(".6 ",2+17|REAL %503-04845000 (REMOTETOG))) 04845100 04846000 ELSE EMITDESCLIT(FILECHECK(".PUNCH",0)); 04847000 IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 04848000 GO TO FORMER; 04849000 SUCH: SCAN; RANDOMTOG~SUCHTOG~TRUE; INLINEFILE ; 04850000 RANDOMTOG~FREEREAD~FALSE ; 04850100 IF NEXT = EQUAL THEN % RANDOM KEY 04852000 BEGIN SCAN; 04853000 IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 04854000 IF RDTRIN THEN EMITPAIR(1,ADD); 04855000 END ELSE IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 04856000 IF NEXT = RPAREN THEN GO TO NF; 04857000 IF NEXT ! COMMA THEN BEGIN FLOG(114); GO TO XIT END; 04858000 SCAN; 04859000 IF NEXT = ID THEN 04860000 IF NAME = "ERR " OR NAME = "END " THEN 04861000 BEGIN ACTIONLABELS(FALSE); 04862000 NF: IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 04863000 EMITL(0); 04863100 NOFORMT ~ TRUE; 04863500 SCAN; GO TO NOFORM; 04864000 END; 04865000 FORMER: IF ADR } 4085 THEN 04866000 BEGIN ADR ~ ADR+1; SEGOVF END; 04866100 IF NEXT = NUM THEN % FORMAT NUMBER 04866200 BEGIN EDITCODE ~ 1; 04867000 IF TEST ~ LBLSHFT(NAME) { 0 THEN 04868000 BEGIN FLAG(135); GO TO LISTER END; 04869000 IF I ~ SEARCH(TEST) = 0 THEN % NEVER SEEN 04870000 OFLOWHANGERS(I~ENTER(0&FORMATID[TOCLASS], TEST)) ELSE 04871000 IF GET(I).CLASS ! FORMATID THEN 04871100 BEGIN FLAG(143); GO TO LISTER END; 04871200 IF XREF THEN ENTERX(TEST,0&FORMATID[TOCLASS]); 04873000 IF GET(I).ADDR = 0 THEN 04874000 BEGIN EMITLINK((INFC ~ GET(I + 2)).BASE); 04875000 PUT(I + 2,INFC&ADR[TOBASE]); 04876000 EMITL(0); EMITL(0); EMITO(NOP); 04877000 END ELSE 04878000 BEGIN EMITL(GET(I+ 2).BASE); 04879000 EMITPAIR(GET(I).ADDR,LOD); 04880000 END; 04881000 GO TO LISTER; 04882000 END ELSE IF RDTRIN THEN IF(FREEREAD := NEXT=SLASH) THEN GO TO LISTER 04883000 ELSE BEGIN IF NEXT NEQ ID THEN BEGIN FLOG(116);GO TO XIT; END;END 04883100 ELSE IF NEXT NEQ ID THEN 04883150 BEGIN IF NEXT = STAR THEN 04883200 BEGIN NAMEDESC := TRUE; GLOBALNAME := TRUE; 04883300 TV := ENTER(0&LISTSID[TOCLASS],LISTID:=LISTID+1); 04883350 SCAN; 04883400 END; 04883450 IF NEXT = LPAREN THEN 04883500 BEGIN SCAN; IF EXPR(TRUE) GTR REALTYPE THEN FLAG(120) ; 04883550 SCAN; END ELSE EMITL(0); 04883600 IF GLOBALNAME AND (FREEREAD := NEXT = SLASH) OR FREEREAD THEN 04883650 GO TO LISTER ELSE BEGIN FLOG(110); GO TO XIT; END; 04883700 END; 04883750 GETALL(I ~ FNEXT,INFA,INFB,INFC); 04884000 IF T ~ INFA.CLASS = ARRAYID THEN % FORMAT ARRAY 04885000 BEGIN EDITCODE ~ 1; 04886000 FORMARY ~ TRUE; 04886050 T ~ EXPR(FALSE); 04886100 ADR ~ ADR-1; % ELIMINATE XCH EMITTED BY EXPR 04887000 IF EXPRESULT ! ARRAYID THEN FLOG(116); 04887100 GO TO LISTER1; % SCAN ALREADY DONE IN EXPR 04888000 END ELSE 04889000 IF T = NAMELIST THEN 04890000 BEGIN NAMETOG := TRUE; 04890100 IF INFA.ADDR = 0 THEN % REFERENCED, NOT DEF 04891000 BEGIN EMITLINK(INFC.BASE); 04892000 PUT(I+ 2,(INFC ~ INFC&ADR[TOBASE])); 04893000 EMITL(0); EMITL(0); EMITO(NOP); 04894000 END ELSE 04895000 BEGIN EMITL(INFC.BASE); 04896000 EMITPAIR(INFA.ADDR,LOD); 04897000 END 04898000 END 04898100 ELSE IF T = UNKNOWN THEN % ASSUME NAMELIST 04899000 BEGIN PUT(I,(INFA ~ INFA&NAMELIST[TOCLASS])); 04900000 NAMETOG := TRUE; 04900100 OFLOWHANGERS(I); 04901000 EMITLINK(0); PUT(I + 2,INFC&ADR[TOBASE]); 04902000 EMITL(0); EMITL(0); EMITO(NOP); 04903000 END ELSE BEGIN XTA ~ INFB; FLOG(116); GO TO XIT END; 04904000 SCAN; 04905000 IF NEXT = COMMA THEN ACTIONLABELS(TRUE); 04906000 IF SUCHTOG THEN 04907000 IF NEXT ! RPAREN THEN FLOG(108) ELSE SCAN; 04908000 IF NEXT ! SEMI THEN BEGIN FLOG(118); GO TO XIT END; 04909000 EMITL(0); EDITCODE ~ 4; EMITOPDCLIT(7); EMITO(FTC); 04910000 GO TO WRAP; 04911000 LISTER: SCAN; 04912000 IF FREEREAD THEN IF NOT RDTRIN THEN 04912100 BEGIN IF NEXT ! SLASH THEN EMITO(SSN) ELSE SCAN; 04912200 IF NEXT = LPAREN THEN 04912300 BEGIN SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(120);SCAN 04912400 END ELSE EMITL(0); 04912500 END; 04912600 LISTER1: 04912700 IF SUCHTOG THEN 04913000 BEGIN IF NEXT = COMMA THEN ACTIONLABELS(TRUE); 04914000 IF NEXT = RPAREN THEN SCAN ELSE BEGIN FLOG(108); GO TO XIT END; 04915000 END ELSE IF NEXT=COMMA THEN SCAN ELSE IF RDTRIN THEN 04916000 IF NEXT!SEMI THEN FLOG(114); 04916100 NOFORM: IF NEXT=SEMI THEN 04917000 BEGIN IF FREEREAD THEN FLOG(061) ELSE EMITL(0); GO TO WRAP END; 04917100 IF (NEXT NEQ LPAREN) AND (NEXT NEQ ID) AND (NEXT NEQ STAR) THEN 04918000 GO TO XIT; 04918100 EDITCODE ~ EDITCODE + 2; 04919000 DAAT: EMITB(-1,FALSE); LADR1 ~ LAX; ADJUST; DESCREQ ~ TRUE; 04920000 IF ADR } 4085 THEN 04920100 BEGIN ADR ~ ADR+1; SEGOVF; ADJUST END; 04920200 ACCIDENT ~ PRGDESCBLDR(0,0,ADR.[36:10] + 1,NSEG); 04921000 EMITOPDCLIT(19); EMITO(GFW); 04922000 LISTART ~ ADR&NSEG[TOSEGNO]; ADJUST; 04923000 LA ~ 0; IOLIST(LA); 04924000 EMITL(1); EMITO(CHS); EMITL(19); EMITO(STD); 04925000 EMITDESCLIT(19); EMITO(RTS); 04926000 FIXB(LADR1); DESCREQ ~ FALSE; 04927000 IF DATATOG THEN 04928000 BEGIN DATASET; 04929000 IF NEXT = SLASH THEN SCAN ELSE 04930000 BEGIN FLOG(110); GO TO XIT END; 04931000 IF LSTA = 0 THEN BEGIN BUMPPRT; LSTA~PRTS END; 04932000 IF (LSTMAX - LSTI) { LSTS THEN 04933000 BEGIN WRITEDATA(LSTI,NXAVIL ~ NXAVIL + 1,LSTP); 04934000 LSTA ~ PRGDESCBLDR(1,LSTA,0,NXAVIL); 04935000 LSTI ~ 0; BUMPPRT; LSTA~PRTS; 04936000 END; 04937000 MOVEW(LSTT,LSTP[LSTI],(LSTS ~ LSTS + 1).[36:6],LSTS); 04938000 EMITO(MKS); EMITL(LSTI); EMITPAIR(LSTA,LOD); 04939000 LSTI ~ LSTI + LSTS; 04940000 EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 04941000 EMITL(6); EMITL(0); EMITL(0); 04942000 EMITV(NEED(".FBINB",INTRFUNID)); 04943000 IF NEXT = COMMA THEN 04944000 BEGIN SCAN; GO TO DAAT END; 04945000 IF SPLINK } 0 THEN BEGIN 04946000 EMITB(-1,FALSE); DATALINK~LAX; 04946500 FIXB(DATAB) END; 04946600 GO TO XIT; 04947000 END; 04948000 EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 04949000 WRAP: IF NOT FREEREAD AND NOT NAMETOG THEN EMITL(EDITCODE); 04950000 IF RDTRIN THEN 04951000 BEGIN IF NX1 = 0 THEN EMITL(0) ELSE EMITLABELDESC(NX1); 04952000 IF NX2 = 0 THEN EMITL(0) ELSE EMITLABELDESC(NX2); 04953000 IF FREEREAD THEN EMITV(NEED(".FREFR", INTRFUNID)) 04954000 ELSE IF NAMETOG THEN EMITV(NEED(".FINAM",INTRFUNID)) 04954050 ELSE IF FORMARY THEN EMITV(NEED(".FTINT",INTRFUNID)) 04954100 ELSE IF NOFORMT THEN EMITV(NEED(".FBINB",INTRFUNID)) 04954150 ELSE EMITV(NEED(".FTNIN",INTRFUNID)); 04954200 END ELSE 04955000 IF FREEREAD THEN 04956000 BEGIN 04956005 IF NAMEDESC THEN 04956010 BEGIN 04956020 PRTSAVER(TV,NAMEIND+1,NAMLIST); 04956040 EMITL(GET(TV+2).BASE); 04956100 EMITPAIR(GET(TV).ADDR,LOD); 04956200 IF NAMLIST[0] = 0 THEN EMITL(0) 04956500 ELSE EMITPAIR(GET(GLOBALSEARCH(".SUBAR")).ADDR,LOD); 04956550 NAMLIST[0] := NAMEIND := 0; 04956600 END ELSE BEGIN EMITL(0);EMITL(0);EMITL(0);END; 04956650 EMITV(NEED(".FREWR",INTRFUNID)) 04956700 END ELSE IF NAMETOG THEN EMITV(NEED(".FONAM",INTRFUNID)) 04956750 ELSE IF FORMARY THEN EMITV(NEED(".FTOUT",INTRFUNID)) 04956800 ELSE BEGIN 04956900 IF NX1=0 THEN EMITL(0) ELSE EMITLABELDESC(NX1); 04956910 IF NX2=0 THEN EMITL(0) ELSE EMITLABELDESC(NX2); 04956920 IF NOFORMT THEN EMITV(NEED(".FBINB",INTRFUNID)) ELSE 04956925 EMITV(NEED(".FTNOU",INTRFUNID)); 04956930 END; 04956940 XIT: 04957000 IF NAMEDESC THEN IF RDTRIN THEN FLAG(159) 04957050 ELSE IF NOT FREEREAD THEN FLAG(160); 04957055 DATATOG := FALSE; NAMEDESC := FALSE; GLOBALNAME := FALSE; 04957100 IF DEBUGTOG THEN FLAGROUTINE(" IOCOM","MAND ",FALSE); 04957110 END IOCOMMAND; 04958000 PROCEDURE STMTFUN(LINK); VALUE LINK; REAL LINK; 04959000 BEGIN 04960000 DEFINE PARAM = LSTT#; 04961000 REAL SAVEBRAD, I; 04962000 REAL INFA, INFC, NPARMS, TYPE, PARMLINK, BEGINSUB, RETURN; 04963000 LABEL XIT,TIX ; 04964000 IF SPLINK < 0 THEN FLAG(12); 04964100 LABL ~ BLANKS; 04964200 FILETOG ~ TRUE; % PREVENTS SCANNER FROM ENTERING IDS IN INFO 04965000 IF XREF THEN ENTERX(GET(LINK+1),0&STMTFUNID[TOCLASS] 04965100 &(GET(LINK))[21:21:3]); 04965200 DO 04966000 BEGIN 04967000 SCAN; 04968000 IF NEXT ! ID THEN BEGIN FLOG(107); GO TO XIT END; 04969000 PARAM[NPARMS~NPARMS+1] ~ NAME; 04970000 SCAN; 04971000 END UNTIL NEXT ! COMMA; 04972000 IF NEXT ! RPAREN THEN FLOG(108) ELSE SCAN; 04973000 04974000 IF NEXT ! EQUAL THEN BEGIN FLOG(104); GO TO XIT END; 04975000 EMITB(-1,FALSE); SAVEBRAD ~ LAX; % BRANCH AROUND ST FUN 04976000 ADJUST; 04977000 BEGINSUB ~ ADR+1; 04978000 BUMPLOCALS; EMITPAIR(RETURN~LOCALS+1536,STD); 04979000 FOR I ~ NPARMS STEP -1 UNTIL 1 DO 04980000 BEGIN 04981000 IF T ~ SEARCH(PARAM[I]) ! 0 THEN 04982000 TYPE ~ GET(T).SUBCLASS ELSE 04983000 IF T~PARAM[I].[12:6] < "I" OR T > "N" THEN 04984000 TYPE ~ REALTYPE ELSE TYPE ~ INTYPE; 04985000 EMITSTORE( ENTER(0&VARID[TOCLASS]&1[TOTYPE] 04986000 &TYPE[TOSUBCL], PARAM[I]), TYPE); 04987000 IF XREF THEN ENTERX(NAME,0&VARID[TOCLASS]&TYPE[TOSUBCL]); 04987100 END; 04988000 PARMLINK ~ NEXTINFO-3; 04989000 GETALL(LINK, INFA, XTA, INFC); 04990000 FILETOG ~ FALSE; 04991000 SCAN; 04992000 IF (TYPE~(INFA~GET(LINK)).SUBCLASS)=LOGTYPE OR TYPE=COMPTYPE OR04993000 (I~EXPR(TRUE))=LOGTYPE OR I=COMPTYPE THEN 04993500 BEGIN IF I!TYPE THEN FLAG(139); GO TIX END ; 04993510 IF TYPE=REALTYPE OR TYPE=INTYPE THEN 04993530 BEGIN 04993540 IF I=DOUBTYPE THEN BEGIN EMITO(XCH); EMITO(DEL) END; 04993550 IF TYPE=INTYPE THEN IF I!INTYPE THEN EMITPAIR(1,IDV) ; 04993560 GO TIX ; 04993570 END ; 04993580 IF I!DOUBTYPE THEN EMITPAIR(0,XCH) ; 04993590 TIX: 04993595 EMITOPDCLIT(RETURN) ; 04994000 EMITO(GFW); 04995000 FIXB(SAVEBRAD); 04996000 IF INFA.CLASS ! UNKNOWN THEN FLAG(140); 04997000 PUT(LINK, -INFA & 1[TOTYPE] & NSEG[TOSEGNO] 04998000 & STMTFUNID[TOCLASS] & BEGINSUB[TOADDR]); 04999000 PUT(LINK+2, -(0 & NPARMS[TONEXTRA] & ADR[TOBASE] 05000000 & PARMLINK[36:36:12])); 05001000 PARMLINK ~ PARMLINK+4; 05002000 FOR I ~ 1 STEP 1 UNTIL NPARMS DO 05003000 PUT(PARMLINK ~ PARMLINK-3, "......"); 05004000 XIT: 05005000 FILETOG ~ FALSE; 05006000 END STMTFUN; 05007000 PROCEDURE ASSIGNMENT; 05008000 BEGIN 05009000 LABEL XIT; 05010000 BOOLEAN CHCK; 05010500 BOOLEAN I; 05010600 IF DEBUGTOG THEN FLAGROUTINE(" ASSIG","NMENT ",TRUE ) ; 05011000 FX1 ~ FNEXT; 05012000 SCAN; 05013000 IF NEXT = LPAREN THEN 05014000 BEGIN 05015000 CHCK~TRUE; 05015500 IF GET(FX1).CLASS = UNKNOWN THEN 05016000 IF EODS THEN 05017000 BEGIN XTA ~ GET(FX1+1); FLOG(035) ; 05017010 PUT(FX1,GET(FX1) & ARRAYID[TOCLASS]) ; 05017020 PUT(FX1+2,GET(FX1+2) & 1[TONEXTRA]) ; 05017030 END 05017040 ELSE BEGIN STMTFUN(FX1); GO TO XIT END ; 05017050 IF XREF THEN ENTERX(GET(FX1+1),1&GET(FX1) [15:15:9]); 05017055 EODS ~ TRUE ; 05017060 EXECUTABLE; 05017100 SCAN; 05018000 I ~ SUBSCRIPTS(FX1,2); 05019000 SCAN; 05020000 END ELSE 05021000 BEGIN 05022000 EODS~TRUE ; 05022010 EXECUTABLE; 05022100 IF T ~ GET(FX1).CLASS = ARRAYID THEN 05023000 BEGIN XTA ~ GET(FX1+1); FLAG(74) END; 05024000 MOVEW(ACCUM[1],HOLDID[0],0,3); 05025000 IF XREF THEN IF HOLDID[0].[12:12] ! "DO" THEN 05025100 ENTERX(GET(FX1+1),1&GET(FX1)[21:21:3]&VARID[TOCLASS]); 05025200 END; 05026000 IF NEXT ! EQUAL THEN BEGIN FLAG(104); GO TO XIT END; 05027000 SCAN; 05028000 IF NEXT=SEMI OR NEXT=COMMA THEN BEGIN FLOG(0); GO TO XIT; END; 05028010 FX2 ~ EXPR(TRUE); 05029000 IF NEXT NEQ COMMA THEN IF HOLDID[0] = "DO" THEN IF XREF THEN 05029200 ENTERX(HOLDID[0] ,1&GET(FX1)[21:21:3]&VARID[TOCLASS]); 05029400 IF NEXT = COMMA THEN IF CHCK THEN FLOG(56) ELSE 05030000 IF HOLDID[0].[12:12] ! "DO" THEN FLOG(56) ELSE 05030100 BEGIN 05031000 IF LOGIFTOG THEN FLAG(101); 05032000 IF FX2 > REALTYPE THEN FLAG(102); 05033000 IF DT ~ DT+1 > MAXDOS THEN BEGIN DT ~ 1; FLAG(138) END; 05034000 EMITN(FX1~ CHECKDO); 05035000 EMITO(STD); 05036000 SCAN; 05037000 IF NEXT=SEMI THEN BEGIN FLAG(36); GO TO XIT END; 05038000 IF (ACCUM[0] = ", " OR ACCUM[0] = "; ") AND 05038900 GLOBALNEXT=NUM AND ABS(FNEXT) > 1023 THEN 05039000 BEGIN 05040000 IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 05041000 IDINFO:=REALID;FNEXT:=ENTER(IDINFO,"2FNV00"&DT[36:36:12]);05041100 EMITN(FNEXT:=GETSPACE(FNEXT)); EMITO(STD); 05041200 EMITB(-1,FALSE); LADR1:=LAX; ADJUST; 05041300 LADR2 ~ (ADR+1) & NSEG[TOSEGNO]; EMITV(FNEXT); 05041400 END 05041450 ELSE BEGIN 05041500 EMITB(-1,FALSE); LADR1:=LAX; ADJUST; 05041600 LADR2:=(ADR+1)&NSEG[TOSEGNO]; 05041700 IF EXPR(TRUE) > REALTYPE THEN FLAG(102) ; 05041800 END ; 05042000 EMITO(GRTR); 05043000 EMITB(-1, TRUE); 05044000 LADR3 ~ LAX; 05045000 EMITB(-1, FALSE); 05046000 ADJUST; 05047000 DOTEST[DT] ~ (ADR+1) & LAX[TOADDR] & NSEG[TOSEGNO]; 05048000 IF NEXT ! COMMA THEN EMITL(1) ELSE 05049000 BEGIN 05050000 SCAN; 05051000 IF NEXT=SEMI THEN BEGIN FLAG(36); GO TO XIT END ; 05051100 IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 05052000 END; 05053000 EMITV(FX1); 05054000 EMITO(ADD); 05055000 EMITN(FX1); 05056000 EMITO(STN); 05057000 EMITB(LADR2, FALSE); 05058000 FIXB(LADR1); 05059000 FIXB(LADR3); 05060000 END ELSE EMITSTORE(FX1, FX2); 05061000 XIT: 05062000 IF DEBUGTOG THEN FLAGROUTINE(" ASSIG","NMENT ",FALSE ) ; 05062010 END ASSIGNMENT; 05063000 BOOLEAN PROCEDURE RINGCHECK; 05063100 COMMENT THIS PROCEDURE PREVENTS THE POSSIBILITY OF DELINKING A 05063110 HEADER FROM THE HEADER RING; 05063120 BEGIN 05063200 INTEGER I; 05063250 I~A; 05063300 DO 05063350 IF I ~ GETC(I).ADDR = ROOT THEN RINGCHECK ~ TRUE 05063400 UNTIL I = A; 05063450 END RINGCHECK; 05063500 PROCEDURE SETLINK(INFADDR); VALUE INFADDR; INTEGER INFADDR; 05063600 COMMENT THIS PROCEDURE LINKS AN ELEMENT TO ITS PREVIOUS HEADER; 05063601 BEGIN 05063610 INTEGER LAST,I; REAL COML; LABEL XIT; 05063620 XIT: 05063625 LAST ~(GETC(INFADDR).LASTC)-1; 05063630 FOR I ~ INFADDR+2 STEP 1 UNTIL LAST 05063640 DO BEGIN IF GETC(I).CLASS = ENDCOM THEN I~GETC(I).LINK; 05063650 IF FX1 = (COML~GETC(I)).LINK THEN 05063660 IF INFADDR~COML.LASTC=A THEN COM[PWI].LASTC~ROOT 05063670 ELSE GO XIT ; 05063680 END; 05063710 END SETLINK; 05063730 PROCEDURE DIMENSION; 05064000 BEGIN 05065000 LABEL L, LOOP, ERROR ; 05066000 BOOLEAN DOUBLED, SINGLETOG; %109-05066005 IF DEBUGTOG THEN FLAGROUTINE(" DIMEN","SION ",TRUE ) ; 05066010 IF LOGIFTOG THEN FLAG(101); 05067000 LABL ~ BLANKS; 05067100 IF NEXT=STAR THEN IF TYPE!DOUBTYPE THEN 05067210 BEGIN 05067220 SCAN ; 05067230 IF NEXT=NUM AND NUMTYPE=INTYPE THEN 05067240 BEGIN 05067250 IF FNEXT=4 THEN 05067260 BEGIN 05067270 SINGLETOG ~ TRUE; %109-05067275 IF TYPE=COMPTYPE THEN FLAG(176); GO L ; 05067280 END ; 05067290 IF FNEXT=8 THEN 05067300 BEGIN 05067310 IF TYPE=REALTYPE THEN TYPE~DOUBTYPE 05067320 ELSE IF TYPE!COMPTYPE THEN FLAG(177) ; 05067330 GO L ; 05067340 END ; 05067350 END ; 05067360 FLAG(IF TYPE=REALTYPE THEN 178 05067370 ELSE 177-REAL(TYPE=COMPTYPE)) ; 05067380 L: NCR~REAL(NCR.[30:3]!0)+3"677777"+NCR; SCN~1; SCAN ; 05067390 END ; 05067420 LOOP: DOUBLED~FALSE; 05068000 IF NEXT ! ID THEN BEGIN FLOG(105); GO TO ERROR END; 05068100 FX1 ~ IF SINGLETOG THEN -FNEXT ELSE FNEXT; %109-05069000 IF TYPE } DOUBTYPE THEN % FIX ARRAY TYPE OFR 05069100 PUT(FX1,GET(FX1)&TYPE[TOSUBCL]); % BOUNDS ROUTINE 05069200 IF XREF THEN BEGIN INFA ~ 0&GET(FX1)[15:15:9]; 05069300 IF TYPE>0 THEN INFA.SUBCLASS~TYPE; 05069400 END; 05069500 XTA ~ INFB ~ NAME; 05070000 SCAN; 05071000 IF XREF THEN 05071100 BEGIN IF INFA.CLASS = UNKNOWN THEN 05071200 INFA.CLASS~IF NEXT=LPAREN THEN ARRAYID ELSE VARID; 05071300 ENTERX(INFB,INFA); 05071400 END; 05071500 IF NEXT=LPAREN THEN BEGIN SCAN; DOUBLED~BOUNDS(FX1) END ELSE 05072000 IF TYPE = -1 THEN FLOG(103); 05073000 GETALL(FX1, INFA, XTA, INFC); 05074000 IF TYPE > 0 THEN 05075000 IF BOOLEAN(INFA.TYPEFIXED) THEN FLAG(31) ELSE 05076000 BEGIN 05077000 IF TYPE > LOGTYPE THEN 05078000 IF GET(FX1+2) <0 THEN 05078200 BEGIN 05078400 IF NOT DOUBLED AND INFA.CLASS=1 THEN 05078500 BEGIN 05078800 BUMPLOCALS; 05079000 LENGTH~LOCALS + 1536; 05079200 PUT(FX1+2,INFC & LENGTH[TOSIZE]); 05079400 END 05079600 END ELSE IF NOT DOUBLED THEN 05079800 BEGIN IF INFC.SIZE > 16383 THEN FLAG(99); 05079900 PUT(FX1+2,INFC & (2 | INFC.SIZE)[TOSIZE]); 05080000 END; 05080100 PUT (FX1,INFA & 1[TOTYPE] & TYPE[TOSUBCL]); 05080500 END; 05081000 IF INFA < 0 THEN FLAG(39) ELSE 05082000 IF TYPE = -2 THEN 05083000 BEGIN 05084000 BAPC(INFA&FX1[TOLINK]&1[TOCE]&ROOT[TOLASTC]); 05085000 IF BOOLEAN(INFA.CE) THEN FLAG(2); 05086000 IF BOOLEAN(INFA.EQ) THEN 05086100 BEGIN 05087000 COM[NEXTCOM.IR,NEXTCOM.IC].LASTC ~ A ~ INFA.ADDR; 05088000 B~GETC(ROOT).ADDR ; 05089000 SETLINK(A); 05089050 IF NOT RINGCHECK THEN 05089100 BEGIN 05089200 COM[PWROOT].ADDR~GETC(A).ADDR ; 05090000 PUTC(A,GETC(A)&B[TOADDR]&7[TOSUBCL]) ; 05091000 END 05091100 END ELSE 05092000 PUT(FX1, INFA & 1[TOCE] & ROOT[TOADDR]); 05093000 IF BOOLEAN(INFA.FORMAL) THEN FLAG(10); 05094000 END; 05095000 IF ERRORTOG THEN 05096000 ERROR: 05096100 WHILE NEXT ! COMMA AND NEXT ! SEMI AND NEXT ! SLASH DO SCAN; 05097000 IF NEXT = COMMA THEN BEGIN SCAN; GO TO LOOP END; 05098000 IF DEBUGTOG THEN FLAGROUTINE(" DIMEN","SION ",FALSE ); 05098010 END DIMENSION; 05099000 PROCEDURE FORMALPP(PARMSREQ, CLASS); VALUE PARMSREQ, CLASS; 05100000 BOOLEAN PARMSREQ; REAL CLASS; 05101000 BEGIN 05102000 LABEL LOOP, XIT; 05103000 IF DEBUGTOG THEN FLAGROUTINE(" FORM","ALPP ",TRUE ) ; 05103010 PARMS ~ 0; 05104000 SCAN; 05105000 IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 05106000 IF CLASS = FUNID THEN 05106100 IF FUNVAR = 0 THEN 05107000 BEGIN 05107020 IF TYPE > 0 THEN 05107030 IF FUNVAR ~ GLOBALSEARCH(NAME) ! 0 THEN 05107040 IF BOOLEAN((T ~ GET(FUNVAR)).TYPEFIXED) AND TYPE ! T.SUBCLASS 05107050 THEN FLAG(31); 05107060 PUT(FUNVAR ~ FNEXT,GET(FNEXT) & VARID[TOCLASS]); 05107100 END; 05107160 FNEW ~ NEED(NNEW ~ NAME, CLASS); 05108000 ENTERX(NAME,IF CLASS = FUNID THEN 05108100 1&GET(FNEW)[15:15:9] ELSE 1&GET(FNEW)[15:15:5]); 05108200 SCAN; 05109000 IF NEXT ! LPAREN THEN 05110000 IF PARMSREQ THEN FLOG(106) ELSE ELSE 05111000 BEGIN 05112000 LOOP: 05113000 SCAN; 05114000 IF NEXT = ID THEN PARMLINK[PARMS ~ PARMS+1] ~ FNEXT ELSE 05115000 IF NEXT=STAR AND CLASS!FUNID THEN PARMLINK[PARMS~PARMS+1]~0ELSE05116000 FLOG(107); 05117000 IF XREF THEN ENTERX(NAME,IF NEXT = STAR THEN 0 ELSE 05117100 0&GET(FNEXT)[15:15:9]); 05117150 SCAN; 05118000 IF NEXT = COMMA THEN GO TO LOOP; 05119000 IF NEXT ! RPAREN THEN FLOG(108); 05120000 SCAN; 05121000 END; 05122000 IF NOT ERRORTOG THEN DECLAREPARMS(FNEW); 05123000 XIT: 05124000 IF DEBUGTOG THEN FLAGROUTINE(" FORM","ALPP ",FALSE) ; 05124010 END FORMALPP; 05125000 PROCEDURE ENDS; FORWARD; 05125100 PROCEDURE FUNCTION ; 05126000 BEGIN 05127000 REAL A,B,C,I; LABEL FOUND ; 05127100 IF SPLINK NEQ 0 THEN BEGIN FLAG(5); ENDS; SEGMENTSTART; END; 05128000 LABL ~ BLANKS; 05128100 FORMALPP(TRUE, FUNID); 05129000 GETALL(FNEW, INFA, INFB, INFC); 05130000 B~NUMINTM1 ; 05130100 WHILE A+1SUPERMAXCOM THEN 05185000 BEGIN ROOT~0; FATAL(124) END 05186000 ELSE ROOT~NEXTCOM ; 05186100 PUTC(ROOT,0&HEADER[TOCLASS]&1[TOCE]&ROOT[TOADDR]) ; 05186200 BAPC(Z); 05187000 END ELSE 05188000 BEGIN 05189000 ROOT ~ T.ADINFO; 05190000 COM[(T~GETC(ROOT).LASTC).IR,T.IC].LINK~NEXTCOM+1 ; 05191000 IF COM[PWROOT]<0 THEN FLAG(2) ; 05191100 END; 05192000 DIMENSION; 05193000 BAPC(0&ENDCOM[TOCLASS]) ; 05194000 COM[PWROOT].LASTC~NEXTCOM ; 05195000 PUT(T~GETC(ROOT+1)+2,GET(T)&ROOT[TOADINFO]) ; 05196000 IF NEXT ! SEMI THEN GO TO LOOP; 05197000 END COMMON; 05198000 PROCEDURE ENDS; 05211000 BEGIN 05212000 IF SPLINK=0 THEN FLAG(184) ELSE %112-05212005 BEGIN %112-05212007 EODS~FALSE ; 05212010 IF LOGIFTOG THEN FLAG(101); 05213000 LABL ~ BLANKS; 05213100 IF SPLINK < 0 THEN EMITO(XIT) ELSE EMITPAIR(0, KOM); 05214000 SEGMENT((ADR+4) DIV 4, NSEG, TRUE, EDOC); 05215000 END; %112-05216000 END ENDS; 05217000 PROCEDURE ENTRY; 05218000 BEGIN 05219000 REAL SP; 05220000 IF SPLINK = 0 THEN FLAG(111) ELSE 05221000 IF SPLINK = 1 THEN BEGIN ELX ~ 0; FLAG(4) END; 05222000 LABL ~ BLANKS; 05222100 ADJUST ; 05222500 SP ~ GET(SPLINK); 05223000 FORMALPP( (T~SP.CLASS) = FUNID, T); 05224000 GETALL(FNEW, INFA, INFB, INFC); 05225000 IF INFA.CLASS = FUNID THEN 05226000 PUT(FNEW, INFA & 1[TOTYPE] & (SP.SUBCLASS)[TOSUBCL]); 05227000 PUT(FNEW+2, INFC & (ADR+1)[TOBASE]); 05228000 END ENTRY; 05229000 PROCEDURE EQUIVALENCE; 05230000 COMMENT THIS PROCEDURE MAKES THE COM ENTRY FOR EQUIV ITEMS AND SETS 05230100 THE EQ BIT IN BOTH THE COM AND INFO TABLES AND LINKS 05230110 THE HEADS OF CHAINS; 05230120 BEGIN 05231000 REAL P, Q, R, S; 05232000 BOOLEAN FIRST,PCOMM; 05232050 LABEL XIT; 05232100 IF LOGIFTOG THEN FLAG(101); 05233000 LABL ~ BLANKS; 05233100 DO 05234000 BEGIN 05235000 FIRST ~ FALSE; 05235500 SCAN; 05236000 IF NEXT ! LPAREN THEN BEGIN FLOG(106); GO TO XIT END; 05237000 IF NEXTCOM~NEXTCOM+1>SUPERMAXCOM THEN 05238000 BEGIN ROOT~0; FATAL(124) END 05238100 ELSE ROOT~NEXTCOM ; 05238200 PUTC(ROOT,0&HEADER[TOCLASS]&ROOT[TOADDR]) ; 05238300 BAPC(0); Q~0 ; 05239000 DO 05240000 BEGIN 05241000 SCAN; 05242000 IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 05243000 IF XREF THEN ENTERX(NAME,0&GET(FNEXT)[15:15:9]); 05243200 FX1 ~ FNEXT; 05244000 LENGTH ~ 0; 05245000 SCAN; 05246000 IF NEXT = LPAREN THEN 05247000 BEGIN 05248000 IF GET(FX1).CLASS ! ARRAYID THEN 05249000 BEGIN XTA ~ GET(FX1+1); FLOG(112) END; 05250000 R ~ 0; P ~ 1; 05251000 S ~ GET(FX1+2).ADINFO; 05252000 DO 05253000 BEGIN 05254000 SCAN; 05255000 IF NEXT ! NUM OR NUMTYPE ! INTYPE THEN FLAG(113); 05256000 LENGTH ~ LENGTH + P|(FNEXT-1); 05257000 P ~ P|EXTRAINFO[(S+R).IR,(S+R).IC] ; 05258000 R ~ R-1; 05259000 SCAN; 05260000 END UNTIL NEXT ! COMMA; 05261000 IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 05262000 IF R!-1 THEN IF R~R+GET(FX1+2).NEXTRA!0 THEN 05262200 BEGIN XTA~GET(FX1+1); FLAG(IF R>0 THEN 23 ELSE 24) END ; 05262300 SCAN; 05263000 END; 05264000 IF (INFA~GET(FX1)) < 0 THEN 05265000 BEGIN XTA ~ GET(FX1+1); FLAG(39) END ELSE 05266000 BEGIN 05267000 IF INFA.SUBCLASS > LOGTYPE THEN LENGTH ~ 2|LENGTH ; 05267100 BAPC(INFA&FX1[TOLINK]&LENGTH[TORELADD]&1[TOEQ]&ROOT[TOLASTC]); 05268000 IF(PCOMM~BOOLEAN(INFA.CE)) OR BOOLEAN(INFA.EQ) THEN 05269000 BEGIN 05270000 IF FIRST AND PCOMM THEN BEGIN XTA~GET(FX1+1); FLAG(2) END 05270100 ELSE IF NOT FIRST THEN FIRST ~ PCOMM; 05270200 PUT(FX1,INFA & 1[TOEQ]); 05270500 COM[NEXTCOM.IR,NEXTCOM.IC].LASTC ~ A ~ INFA.ADDR; 05271000 B~GETC(ROOT).ADDR ; 05272000 SETLINK(A); 05272050 IF NOT RINGCHECK THEN 05272100 BEGIN 05272200 COM[PWROOT].ADDR~GETC(A).ADDR ; 05273000 PUTC(A,GETC(A)&B[TOADDR]&7[TOSUBCL]) ; 05274000 END 05274200 END ELSE 05275000 PUT(FX1,INFA & 1[TOEQ] & ROOT[TOADDR]); 05276000 IF LENGTH > Q THEN Q ~ LENGTH; 05277000 IF BOOLEAN(INFA.FORMAL) THEN 05278000 BEGIN XTA ~ GET(FX1+1); FLAG(11) END; 05279000 END; 05280000 END UNTIL NEXT ! COMMA; 05281000 IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 05282000 SCAN; 05283000 PUTC(ROOT+1,Q); 05284000 BAPC(0&ENDCOM[TOCLASS]) ; 05285000 COM[PWROOT].LASTC~NEXTCOM ; 05286000 END UNTIL NEXT ! COMMA; 05287000 XIT: 05287100 END EQUIVALENCE; 05288000 PROCEDURE EXTERNAL; 05289000 BEGIN 05290000 IF SPLINK < 0 THEN FLAG( 12); 05291000 IF LOGIFTOG THEN FLAG(101); 05292000 LABL ~ BLANKS; 05292100 DO 05293000 BEGIN 05294000 SCAN; 05295000 IF NEXT ! ID THEN FLOG(105) ELSE 05296000 BEGIN T ~ NEED(NAME,EXTID); 05297000 IF XREF THEN ENTERX(NAME,0&GET(T)[15:15:9]); 05297300 SCAN; 05297500 END; 05297800 05298000 END UNTIL NEXT ! COMMA; 05299000 END EXTERNAL; 05300000 PROCEDURE CHAIN; 05300100 BEGIN 05300150 LABEL AGN, XIT; 05300160 REAL T1; 05300170 DEFINE FLG(FLG1) = BEGIN FLOG(FLG1); GO TO XIT END#; 05300180 EXECUTABLE; 05300182 SCAN; 05300184 T1 ~ 2; 05300190 IF FALSE THEN 05300210 AGN: IF GLOBALNEXT ! COMMA THEN FLG(28); 05300220 SCAN; 05300230 IF EXPR(TRUE) > REALTYPE THEN FLG(102); 05300240 IF (T1 ~ T1 - 1) ! 0 THEN GO TO AGN; 05300250 IF GLOBALNEXT ! RPAREN THEN FLG(3); 05300260 EMITPAIR(37,KOM); 05300270 SCAN; 05300280 IF GLOBALNEXT ! SEMI THEN FLOG(117); 05300290 XIT: WHILE GLOBALNEXT ! SEMI DO SCAN; 05300300 END CHAIN; 05300310 PROCEDURE GOTOS; 05301000 BEGIN LABEL XIT; 05302000 REAL ASSIGNEDID; 05302100 EODS~TRUE ; 05302110 EXECUTABLE; 05303000 SCAN; 05304000 IF NEXT = NUM THEN 05305000 BEGIN 05306000 LABELBRANCH(NAME, FALSE); 05307000 SCAN; 05308000 GO TO XIT; 05309000 END; 05310000 IF NEXT = ID THEN 05311000 BEGIN 05312000 ASSIGNEDID ~ FNEXT; 05313000 IF XREF THEN ENTERX(XTA,0&GET(FNEXT)[15:15:9]); 05313200 SCAN; 05313300 IF NEXT ! COMMA THEN FLOG(114); 05313600 SCAN; 05314000 IF NEXT ! LPAREN THEN FLOG(106); 05314300 DO 05314600 BEGIN 05315000 SCAN; 05315300 IF NEXT ! NUM THEN FLOG(109); 05315600 EMITV(ASSIGNEDID); 05316000 EMITNUM(FNEXT); 05316300 EMITO(NEQL); 05316600 LABELBRANCH(NAME, TRUE); 05317000 SCAN; 05317300 END UNTIL NEXT ! COMMA; 05317600 IF NEXT ! RPAREN THEN FLOG(108); 05318000 SCAN; 05318200 EMITPAIR(1, SSN); % CAUSE INVALID INDEX TERMINATION 05318400 EMITDESCLIT(10); 05318600 GO TO XIT; 05319000 END; 05320000 IF NEXT ! LPAREN THEN FLOG(106); 05321000 P ~ 0; 05322000 DO 05323000 BEGIN 05324000 SCAN; 05325000 IF NEXT ! NUM THEN BEGIN FLOG(109); GO TO XIT END; 05326000 LSTT[P~P+1] ~ NAME; 05327000 SCAN; 05328000 END UNTIL NEXT ! COMMA; 05329000 IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 05330000 SCAN; 05331000 IF NEXT ! COMMA THEN BEGIN FLOG(114); GO TO XIT END; 05332000 SCAN; 05333000 IT ~ P+1; % DONT LET EXPR WIPE OUT LSTT 05334000 IF EXPR(TRUE) > REALTYPE THEN FLOG(102); 05335000 EMITPAIR(JUNK, ISN); 05336000 EMITPAIR(1,LESS); 05337000 EMITOPDCLIT(JUNK); 05338000 EMITPAIR(P,GRTR); 05339000 EMITO(LOR); 05340000 EMITOPDCLIT(JUNK); 05341000 EMITL(3); 05342000 EMITO(MUL); 05343000 05344000 IF ADR+3|P > 4085 THEN BEGIN ADR~ADR+1; SEGOVF END; 05345000 EMITO(BFC); 05346000 EMITPAIR(1, SSN); 05347000 EMITDESCLIT(10); 05348000 FOR I ~ 1 STEP 1 UNTIL P DO 05349000 BEGIN 05349100 J ~ ADR; LABELBRANCH(LSTT[I], FALSE); 05349200 IF ADR-J = 2 THEN EMITO(NOP); 05349300 END; 05349400 XIT: 05350000 IT ~ 0; 05351000 END GOTOS; 05352000 PROCEDURE IFS; 05353000 BEGIN REAL TYPE, LOGIFADR, SAVELABL; 05354000 EODS~TRUE; 05354010 EXECUTABLE; 05355000 SCAN; 05356000 IF NEXT ! LPAREN THEN FLOG(106); 05357000 SCAN; 05358000 IF TYPE ~ EXPR(TRUE) = COMPTYPE THEN FLAG(89); 05359000 IF NEXT ! RPAREN THEN FLOG(108); 05360000 IF TYPE = LOGTYPE THEN 05361000 BEGIN 05362000 EMITB(-1, TRUE); 05363000 LOGIFADR ~ LAX; 05364000 LOGIFTOG ~ TRUE; EOSTOG ~ TRUE; 05365000 SAVELABL ~ LABL; LABL ~ BLANKS; 05365100 STATEMENT; 05366000 LABL ~ SAVELABL; 05366100 LOGIFTOG ~ FALSE; EOSTOG ~ FALSE; 05367000 FIXB(LOGIFADR); 05368000 END ELSE 05369000 BEGIN 05370000 IF TYPE = DOUBTYPE THEN 05371000 BEGIN EMITO(XCH); EMITO(DEL) END; 05372000 SCAN; 05373000 IF NEXT ! NUM THEN FLOG(109); 05374000 FX1 ~ FNEXT; NX1 ~ NAME; 05375000 SCAN; 05376000 IF NEXT ! COMMA THEN FLOG(114); 05377000 SCAN; 05378000 IF NEXT ! NUM THEN FLOG(109); 05379000 FX2 ~ FNEXT; NX2 ~ NAME; 05380000 SCAN; 05381000 IF NEXT ! COMMA THEN FLOG(114); 05382000 SCAN; 05383000 IF NEXT ! NUM THEN FLOG(109); 05384000 FX3 ~ FNEXT; NX3 ~ NAME; 05385000 SCAN; 05386000 IF FX2 = FX3 THEN 05387000 BEGIN 05388000 EMITPAIR(0,GEQL); 05389000 LABELBRANCH(NX1, TRUE); 05390000 LABELBRANCH(NX3, FALSE); 05391000 IF XREF THEN ENTERX(NX2,0&LABELID[TOCLASS]); 05391200 END ELSE 05392000 IF FX1 = FX3 THEN 05393000 BEGIN 05394000 EMITPAIR(0,NEQL); 05395000 LABELBRANCH(NX2, TRUE); 05396000 LABELBRANCH(NX1, FALSE); 05397000 IF XREF THEN ENTERX(NX3,0&LABELID[TOCLASS]); 05397200 END ELSE 05398000 IF FX1 = FX2 THEN 05399000 BEGIN 05400000 EMITPAIR(0,LEQL); 05401000 LABELBRANCH(NX3, TRUE); 05402000 LABELBRANCH(NX1, FALSE); 05403000 IF XREF THEN ENTERX(NX2,0&LABELID[TOCLASS]); 05403200 END ELSE 05404000 BEGIN 05405000 EMITO(DUP); 05406000 EMITPAIR(0,NEQL); 05407000 EMITB(-1,TRUE); 05408000 EMITPAIR(0,LESS); 05409000 LABELBRANCH(NX3, TRUE); 05410000 LABELBRANCH(NX1, FALSE); 05411000 FIXB(LAX); 05412000 EMITO(DEL); 05413000 LABELBRANCH(NX2, FALSE); 05414000 END; 05415000 END; 05416000 END IFS; 05417000 PROCEDURE NAMEL; 05430000 BEGIN LABEL NIM,XIT,ELMNT,WRAP; 05431000 IF SPLINK < 0 THEN FLAG(12); 05432000 IF LOGIFTOG THEN FLAG(101); 05433000 LABL ~ BLANKS; 05433100 SCAN; IF NEXT ! SLASH THEN FLOG(110); 05434000 NIM: SCAN; IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 05435000 IF J ~ (INFA ~ GET(LADR2 ~ FNEXT)).CLASS = UNKNOWN THEN 05436000 PUT(LADR2,INFA&NAMELIST[TOCLASS]) 05437000 ELSE IF J ! NAMELIST THEN 05438000 BEGIN XTA ~ GET(LADR2 + 1); 05439000 FLAG(20); 05440000 END; 05441000 LSTT[LSTS ~ LADR1 ~ 0] ~ NAME; 05442000 IF XREF THEN ENTERX(NAME,0&NAMELIST[TOCLASS]); 05442500 SCAN; IF NEXT ! SLASH THEN FLOG(110); 05443000 ELMNT: SCAN; IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 05444000 LADR1 ~ LADR1 + 1; 05445000 IF (T ~ GET(FNEW ~ GETSPACE(FNEXT)).CLASS) > VARID THEN FLAG(48); 05446000 GETALL(FNEW,INFA,INFB,INFC); 05447000 IF XREF THEN ENTERX(INFB,0&INFA[15:15:9]); 05447500 IF LSTS ~ LSTS+1 = LSTMAX THEN BEGIN FLOG(78); GO TO XIT END ELSE 05448000 LSTT[LSTS] ~ NAME&INFA.CLASNSUB[2:38:10]&0[8:47:1]; 05448500 IF T = ARRAYID THEN 05449000 BEGIN J ~ INFC.ADINFO; 05450000 I ~ INFC.NEXTRA; 05451000 IF LSTS + I + 1 > LSTMAX THEN 05451100 BEGIN FLOG(78); GO TO XIT END; 05451200 LSTT[LSTS ~ LSTS + 1] ~ 0&I[1:42:6] % # DIMENSIONS 05452000 &INFA.ADDR[7:37:11] % REL ADR 05453000 &INFC.BASE[18:33:15] % BASE 05454000 &INFC.SIZE[33:33:15]; % SIZE 05455000 FOR T ~ J STEP -1 UNTIL J - I + 1 DO 05456000 LSTT[LSTS ~ LSTS + 1] ~ EXTRAINFO[T.IR,T.IC]; 05457000 END ELSE BEGIN LSTT[LSTS~LSTS+1]~0&(INFA.ADDR)[7:37:11]; 05458000 IF BOOLEAN(INFA.CE) THEN LSTT[LSTS]~LSTT[LSTS]&INFC.BASE[18:33:15]05458400 &INFC.SIZE[33:33:15] END; 05458600 SCAN; IF NEXT = COMMA THEN GO TO ELMNT; 05459000 IF NEXT ! SEMI AND NEXT ! SLASH THEN FLOG(115); 05460000 LSTT[LSTS + 1] ~ 0; 05461000 LSTT[0].[2:10] ~ LADR1; 05462000 PRTSAVER(LADR2,LSTS + 2,LSTT); 05463000 IF NEXT ! SEMI THEN GO TO NIM; 05464000 XIT: 05465000 END NAMEL; 05466000 PROCEDURE PAUSE; 05467000 IF DCINPUT THEN BEGIN XTA~"PAUSE "; FLOG(151) END ELSE 05467100 BEGIN 05468000 EODS~TRUE ; 05468010 IF TSSEDITOG THEN TSSED("PAUSE ",2) ; 05468100 EXECUTABLE; 05469000 SCAN; 05470000 IF NEXT = SEMI THEN EMITL(0) ELSE 05471000 IF NEXT = NUM THEN 05472000 BEGIN 05473000 EMITNUM(NAME); 05474000 SCAN; 05475000 END; 05476000 EMITPAIR(33, KOM); 05477000 EMITO(DEL); 05477100 END PAUSE; 05478000 PROCEDURE TYPIT(TYP,TMPNXT); VALUE TYP; REAL TYP,TMPNXT ; 05479000 BEGIN 05480000 TYPE~TYP; SCAN ; 05480010 IF NEXT=16 THEN BEGIN TMPNXT~16; FUNCTION END ELSE DIMENSION ; 05480020 END OF TYPIT ; 05480040 DEFINE COMPLEX =TYPIT(COMPTYPE,TEMPNEXT) #, 05481000 LOGICAL =TYPIT(LOGTYPE ,TEMPNEXT) #, 05482000 DOUBLEPRECISION =TYPIT(DOUBTYPE,TEMPNEXT) #, 05483000 INTEGERS =TYPIT(INTYPE ,TEMPNEXT) #, 05484000 REALS =TYPIT(REALTYPE,TEMPNEXT) #; 05484500 PROCEDURE STOP; 05485000 BEGIN 05486000 RETURNFOUND ~ TRUE; 05486100 EODS~TRUE; 05486110 EXECUTABLE; 05487000 COMMENT INITIAL SCAN ALREADY DONE; 05488000 EMITL(1); 05489000 EMITPAIR(16,STD); 05490000 EMITPAIR(10, KOM); 05491000 EMITPAIR(5, KOM); 05492000 WHILE NEXT ! SEMI DO SCAN; 05493000 END STOP; 05494000 PROCEDURE RETURN; 05495000 BEGIN LABEL EXIT; 05496000 REAL T, XITCODE; 05497000 RETURNFOUND ~ TRUE; 05497100 EODS~TRUE ; 05497110 EXECUTABLE; 05498000 05498100 05498200 SCAN; 05499000 IF SPLINK=0 OR SPLINK=1 THEN 05499100 BEGIN XTA~"RETURN"; FLOG(153); GO EXIT END ; 05500000 IF NEXT = SEMI THEN 05501000 BEGIN 05502000 IF (T ~ GET(SPLINK)).CLASS = FUNID THEN 05503000 BEGIN 05504000 EMITV(FUNVAR); 05505000 IF T.SUBCLASS > LOGTYPE THEN EMITPAIR(JUNK, STD); 05506000 XITCODE ~ RTN; 05507000 END ELSE XITCODE ~ XIT; 05508000 IF ADR } 4077 THEN 05509000 BEGIN ADR ~ ADR+1; SEGOVF END; 05510000 EMITOPDCLIT(1538); % F+2 05511000 EMITPAIR(3, BFC); 05512000 EMITPAIR(10, KOM); 05513000 EMITO(XITCODE); 05514000 EMITOPDCLIT(16); 05515000 EMITPAIR(1, SUB); 05516000 EMITPAIR(16, STD); 05517000 EMITO(XITCODE); 05518000 GO TO EXIT; 05519000 END; 05520000 IF LABELMOM = 0 THEN FLOG(145); 05520100 IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 05521000 IF EXPRESULT = NUMCLASS THEN 05521100 BEGIN IF XREF THEN ENTERX(EXPVALUE,0&LABELID[TOCLASS]); 05521200 ADR ~ ADR-1;EMITL(EXPVALUE-1) 05521400 END ELSE 05521600 EMITPAIR(1, SUB); 05522000 EMITOPDCLIT(LABELMOM); 05523000 EMITO(MKS); 05524000 EMITL(9); 05525000 EMITOPDCLIT(5); 05526000 05527000 EXIT: 05528000 END RETURN; 05529000 PROCEDURE IMPLICIT ; 05529100 BEGIN 05529105 REAL R1,R2,R3,R4 ; 05529110 LABEL R,A,X,L ; 05529120 IF NOT(LASTNEXT=42 OR LASTNEXT=1000 OR LASTNEXT=30 %110-05529130 OR LASTNEXT=16 OR LASTNEXT = 11) %110-05529131 THEN BEGIN FLOG(181); FILETOG~TRUE; GO X END ; 05529140 R: EOSTOG~ERRORTOG~TRUE; FILETOG~FALSE ; 05529210 MOVEW(ACCUM[3],ACCUM[2],0,3); SCAN; ERRORTOG~FALSE; FILETOG~TRUE ; 05529215 IF R1~IF R3~NEXT=18 THEN INTID ELSE IF R3=26 THEN REALID ELSE 0& 05529220 (IF R3=10 THEN DOUBTYPE ELSE IF R3=19 THEN LOGTYPE ELSE IF R3=05529230 6 THEN COMPTYPE ELSE 0)[TOSUBCL]=0 THEN 05529240 BEGIN FLOG(182); GO X END ; 05529250 SCN~2; SCAN ; 05529260 IF NEXT = STAR THEN IF R3!10 THEN 05529270 BEGIN SCAN ; 05529280 IF NEXT=NUM AND NUMTYPE=INTYPE THEN 05529290 BEGIN 05529300 IF FNEXT=4 THEN BEGIN IF R3=6 THEN FLAG(176); GO L END ; 05529310 IF FNEXT=8 THEN 05529320 BEGIN 05529330 IF R3=26 THEN R1~0&DOUBTYPE[TOSUBCL] 05529340 ELSE IF R3!6 THEN FLAG(177) ; 05529350 GO L; 05529360 END ; 05529370 END ; 05529380 FLAG(IF R3=26 THEN 178 ELSE 177-REAL(R3=6)) ; 05529390 L: NCR~REAL(NCR.[30:3]!0)+3"677777"+NCR; SCN~1; SCAN ; 05529400 END ; 05529410 IF NEXT!LPAREN THEN BEGIN FLOG(106); GO X END ; 05529420 A: SCAN; R4~ERRORCT ; 05529430 IF R2~NAME.[12:6]<17 OR (R2>25 AND R2<33) OR (R2>41 AND R2<50) 05529440 OR R2>57 OR NAME.[18:30]!" " THEN FLAG(179) ; 05529450 SCAN ; 05529460 IF NEXT!MINUS THEN 05529470 BEGIN IF ERRORCT=R4 THEN TIPE[IF R2!"0" THEN R2 ELSE 12]~R1 END05529475 ELSE BEGIN 05529480 SCAN ; 05529490 IF R3~NAME.[12:6]<17 OR (R3>25 AND R3<33) OR (R3>41 AND R3<50) 05529500 OR R3>57 OR NAME.[18:30]!" " THEN FLAG(179) ; 05529510 IF R3 LEQ R2 THEN FLAG(180) ; 05529520 IF ERRORCT=R4 THEN FOR R2~R2 STEP 1 UNTIL R3 DO 05529530 BEGIN 05529540 IF R2>25 AND R2<33 THEN R2~33 ELSE IF R2>41 AND R2<50 05529550 THEN R2~50 ; 05529560 TIPE[IF R2!"0" THEN R2 ELSE 12]~R1 ; 05529570 END ; 05529580 SCAN ; 05529590 END ; 05529600 IF NEXT=COMMA THEN GO A ; 05529610 IF NEXT!RPAREN THEN BEGIN FLOG(108); GO X END ; 05529620 SCAN; IF NEXT=COMMA THEN GO R ; 05529630 IF NEXT!SEMI THEN BEGIN FLOG(117); GO X END ; 05529635 IF SPLINK > 1 THEN 05529640 BEGIN 05529650 IF BOOLEAN(TYPE.[2:1]) THEN IF GET(SPLINK).CLASS=FUNID THEN 05529660 BEGIN 05529670 INFO[SPLINK.IR,SPLINK.IC].SUBCLASS~R3~TIPE[IF R3~GET( 05529680 SPLINK+1).[12:6]!"0" THEN R3 ELSE 12].SUBCLASS ; 05529690 INFO[FUNVAR.IR,FUNVAR.IC].SUBCLASS~R3 ; 05529700 END ; 05529710 IF R1~GET(SPLINK+2)<0 THEN 05529720 FOR R2~R1.NEXTRA-1+R1~R1.ADINFO STEP -1 UNTIL R1 DO 05529730 IF R3~PARMLINK[R2-R1+1]!0 THEN 05529740 BEGIN 05529750 EXTRAINFO[R2.IR,R2.IC].SUBCLASS~R4~TIPE[IF R4~ 05529760 GET(R3+1).[12:6]!"0" THEN R4 ELSE 12] 05529770 .SUBCLASS ; 05529780 INFO[R3.IR,R3.IC].SUBCLASS~R4 ; 05529790 END ; 05529800 END ; 05529810 X: WHILE NEXT!SEMI DO SCAN; FILETOG~FALSE ; 05529820 END OF IMPLICIT ; 05529830 PROCEDURE SUBROUTINE; 05530000 BEGIN 05531000 IF SPLINK NEQ 0 THEN BEGIN FLAG(5); ENDS; SEGMENTSTART; END; 05532000 LABL ~ BLANKS; 05532100 FORMALPP(FALSE, SUBRID); 05533000 SPLINK ~ FNEW; 05534000 END SUBROUTINE; 05535000 PROCEDURE MEMHANDLER(N); VALUE N; REAL N ; 05535010 BEGIN 05535020 REAL A ; 05535030 LABEL L1,L2,L3,XIT ; 05535040 IF DEBUGTOG THEN FLAGROUTINE(" MEMHA","NDLER ",TRUE) ; 05535045 IF N LEQ 2 THEN 05535050 BEGIN % FIXED=1, VARYING=2. 05535060 N~IF N=1 THEN 6 ELSE 0 ; 05535070 L1: SCAN; 05535080 IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 05535090 IF (A~GET(GETSPACE(FNEXT))).CLASS!ARRAYID THEN 05535100 BEGIN FLOG(35); GO XIT END ; 05535110 IF XREF THEN ENTERX(XTA,0&A[15:15:9]) ; 05535120 IF BOOLEAN(A.EQ) OR BOOLEAN(A.FORMAL) THEN FLAG(169) 05535130 ELSE BEGIN 05535140 EMITO(MKS); EMITPAIR(A.ADDR,LOD); EMITL(N) ; 05535150 EMITV(NEED(".MEMHR",INTRFUNID)) ; 05535160 END ; 05535170 SCAN; IF NEXT=COMMA THEN GO L1 ; 05535180 END 05535190 ELSE IF N=3 THEN 05535200 BEGIN % AUXMEMED FUNCTION OR SUBROUTINE. 05535210 SCAN ; 05535220 IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 05535225 IF GET(FNEXT+1)!GET(SPLINK+1) THEN 05535230 BEGIN FLOG(170); GO XIT END ; 05535235 PUT(SPLINK,GET(SPLINK)&1[TOADJ]) ; 05535240 IF XREF THEN ENTERX(XTA,0&GET(FNEXT)[15:15:9]); SCAN ; 05535250 END 05535420 ELSE BEGIN % RELEASE. 05535430 L2: SCAN ; 05535440 IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 05535450 IF (A~GET(GETSPACE(FNEXT))).CLASS=ARRAYID THEN 05535460 BEGIN 05535470 IF BOOLEAN(A.EQ) OR BOOLEAN(A.FORMAL) THEN FLAG(169) 05535480 ELSE BEGIN 05535490 EMITO(MKS); EMITPAIR(A.ADDR,LOD) ; 05535500 EMITPAIR(1,SSN) ; 05535510 EMITV(NEED(".MEMHR",INTRFUNID)) ; 05535520 END ; 05535530 L3: IF XREF THEN ENTERX(XTA,0&A[15:15:9]) ; 05535540 END 05535550 ELSE IF A.CLASS}BLOCKID OR A.CLASS{LABELID THEN 05535560 BEGIN FLOG(171); GO XIT END 05535570 ELSE BEGIN 05535575 EMITPAIR(A.ADDR,LOD); EMITPAIR(38,KOM) ; 05535580 EMITO(DEL); GO L3 ; 05535585 END ; 05535590 SCAN; IF NEXT=COMMA THEN GO L2 ; 05535595 END ; 05535600 XIT:IF DEBUGTOG THEN FLAGROUTINE(" MEMHA","NDLER ",FALSE) ; 05535605 END OF MEMHANDLER ; 05535610 PROCEDURE STATEMENT; 05536000 BEGIN LABEL DOL1, XIT; 05537000 REAL TEMPNEXT ; 05537100 BOOLEAN ENDTOG; %112-05537200 DO SCAN UNTIL NEXT ! SEMI; 05538000 IF NEXT=ID THEN ASSIGNMENT ELSE IF NEXT LEQ RSH1 THEN 05539000 CASE(TEMPNEXT~NEXT) OF 05540000 BEGIN 05541000 FLOG(16); 05542000 ASSIGN; 05543000 IOCOMMAND(4); %BACKSPACE 05544000 BLOCKDATA; 05545000 CALL; 05546000 COMMON; 05547000 COMPLEX; 05548000 BEGIN EXECUTABLE; SCAN END; % CONTINUE 05549000 IOCOMMAND(7); % DATA 05550000 BEGIN SCAN; TYPE ~ -1; DIMENSION END; 05551000 DOUBLEPRECISION; 05552000 BEGIN ENDS; ENDTOG:=TRUE; SCAN END; %112-05553000 FILECONTROL(1); %ENDFILE 05554000 ENTRY; 05555000 EQUIVALENCE; 05556000 EXTERNAL; 05557000 BEGIN TYPE ~ -1; FUNCTION END; 05558000 GOTOS; 05559000 INTEGERS; 05560000 LOGICAL; 05561000 NAMEL; 05562000 PAUSE; 05563000 IOCOMMAND(2); %PRINT 05564000 ; 05565000 IOCOMMAND(3); %PUNCH 05566000 IOCOMMAND(0); %READ 05567000 REALS; 05568000 RETURN; 05569000 FILECONTROL(0); %REWIND 05570000 BEGIN SCAN; STOP END; 05571000 SUBROUTINE; 05572000 IOCOMMAND(1); %WRITE 05573000 FILECONTROL(7); %CLOSE 05573100 FILECONTROL(6); %LOCK 05573200 FILECONTROL(4); %PURGE 05573300 IFS; 05574000 FORMATER; 05575000 CHAIN; 05575100 MEMHANDLER(1) ; %FIXED 05576000 MEMHANDLER(2) ; %VARYING 05576100 MEMHANDLER(3) ; %AUXMEM FOR SUBPROGRAMS 05576200 MEMHANDLER(4) ; %RELEASE 05577000 IMPLICIT ; 05577100 END ELSE IF NEXT=EOF THEN GO XIT ELSE BEGIN NEXT~0; FLOG(16) END ; 05578000 LASTNEXT.[33:15]~TEMPNEXT ; 05578100 IF NOT ENDTOG THEN IF SPLINK=0 THEN SPLINK:=1; %112-05579000 ENDTOG:=FALSE; %112-05579100 IF LABL ! BLANKS THEN 05580000 BEGIN 05581000 IF DT ! 0 THEN 05582000 BEGIN 05583000 DOL1: IF LABL = DOLAB[TEST ~ DT] THEN 05584000 BEGIN 05585000 EMITB(DOTEST[DT], FALSE); 05586000 FIXB(DOTEST[DT].ADDR); 05587000 IF DT ~ DT-1 > 0 THEN GO TO DOL1; 05588000 END ELSE 05589000 WHILE TEST ~ TEST-1 > 0 DO 05590000 IF DOLAB[TEST] = LABL THEN FLAG(14); 05591000 END; 05592000 LABL ~ BLANKS; 05592100 END; 05593000 05594000 IF NEXT ! SEMI THEN 05595000 BEGIN 05596000 FLAG(117); 05597000 DO SCAN UNTIL NEXT=SEMI OR NEXT=EOF ; 05598000 END; 05599000 ERRORTOG ~ FALSE; 05600000 EOSTOG ~ TRUE; 05601000 XIT: 05602000 END STATEMENT; 05603000 BOOLEAN STREAM PROCEDURE FLAGLAST(BUFF,ERR) ; 05603010 BEGIN 05603020 LOCAL A; SI~ERR; 8(IF SC!" " THEN JUMP OUT;SI~SI+1;TALLY~TALLY+1);05603030 A~TALLY; SI~LOC A; SI~SI+7 ; 05603040 IF SC<"8" THEN 05603050 BEGIN TALLY~1; FLAGLAST~TALLY ; 05603060 DI~BUFF;DS~46 LIT"LAST SYNTAX ERROR OCCURRED AT SEQUENCE NUMBER ";05603070 DS~LIT"""; SI~ERR; DS~8 CHR; DS~LIT"""; 05603080 DS~32 LIT " "; %510-05603081 DS~32 LIT " "; %510-05603082 END 05603090 END FLAGLAST ; 05603100 INTEGER PROCEDURE FEELD(X); VALUE X; INTEGER X; 05603110 FEELD~IF X<10 THEN 1 ELSE IF X<100 THEN 2 ELSE IF X<1000 THEN 3 ELSE IF 05603120 X<10000 THEN 4 ELSE IF X<100000 THEN 5 ELSE IF X<1000000 THEN 6 ELSE 7; 05603130 FORMAT EOC1(/ "NUMBER OF SYNTAX ERRORS DETECTED = ",I*,".",X*, 05604000 "NUMBER OF SEQUENCE ERRORS DETECTED = ",I*,"."), 05605000 EOC2("PRT SIZE = ",I*,"; TOTAL SEGMENT SIZE = ",I*, 05606000 " WORDS; DISK SIZE = ",I*," SEGS; NO. PRGM. SEGS = ",I*, 05607000 "."), 05607010 EOC3("ESTIMATED CORE STORAGE REQUIREMENT = ",I*," WORDS;", 05608000 " COMPILATION TIME = ",I*," MIN, ",I*," SECS;", 05608010 " NO. CARDS = ",I*,"."), 05608020 EOC4("ESTIMATED CORE STORAGE REQUIREMENT = ",I*," WORDS;" 05608030 " COMPILATION TIME = ",I*," SECS; NO. CARDS = ",I*,"."), 05608040 EOC5("NUMBER OF TSS WARNINGS DETECTED = ",I*,".") ; 05608050 COMMENT MAIN DRIVER FOR FORTRAN COMPILER BEGINS HERE; 05609000 RTI ~ TIME(1); 05610000 INITIALIZATION; 05611000 DO STATEMENT UNTIL NEXT = EOF; 05612000 IF NOT ENDSEGTOG THEN IF SPLINK NEQ 0 %112-05612100 THEN BEGIN XTA:=BLANKS; FLAG(5); ENDS END; %112-05612200 WRAPUP; 05613000 POSTWRAPUP: 05613900 IF TIMETOG THEN IF FIRSTCALL THEN DATIME; 05614000 IF NOT FIRSTCALL THEN 05615000 BEGIN 05616000 WRITE(RITE,EOC1,FEELD(ERRORCT),ERRORCT,IF SEQERRCT=0 THEN 99 ELSE 05617000 5,FEELD(SEQERRCT-1),SEQERRCT-1) ; 05618000 IF WARNED AND NOT DCINPUT THEN WRITE(RITE,EOC5,FEELD(WARNCOUNT), 05618100 WARNCOUNT) ; 05618110 WRITE(RITE,EOC2,FEELD(PRTS),PRTS,FEELD(TSEGSZ),TSEGSZ,FEELD(DALOC-1),05619000 DALOC-1,FEELD(NXAVIL),NXAVIL) ; 05619010 IF C1~(TIME(1)-RTI)/60 > 59 THEN WRITE(RITE,EOC3,FEELD(64|ESTIMATE), 05619020 64|ESTIMATE,FEELD(C1 DIV 60),C1 DIV 60,FEELD(C1 MOD 60),C1 MOD 60, 05619030 FEELD(CARDCOUNT-1),CARDCOUNT-1) ELSE WRITE(RITE,EOC4,FEELD(ESTIMATE 05619040 |64),ESTIMATE|64,FEELD(C1),C1,FEELD(CARDCOUNT-1),CARDCOUNT-1) ; 05619045 IF ERRORCT>0 THEN IF FLAGLAST(ERRORBUFF,LASTERR) THEN WRITE(RITE,15, 05619050 ERRORBUFF[*]) ; 05619100 END ; 05619200 END INNER BLOCK; 05620000 END. 05621000