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 FIELD(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,"+",FIELD(FLAGROUTINECOUNTER~FLAGROUTINECOUNTER+1), 00600060 FLAGROUTINECOUNTER,0) ELSE 00600065 BEGIN 00600070 WRITALIST(FLAGROUTINEFORMAT,7,"LEAVIN","G ",NAME1,NAME2,"-", 00600080 FIELD(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 01855000 BEGIN LASTLINE~FALSE; WRITE(LINE,15,PRINTBUFF[*]) ; 01856000 L6: BLANKIT(PRINTBUFF,15,IT~0) ; 01857000 END; 01858000 SETPNT(REC[0],REC[1],PRINTBUFF,KLASS[REC[2].CLASS],TYPES[REC[2]01859000 .SUBCLASS],IF BOOLEAN(REC[2]) THEN "*" ELSE " ",IT,L-1, 01860000 LASTLINE,6-REC[2].[27:3]) ; 01861000 END 01862000 ELSE BEGIN 01863000 LASTLINE~TRUE; WRITE(RITE,15,PRINTBUFF[*]); XTA~REC[0] ;01864000 GO L6 ; 01865000 END ; 01866000 END OF PT ; 01867000 01868000 PROCEDURE CHECKINFO; 01869000 BEGIN REAL I, T, A; 01870000 REAL LASTF; 01871000 REAL INFB,INFC; 01872000 LABEL NXT; ALPHA N; 01873000 FORMAT INFOF( 3(A6, X2), 01874000 " ADDRESS = ", A2, A4, 01875000 ", LENGTH = ", I5, 01876000 ", OFFSET = ", I5), 01877000 INFOT( / "LOCAL IDENTIFIERS:"), 01878000 LABF(A6,X10,"LABEL REL-ADR = ",I6,", SEGMNT = ",I5); 01879000 IF PRTOG THEN 01880000 WRITALIST(INFOT,0,0,0,0,0,0,0,0,0) ; 01881000 IF I ~ SEARCH("ERR ") ! 0 THEN 01882000 IF GET(I).CLASS = UNKNOWN THEN PUT(I+1, "......"); 01883000 IF I ~ SEARCH("END ") ! 0 THEN 01884000 IF GET(I).CLASS = UNKNOWN THEN PUT(I+1, "......"); 01885000 IF NOT DCINPUT THEN IF I~SEARCH("ZIP ") ! 0 THEN 01886000 IF GET(I).CLASS=UNKNOWN THEN PUT(I+1,"......") ; 01887000 FOR I ~ 0 STEP 1 UNTIL NEXTCOM DO 01888000 IF GETC(I).CLASS=HEADER THEN 01889000 01890000 IF GETC(I).CE=1 THEN 01891000 PUT((T~GETC(I+1).LINK+2),GET(T)&0[TOADINFO]) ; 01892000 01893000 T ~ 2; WHILE T < NEXTINFO DO 01894000 BEGIN 01895000 GETALL(T,A,INFB,INFC); 01896000 IF I ~ A.CLASS > FILEID THEN GO TO NXT; 01897000 IF N ~ INFB = "......" THEN GO TO NXT; 01898000 XTA ~ N; 01899000 IF I = LABELID THEN 01900000 BEGIN 01901000 IF A > 0 THEN FLAG(19) ELSE 01902000 IF PRTOG THEN WRITALIST(LABF,3,N,A.ADDR DIV 4,A.SEGNO,0,0,0,0, 01903000 0) ; 01904000 GO TO NXT; 01905000 END; 01906000 IF I = FORMATID THEN 01907000 IF A > 0 THEN BEGIN FLAG(62); GO TO NXT END ; 01908000 IF I = NAMELIST THEN 01909000 IF A > 0 THEN BEGIN FLAG(136); GO TO NXT END; 01910000 IF I = ARRAYID THEN 01911000 IF BOOLEAN(A.CE) THEN BEGIN IF A>0 THEN T~GETSPACE(T) END 01912000 ELSE IF A<0 THEN 01913000 IF BOOLEAN(A.FORMAL) THEN 01914000 BEGIN IF SPLINK > 1 AND ELX > 1 THEN 01915000 BEGIN % THIS IS A FORMAL PARAMETER FOR A SUBROUTINE OR A 01916000 % FUNCTION THAT HAS ONE OR MORE ENTRY STATEMENT. THIS 01917000 % PARAMETER WILL BE INITIALIZED TO AN ARRAY DESCRIPTOR01918000 % TO 0 SO THAT IF THE PARAMETERS ARE NOT SET UP BY THE01919000 % CALL ANY REFERENCE TO THEM WILL CAUSE AN INVALID 01920000 % ADDRESS 01921000 IF LASTF = 0 THEN % FIRST TIME THRU 01922000 BEGIN LASTF ~ A.ADDR; 01923000 EMITDESCLIT(2); EMITL(1); 01924000 EMITD(50,DIA); EMITD(10,DIB); EMITD(10,TRB); 01925000 END ELSE EMITPAIR(LASTF,LOD); 01926000 EMITPAIR(A.ADDR,SND); 01927000 END 01928000 END 01929000 ELSE ARRAYDEC(T); 01930000 IF PRTOG THEN 01931000 WRITALIST(INFOF,7,INFB, 01932000 IF BOOLEAN(A.TYPEFIXED) THEN TYPES[A.SUBCLASS] ELSE " ", 01933000 KLASS[A.CLASS], 01934000 IF A.ADDR < 1024 AND A < 0 THEN "R+" ELSE " ", 01935000 IF A < 0 THEN B2D(A.[26:10]) ELSE "NULL", 01936000 INFC.SIZE, 01937000 INFC.BASE,0); 01938000 IF BOOLEAN(A.CE) THEN IF A.SUBCLASS } DOUBTYPE THEN 01939000 IF BOOLEAN(INFC.BASE) THEN FLAG(146); 01940000 NXT: 01941000 T ~ T+3; 01942000 END; 01943000 END CHECKINFO; 01944000 01945000 PROCEDURE SEGMENTSTART; 01946000 BEGIN 01947000 NSEG ~ NXAVIL ~ NXAVIL + 1; 01948000 IF LISTOG THEN WRITALIST(SEGSTRT,1,NSEG,0,0,0,0,0,0,0) ; 01949000 DEBUGADR~ADR~-1; 01950000 IF NOT SEGOVFLAG THEN 01951000 BEGIN 01952000 DATAPRT~DATASTRT~DATALINK~DATASKP~ 01953000 LABELMOM ~ BRANCHX ~ FUNVAR ~ 01954000 DT ~ SPLINK ~ NEXTCOM ~ ELX ~ 0; 01955000 NEXTSS ~ 1022; 01956000 INITIALSEGNO ~ NSEG; 01957000 FOR I ~ 0 STEP 1 UNTIL LBRANCH DO BRANCHES[I] ~ I+1; 01958000 FOR I~0 STEP 1 UNTIL SHX DO STACKHEAD[I] ~ 0; 01959000 NEXTINFO ~ LOCALS ~ 2; 01960000 F2TOG ~ FALSE; RETURNFOUND ~ FALSE; 01961000 END; 01962000 ENDSEGTOG ~ FALSE; 01963000 IF SEGSW THEN LINESEG[NOLIN~0,0]~0 & D2B(LASTSEQ)[10:20:28] ; 01964000 END SEGMENTSTART; 01965000 PROCEDURE FIXPARAMS(I); VALUE I; INTEGER I; 01966000 BEGIN 01967000 REAL FMINUS, NPARMS, ELINK, LABX; 01968000 REAL PLINKX, PLINK; 01969000 REAL PTYPEX, PTYPE; 01970000 REAL CL, INF; 01971000 LABEL ARRY, LOAD, INDX; 01972000 REAL EWORD; 01973000 IF DEBUGTOG THEN FLAGROUTINE(" FIXP","ARMS ",TRUE); 01974000 EWORD ~ ENTRYLINK[I]; 01975000 ELINK ~ EWORD.LINK; 01976000 IF LABX ~ EWORD.CLASS > 0 THEN 01977000 BEGIN 01978000 EMITO(MKS); 01979000 EMITDESCLIT(LABELMOM); 01980000 EMITL(LABX); 01981000 EMITL(1); EMITL(1); EMITL(0); 01982000 EMITOPDCLIT(BLKCNTRLINT); 01983000 EMITL(1); EMITPAIR(FPLUS2,STD);% F+2~TRUE FOR BLKXIT CALL 01984000 END; %106-01985000 FMINUS ~ 1920; 01986000 NPARMS ~ (J~GET(ELINK+2)).NEXTRA; 01987000 IF NPARMS > 0 THEN %106-01988000 BEGIN 01989000 PLINKX ~ EWORD.ADDR-NPARMS+1; 01990000 PTYPEX ~ J.ADINFO + NPARMS-1; 01991000 FOR J ~ 1 STEP 1 UNTIL NPARMS DO 01992000 BEGIN 01993000 PLINK ~ EXTRAINFO[PLINKX.IR,PLINKX.IC]; 01994000 PTYPE ~ EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS; 01995000 FMINUS ~ FMINUS+1; 01996000 IF PLINK = 0 THEN 01997000 BEGIN 01998000 EMITOPDCLIT(FMINUS); 01999000 EMITL(LABX ~ LABX-1); 01100000 EMITDESCLIT(LABELMOM); 01100100 EMITO(STD); 01100200 END ELSE 01100300 BEGIN 01100400 IF CL ~ (INF ~ GET(PLINK)).CLASS = UNKNOWN THEN CL ~ VARID; 01100500 XTA ~ GET(PLINK+1); 01100600 IF PTYPE = 0 THEN EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS 01100700 ~ PTYPE ~ CL; 01100800 CASE PTYPE OF 01100900 BEGIN ; 01101000 IF CL ! ARRAYID THEN FLAG(79) ELSE 01101100 ARRY: 01101200 BEGIN 01101300 FMINUS ~ FMINUS+1; 01101400 IF INF < 0 THEN 01101500 BEGIN 01101600 EMITPAIR(FMINUS, LOD); 01101700 EMITPAIR(T~INF.ADDR, STD); 01101800 EMITOPDCLIT(FMINUS-1); 01101900 EMITPAIR(T-1, STD); 01102000 END; 01102100 END; 01102200 IF CL ! VARID THEN FLAG(80) ELSE 01102300 LOAD: 01102400 BEGIN 01102500 IF INF.SUBCLASS}DOUBTYPE AND CL=VARID THEN FMINUS~FMINUS+1; 01102600 IF INF<0 THEN 01102700 BEGIN 01102800 EMITPAIR(FMINUS, LOD); 01102900 EMITPAIR(T~INF.ADDR,STD); 01103000 IF INF.SUBCLASS}DOUBTYPE AND CL=VARID THEN %105-11103100 BEGIN EMITOPDCLIT(FMINUS-1); 01103200 EMITPAIR(T+1,STD); 01103300 END; 01103400 END ; 01103500 END; 01103600 ; ; ; ; 01103700 IF CL = FUNID THEN GO TO LOAD ELSE FLAG(81); 01103800 01103900 ; 01104000 IF CL = FUNID OR CL = SUBRID OR CL = EXTID THEN GO TO LOAD 01104100 ELSE FLAG(83); 01104200 IF CL = SUBRID THEN GO TO LOAD ELSE FLAG(82); 01104300 ; ; 01104400 BEGIN 01104500 IF CL = ARRAYID THEN 01104600 BEGIN 01104700 EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS ~ CL; 01104800 GO TO ARRY; 01104900 END; 01105000 INDX: 01105100 IF CL ! VARID THEN FLAG(80); 01105200 FMINUS ~ FMINUS+1; 01105300 IF INF < 0 THEN 01105400 BEGIN 01105500 EMITOPDCLIT(FMINUS-1); 01105600 EMITDESCLIT(FMINUS); 01105700 EMITPAIR(INF.ADDR, STD); 01105800 END; 01105900 END; 01106000 IF CL = VARID THEN GO TO LOAD ELSE FLAG(80); 01106100 GO TO INDX; 01106200 END CASE STATEMENT; 01106300 01106400 01106500 A ~ INF.SUBCLASS; 01106600 IF T ~ EXTRAINFO[PTYPEX.IR,PTYPEX.IC].SUBCLASS = 0 OR 01106700 T = INTYPE AND A = REALTYPE THEN 01106800 EXTRAINFO[PTYPEX.IR,PTYPEX.IC].SUBCLASS ~ A ELSE 01106900 IF T ! A THEN 01107000 BEGIN XTA ~ GET(PLINK+1); FLAG(88) END; 01107100 END; 01107200 PLINKX ~ PLINKX+1; 01107300 PTYPEX ~ PTYPEX-1; 01107400 END; 01107500 PLINKX ~ PLINKX-NPARMS; 01107600 FOR J ~ 1 STEP 1 UNTIL NPARMS DO 01107700 BEGIN 01107800 PLINK ~ EXTRAINFO[PLINKX.IR,PLINKX.IC]; 01107900 IF PLINK ! 0 THEN 01108000 IF (A~GET(PLINK)).CLASS = ARRAYID THEN 01108100 IF T~GET(PLINK+2) <0 THEN VARIABLEDIMS(A, T); 01108200 PLINKX ~ PLINKX+1; 01108300 END; 01108400 END; 01108500 EMITB(GET(ELINK+2).BASE & (GET(ELINK).SEGNO)[TOSEGNO], FALSE); 01108600 IF DEBUGTOG THEN FLAGROUTINE(" FIXP","ARMS ",FALSE) ; 01108700 END FIXPARAMS; 01108800 01108900 PROCEDURE XREFCORESORT ; 01109000 BEGIN 01109100 REAL F,G,H,J,K,L,T,TT,IJ,M,TN ; 01109200 SAVE ARRAY A[0:XRI-1], IL,IU[0:8]; 01109300 ARRAY W2,W3[0:XRI-1] ; 01109400 LABEL L1,L2,L3,L4,L5,L6,L11,L12,L13,L14 ; 01109500 DEFINE CMPARGT(A) = A.NAME=TN THEN IF (IF G~W3[H~A.[2:10]].[26:4] 01109600 =TT~W3[F~T.[2:10]].[26:4] THEN NOT CMPA(W2[H], 01109700 W2[F]) ELSE G>TT) #, 01109800 CMPARLS(A) = A.NAME=TN THEN IF (IF G~W3[H~T.[2:10]].[26:4] 01109900 =TT~W3[F~A.[2:10]].[26:4] THEN NOT CMPA(W2[H], 01110000 W2[F]) ELSE G>TT) #, 01110100 NAME = [12:36] # ; 01110200 J~XRI-1; G~XRI DIV K~XRBUFFDIV3; H~XRBUFF ; 01110300 FOR L~1 STEP 1 UNTIL G DO 01110400 BEGIN 01110500 L11: READ(XREFF,H,XRRY[*]); TRANSFER(W2[T~(L-1)|50],XRRY,K) ; 01110600 IJ~T+K-1; TN~-3; 01110700 FOR F~T STEP 1 UNTIL IJ DO 01110800 BEGIN A[F]~XRRY[TN~TN+3]&F[2:38:10]; W3[F]~XRRY[TN+2] END;01110900 END; 01111000 IF H=XRBUFF THEN IF K~XRI MOD K DIV 1!0 THEN BEGIN H~3|K;GO L11 END;01111100 GO L4 ; 01111200 L1: IF A[K~I].NAME>TN~(T~A[IJ~((L~J)+I+1).[37:10]]).NAME THEN 01111300 L12: BEGIN A[IJ]~A[I]; A[I]~T; TN~(T~A[IJ]).NAME END 01111400 ELSE IF CMPARGT(A[I]) THEN GO L12 ; 01111500 IF A[J].NAMETN THEN GO L2; IF CMPARGT(A[L]) THEN GO L2; 01112400 L3: IF A[K~K+1].NAMEJ+I THEN BEGIN IL[M]~I; IU[M]~L; I~K END 01112700 ELSE BEGIN IL[M]~K; IU[M]~J; J~L END ; 11112800 M~M+1 ; 01112900 L4: IF I+10TN~(T~A[I]).NAME THEN 01113300 BEGIN 01113400 L5: A[K+1]~A[K]; IF A[K~K-1].NAME>TN THEN GO L5 ; 01113500 IF CMPARGT(A[K]) THEN GO L5 ; 01113600 A[K+1]~T ; 01113700 END 01113800 ELSE IF CMPARGT(A[K]) THEN GO L5 ; 01113900 IF (M~M-1) GEQ 0 THEN BEGIN I~IL[M]; J~IU[M]; GO L4 END ; 01114000 G~XRI-1 ; 01114100 FOR I~ 0 STEP 1 UNTIL G DO 01114200 IF BOOLEAN(L~REAL(A[I]~A[I].NAME&(TN~W3[J~A[I].[2:10]])[1:26:1]01114300 =XTA)) THEN 01114400 BEGIN 01114500 IF IT~IT+1=9 THEN 01114600 BEGIN LASTLINE~FALSE; WRITE(LINE,15,PRINTBUFF[*]) ; 01114700 L6: BLANKIT(PRINTBUFF,15,IT~0) ; 01114800 END ; 01114900 SETPNT(A[I],W2[J],PRINTBUFF,KLASS[TN.CLASS],TYPES[TN. 01115000 SUBCLASS],IF BOOLEAN(TN) THEN "*" ELSE " ",IT,L-1, 01115100 LASTLINE,6-TN.[27:3]) ; 01115200 END 01115300 ELSE BEGIN 01115400 LASTLINE~TRUE; WRITE(RITE,15,PRINTBUFF[*]); XTA~A[I]; 01115500 GO L6; 01115600 END ; 01115700 WRITE(LINE,15,PRINTBUFF[*]); XRI~0; 01115800 END OF XREFCORESORT ; 01115900 01116000 PROCEDURE SETUPSTACK ; 01116100 BEGIN 01116200 REAL I; 01116300 EMITOPDCLIT(16); 01116400 EMITL(1); 01116500 EMITO(ADD); 01116600 EMITL(16); 01116700 EMITO(SND); 01116800 FOR I ~ 1 STEP 1 UNTIL LOCALS DO EMITL(0); 01116900 CHECKINFO; 01117000 IF DATAPRT ! 0 THEN 01117100 BEGIN ADJUST; EMITOPDCLIT(DATAPRT); EMITO(LNG); EMITB(-1,TRUE);01117200 DATASKP~LAX; EMITB(DATASTRT,FALSE); FIXB(DATALINK); 01117300 EMITL(1); EMITPAIR(DATAPRT,STD); FIXB(DATASKP); 01117400 END; 01117500 ADJUST; 01117600 END SETUPSTACK; 01117700 01117800 PROCEDURE BRANCHLIT(X,Y); VALUE X,Y; REAL X; BOOLEAN Y; 01117900 BEGIN 01118000 IF ADR } 4075 THEN 01118100 BEGIN ADR ~ ADR+1; SEGOVF END; 01118200 ADJUST; 01118300 IF X.SEGNO!NSEG THEN BEGIN 01118400 IF(PRTS+1).[37:2]=1 AND Y THEN 01118500 EMITOPDCLIT(PRGDESCBLDR(2,0,(ADR+5) DIV 4+1,NSEG)) 01118600 ELSE EMITOPDCLIT(PRGDESCBLDR(2,0,(ADR+5) DIV 4,NSEG)) END 01118700 ELSE 01118800 EMITL((ADR+5) DIV 4 - X.LINK DIV 4) ; 01118900 END BRANCHLIT; 01119000 PROCEDURE SEGMENT(SZ,CURSEG,SEGTYP,EDOC); % WRITES OUT EDOC AS SEGMENT 01119100 VALUE SZ,CURSEG,SEGTYP; % UPDATES PDPRT WITH PSUEDO 01119200 REAL SZ,CURSEG; % UPDATES PDPRT WITH PSUEDO 01119300 BOOLEAN SEGTYP; % TRUE TO WRAP UP A SUBROUTINE BLOCK 01119400 % FALSE TO WRAP UP A SPLIT BLOCK 01119500 ARRAY EDOC[0,0]; % CONTAINS DATA TO WRITE; 01119600 BEGIN 01119700 STREAM PROCEDURE M1(F,T); BEGIN DI ~ T; SI ~ F; DS ~ 2 WDS END;01119800 REAL T; 01119900 REAL BEGINSUB, ENDSUB, HERE; 01120000 LABEL WRITEPGM; 01120100 INTEGER I, CNTR; 01120200 IF DEBUGTOG THEN FLAGROUTINE(" SEGM","ENT ",TRUE ); 01120300 IF NOT SEGTYP THEN GO TO WRITEPGM; 01120400 IF SPLINK > 1 AND NOT RETURNFOUND THEN 01120500 BEGIN XTA ~ BLANKS; FLAG(142) END; 01120600 IF SPLINK < 0 THEN 01120700 BEGIN 01120800 ADJUST; 01120900 BDPRT[BDX~BDX+1] ~ PRGDESCBLDR(1, 0, (ADR+1) DIV 4, NSEG); 01121000 FOR I ~ 1 STEP 1 UNTIL LOCALS DO EMITL(0); 01121100 CHECKINFO; 01121200 01121300 EMITB(0&INITIALSEGNO[TOSEGNO], FALSE); 01121400 END 01121500 ELSE 01121600 IF SPLINK = 1 THEN % MAIN PROGRAM 01121700 BEGIN 01121800 ADJUST; 01121900 IF STRTSEG ! 0 THEN FLAG(75); 01122000 STRTSEG ~ NSEG & 01122100 PRGDESCBLDR(1, 0, (ADR+1) DIV 4, NSEG)[18:33:15]; 01122200 SETUPSTACK; 01122300 01122400 EMITB(0&INITIALSEGNO[TOSEGNO], FALSE); 01122500 END 01122600 ELSE 01122700 IF ELX { 1 THEN 01122800 BEGIN 01122900 ADJUST; 01123000 T ~ PRGDESCBLDR(1, GET(SPLINK).ADDR, (ADR+1) DIV 4, NSEG); 01123100 SETUPSTACK; 01123200 FIXPARAMS(0); 01123300 INFO[SPLINK.IR, SPLINK.IC].SEGNO ~ NSEG; 01123400 END 01123500 ELSE 01123600 BEGIN 01123700 ADJUST; 01123800 BEGINSUB ~ (ADR+1) & NSEG[TOSEGNO]; 01123900 EMITL(17); EMITO(STD); 01124000 SETUPSTACK; 01124100 EMITOPDCLIT(17); EMITO(GFW); 01124200 ENDSUB ~ ADR & NSEG[TOSEGNO]; 01124300 FOR I ~ 0 STEP 1 UNTIL ELX-1 DO 01124400 BEGIN 01124500 ADJUST; 01124600 HERE ~ (ADR+1) DIV 4; 01124700 T ~ ENTRYLINK[I].LINK; 01124800 %VOID 01124900 T ~ PRGDESCBLDR(1, GET(T).ADDR, HERE, NSEG); 01125000 BRANCHLIT(ENDSUB,FALSE); 01125100 EMITB(BEGINSUB, FALSE); 01125200 ADJUST; 01125300 FIXPARAMS(I); 01125400 INFO[(ENTRYLINK[I].LINK).IR,(ENTRYLINK[I].LINK).IC].SEGNO~NSEG;01125500 END; 01125600 END; 01125700 SZ ~ (ADR+4) DIV 4; 01125800 CNTR ~ 0; 01125900 CURSEG ~ NSEG; 01126000 WRITEPGM: 01126100 NSEG ~ ((T ~ SZ) + 29) DIV 30; 01126200 IF DALOC DIV CHUNK < I ~ (DALOC+NSEG) DIV CHUNK 01126300 THEN DALOC ~ CHUNK | I; % INSURE SEGMENT DONT BREAK 01126400 % ACROSS ROW 01126500 IF LISTOG THEN WRITALIST(SEGEND,2,CURSEG,T,0,0,0,0,0,0) ; 01126600 PDPRT[PDIR,PDIC] ~ % PDPRT ENTRY FOR SEGMENT 01126700 SZ&DALOC[DKAC] 01126800 & GET(SPLINK)[12:41:1] 01126900 &CURSEG[SGNOC]; 01127000 IF ERRORCT = 0 THEN 01127100 DO BEGIN 01127200 FOR I~0 STEP 2 WHILE I < 30 AND CNTR < SZ DO 01127300 BEGIN M1(EDOC[CNTR.[38:3],CNTR.[41:7]],CODE(I)); 01127400 CNTR ~ CNTR + 2; 01127500 END; 01127600 WRITE(CODE[DALOC]); 01127700 DALOC ~ DALOC +1; 01127800 END UNTIL CNTR } SZ; 01127900 PDINX ~ PDINX +1; 01128000 IF NOT SEGOVFLAG THEN 01128100 IF PXREF THEN 01128200 IF(EODS~(NEXT=EOF))AND NOT XGLOBALS THEN ELSE 01128300 BEGIN KLASS[6]~ "LABEL "; 01128400 WRITE(XREFF,XRBUFF,XRRY[*]) ; 01128500 IF FIRSTCALL THEN DATIME ELSE WRITE(PTR[PAGE]); 01128600 IF SPLINK<0 THEN 01128700 BEGIN WRITE(PTR,XHEDB);REWIND(XREFF);END 01128800 ELSE 01128900 IF EODS THEN BEGIN WRITE(PTR,XHEDG); REWIND(XREFG) END 01129000 ELSE BEGIN REWIND(XREFF); C2~(XR[4].SUBCLASS|2+5); 01129100 IF IT~XR[4].CLASS=FUNID THEN WRITE(PTR,XHEDF, 01129200 XR[C2],XR[C2+1],XR[3],XR[C2+12], 01129300 XR[C2+13],"------") 01129400 ELSE IF IT=SUBRID THEN WRITE(PTR,XHEDS,XR[3], 01129500 "------") ELSE WRITE(PTR,XHEDM); 01129600 END; 01129700 IT~XTA~0; 01129800 LASTLINE ~ FALSE; 01129900 BLANKIT(PRINTBUFF,15,0); 01130000 IF XRI>1023 OR EODS THEN SORT(PT,INP,0,HV,CMP,3,4000) 01130100 ELSE XREFCORESORT ; 01130200 REWIND(XREFF); 01130300 PXREF~IF XREF THEN TRUE ELSE FALSE; 01130400 KLASS[6] ~ "ERROR "; 01130500 IF (NOT SEGTYP AND EODS) OR (SEGTYP AND LISTOG AND 01130600 NOT SEGPTOG) THEN WRITE (PTR[PAGE]); 01130700 END; 01130800 IF LISTOG AND SEGTYP AND SEGPTOG THEN WRITE(PTR[PAGE]); 01130900 IF SEGTYP THEN 01131000 BEGIN 01131100 FOR I~12,17 STEP 1 UNTIL 24,39 STEP 1 UNTIL 41, 01131200 50 STEP 1 UNTIL 57 DO TIPE[I]~REALID ; 01131300 FOR I~25,33 STEP 1 UNTIL 37 DO TIPE[I]~INTID ; 01131400 LASTNEXT ~ 1000; 01131500 END; 01131600 ENDSEGTOG ~ TRUE; 01131700 TSEGSZ ~ TSEGSZ + SZ; 01131800 COMMENT IF SEGSW THEN LETS ALSO WRITE OUT THE LINE SEGMENTS 01131900 THAT WE VE GONE TO SUCH TROUBLE BUILDING. LINESEG 01132000 CONTAINS A CARD SEQUENCE NUMBER(BINARY) IN [10:28] 01132100 AND THE WORD BOUNDARY ADDRESS OF THE FIRST CODE 01132200 SYLLABLE IN [38:10]; 01132300 IF SEGSW THEN 01132400 IF NOLIN > 0 THEN 01132500 BEGIN 01132600 LINEDICT[CURSEG.IR,CURSEG.IC] ~ % UPDATE LINE DICTIONARY 01132700 0 & NOLIN[18:33:15] & DALOC[33:33:15];%FOR THIS SEGMENT 01132800 CNTR ~ 0; DO BEGIN 01132900 FOR I ~ 0 STEP 2 WHILE I<30 AND CNTR 30 THEN 30 ELSE (SZ-I)); 01136600 WRITE(CODE[DALOC]); 01136700 DALOC ~ DALOC +1; 01136800 END; 01136900 IF LISTOG THEN WRITALIST(SEGEND,2,SEG,T,0,0,0,0,0,0) ; 01137000 TSEGSZ ~ TSEGSZ + SZ; 01137100 END WRITEDATA; 01137200 01137300 REAL PROCEDURE PRGDESCBLDR(DT,PRT,RELADR,SGNO); 01137400 VALUE DT,PRT,RELADR,SGNO; 01137500 REAL DT,PRT,RELADR,SGNO; 01137600 BEGIN 01137700 FORMAT FMT("PRT=",A4,", REL-ADR=",A4,", SEG=",I4,", TYPE=",A2); 01137800 IF PRT=0 THEN BEGIN BUMPPRT; PRT~PRTS END; 01137900 PDPRT[PDIR,PDIC] ~ 01138000 0&DT[DTYPC] 01138100 &PRT[PRTAC] 01138200 &RELADR[RELADC] 01138300 &SGNO[SGNOC]; 01138400 PDINX ~ PDINX +1; 01138500 IF CODETOG THEN WRITALIST(FMT,4,B2D(PRT),B2D(RELADR),SGNO, 01138600 IF DT=0 THEN "AE" ELSE IF DT=1 THEN "PD" ELSE "LD",0,0,0,0) ; 01138700 PRGDESCBLDR ~ PRT; 01138800 END PRGDESCBLDR; 01138900 01139000 PROCEDURE EQUIV(R); VALUE R; REAL R; 01139100 COMMENT THIS PROCEDURE FIXES UP THE INFO TABLE FOR THE EQUIV OR 01139200 COMMON RING. THE FIRST ELEMENT PAST HAS AN OFFSET (DO NOT 01139300 ALTER THIS) THE TYPE IS FIXED. THE OFFSET IS DETERMINED 01139400 FROM THE FIRST. CORRECTINFO ADJUST THE OFFSET IF THERE 01139500 IS A NEGATIVE OFFSET ON ANY ELEMENT. THE INFA[ADJ] BIT IS 01139600 SET IF THE ELEMENT HAS A NEGATIVE OFFSET. IF THE ELEMENT 01139700 APPEARED IN MORE THAN ONE EQUIVALENCE STATEMENT OR AN 01139800 EQUIVALENCE STATEMENT AND A COMMON STATEMENT THE ELEMENTS 01139900 ARE LINKED BY COM[LASTC] WHICH POINTS TO THE HEADER 01140000 OF THAT STATEMENT; 01140100 BEGIN 01140200 DEFINE BASS = LOCALS #, % THESE DEFINES ARE USED TO REDUCE THE01140300 REL = PARMS #, % STACKSIZE OF EQUIV FOR RECURSION 01140400 I = PRTS #, 01140500 T = LSTS #, 01140600 Q = LSTA #, 01140700 LAST = TV #, 01140800 B = SAVESUBS #, 01140900 P = NAMEIND #, 01141000 PRTX = LSTI #, 01141100 C = FX1 #, 01141200 INFA = FX2 #, 01141300 INFB = FX3 #, 01141400 INFC = NX1 #; 01141500 LABEL XIT, CHECK; 01141600 IF DEBUGTOG THEN FLAGROUTINE(" EQU","IV ",TRUE) ; 01141700 IF GETC(R) <0 THEN GO TO XIT; 01141800 PUTC(R,-GETC(R)) ; 01141900 PRTX ~ GROUPPRT; 01142000 C~REAL(GETC(R).CE=1) ; 01142100 LAST~GETC(R).LASTC-1 ; 01142200 BASS~GETC(R+1); P~0 ; 01142300 FOR I ~ R+2 STEP 1 UNTIL LAST DO 01142400 BEGIN IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; 01142500 GETALL(T~GETC(I).LINK,INFA,INFB,INFC) ; 01142600 IF Q~INFC.SIZE=0 THEN % A SIMPLE VARIABLE 01142700 INFC.SIZE ~ Q ~ IF INFA.SUBCLASS { LOGTYPE THEN 1 ELSE 2; 01142800 PUT(T+2,INFC); 01142900 IF INFA.SUBCLASS>LOGTYPE THEN SEENADOUB~TRUE; 01143000 IF BOOLEAN(C) THEN 01143100 BEGIN COM[PWI].RELADD~REL~P ; 01143200 P ~ P + Q; 01143300 END ELSE COM[PWI].RELADD~REL~BASS-GETC(I).RELADD ; 01143400 IF INFA < 0 THEN IF INFA .ADJ = 1 THEN 01143500 B ~ -INFC.BASE - REL ELSE B ~ INFC.BASE - REL; 01143600 END; 01143700 FOR I ~ R+2 STEP 1 UNTIL LAST DO 01143800 BEGIN IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; 01143900 GETALL(T~GETC(I).LINK,INFA,INFB,INFC) ; 01144000 IF INFA.CLASS = 1 THEN SWARYCT ~ 1; 01144100 P~B+GETC(I).RELADD ; 01144200 Q ~ INFC .SIZE; 01144300 IF INFA < 0 THEN 01144400 BEGIN IF INFA .ADJ = 1 THEN BASS ~ -INFC .BASE ELSE 01144500 BASS ~ INFC.BASE; 01144600 IF P ! BASS THEN 01144700 BEGIN XTA ~ INFB ; FLAG(2) END; 01144800 GO TO CHECK; 01144900 END; 01145000 INFA ~ -INFA & PRTX[TOADDR]; 01145100 IF INFA .CLASS = UNKNOWN THEN INFA .CLASS ~ VARID; 01145200 INFA .TYPEFIXED ~ 1; 01145300 INFC.BASE ~ P; 01145400 PUT(T+2,INFC); 01145500 IF P < 0 THEN INFA .ADJ ~ 1; 01145600 PUT(T,INFA); 01145700 CHECK: 01145800 IF P+Q > LENGTH THEN LENGTH ~ P+Q; 01145900 IF P < LOWERBOUND THEN LOWERBOUND ~ P; 01146000 END; 01146100 FOR I ~ R+2 STEP 1 UNTIL LAST DO 01146200 BEGIN 01146300 IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; 01146400 IF T~GETC(I).LASTC!R THEN 01146500 IF GETC(T)}0 THEN 01146600 BEGIN R~R&LAST[3:33:15]&I[18:33:15] ; 01146700 EQUIV(T); LAST~R.[3:15]; I~R.[18:15]; R~R.[33:15] ; 01146800 END; 01146900 END; 01147000 XIT: 01147100 IF DEBUGTOG THEN FLAGROUTINE(" EQU","IV ",FALSE) ; 01147200 END EQUIV; 01147300 ALPHA PROCEDURE GETSPACE(S); VALUE S; ALPHA S; 01147400 BEGIN LABEL RPLUS, FMINUS, XIT; 01147500 LABEL DONE; 01147600 REAL A; 01147700 BOOLEAN OWNID; 01147800 IF OWNID ~ S < 0 THEN S~ -S; % IN DATA STMT, THUS OWN 01147900 IF A ~ GET(GETSPACE~S) < 0 THEN GO TO DONE; 01148000 IF A.CLASS GEQ 13 THEN FLAG(34) ELSE %104-01148100 CASE A.CLASS OF 01148200 BEGIN 01148300 BEGIN 01148400 PUT(S,A~A&VARID[TOCLASS]); 01148500 PUT(S+2,(GET(S+2) &(IF A.SUBCLASS { LOGTYPE 01148600 THEN 1 ELSE 2 )[TOSIZE])); 01148700 END; 01148800 IF BOOLEAN(A.FORMAL) THEN BUMPLOCALS; 01148900 ; 01149000 BEGIN A.TYPEFIXED ~ 1; GO TO RPLUS END; 01149100 GO TO RPLUS; 01149200 GO TO RPLUS; 01149300 GO TO DONE; 01149400 BEGIN A.TYPEFIXED ~ 1; IF BOOLEAN(A.FORMAL) THEN GO TO FMINUS 01149500 ELSE GO TO RPLUS; 01149600 END; 01149700 BEGIN A.TYPEFIXED ~ 1; GO TO RPLUS END; 01149800 IF BOOLEAN(A.FORMAL) THEN GO TO FMINUS ELSE GO TO RPLUS; 01149900 IF BOOLEAN(A.FORMAL) THEN GO TO FMINUS ELSE GO TO RPLUS; 01150000 GO TO RPLUS; 01150100 GO TO RPLUS; 01150200 END OF CASE STATEMENT; 01150300 01150400 01150500 A.TYPEFIXED ~ 1; 01150600 IF BOOLEAN(A.FORMAL) THEN 01150700 GO TO FMINUS; 01150800 IF BOOLEAN(A.CE) OR BOOLEAN(A.EQ) THEN 01150900 BEGIN 01151000 PUT(S,A); 01151100 CALLEQUIV(A.ADDR,OWNID,GET(S+1)) ; 01151200 GO TO DONE; 01151300 END; 01151400 A.TWOD ~ REAL(GET(S+2).SIZE > 1023); 01151500 FMINUS: 01151600 IF OWNID THEN BEGIN BUMPPRT; A.ADDR~PRTS END ELSE 01151700 BEGIN BUMPLOCALS; A.ADDR ~ LOCALS +1536 END; 01151800 IF A.CLASS = VARID THEN IF A.SUBCLASS } DOUBTYPE THEN 01151900 IF OWNID THEN BUMPPRT ELSE 01152000 BUMPLOCALS; 01152100 GO TO XIT; 01152200 RPLUS: 01152300 BUMPPRT; A.ADDR~PRTS; 01152400 XIT: 01152500 PUT(S, -A); 01152600 DONE: 01152700 END GETSPACE; 01152800 INTEGER STREAM PROCEDURE LBLSHFT(S); VALUE S; 01152900 BEGIN 01153000 LOCAL T; 01153100 LABEL L; 01153200 DI ~ LOC LBLSHFT; DS ~ 8 LIT "00 "; 01153300 DI ~ DI - 6; SI ~LOC S; SI ~ SI + 2; 01153400 TALLY ~ 1; T ~ TALLY; 01153500 5(T(IF SC="0" THEN BEGIN SI~SI+1; JUMP OUT 1 TO L END 01153600 ELSE TALLY~0; T~TALLY); 01153700 IF SC}"0" THEN DS~CHR ELSE IF SC=" " THEN SI~SI+1 01153800 ELSE JUMP OUT; L: ) ; 01153900 IF SC ! " " THEN BEGIN DI ~ LOC LBLSHFT; DS ~ LIT "+" END; 01154000 END LBLSHFT; 01154100 COMMENT EMITTERS AND CODE CONTROL; 01154200 ALPHA PROCEDURE B2D(B); VALUE B; REAL B; 01154300 B2D ~ 0&B[45:45:3]&B[39:42:3]&B[33:39:3]&B[27:36:3]; 01154400 PROCEDURE DEBUG(S); % PRINTS OUT DEBUG CODE 01154500 VALUE S; REAL S; % IF S<0 THEN S IS FIELD TYPE OPERATOR 01154600 BEGIN 01154700 FORMAT FF(X35,*(33(".")),A4,":",A1,2(X2,A4),X4,A4) ; 01154800 ALPHA CODE,MNM,SYL; 01154900 REAL T; 01155000 PROCEDURE SEARCH(CODE,S); VALUE S; REAL S,CODE; 01155100 BEGIN % SEARCHS WOP TO FIND CODE FOR S 01155200 REAL N,I; 01155300 LABEL L; 01155400 N ~ 64; 01155500 FOR I ~ 66 STEP IF WOP[I] < S THEN N ELSE -N 01155600 WHILE N ~ N DIV 2 } 1 DO 01155700 IF WOP[I] =S THEN GO TO L; 01155800 I ~ 0; % NOT FOUND 01155900 L: CODE ~ WOP[I+1]; 01156000 END SEARCH; 01156100 01156200 IF S < 0 THEN 01156300 BEGIN % FIELD TYPE OPERATOR 01156400 SYL ~ S; 01156500 MNM ~ B2D(S.[36:6]); 01156600 IF (S ~ S.[42:6]) = 37 THEN CODE ~ "ISO " ELSE 01156700 IF S = 45 THEN CODE ~ "DIA " ELSE 01156800 IF S = 49 THEN CODE ~ "DIB " ELSE 01156900 IF S = 53 THEN CODE ~ "TRB "; 01157000 END 01157100 ELSE 01157200 BEGIN 01157300 IF (T ~ S.[46:2]) ! 1 THEN 01157400 BEGIN 01157500 SYL ~ S; 01157600 MNM ~ B2D(S.[36:10]); 01157700 IF T = 0 THEN CODE ~ "LITC" 01157800 ELSE IF T =2 THEN CODE ~ "OPDC" 01157900 ELSE CODE ~ "DESC"; 01158000 END 01158100 ELSE 01158200 BEGIN % SEARCH WOP FOR OPERATOR NAME 01158300 SYL ~ S; 01158400 MNM ~ " "; 01158500 SEARCH(CODE,S.[36:10]); 01158600 END; 01158700 END; 01158800 WRITALIST(FF,6,IF ADR{DEBUGADR THEN 1 ELSE -1,B2D(ADR.[36:10]),01158900 B2D(ADR.[46:2]),CODE,MNM,B2D(SYL),0,0) ; 01159000 IF DEBUGADR0 THEN S~GET(GETSPACE(P)); 01164100 IF S.CLASS = VARID THEN IF BOOLEAN(S.CE) THEN 01164200 IF BOOLEAN(S.TWOD) THEN 01164300 BEGIN 01164400 EMITL( (T~GET(P+2).BASE).[33:7]); 01164500 EMITDESCLIT(S.ADDR); 01164600 EMITO(LOD); 01164700 EMITL(T.[40:8]); 01164800 EMITO(CDC); 01164900 GO TO XIT; 01165000 END ELSE 01165100 EMITNUM(GET(P+2).BASE) 01165200 ELSE 01165300 IF NOT BOOLEAN(S.FORMAL) THEN IF NOT DESCREQ THEN 01165400 BEGIN 01165500 EMITL(S~S.ADDR); 01165600 IF S.[37:2]=1 THEN %REFERENCING 2ND HALF OF PRT; 01165700 BEGIN 01165800 IF ADR } 4087 THEN 01165900 BEGIN ADR ~ ADR+1; SEGOVF END; 01166000 EMITO(XRT); 01166100 END; 01166200 GO TO XIT; 01166300 END; 01166400 EMITDESCLIT(S.ADDR); 01166500 XIT: 01166600 END EMITN; 01166700 01166800 PROCEDURE EMITV(P); VALUE P; ALPHA P; 01166900 BEGIN 01167000 ALPHA S; 01167100 IF S~ GET(P) > 0 THEN S ~ GET(GETSPACE(P)); 01167200 IF S.CLASS = VARID THEN 01167300 IF BOOLEAN(S.CE) THEN 01167400 IF BOOLEAN(S.TWOD) THEN 01167500 BEGIN 01167600 EMITL( (T~GET(P+2).BASE).[33:7]); 01167700 EMITDESCLIT(S.ADDR); 01167800 EMITO(LOD); 01167900 IF S.SUBCLASS } DOUBTYPE THEN 01168000 BEGIN 01168100 EMITO(DUP); 01168200 EMITPAIR(T.[40:8]+1, COC); 01168300 EMITO(XCH); 01168400 EMITPAIR(T.[40:8], COC); 01168500 END ELSE EMITPAIR(T.[40:8], COC); 01168600 END 01168700 ELSE 01168800 IF S.SUBCLASS } DOUBTYPE THEN 01168900 BEGIN 01169000 EMITNUM( (T~GET(P+2).BASE)+1); 01169100 EMITOPDCLIT(S.ADDR); 01169200 EMITNUM(T); 01169300 EMITOPDCLIT(S.ADDR); 01169400 END ELSE 01169500 BEGIN 01169600 EMITNUM(GET(P+2).BASE); 01169700 EMITOPDCLIT(S.ADDR); 01169800 END 01169900 ELSE 01170000 IF S.SUBCLASS } DOUBTYPE THEN 01170100 IF BOOLEAN(S.FORMAL) THEN 01170200 BEGIN 01170300 EMITDESCLIT(S.ADDR); 01170400 EMITO(DUP); 01170500 EMITPAIR(1, XCH); 01170600 EMITO(INX); 01170700 EMITO(LOD); 01170800 EMITO(XCH); 01170900 EMITO(LOD); 01171000 END ELSE 01171100 BEGIN 01171200 EMITOPDCLIT(S.ADDR+1); 01171300 EMITOPDCLIT(S.ADDR); 01171400 END 01171500 ELSE EMITOPDCLIT(S.ADDR) 01171600 ELSE EMITOPDCLIT(S.ADDR); 01171700 END EMITV; 01171800 01171900 PROCEDURE EMITL(N); VALUE N; REAL N; 01172000 BEGIN 01172100 BUMPADR; 01172200 PACK(EDOC[EDOCI],(N~0&N[36:38:10]),ADR.[46:2]); 01172300 IF CODETOG THEN DEBUG(N); 01172400 END EMITL; 01172500 PROCEDURE EMITD(R, OP); VALUE R, OP; REAL R, OP; 01172600 BEGIN 01172700 BUMPADR; 01172800 PACK(EDOC[EDOCI], (R ~ OP & R[36:42:6]), ADR.[46:2]); 01172900 IF CODETOG THEN DEBUG(-R); 01173000 END EMITD; 01173100 PROCEDURE EMITDDT(B,A,X); VALUE B,A,X; INTEGER B,A,X ; 01173200 BEGIN % DOES DIB B, DIA A, TRB X; HANDLES [B:A:X]. 01173300 EMITD(B~B MOD 6+B DIV 6|8,DIB); EMITD(A~A MOD 6+A DIV 6|8,DIA) ; 01173400 EMITD(X~X,TRB); 01173500 END OF EMITDDT ; 01173600 PROCEDURE EMITPAIR(L, OP); VALUE L, OP; INTEGER L, OP; 01173700 BEGIN 01173800 EMITL(L); 01173900 IF L.[37:2] = 1 THEN 01174000 BEGIN 01174100 IF ADR } 4087 THEN 01174200 BEGIN ADR ~ ADR+1; SEGOVF END; 01174300 EMITO(XRT); 01174400 END; 01174500 EMITO(OP); 01174600 END EMITPAIR; 01174700 PROCEDURE ADJUST; 01174800 WHILE ADR.[46:2] ! 3 DO EMITO(NOP); 01174900 PROCEDURE EMITNUM(N); VALUE N; REAL N; 01175000 BEGIN 01175100 DEFINE CPLUS = 1792#; 01175200 IF N.[3:6] =0 AND ABS(N) < 1024 THEN 01175300 BEGIN 01175400 EMITL(N); 01175500 IF N < 0 THEN EMITO(SSN); 01175600 END ELSE 01175700 BEGIN 01175800 IF ADR } 4079 THEN 01175900 BEGIN ADR ~ ADR+1; SEGOVF END; 01176000 EMITOPDCLIT(CPLUS + (ADR+1).[46:1] + 1); 01176100 EMITL(2); 01176200 EMITO(GFW); 01176300 ADJUST; 01176400 BUMPADR; 01176500 PACK(EDOC[EDOCI],N.[1:11],ADR.[46:2]); 01176600 BUMPADR; 01176700 PACK(EDOC[EDOCI],N.[12:12],ADR.[46:2]); 01176800 BUMPADR; 01176900 PACK(EDOC[EDOCI],N.[24:12],ADR.[46:2]); 01177000 BUMPADR; 01177100 PACK(EDOC[EDOCI],N.[36:12],ADR.[46:2]); 01177200 IF N.[36:12]=49 THEN %%% IF C-REL CONSTANT LOOKS LIKE AN XRT 01177300 EMITO(NOP); %%% THEN INSURE AGAINST P-BIT INTERRUPT. 01177400 IF CODETOG THEN DEBUGWORD(N); 01177500 END; 01177600 END EMITNUM; 01177700 01177800 PROCEDURE EMITNUM2(HI,LO);VALUE HI,LO; REAL HI,LO; 01177900 BEGIN 01178000 BOOLEAN B; REAL I,N; 01178100 LABEL Z,X; 01178200 DEFINE CPLUS = 1792#; 01178300 IF HI=0 OR LO=0 THEN BEGIN EMITNUM(LO); EMITNUM(HI); GO Z END; 01178400 ADJUST; 01178500 IF ADR } 4077 THEN 01178600 BEGIN ADR~ADR+1; SEGOVF; ADR~-1 END; 01178700 EMITOPDCLIT(CPLUS + 2); EMITOPDCLIT(CPLUS + 1); 01178800 EMITPAIR(3,GFW); 01178900 X: FOR I ~ 0 STEP 1 UNTIL 3 DO 01179000 BEGIN 01179100 CASE I OF BEGIN 01179200 N ~ HI.[ 1:11]; 01179300 N ~ HI.[12:12]; 01179400 N ~ HI.[24:12]; 01179500 N ~ HI.[36:12]; 01179600 END CASE; 01179700 BUMPADR; PACK(EDOC[EDOCI],N,ADR.[46:2]); 01179800 END; 01179900 IF CODETOG THEN DEBUGWORD(HI); 01180000 IF NOT B THEN BEGIN B~TRUE; HI~LO; GO TO X; END; 01180100 IF N=49 THEN %%% IF C-REL CONSTANT LOOKS LIKE AN XRT 01180200 EMITO(NOP) ; %%% THEN INSURE AGAINST P-BIT INTERRUPT. 01180300 Z: 01180400 END EMITNUM2; 01180500 01180600 PROCEDURE EMITLINK(N); VALUE N; REAL N; % EMITS LINKS 01180700 BEGIN 01180800 FORMAT FF(X35,*(33(".")),A4,":",A1," LINK",X10,A4,"******") ; 01180900 BUMPADR; 01181000 PACK(EDOC[EDOCI],N,ADR.[46:2]); 01181100 IF CODETOG THEN 01181200 WRITALIST(FF,4,IF ADR{DEBUGADR THEN 1 ELSE -1,B2D(ADR.[36:10]),01181300 B2D(ADR.[46:2]),B2D(N),0,0,0,0) ; 01181400 IF DEBUGADRLBRANCH THEN FATAL(123); 00191200 BRANCHX ~ BRANCHES[LAX~BRANCHX]; 00191300 BRANCHES[LAX] ~ -(ADR+1); 00191400 EMITLINK(0); 00191500 EMITO(IF C THEN BFC ELSE BFW); 00191600 EMITO(NOP); 00191700 END ELSE 00191800 BEGIN 00191900 SEG ~ A.SEGNO; 00192000 A ~ A.LINK; 00192100 BEOREF ~ ADR > A; 00192200 IF A.[46:2] =0 THEN 00192300 BEGIN 00192400 IF SEG > 0 AND SEG ! NSEG THEN 00192500 EMITOPDCLIT(PRGDESCBLDR(2, 0, A.[36:10], SEG)) 00192600 ELSE 00192700 EMITL(ABS((ADR+2).[36:10] - A.[36:10])); 00192800 IF BEOREF THEN 00192900 EMITO( IF C THEN GBC ELSE GBW) ELSE 00193000 EMITO( IF C THEN GFC ELSE GFW); 00193100 END ELSE 00193200 BEGIN 00193300 EMITL(ABS(ADR + 3 - A)); 00193400 IF BEOREF THEN 00193500 EMITO(IF C THEN BBC ELSE BBW) ELSE 00193600 EMITO(IF C THEN BFC ELSE BFW); 00193700 END; 00193800 END; 00193900 END EMITB; 00194000 00194100 PROCEDURE EMITDESCLIT(N); VALUE N; REAL N; 00194200 BEGIN 00194300 IF N.[37:2] = 1 THEN 00194400 BEGIN 00194500 IF ADR } 4087 THEN 00194600 BEGIN ADR ~ ADR+1; SEGOVF END; 00194700 EMITO(XRT); 00194800 END; 00194900 BUMPADR; 00195000 PACK(EDOC[EDOCI],(N~3&N[36:38:10]),ADR.[46:2]); 00195100 IF CODETOG THEN DEBUG(N); 00195200 END EMITDESCLIT; 00195300 PROCEDURE EMITOPDCLIT(N); VALUE N; REAL N; 00195400 BEGIN 00195500 IF N.[37:2] = 1 THEN 00195600 BEGIN 00195700 IF ADR } 4087 THEN 00195800 BEGIN ADR ~ ADR+1; SEGOVF END; 00195900 EMITO(XRT); 00196000 END; 00196100 BUMPADR; 00196200 PACK(EDOC[EDOCI],(N~2&N[36:38:10]),ADR.[46:2]); 00196300 IF CODETOG THEN DEBUG(N); 00196400 END EMITOPDCLIT; 00196500 PROCEDURE EMITLABELDESC(N); VALUE N; ALPHA N; 00196600 BEGIN 00196700 LABEL XIT; 00196800 REAL T,B,C,D ; 00196900 IF N ~ LBLSHFT(XTA~N) = 0 OR N = BLANKS THEN 00197000 BEGIN FLAG(135); GO TO XIT END; 00197100 IF T ~ SEARCH(N) = 0 THEN 00197200 T ~ ENTER(0 & LABELID[TOCLASS], N) ELSE 00197300 IF GET(T).CLASS ! LABELID THEN 00197400 BEGIN FLAG(144); GO TO XIT END; 00197500 IF XREF THEN ENTERX(N,0&LABELID[TOCLASS]); 00197600 IF B ~(C~GET(T+2)).BASE =0 THEN 00197700 IF (D~GET(T)).SEGNO!0 THEN C.BASE~B~PRGDESCBLDR(2,0,D.ADDR DIV 4, 00197800 D.SEGNO) ELSE 00197900 BEGIN BUMPPRT; C.BASE~B~PRTS END; PUT(T+2,C); 00198000 EMITL(B); EMITO(MKS); 00198100 EMITDESCLIT(1536); % F+0 00198200 EMITOPDCLIT(1537); % F+1 00198300 EMITV(NEED(".LABEL", INTRFUNID)); 00198400 XIT: 00198500 END EMITLABELDESC; 00198600 00198700 COMMENT TRACEBACK, OFLOWHANGERS, AND PRTSAVER ARE 00198800 PROCEDURES USED TO ACCUMULATE FORMAT AND NAMELIST ARRAYS; 00198900 PROCEDURE TRACEBACK(M,DEX,PRT); VALUE M,DEX,PRT; INTEGER M,DEX,PRT; 00199000 BEGIN INTEGER I,J; REAL C; 00199100 IF (C~GET(M+2)).BASE ! 0 THEN 00199200 BEGIN I ~ ADR; ADR ~ C.BASE; 00199300 DO BEGIN J ~ GIT(ADR); 00199400 ADR ~ ADR - 1; 00199500 EMITL(DEX); 00199600 EMITPAIR(PRT,LOD); 00199700 END UNTIL ADR ~ J = 0; 00199800 ADR ~ I; 00199900 END; 00200000 INFO[M.IR,M.IC].ADDR ~ PRT; PUT(M+2,0&DEX[TOBASE]); 00200100 END TRACEBACK; 00200200 00200300 PROCEDURE OFLOWHANGERS(I); VALUE I; INTEGER I; 00200400 BEGIN INTEGER J; LABEL XIT; 00200500 FOR J ~ 1 STEP 1 UNTIL MAXNBHANG DO 00200600 IF FNNHANG[J] = 0 THEN % MAKE AN ENTRY 00200700 BEGIN FNNHANG[J] ~ I; 00200800 PUT(I+2,J); 00200900 GO TO XIT; 00201000 END; 00201100 XTA ~ MAXNBHANG; % IF WE REACH HERE WERE HURTIN 00201200 FLAG(91); 00201300 XIT: 00201400 END OFLOWHANGERS; 00201500 00201600 PROCEDURE PRTSAVER(M,SZ,ARY); VALUE M,SZ; 00201700 INTEGER M,SZ; ARRAY ARY[0]; 00201800 BEGIN INTEGER I; REAL INFA; 00201900 LABEL SHOW,XIT; 00202000 IF (INFA~GET(M)) < 0 THEN % PREVIOUSLY DEFINED 00202100 BEGIN XTA ~ GET(M+1); 00202200 FLAG(20); GO TO XIT; 00202300 END; 00202400 IF I ~ INFA .ADDR ! 0 THEN % PRT ASSIGNED AT OFLOW TIME 00202500 SHOW: 00202600 BEGIN I ~ PRGDESCBLDR(1,I,0,NXAVIL ~ NXAVIL + 1); 00202700 WRITEDATA(SZ,NXAVIL,ARY); 00202800 FNNHANG[GET(M+2).SIZE] ~ 0; 00202900 END ELSE % ADD THIS ARRAY TO HOLD 00203000 BEGIN IF FNNPRT=0 THEN BEGIN BUMPPRT; FNNPRT~PRTS END; 00203100 IF FNNINDEX + SZ > DUMPSIZE THEN % ARRAY WONT FIT 00203200 BEGIN BUMPPRT;FNNHANG[GET(M+2).SIZE]~0; TRACEBACK(M,0,I~PRTS); 00203300 GO TO SHOW; 00203400 END ELSE % DUMP OUT CURRENT HOLDINGS 00203500 BEGIN FNNPRT ~ PRGDESCBLDR(1,FNNPRT,0,NXAVIL ~ NXAVIL + 1); 00203600 WRITEDATA(FNNINDEX,NXAVIL,FNNHOLD); 00203700 FNNINDEX ~ 0; BUMPPRT; FNNPRT ~PRTS; 00203800 END; 00203900 FNNHANG[GET(M + 2).SIZE] ~0; 00204000 TRACEBACK(M,FNNINDEX,FNNPRT); 00204100 MOVEW(ARY,FNNHOLD[FNNINDEX],SZ.[36:6],SZ); 00204200 FNNINDEX ~ FNNINDEX + SZ; 00204300 END; 00204400 PUT(M,-GET(M)); % ID NOW ASSIGNED 00204500 XIT: 00204600 END PRTSAVER; 00204700 00204800 PROCEDURE SEGOVF; 00204900 BEGIN 00205000 REAL I, T, A, J, SADR, INFC, LABPRT; 00205100 REAL SAVINS; 00205200 FOR T ~ 1 STEP 1 UNTIL MAXNBHANG DO 00205300 IF J~FNNHANG[T]!0 THEN BEGIN BUMPPRT;TRACEBACK(J,FNNHANG[T]~0,PRTS) END;00205400 SEGOVFLAG ~ TRUE; 00205500 BUMPPRT; 00205600 IF PRTS.[37:2]=1 THEN BEGIN 00205700 PACK(EDOC[EDOCI],(T~1&XRT[36:38:10]),ADR.[46:2]); 00205800 IF CODETOG THEN DEBUG(T); ADR~ADR+1 END; 00205900 PACK(EDOC[EDOCI], (T~2&PRTS[36:38:10]), ADR.[46:2]); 00206000 IF CODETOG THEN DEBUG(T); 00206100 ADR ~ ADR+1; 00206200 PACK(EDOC[EDOCI], (T~1&BFW [36:38:10]), ADR.[46:2]); 00206300 IF CODETOG THEN DEBUG(T); 00206400 SADR ~ ADR; 00206500 T ~ PRGDESCBLDR(2, PRTS, 0, NXAVIL+1); 00206600 FOR I ~ 0 STEP 1 UNTIL SHX DO 00206700 BEGIN T ~ STACKHEAD[I]; 00206800 WHILE T ! 0 DO 00206900 BEGIN IF (A~ GET(T)).CLASS = LABELID THEN 00207000 IF A > 0 THEN 00207100 BEGIN 00207200 ADR ~ A.ADDR; 00207300 IF LABPRT ~ (INFC~GET(T+2)).BASE = 0 THEN 00207400 BEGIN 00207500 BUMPPRT; LABPRT~PRTS; 00207600 PUT(T+2, INFC & PRTS[TOBASE]); 00207700 END; 00207800 WHILE ADR ! 0 DO 00207900 BEGIN J ~ GIT(ADR); ADR ~ ADR-1; 00208000 SAVINS~GIT(ADR+2).[36:10]; 00208100 EMITOPDCLIT(LABPRT); 00208200 EMITO(SAVINS); 00208300 ADR ~ J; 00208400 END; 00208500 INFO[T.IR,T.IC].ADDR ~ 0; 00208600 END; 00208700 T ~ A.LINK; 00208800 END; 00208900 END; 00209000 FOR I ~ 0 STEP 1 UNTIL LBRANCH DO 00209100 IF T ~ - BRANCHES[I] > 0 AND T < 4096 THEN 00209200 BEGIN 00209300 ADR ~ T-1; 00209400 SAVINS~GIT(ADR+2).[36:10]; 00209500 BUMPPRT; EMITOPDCLIT(PRTS); 00209600 EMITO(SAVINS); 00209700 BRANCHES[I] ~ - (PRTS+4096); 00209800 END; 00209900 SEGMENT((SADR+4) DIV 4,NSEG,FALSE,EDOC); 00210000 SEGMENTSTART; 00210100 EMITO(NOP); EMITO(NOP); 00210200 SEGOVFLAG ~ FALSE; 00210300 END SEGOVF; 00210400 00210500 PROCEDURE ARRAYDEC(I); VALUE I; REAL I; 00210600 BEGIN % DECLARES ARRAYS WHOSE INFO INDEX IS I 00210700 REAL PRT,LNK,J; 00210800 LABEL XIT; 00210900 BOOLEAN OWNID; REAL X; 00211000 IF DEBUGTOG THEN FLAGROUTINE(" ARRA","YDEC ",TRUE ); 00211100 PRT ~ GET(I).ADDR; 00211200 IF LNK ~ GET(I+2).SIZE = 0 THEN GO TO XIT ; 00211300 IF (OWNID ~ PRT < 1536 AND DATAPRT ! 0) THEN 00211400 BEGIN 00211500 EMITOPDCLIT(DATAPRT); EMITO(LNG); 00211600 EMITB(-1, TRUE); X ~ LAX; 00211700 END; 00211800 EMITO(MKS); 00211900 EMITDESCLIT(PRT); % STACK OR PRT ADDRESS 00212000 IF LNK { 1023 THEN 00212100 BEGIN 00212200 IF OWNID THEN EMITL(0); % LOWER BOUND 00212300 EMITL(LNK); % ARRAY SIZE 00212400 EMITL(1); % ONE DIMENSION 00212500 END 00212600 ELSE 00212700 BEGIN 00212800 J ~ (LNK + 255) DIV 256; 00212900 LNK ~ 256; %INCLUDE ENTIRE ARRAY SIZE IN ESTIMATE %512- 00213000 IF OWNID THEN EMITL(0); % FIRST LOWER BOUND 00213100 EMITL(J); % NUMBER OF ROWS 00213200 IF OWNID THEN EMITL(0); % SECOND LOWER BOUND 00213300 EMITL(256); % SIZE OF EACH ROW 00213400 EMITL(2); % TWO DIMENSIONS 00213500 END; 00213600 EMITL(1); % ONE ARRAY 00213700 EMITL(IF OWNID THEN 2 ELSE 0); %OWN OR LOCAL 00213800 EMITOPDCLIT(5); % CALL BLOCK 00213900 ARYSZ ~ ARYSZ + J + LNK; 00214000 IF NOT(F2TOG OR OWNID) THEN 00214100 BEGIN 00214200 F2TOG ~ TRUE; 00214300 EMITL(1); 00214400 EMITPAIR(FPLUS2,STD);% F+2~TRUE 00214500 END; 00214600 IF OWNID THEN FIXB(X); 00214700 XIT: 00214800 IF DEBUGTOG THEN FLAGROUTINE(" ARRA","YDEC ",FALSE) ; 00214900 END ARRAYDEC; 00215000 00215100 REAL PROCEDURE SEARCH(E); VALUE E; REAL E; 00215200 BEGIN REAL T; LABEL XIT; 00215300 T ~ STACKHEAD[E MOD SHX]; 00215400 WHILE T ! 0 DO 00215500 IF INFO[(T+1).IR,(T+1).IC] = E THEN GO TO XIT 00215600 ELSE T ~ INFO[T.IR,T.IC].LINK; 00215700 XIT: SEARCH ~ T; 00215800 END SEARCH; 00215900 00216000 INTEGER PROCEDURE GLOBALSEARCH(E); VALUE E; REAL E; 00216100 BEGIN REAL T; LABEL XIT; 00216200 T ~ GLOBALSTACKHEAD[E MOD GHX]; 00216300 WHILE T ! 0 DO 00216400 IF INFO[(T+1).IR,(T+1).IC] = E THEN GO TO XIT 00216500 ELSE T ~ INFO[T.IR,T.IC].LINK; 00216600 XIT: GLOBALSEARCH ~ T; 00216700 END GLOBALSEARCH; 00216800 00216900 PROCEDURE PURGEINFO; 00217000 BEGIN REAL J; 00217100 FLAG(13); 00217200 FOR J ~ 0 STEP 1 UNTIL SHX DO STACKHEAD[J] ~ 0; 00217300 NEXTINFO ~ 2; 00217400 NEXTCOM ~ 0; 00217500 END; 00217600 00217700 INTEGER PROCEDURE ENTER(W, E); VALUE W, E; ALPHA W, E; 00217800 BEGIN REAL J; 00217900 IF GLOBALNEXTINFO { NEXTINFO THEN PURGEINFO; 00218000 W.LINK ~ STACKHEAD[J ~ E MOD SHX]; 00218100 STACKHEAD[J] ~ ENTER ~ J ~ NEXTINFO; 00218200 INFO[J.IR,J.IC] ~ W; 00218300 INFO[(J~J+1).IR,J.IC] ~ E; 00218400 INFO[(J~J+1).IR,J.IC] ~ 0; 00218500 NEXTINFO ~ NEXTINFO + 3; 00218600 END ENTER; 00218700 00218800 INTEGER PROCEDURE GLOBALENTER(W, E); VALUE W, E; ALPHA W, E; 00218900 BEGIN REAL J; 00219000 IF GLOBALNEXTINFO { NEXTINFO THEN PURGEINFO; 00219100 W.LINK ~ GLOBALSTACKHEAD[J ~ E MOD GHX]; 00219200 GLOBALSTACKHEAD[J] ~ GLOBALENTER ~ J ~ GLOBALNEXTINFO; 00219300 INFO[J.IR,J.IC] ~ W; 00219400 INFO[(J~J+1).IR,J.IC] ~ E; 00219500 INFO[(J~J+1).IR,J.IC] ~ 0; 00219600 GLOBALNEXTINFO ~ GLOBALNEXTINFO - 3; 00219700 END GLOBALENTER; 00219800 00219900 PROCEDURE LABELBRANCH(K, C); VALUE K, C; REAL K; BOOLEAN C; 00220000 BEGIN REAL TS,T,I,X; 00220100 DEFINE LABL = K#; 00220200 COMMENT LABELBRANCH GENERATES A "LITC ..." AND "BRANCH" FROM THE 00220300 CURRENT ADDRESS TO LABEL K. IF THE BOOLEAN C IS TRUE 00220400 THE BRANCH IS CONDITIONAL. IF THE LABEL HAS NOT BEEN ENCOUNTERED 00220500 THEN THE APPROPRIATE LINKAGE IS MADE; 00220600 LABEL XIT; 00220700 IF ADR } 4086 THEN 00220800 BEGIN ADR ~ ADR+1; SEGOVF END; 00220900 IF LABL ~ LBLSHFT(XTA~LABL) { 0 OR LABL = BLANKS THEN 00221000 BEGIN FLAG(135); GO TO XIT END; 00221100 IF T ~ SEARCH(LABL) ! 0 THEN 00221200 BEGIN TS ~ (I ~ GET(T)).ADDR; 00221300 IF I.CLASS ! LABELID THEN BEGIN FLAG(144); GO TO XIT END; 00221400 IF I > 0 THEN 00221500 BEGIN EMITLINK(TS); 00221600 EMITO(IF C THEN BFC ELSE BFW); 00221700 PUT(T,I&(ADR-1)[TOADDR]); 00221800 EMITO(NOP); 00221900 END ELSE 00222000 IF I.SEGNO = NSEG THEN EMITB(TS, C) ELSE 00222100 BEGIN IF TS~(X~GET(T+2)).BASE = 0 THEN 00222200 X.BASE ~ TS ~ PRGDESCBLDR(2,0,(I.ADDR).[36:10],I.SEGNO); 00222300 PUT(T+2,X); 00222400 EMITOPDCLIT(TS); 00222500 EMITO(IF C THEN BFC ELSE BFW); 00222600 END; 00222700 END ELSE 00222800 BEGIN 00222900 IF ADR < 0 THEN EMITO(NOP); 00223000 EMITLINK(0); 00223100 EMITO( IF C THEN BFC ELSE BFW); 00223200 T ~ ENTER(0 & LABELID[TOCLASS] & (ADR-1)[TOADDR], LABL); 00223300 EMITO(NOP); 00223400 END; 00223500 IF XREF THEN ENTERX(LABL,0&LABELID[TOCLASS]); 00223600 XIT: 00223700 END LABELBRANCH; 00223800 00223900 PROCEDURE DATASET; % SCANS CONSTANTS IN BLOCK DATA 00224000 BEGIN 00224100 REAL LST,CUR,LTYP,CTYP,SIZ,RPT; 00224200 REAL CUD; 00224300 BOOLEAN SGN; 00224400 DEFINE TYP = GLOBALNEXT#, 00224500 TYPC = 18:33:15#; 00224600 LABEL XIT,ERROR,DPP,SPP,CPP,COMM,S; 00224700 IF DEBUGTOG THEN FLAGROUTINE(" DATA","SET ",TRUE) ; 00224800 DATATOG ~ TRUE; FILETOG ~ TRUE; 00224900 SCAN; 00225000 LSTS ~ -1; LTYP ~77; 00225100 S: IF TYP = PLUS OR (SGN ~ TYP = MINUS ) THEN SCAN; 00225200 IF TYP = NUM THEN 00225300 BEGIN 00225400 IF NUMTYPE = STRINGTYPE AND STRINGSIZE > 1 THEN 00225500 BEGIN 00225600 IF LTYP ! 77 THEN 00225700 BEGIN % NOT FIRST ENTRY-PUSH DOWN PRIOR NUMBER 00225800 IF LSTS+2 > LSTMAX THEN 00225900 BEGIN FLAG(127); GO TO ERROR END; 00226000 LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 00226100 LSTT[LSTS~LSTS+1] ~ LST; 00226200 LTYP ~ 77; 00226300 END; 00226400 00226500 IF LSTS + STRINGSIZE > LSTMAX THEN 00226600 BEGIN FLAG(127); GO TO ERROR END; 00226700 LSTT[LSTS~LSTS+1] ~ STRINGSIZE & STRINGTYPE[TYPC] 00226800 & SIZ[3:33:15]; 00226900 MOVEW(STRINGARRAY,LSTT[LSTS~LSTS+1], 00227000 STRINGSIZE.[36:6],STRINGSIZE); 00227100 LSTS ~ LSTS + STRINGSIZE -1; 00227200 SCAN; 00227300 GO TO COMM; 00227400 END; 00227500 % GOT NUMBER 00227600 IF NUMTYPE = STRINGTYPE THEN 00227700 BEGIN 00227800 FNEXT ~ STRINGARRAY[0]; 00227900 NUMTYPE ~ INTYPE; 00228000 IF SIZ = 0 THEN SIZ ~ 1; 00228100 END; 00228200 CUR ~ IF SGN THEN -FNEXT ELSE FNEXT; 00228300 CTYP ~ NUMTYPE; CUD ~ DBLOW; 00228400 00228500 SCAN; 00228600 IF TYP = COMMA OR TYP = SLASH THEN 00228700 BEGIN 00228800 IF SIZ = 0 THEN SIZ ~ 1; 00228900 IF CTYP = DOUBTYPE THEN 00229000 BEGIN 00229100 DPP: IF LTYP ! 77 THEN 00229200 BEGIN 00229300 IF LSTS+2 > LSTMAX THEN 00229400 BEGIN FLAG(127); GO TO ERROR END; 00229500 LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 00229600 LSTT[LSTS~LSTS+1] ~ LST; 00229700 LTYP ~ 77; 00229800 END; 00229900 IF LSTS+3 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END; 00230000 LSTT[LSTS~LSTS+1] ~ SIZ&DOUBTYPE[TYPC]; 00230100 LSTT[LSTS~LSTS+1] ~ CUR; 00230200 LSTT[LSTS~LSTS+1] ~ CUD; 00230300 GO TO COMM; 00230400 END; 00230500 % SINGLE PRECISION 00230600 SPP: 00230700 IF LTYP = 77 THEN 00230800 BEGIN 00230900 LST ~ CUR; 00231000 LTYP ~ CTYP; 00231100 RPT ~ SIZ; 00231200 GO TO COMM; 00231300 END; 00231400 IF LTYP = CTYP THEN 00231500 IF REAL(BOOLEAN(CUR) EQV BOOLEAN(LST)) = REAL(NOT FALSE) THEN 00231600 BEGIN 00231700 RPT ~ RPT + SIZ; 00231800 GO TO COMM; 00231900 END; 00232000 IF LSTS+2 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END; 00232100 LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 00232200 LSTT[LSTS~LSTS+1] ~ LST; 00232300 RPT ~ SIZ; 00232400 LST ~ CUR; LTYP ~ CTYP; 00232500 GO TO COMM; 00232600 END; 00232700 % TYP ! COMMA - CHECK FOR * 00232800 IF TYP ! STAR THEN BEGIN FLAG(125); GO TO ERROR END; 00232900 IF CTYP ! INTYPE THEN BEGIN FLAG(113); GO TO ERROR END; 00233000 IF SIZ ! 0 OR SIZ ~ CUR { 0 THEN 00233100 BEGIN FLAG(64); GO TO ERROR END; 00233200 SCAN; GO TO S; 00233300 END; 00233400 % TYP ! NUM AT LABEL S 00233500 IF SIZ = 0 THEN SIZ ~ 1; 00233600 IF NAME = "T " OR NAME = "F " THEN 00233700 BEGIN 00233800 CUR ~ REAL(NAME = "T "); 00233900 CTYP ~ LOGTYPE; 00234000 SCAN; GO TO SPP; 00234100 END; 00234200 IF TYP ! LPAREN THEN BEGIN FLAG(64); GO TO ERROR END; 00234300 CPP: % COMPLEX 00234400 IF LTYP ! 77 THEN 00234500 BEGIN 00234600 IF LSTS+2 > LSTMAX THEN 00234700 BEGIN FLAG(127); GO TO ERROR END; 00234800 LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 00234900 LSTT[LSTS~LSTS+1] ~ LST; 00235000 LTYP ~ 77; 00235100 END; 00235200 SCAN; 00235300 IF TYP = PLUS OR (SGN~TYP=MINUS) THEN SCAN; 00235400 IF TYP ! NUM OR NUMTYPE > REALTYPE THEN 00235500 BEGIN FLAG(64); GO TO ERROR END; 00235600 IF LSTS+2 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END;00235700 LSTT[LSTS~LSTS+1] ~ SIZ&COMPTYPE[TYPC]; 00235800 LSTT[LSTS~LSTS+1] ~ IF SGN THEN -FNEXT ELSE FNEXT; 00235900 SCAN; 00236000 IF TYP ! COMMA THEN BEGIN FLAG(114); GO TO ERROR END; 00236100 SCAN; 00236200 IF TYP = PLUS OR (SGN ~ TYP = MINUS) THEN SCAN; 00236300 IF TYP ! NUM OR NUMTYPE > REALTYPE THEN 00236400 BEGIN FLAG(64); GO TO ERROR END; 00236500 LSTT[LSTS~LSTS+1]~IF SGN THEN - FNEXT ELSE FNEXT ; 00236600 SCAN; 00236700 IF TYP ! RPAREN THEN BEGIN FLAG(108); GO TO ERROR END; 00236800 SCAN; 00236900 COMM: 00237000 SIZ ~ 0; 00237100 IF TYP = COMMA THEN BEGIN SCAN; GO TO S; END; 00237200 IF TYP = SLASH THEN GO TO XIT; 00237300 FLAG(126); 00237400 ERROR: 00237500 LSTS ~ 0; 00237600 WHILE TYP ! COMMA AND TYP ! SLASH AND TYP ! SEMI DO SCAN;00237700 IF TYP = COMMA THEN GO TO COMM; 00237800 XIT: 00237900 IF LTYP ! 77 THEN 00238000 BEGIN 00238100 IF LSTS+2>LSTMAX THEN BEGIN FLAG(127); LSTS~0 END;00238200 LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 00238300 LSTT[LSTS~LSTS+1] ~ LST; 00238400 END; 00238500 IF LSTS+1 > LSTMAX THEN BEGIN FLAG(127); LSTS~0 END; 00238600 LSTT[LSTS~LSTS+1]~0; 00238700 IF DEBUGTOG THEN FLAGROUTINE(" DATA","SET ",FALSE); 00238800 DATATOG ~ FALSE; FILETOG ~ FALSE; 00238900 END DATASET; 00239000 00239100 ALPHA PROCEDURE CHECKDO; 00239200 BEGIN ALPHA X, T; INTEGER N; 00239300 STREAM PROCEDURE CKDO(A, ID, LAB); 00239400 BEGIN 00239500 SI ~ A; SI ~ SI+4; DI ~ LAB; DI ~ DI+2; 00239600 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); 00239700 DI ~ ID; DI ~ DI+2; 00239800 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); 00239900 END CKDO; 00240000 IF (XTA~HOLDID[0]).[12:24] = "FILE" THEN FLOG(37) ELSE 00240100 IF XTA.[12:12] ! "DO" THEN FLOG(17) ELSE 00240200 BEGIN 00240300 X ~ T ~ BLANKS; 00240400 CKDO(HOLDID[0], X, T); 00240500 IF X=BLANKS THEN FLOG(105); 00240600 IF T ~ LBLSHFT(T) < 0 OR T = BLANKS THEN FLOG(17) ELSE 00240700 TEST ~ NEED(T, LABELID); 00240800 DOLAB[DT]~ T; 00240900 IF XREF THEN ENTERX(T,0&LABELID[TOCLASS]); 00241000 IF GET(TEST) < 0 THEN % TEST FOR PREV DEFINITION 00241100 BEGIN 00241200 XTA ~ GET(TEST+1); 00241300 FLAG(15); 00241400 DT ~ DT-1; 00241500 END; 00241600 IF N ~ SEARCH(X) = 0 THEN 00241700 N~ENTER(TIPE[IF T~X.[12:6]!"0" THEN T ELSE 12],X); 00241800 CHECKDO ~ GETSPACE(N); 00241900 IF XREF THEN ENTERX(X,1&GET(N) [15:15:9]); 00242000 IF (X~GET(N)).SUBCLASS > REALTYPE OR X.CLASS ! VARID THEN 00242100 BEGIN XTA ~ GET(N+1); FLAG(84) END; 00242200 IF GET(FX1).CLASS = UNKNOWN THEN PUT(FX1+1, "......"); 00242300 END; 00242400 END CHECKDO; 00242500 00242600 PROCEDURE FIXB(N); VALUE N; REAL N; 00242700 BEGIN 00242800 REAL T, U, FROM; 00242900 LABEL XIT, BIGJ; 00243000 IF DEBUGTOG THEN FLAGROUTINE(" FI","XB ",TRUE); 00243100 IF N } 10000 THEN FROM ~ N-10000 ELSE 00243200 IF FROM ~ - BRANCHES[N] > 4095 THEN 00243300 BEGIN 00243400 ADJUST; 00243500 T ~ PRGDESCBLDR(2, FROM.LINK, (ADR+1).[36:10], NSEG); 00243600 GO TO XIT; 00243700 END; 00243800 T ~ ADR; ADR ~ FROM - 1; 00243900 IF (T + 1).[46:2] = 0 THEN GO TO BIGJ; 00244000 IF (U ~ T - 2 - ADR) { 1023 THEN EMITL(U) ELSE 00244100 BEGIN ADR ~ T; ADJUST; T ~ ADR; ADR ~ FROM - 1; 00244200 BIGJ: EMITL((T+1).[36:10] - (ADR+2).[36:10]); 00244300 EMITO(IF BOOLEAN(GIT(FROM + 1).[36:1]) THEN GFW ELSE GFC); 00244400 END; 00244500 ADR ~ T; 00244600 XIT: 00244700 IF N < 10000 THEN BEGIN 00244800 BRANCHES[N] ~ BRANCHX; 00244900 BRANCHX ~ N; 00245000 END; 00245100 IF DEBUGTOG THEN FLAGROUTINE(" FI","XB ",FALSE); 00245200 END FIXB; 00245300 00245400 PROCEDURE DATIME; % PRODUCES HEADING LINE FOR LISTING. 00245500 BEGIN 00245600 INTEGER D; 00245700 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 ",00245800 "XVI.0" 00245900 ,",",A2,",",A8,"DAY, ",2(A2,"/"),A2,",",A2,":",A2," H,"/); 00246000 WRITALIST(T,7, 00246100 "16" %999-00246200 ,TIME(6),(D~TIME(5)).[12:12],D.[24:12],D.[36:12], 00246300 D~(D~RTI DIV 216000) MOD 10+D DIV 10|64, 00246400 D~(D~RTI DIV 3600 MOD 60) MOD 10+D DIV 10|64,0) ; 00246500 IF D~LINE.TYPE=10 OR D=12 OR D=13 THEN 00246600 BEGIN 00246700 LOCK(LINE); LINE.AREAS~0; LINE.AREASIZE~0 ; 00246800 IF D ! 12 THEN LINE.TYPE~12; SPACE(LINE,2) ; 00246900 END; 00247000 FIRSTCALL~FALSE ; 00247100 END DATIME; 00247200 00247300 PROCEDURE PRINTCARD; 00247400 BEGIN 00247500 STREAM PROCEDURE MOVE(P, Q, A); VALUE A, Q; 00247600 BEGIN 00247700 SI ~ Q; DI ~ P; 00247800 DS ~ CHR; 00247900 DI ~ DI+11; SI ~ LOC A; 00248000 DS ~ 4 DEC; 00248100 END MOVE; 00248200 STREAM PROCEDURE MOVEBACK(P); 00248300 BEGIN DI ~ P; DS ~ LIT "]" END; 00248400 MOVE (CRD[9],BUFL,(ADR+1).[36:10]); 00248500 IF FIRSTCALL THEN DATIME; 00248600 IF UNPRINTED THEN WRITAROW(15,CRD) ; 00248700 MOVEBACK(CRD[9]); 00248800 IF SEQERRORS THEN WRITAROW(14,ERRORBUFF) ; 00248900 END PRINTCARD; 00249000 00249100 BOOLEAN PROCEDURE READACARD; FORWARD; 00249200 PROCEDURE FILEOPTION; FORWARD; 00249300 BOOLEAN PROCEDURE LABELR; 00249400 BEGIN 00249500 LABEL XIT, LOOP; 00249600 BOOLEAN STREAM PROCEDURE CHECK(CD, LAB); 00249700 BEGIN LABEL XIT; LOCAL T1; 00249800 SI ~ CD; 00249900 IF SC ! " " THEN IF SC < "0" THEN 00250000 BEGIN DI ~ LAB; DI ~ DI + 2; 00250100 DS ~ 6 CHR; GO TO XIT; 00250200 END; 00250300 DI ~LOC T1; DS ~ 6 LIT " "; DI ~ DI -6; 00250400 5(IF SC } "0" THEN DS ~ CHR ELSE SI ~ SI+1); 00250500 DI ~LAB; DI ~DI + 2; SI ~ LOC T1; 00250600 5(IF SC ! "0" THEN JUMP OUT; SI ~ SI + 1); 00250700 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); 00250800 TALLY ~ 1; 00250900 XIT: CHECK ~ TALLY; 00251000 END CHECK; 00251100 BOOLEAN STREAM PROCEDURE BLANKCARD(CD); 00251200 BEGIN LABEL XIT; 00251300 SI ~ CD; 00251400 2(36( IF SC ! " " THEN JUMP OUT 2 TO XIT ELSE SI ~ SI + 1)); 00251500 TALLY ~ 1; 00251600 XIT: BLANKCARD ~ TALLY; 00251700 END BLANKCARD; 00251800 LOOP: 00251900 LABL ~ BLANKS; 00252000 IF LABELR ~ NOT READACARD THEN GO TO XIT; 00252100 IF NOT CHECK(CRD[0],LABL) THEN 00252200 BEGIN IF LABL = "FILE " THEN FILEOPTION ELSE 00252300 BEGIN IF LISTOG THEN PRINTCARD; 00252400 IF (XTA ~ LABL).[12:6] ! "C" THEN FLAG(135); 00252500 END; 00252600 GO TO LOOP; 00252700 END; 00252800 IF ENDSEGTOG THEN IF BLANKCARD(CRD) THEN 00252900 BEGIN IF LISTOG THEN PRINTCARD; GO TO LOOP END ELSE 00253000 BEGIN SEGMENTSTART; 00253100 IF LISTOG THEN PRINTCARD; 00253200 IF LABL = BLANKS THEN GO TO XIT; 00253300 END ELSE 00253400 BEGIN 00253500 IF LABL = BLANKS THEN 00253600 BEGIN IF LISTOG THEN PRINTCARD; GO TO XIT END; 00253700 IF ADR > 0 THEN ADJUST; 00253800 IF LISTOG THEN PRINTCARD; 00253900 END; 00254000 XIT: 00254100 END LABELR; 00254200 00254300 PROCEDURE FILEOPTION; 00254400 BEGIN COMMENT THIS PROCEDURE PROCESSES THE OPTIONAL FILE CONTROL CARD. 00254500 THE WORD "FILE" APPEARS IN COL. 1 - 4. COL. 5 AND 6 ARE BLANK. 00254600 #1 BELOW IS REQUIRED, OTHER ENTRIES MAY BE AS SPARSE AS DESIRED. 00254700 1. FILE = / 00254800 OR 00254900 FILE = 00255000 THE FOLLOWING "/" IS A DOCUMMENTARY OR. 00255100 THE SEQUENCE OF RESERVED WORDS MUST BE MAINTAINED. 00255200 2. UNIT=PRINT/READER/PUNCH/DISK/TAPE7/TAPE9/REMOTE (UNIT DESIGNATE). 00255300 3. UNLABELED (FOR UNLABELED TAPES) 00255400 4. ALPHA (FOR ALPHA RECORDING MODE) 00255500 5. BCL (IGNORED, FOR 3500 USE) 00255600 6. FIXED (IGNORED, FOR 3500 USE) 00255700 7. SAVE = (SAVE FACTOR IN DAYS) 00255800 8. LOCK (LOCK FILE AT EOJ) 00255900 9. RANDOM/SERIAL/UPDATE (DISK USE) 00256000 10. AREA = (DISK RECORDS/ROW) 00256100 11. BLOCKING = (RECORD PER BLOCK) 00256200 12. RECORD = (RECORD SIZE) 00256300 13. BUFFER = (# OF BUFFERS) 00256400 14. WORKAREA (IGNORED, FOR 3500) ; 00256500 ALPHA P,KEEP; BOOLEAN TOG,CA,TS; LABEL XIT; 00256600 COMMENT INXFIL = INFC.ADINFO, MULTI FILE ID = FILEINFO[1,INXFIL], 00256700 FILE ID = FILEINFO[2,INXFIL], DISK RECORDS = FILEINFO[3,INXFIL],00256800 FILEINFO[0,INXFIL] FROM RIGHT TO LEFT IS; 00256900 INTEGER % NAME USE BITS 00257000 BUFF, % # BUFFERS 6 00257100 RECORD, % RECORD SIZE 12 00257200 BLOCK, % BLOCK SIZE 12 00257300 SAVER, % SAVE FACTOR 12 00257400 SPIN, % REW & LOCK @ EOJ 2 00257500 ALPH; % RECORDING MODE 1 00257600 PROCEDURE FETCH; 00257700 BEGIN SCAN; XTA ~ SYMBOL; 00257800 IF NEXT=COMMA OR NEXT=MINUS THEN 00257900 BEGIN SCAN; XTA ~ SYMBOL; 00258000 IF NEXT ! ID THEN FLOG(37); 00258100 END; 00258200 END FETCH; 00258300 INTEGER STREAM PROCEDURE MAKEINT(XTA); 00258400 BEGIN LABEL LOOP; LOCAL T; 00258500 SI ~ XTA; SI ~ SI + 2; 00258600 LOOP: IF SC } "0" THEN 00258700 BEGIN TALLY ~ TALLY + 1; SI ~ SI + 1; GO TO LOOP END; 00258800 T ~ TALLY; SI ~ XTA; SI ~ SI + 2; DI ~ LOC MAKEINT; DS ~ T OCT; 00258900 END MAKEINT; 00259000 INTEGER PROCEDURE REPLACEMENT; 00259100 BEGIN 00259200 FETCH; IF NEXT = EQUAL THEN 00259300 BEGIN FETCH; IF XTA.[12:6] { 11 THEN BEGIN REPLACEMENT ~ MAKEINT(XTA); 00259400 FETCH END ELSE FLOG(37); 00259500 END ELSE FLOG(37); 00259600 END REPLACEMENT; 00259700 INTEGER STREAM PROCEDURE SRI7(S); 00259800 BEGIN SI ~ S; DI ~ LOC SRI7; 00259900 SI ~ SI + 2; DI ~ DI + 1; DS ~ 7 CHR; 00260000 END SRI7; 00260100 COMMENT * * * * * START OF CODE * * * * ; 00260200 IF DEBUGTOG THEN FLAGROUTINE(" FILEO","PTION ", TRUE); 00260300 ERRORTOG ~ FALSE; 00260400 IF LISTOG THEN PRINTCARD; 00260500 XTA ~ "FILE "; 00260600 IF NSEG ! 0 THEN FLAG(60); 00260700 IF INXFIL ~ INXFIL + 1 > MAXOPFILES THEN 00260800 BEGIN FLAG(59); GO TO XIT END; 00260900 BUMPPRT; 00261000 MAXFILES ~ MAXFILES + 1; 00261100 FILETOG ~ TRUE; SCN ~ 1; % START SCAN MAINTAINENCE 00261200 FETCH; IF XTA.[12:6] > 11 THEN BEGIN FLAG(37); GO TO XIT END; 00261300 IF XTA.[12:6] = 0 THEN BEGIN FLOG(037); GO TO XIT END; 00261400 IF T ~ GLOBALSEARCH(P ~ 0&"."[12:42:6]&XTA[18:12:30]) ! 0 THEN FLAG(20) 00261500 ELSE BEGIN P~ GLOBALENTER(-0&PRTS[TOADDR]&FILEID[TOCLASS],P); 00261600 PUT(P+2,GET(P+2)&INXFIL[TOADINFO]); 00261700 IF XREF THEN ENTERX(XTA &1[TOCE],1&FILEID[TOCLASS]); 00261800 END; 00261900 INFC ~ GET(P + 2); 00262000 FETCH; IF NEXT = EQUAL THEN FETCH ELSE 00262100 BEGIN FLOG(37); GO TO XIT; END; 00262200 IF NEXT = SEMI THEN 00262300 BEGIN FLAG(37); GO TO XIT END 00262400 ELSE FILEINFO[2,INXFIL] ~ SRI7(ACCUM[1]); 00262500 FETCH; IF NEXT = SLASH THEN 00262600 BEGIN FILEINFO[1,INXFIL] ~ FILEINFO[2,INXFIL]; % MULTI FILE ID 00262700 FETCH; 00262800 IF NEXT = SEMI THEN BEGIN FLAG(37); GO TO XIT; END 00262900 ELSE FILEINFO[2,INXFIL] ~ SRI7(ACCUM[1]); 00263000 FETCH; 00263100 END; 00263200 IF XTA = "UNIT " THEN 00263300 BEGIN 00263400 FETCH; 00263500 IF NEXT = EQUAL THEN FETCH ELSE FLOG(37); 00263600 INFC.LINK ~ KEEP ~ (IF TOG ~ XTA = "PRINT " 00263700 OR XTA = "PRINTE" THEN 18 ELSE 00263800 IF CA ~ TOG ~ XTA = "READ " 00263900 OR XTA = "READER" THEN 2 ELSE 00264000 IF CA ~ TOG ~ XTA = "PUNCH " THEN 0 ELSE 00264100 IF TOG ~ XTA = "DISK " THEN 12 ELSE 00264200 IF TOG ~ XTA = "TAPE " 00264300 OR XTA = "TAPE7 " THEN 2 ELSE 00264400 IF TOG ~ XTA = "PAPER " THEN 8 ELSE 00264500 IF CA ~TOG~XTA= "REMOTE" THEN 19 ELSE 00264600 IF TOG ~ XTA = "TAPE9 " THEN 2 ELSE 2); 00264700 IF TOG THEN FETCH ELSE FLOG(37) 00264800 END ELSE INFC.LINK~KEEP~IF DCINPUT THEN 12 ELSE 2 ; 00264900 TS~KEEP=12 ; 00265000 IF XTA="BACKUP" THEN 00265100 BEGIN 00265200 FETCH; IF KEEP!0 AND KEEP!18 THEN FLAG(37); 00265300 IF TOG~XTA="DISK " THEN KEEP~IF KEEP=0 THEN 22 ELSE 15 00265400 ELSE IF TOG~XTA="TAPE " THEN KEEP~IF KEEP=0 THEN 20 ELSE 6 00265500 ELSE BEGIN 00265600 TOG~XTA="ALTERN"; KEEP~IF KEEP=0 THEN 25 ELSE 16 ; 00265700 END; 00265800 IF TOG THEN FETCH; INFC.LINK~KEEP ; 00265900 END ; 00266000 IF XTA = "UNLABE" THEN % FOR UNLABELED TAPES 00266100 BEGIN IF KEEP = 2 THEN INFC .LINK ~ 9; FETCH; END; 00266200 IF XTA = "ALPHA " THEN FETCH ELSE IF KEEP = 2 THEN ALPH ~ 1; % MODE 00266300 IF XTA = "BCL " THEN FETCH; % FOR B3500 00266400 IF XTA = "FIXED " THEN FETCH; % FOR B3500 00266500 IF XTA = "SAVE " THEN SAVER ~ REPLACEMENT; 00266600 IF XTA = "LOCK " THEN BEGIN SPIN ~ 2; FETCH END; % REW & LOCK AT EOJ 00266700 IF TOG ~ XTA = "RANDOM" THEN T ~ 10 ELSE 00266800 IF TOG ~ XTA = "SERIAL" THEN T ~ 12 ELSE 00266900 IF TOG ~ XTA = "UPDATE" THEN T ~ 13; 00267000 IF TOG THEN 00267100 BEGIN IF KEEP=12 THEN INFC.LINK~T ELSE FLAG(37); FETCH END; 00267200 IF XTA="AREA " THEN 00267300 BEGIN 00267400 IF KEEP!12 THEN FLAG(37); 00267500 T~REPLACEMENT; 00267600 IF XTA="EU " THEN 00267700 IF I~REPLACEMENT>19 THEN FLAG(37) 00267800 ELSE T.EUNF~I+1;% 0 MEANS EU NOT SPECIFIED 00267900 IF XTA="SPEED " THEN 00268000 BEGIN 00268100 FETCH; 00268200 IF NEXT=EQUAL THEN 00268300 BEGIN 00268400 FETCH; 00268500 IF XTA.[12:6]{SLOWV THEN 00268600 IF I~MAKEINT(XTA)>SLOWV THEN FLAG(37) 00268700 ELSE 00268800 ELSE IF XTA="FAST " THEN T.SPDF~FASTV 00268900 ELSE IF XTA="SLOW " THEN T.SPDF~SLOWV 00269000 ELSE FLOG(37); 00269100 FETCH; 00269200 END 00269300 ELSE FLOG(37); 00269400 END; 00269500 IF XTA="SENSIT" THEN 00269600 BEGIN 00269700 T.SENSE~1; 00269800 FETCH; 00269900 END; 00270000 FILEINFO[3,INXFIL]~T; 00270100 END; 00270200 IF XTA = "BLOCKI" THEN BLOCK ~ REPLACEMENT & 1[2:47:1]; 00270300 RECORD ~ IF XTA="RECORD" THEN REPLACEMENT ELSE IF CA THEN 10 ELSE IF TS 00270400 AND NOT (BOOLEAN(BLOCK.[2:1])) THEN 10 & 1[2:47:1] ELSE 17; 00270500 BUFF ~ IF XTA = "BUFFER" THEN REPLACEMENT ELSE 2; 00270600 IF XTA = "WORKAR" THEN FETCH; % IGNORED, FOR 3500 00270700 IF BUFF<1 OR BUFF>32 THEN BEGIN XTA~"BUFFER"; FLAG(152) END ; 00270800 IF RECORD<1 THEN BEGIN XTA~"RECORD"; FLAG(152)END ; 00270900 IF SAVER>999 THEN BEGIN XTA~"SAVE "; FLAG(152) END ; 00271000 IF T~INFC.LINK=10 OR T=12 OR T=13 THEN %%% ARE IN DISK FILE 00271100 BEGIN 00271200 IF BOOLEAN(RECORD.[2:1])THEN BLOCK ~ 300 00271300 ELSE 00271400 IF BLOCK~BLOCK|RECORD>1890 OR RECORD>1023 THEN 00271500 BEGIN XTA~"BK/REC"; FLAG(152) END 00271600 END 00271700 ELSE IF BLOCK~BLOCK|RECORD>1023 OR RECORD>1023 THEN IF KEEP ! 2 THEN 00271800 BEGIN XTA~"BK/REC"; FLAG(58 ) END ELSE BEGIN RECORD~257; BLOCK~0END;00271900 FILEINFO[0,INXFIL] ~ 0&BUFF[42:42:6]&RECORD[30:36:12]&BLOCK[18:36:12] 00272000 &SAVER[6:36:12]&SPIN[4:46:2]&ALPH[3:47:1]; 00272100 XIT: IF NEXT ! SEMI THEN 00272200 BEGIN FLOG(37); DO SCAN UNTIL NEXT = SEMI; END; 00272300 FILETOG ~ FALSE; % END SCAN MAINTAINENCE 00272400 PUT(P+2,INFC); 00272500 IF DEBUGTOG THEN FLAGROUTINE(" FILEO","PTION ",FALSE) ; 00272600 END FILEOPTION; 00272700 00272800 PROCEDURE DOLOPT; 00272900 BEGIN 00273000 REAL STREAM PROCEDURE SCAN(BUF,ID); VALUE BUF; 00273100 BEGIN LABEL LP,LA,LE,XIT; 00273200 SI ~ BUF; DI ~ ID; DS ~ 2 LIT "0"; 00273300 LP: IF SC = " " THEN BEGIN SI~SI+1; GO TO LP; END; 00273400 IF SC = "," THEN BEGIN SI~SI+1; GO TO LP; END; 00273500 IF SC = "+" THEN BEGIN DS~CHR; GO TO XIT; END; 00273600 IF SC = "-" THEN BEGIN DS~CHR; GO TO XIT; END; 00273700 IF SC < "A" THEN BEGIN DI ~ ID; DS ~ 8 LIT "+0000001"; 00273800 LE: SI~SI+1; 00273900 GO TO XIT; 00274000 END; 00274100 IF SC="|" THEN GO TO LE;% THIS IS > "A" 00274200 IF SC="!" THEN GO TO LE;% THIS IS > "A" 00274300 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); 00274400 LA: IF SC = ALPHA THEN BEGIN SI~SI+1; GO TO LA; END; 00274500 XIT: 00274600 SCAN ~ SI; 00274700 END SCAN; 00274800 REAL STREAM PROCEDURE GETVOID(BUF,VOIDSEQ,FR); VALUE BUF,FR; 00274900 BEGIN LABEL L,LC,LD,LE,XIT; LOCAL TA; 00275000 SI ~ BUF; DI~VOIDSEQ; DS~8LIT" "; DI~VOIDSEQ; 00275100 L: IF SC = " " THEN BEGIN SI~SI+1; GO TO L; END; 00275200 TA ~ SI; 00275300 IF SC = """ THEN 00275400 BEGIN 9(SI~SI+1; 00275500 IF SC = """ THEN BEGIN SI~SI+1; JUMP OUT TO LC; END 00275600 ELSE TALLY ~ TALLY + 1); 00275700 TALLY~TALLY+63; SI~TA; SI~SI+1; GO TO LE; 00275800 END; 00275900 IF SC < "0" THEN GO TO LD; 00276000 DS:=8LIT"0"; %115-00276100 8(SI:=SI+1; DI:=DI-1; TALLY:=TALLY+1; %115-00276200 IF SC LSS "0" THEN JUMP OUT); %115-00276300 LC: SI ~ TA; 00276400 LE: TA~TALLY; DS~TA CHR; GETVOID~SI; GO TO XIT; 00276500 LD: GETVOID~SI; 00276600 FR(DS~8LIT"9"); 00276700 XIT: 00276800 END GETVOID; 00276900 REAL STREAM PROCEDURE SEQNUM(BUF,VLU); VALUE BUF; 00277000 BEGIN LABEL L,LA,LC; LOCAL TA,TB; 00277100 SI ~ BUF; 00277200 L: IF SC = " " THEN BEGIN SI~SI+1; GO TO L; END; 00277300 IF SC = "," THEN BEGIN SI~SI+1; GO TO L; END; 00277400 TA ~ SI; 00277500 IF SC = "+" THEN 00277600 BEGIN SI~SI+1; 00277700 LA: IF SC = " " THEN BEGIN SI~SI+1; GO TO LA;END; 00277800 TB ~ SI; 00277900 IF SC < "0" THEN BEGIN SI~TA; GO TO LC; END; 00278000 DI~TB;TA~DI; 00278100 END; 00278200 8(IF SC < "0" THEN JUMP OUT TO LC; 00278300 TALLY~TALLY+1; SI~SI+1;); 00278400 LC: TB ~ TALLY; SEQNUM ~ SI; 00278500 SI ~ TA; DI ~ VLU; DS ~ TB OCT; 00278600 END SEQNUM; 00278700 REAL STREAM PROCEDURE MKABS(S); 00278800 BEGIN SI ~ S; SI~SI+1; MKABS ~ SI; 00278900 DI ~ S; 9(DI ~ DI + 8); DS ~ LIT "["; 00279000 END MKABS; 00279100 STREAM PROCEDURE MOVEW(P,Q); VALUE Q; 00279200 BEGIN SI~P; DI ~ Q; DS~CHR; END ; 00279300 REAL BUF,ID; 00279400 BOOLEAN VAL, SAVELISTOG; %511-00279500 LABEL LP,SET,RESET; 00279600 FORMAT WARN(X18,A6," ILLEGAL CONSTRUCT ON DALLAR CARD XXXX",X39, 00279700 "WARNING"); 00279800 DEFINE GETID = BEGIN ID~ " "; BUF ~ SCAN(BUF,ID) END#; 00279900 SAVELISTOG ~ LISTOG; %511- 00280000 MOVEW(CRD[9],BUFL); 00280100 BUF ~ MKABS(CRD[0]); 00280200 GETID; 00280300 IF ID = "VOID " THEN 00280400 BEGIN BUF ~ GETVOID(BUF, VOIDSEQ,0); VOIDTOG ~ TRUE 00280500 END ELSE 00280600 IF ID = "VOIDT " THEN 00280700 BEGIN BUF ~ GETVOID(BUF, VOIDTSEQ,0); VOIDTTOG ~ TRUE 00280800 END ELSE 00280900 BEGIN 00281000 TAPETOG.[47:1] ~ LASTMODE = 2; %517-00281100 IF ID = "SET " OR ID = "+ " THEN 00281200 SET: BEGIN GETID; VAL~ TRUE END 00281300 ELSE 00281400 IF ID = "RESET " OR ID = "- " THEN 00281500 RESET: BEGIN GETID; VAL ~ FALSE END 00281600 ELSE 00281700 BEGIN 00281800 TSSMESTOG ~ VAL; TSSEDITOG ~ VAL; CHECKTOG ~ VAL; %501-00281900 SINGLETOG~NOT VAL; HOLTOG~VAL; %501-00282000 LISTOG~VAL; CODETOG ~ DEBUGTOG ~ VAL; NEWTPTOG ~ VAL; 00282100 PRTOG~VAL; DOLIST~VAL; LIBTAPE~VAL; SEGPTOG~VAL; %501-00282200 LISTPTOG ~ VAL; FREEFTOG ~ XREF ~ VAL ; 00282300 VAL ~ TRUE; 00282400 END; 00282500 LP: IF ID > 0 THEN 00282600 BEGIN 00282700 IF ID = "TRACE " THEN 00282800 BEGIN PRTOG~VAL; LISTOG~VAL; CODETOG~DEBUGTOG~VAL; 00282900 END ELSE 00283000 IF ID = "CARD " THEN 00283100 BEGIN TAPETOG.[47:1]~NOT VAL; LASTMODE~2-REAL(VAL) END ELSE 00283200 IF ID = "TAPE " THEN 00283300 BEGIN TAPETOG.[47:1] ~ VAL; LASTMODE ~ REAL(VAL)+1; END ELSE00283400 IF ID = "NOSEQ " THEN SEQTOG ~ FALSE ELSE 00283500 IF ID = "SET " OR ID = "+ " THEN GO TO SET ELSE 00283600 IF ID = "RESET " OR ID = "- " THEN GO TO RESET ELSE 00283700 IF ID = "ONSITE" AND NOT REMFIXED THEN REMOTETOG ~ FALSE ELSE 00283800 IF ID = "REMOTE" AND NOT REMFIXED THEN REMOTETOG ~ VAL ELSE 00283900 IF ID = "FREEFO" THEN FREEFTOG ~ VAL ELSE 00284000 IF ID = "SINGLE" OR ID = "SGL " THEN 00284100 BEGIN SINGLETOG ~ VAL; LISTOG ~ TRUE; END ELSE 00284200 IF ID = "NEW " OR ID = "NEWTAP" THEN 00284300 BEGIN LIBTAPE~VAL; NEWTPTOG~VAL; NTAPTOG~TRUE; %501- 00284400 IF ID = "NEW " THEN %501-00284500 BEGIN %501-00284600 GETID; %501-00284700 IF ID ! "TAPE " THEN %501-00284800 GO TO LP; %501-00284900 END; %501-00285000 END ELSE %501-00285100 IF ID = "LIST " THEN LISTOG ~ VAL ELSE 00285200 IF ID = "SEQXEQ" AND NOT SEGSWFIXED THEN SEGSW ~ VAL ELSE 00285300 IF ID = "PRT " THEN PRTOG ~ VAL ELSE 00285400 IF ID = "DEBUGN" THEN 00285500 BEGIN LISTOG~VAL; CODETOG~VAL; PRTOG ~ VAL END ELSE 00285600 IF ID = "TIME " THEN TIMETOG ~ VAL ELSE 00285700 IF ID = "ERRMES" THEN TSSMESTOG ~ VAL ELSE 00285800 IF ID = "TSSEDI" THEN TSSEDITOG ~ VAL ELSE 00285900 IF ID = "LISTLI" THEN LISTLIBTOG ~ VAL ELSE 00286000 IF(ID = "SEGMEN" OR ID = "SEG ") AND VAL THEN 00286100 BEGIN ADR~ADR+1; SEGOVF; END ELSE 00286200 IF ID = "PAGE " AND VAL THEN WRITE(LINE[PAGE]) ELSE 00286300 IF ID = "VOID " THEN 00286400 BEGIN VOIDTOG ~ VAL; 00286500 IF VAL THEN BUF ~ GETVOID(BUF,VOIDSEQ,1); 00286600 END ELSE 00286700 IF ID = "VOIDT " THEN 00286800 BEGIN VOIDTTOG ~ VAL; 00286900 IF VAL THEN BUF ~ GETVOID(BUF,VOIDTSEQ,1); 00287000 END ELSE 00287100 IF ID = "LIMIT " THEN 00287200 BEGIN LIMIT ~ IF VAL THEN 0 ELSE @60; 00287300 BUF ~ SEQNUM(BUF,LIMIT); 00287400 IF LIMIT LEQ ERRORCT THEN GO TO POSTWRAPUP; 00287500 END ELSE 00287600 IF ID = "XREF " THEN 00287700 BEGIN 00287800 PXREF ~ TRUE; XREF ~ VAL; 00287900 END ELSE 00288000 IF ID = "SEQ " THEN 00288100 BEGIN SEQTOG ~ VAL; 00288200 IF VAL THEN 00288300 BEGIN SEQBASE ~ SEQINCR ~ 0; 00288400 BUF ~ SEQNUM(BUF,SEQBASE); 00288500 BUF ~ SEQNUM(BUF,SEQINCR); 00288600 IF SEQINCR { 0 THEN SEQINCR ~ 1000; 00288700 END END ELSE 00288800 IF ID = "LISTDO" THEN DOLIST ~ VAL ELSE 00288900 IF ID = "HOL " THEN HOLTOG ~ VAL ELSE 00289000 IF ID = "CHECK " THEN CHECKTOG ~ VAL ELSE 00289100 IF ID = "NEWPAG" THEN SEGPTOG ~ VAL ELSE %501-00289200 IF ID = "LISTP " THEN LISTPTOG ~ VAL ELSE 00289300 BEGIN IF FIRSTCALL THEN DATIME; 00289400 IF UNPRINTED THEN BEGIN PRINTCARD; UNPRINTED~FALSE END; 00289500 IF SINGLETOG THEN WRITE(LINE,WARN,ID) 00289600 ELSE WRITE(RITE,WARN,ID); 00289700 END 00289800 ; 00289900 GETID; 00290000 GO TO LP; 00290100 END; 00290200 END; 00290300 IF DOLIST OR LISTOG OR SAVELISTOG THEN %511-00290400 IF UNPRINTED THEN PRINTCARD; %517-00290500 UNPRINTED ~ TRUE; 00290600 END DOLOPT; 00290700 00290800 STREAM PROCEDURE NEWSEQ(A,B); VALUE B; 00290900 BEGIN 00291000 SI ~ LOC B; DI ~ A; DS ~ 8 DEC; 00291100 END NEWSEQ; 00291200 INTEGER STREAM PROCEDURE SEQCHK(T,C); 00291300 BEGIN 00291400 SI ~ T; DI ~ C; 00291500 IF 8 SC < DC THEN TALLY ~ 4 ELSE 00291600 BEGIN 00291700 SI ~ SI - 8; DI ~ DI - 8; 00291800 IF 8 SC =DC THEN TALLY ~ 2 00291900 ELSE TALLY ~ 3; 00292000 END; 00292100 SEQCHK ~ TALLY; 00292200 END SEQCHK; 00292300 BOOLEAN PROCEDURE READACARD; 00292400 BEGIN 00292500 DEFINE FLAGI(FLAGI1) = BEGIN FLAG(FLAGI1); GO TO E4A;END #; 00292600 REAL STREAM PROCEDURE SCANINC(BUF,ID,RESULT,N,M); 00292700 VALUE BUF,M,N; 00292800 BEGIN 00292900 LOCAL TA; 00293000 LABEL LP,LQ,XIT; 00293100 DI := RESULT; DI := DI +7; 00293200 SI := BUF; 00293300 LP: IF SC = " " THEN BEGIN SI := SI + 1; GO TO LP; END; 00293400 IF SC = ALPHA THEN ELSE BEGIN DS:=LIT "1"; DI:=ID; DS~2LIT"0"; 00293500 DS := CHR; DS := 5LIT" ";GO TO XIT; END; 00293600 IF SC LSS "0" THEN DS:=LIT "2" ELSE DS:=LIT "3"; %400-00293700 N (DI:=ID; DS:=8 LIT "0 "; DI:=DI-7; %400-00293800 7(IF SC=ALPHA THEN DS~CHR ELSE JUMP OUT 2 TO XIT); 00293900 JUMP OUT TO XIT); 00294000 M ( 8 ( IF SC LSS "0" THEN JUMP OUT 2 TO LQ; %400-00294100 IF SC GTR "9" THEN JUMP OUT 2 TO LQ; %400-00294200 SI:=SI+1; TALLY:=TALLY+1)); %400-00294300 LQ: TA := TALLY; 00294400 SI := SI - TA; 00294500 DI := ID; 00294600 DS := TA OCT; 00294700 XIT: SCANINC := SI; 00294800 END SCANINC; 00294900 REAL STREAM PROCEDURE MKABS(S); 00295000 BEGIN SI := S; SI := SI + 1; MKABS := SI; END; 00295100 STREAM PROCEDURE MOVE(P, Q); VALUE Q; 00295200 BEGIN SI ~ P; DI ~ Q; DS ~ CHR; 00295300 DI ~ P; DS ~ LIT "]"; 00295400 END MOVE; 00295500 STREAM PROCEDURE MOVEC(C,B); VALUE B; 00295600 BEGIN SI~B; DI~C; DS~CHR; END; 00295700 BOOLEAN STREAM PROCEDURE GETCOL1(BUF); 00295800 BEGIN 00295900 SI ~ BUF; IF SC = "$" THEN TALLY ~ 1; 00296000 GETCOL1 ~ TALLY; 00296100 END; 00296200 STREAM PROCEDURE TSSEDITS(C,P); BEGIN SI~C; DI~P; DS~10WDS; SI~C ; 00296300 IF SC="C" THEN BEGIN DI~P; DI~DI+1; DS~LIT"-" END ELSE 00296400 IF SC!"$" THEN BEGIN SI~SI+5; IF SC!" " THEN IF SC!"0" THEN BEGIN DI~P;00296500 DS~6LIT"- " END END END OF TSSEDITS ; 00296600 STREAM PROCEDURE MOVEW(F,T,B,R); VALUE B, R; 00296700 BEGIN 00296800 LABEL XIT; 00296900 SI ~ F; DI ~ T; 00297000 B( 00297100 2(40( IF SC = ALPHA THEN DS ~ CHR ELSE 00297200 IF SC = " " THEN DS ~ CHR ELSE 00297300 IF SC = "%" THEN BEGIN DS ~ LIT "("; SI ~ SI+1 END ELSE 00297400 IF SC = "[" THEN BEGIN DS ~ LIT ")"; SI ~ SI+1 END ELSE 00297500 IF SC = "#" THEN BEGIN DS ~ LIT "="; SI ~ SI+1 END ELSE 00297600 IF SC = "&" THEN BEGIN DS ~ LIT "+"; SI ~ SI+1 END ELSE 00297700 IF SC = "@" THEN BEGIN DS ~ LIT """; SI ~ SI+1 END ELSE 00297800 IF SC = ":" THEN BEGIN DS ~ LIT """; SI ~ SI+1 END ELSE 00297900 IF SC = "<" THEN BEGIN DS ~ LIT "+"; SI ~ SI+1 END ELSE 00298000 IF SC = ">" THEN BEGIN DS ~ LIT "="; SI ~ SI+1 END ELSE 00298100 DS ~ CHR )); JUMP OUT TO XIT); 00298200 XIT: 00298300 SI~LOC R; SI~SI+7; DI~DI+1 ; 00298400 DS~CHR ; 00298500 END MOVEW; 00298600 ALPHA STREAM PROCEDURE DCMOVEW(F,T,B,FIL,R); VALUE B,FIL,R; 00298700 BEGIN LOCAL C; LABEL L1,L2,L3,L4 ; 00298800 SI~F; DI~T; 2(SI~SI+36; DS~36LIT" "); C~SI; DS~8CHR ; 00298900 SI~LOC R; SI~SI+6; DS~2CHR; DI~C; DS~8LIT"]";TALLY~33;SI~F; 00299000 IF SC = " " THEN %%% IT MIGHT BE A FILES CARD. 00299100 BEGIN SI~SI+1; IF SC="F" THEN 00299200 BEGIN DI~LOC FIL; DI~DI+2; IF 5SC=DC THEN 00299300 BEGIN DI~F; SI~LOC FIL; SI~SI+2; DS~6CHR ; GO TO L1; END 00299400 ELSE SI~F END ELSE SI~F END 00299500 ELSE IF SC = "F" THEN BEGIN DI~LOC FIL;DI~DI+2;IF 6SC=DC THEN GO L1 00299600 ELSE SI~F;END 00299700 ELSE IF SC="-" THEN 00299800 BEGIN %%% IT IS A CONTINUATION CARD. 00299900 SI~SI+1; DI~T; DS~6LIT" *" ; 00300000 5(IF SC=" " THEN SI~SI+1 ELSE JUMP OUT); GO TO L2 ; 00300100 END 00300200 ELSE IF SC="C" THEN 00300300 BEGIN %%% IT MIGHT BE A COMMENT CARD. 00300400 SI~SI+1; IF SC="-" THEN GO TO L1 ELSE SI~F ; 00300500 END ; 00300600 IF SC!"$" THEN %%% IT IS NOT A COMMENT CARD, NOR IS IT A $ CARD, 00300700 BEGIN %%% NOR A CONTINUATION CARD, NOR A FILES CARD. 00300800 2(33(IF SC=" " THEN SI~SI+1 ELSE JUMP OUT 2 TO L3)); L3: DI~T;00300900 5(IF SC=" " THEN SI~SI+1 ELSE IF SC}"0" THEN IF SC{"9" 00301000 THEN DS~CHR ELSE JUMP OUT ELSE JUMP OUT) ; 00301100 DI~T; DI~DI+6; IF SC=" " THEN SI~SI+1 ; 00301200 END 00301300 ELSE 00301400 BEGIN 00301500 L1: SI~F; DI~T; TALLY~36 ; 00301600 END ; 00301700 L2: C~TALLY ; 00301800 B(2(C(IF SC>">" THEN DS~CHR ELSE IF SC<"[" THEN DS~CHR ELSE 00301900 IF SC="%" THEN BEGIN DS~LIT"("; SI~SI+1 END ELSE 00302000 IF SC="#" THEN BEGIN DS~LIT"="; SI~SI+1 END ELSE 00302100 IF SC="&" THEN BEGIN DS~LIT"+"; SI~SI+1 END ELSE 00302200 IF SC="@" THEN BEGIN DS~LIT"""; SI~SI+1 END ELSE 00302300 IF SC=":" THEN BEGIN DS~LIT"""; SI~SI+1 END ELSE 00302400 IF SC="<" THEN BEGIN DS~LIT"+"; SI~SI+1 END ELSE 00302500 IF SC=">" THEN BEGIN DS~LIT"="; SI~SI+1 END ELSE 00302600 IF SC="[" THEN BEGIN DS~LIT")"; SI~SI+1 END ELSE 00302700 IF SC="]" THEN JUMP OUT 3 TO L4 ELSE DS~CHR));JUMP OUT TO L4);00302800 2(C(IF SC="]" THEN JUMP OUT 2 TO L4 ELSE DS~CHR)) ; 00302900 L4: DI~LOC DCMOVEW; DS~8LIT"00 "; DI~DI-6 ; 00303000 6(IF SC="]" THEN JUMP OUT ELSE DS~CHR) ; 00303100 END OF DCMOVEW ; 00303200 STREAM PROCEDURE SEQERR(BUFF, NEW, OLD); 00303300 BEGIN 00303400 DI ~ BUFF; DS ~ 18 LIT "SEQUENCE ERROR "; 00303500 SI ~ NEW; DS ~ LIT"""; 00303600 DS ~ 8 CHR; DS ~ LIT """; 00303700 DS ~ 3 LIT " < "; 00303800 SI ~ OLD; DS ~ LIT """; 00303900 DS ~ 8 CHR; DS ~ LIT """; 00304000 DS ~ 59 LIT " "; 00304100 DS ~ 8 LIT "X"; DS ~ 4 LIT " "; 00304200 END SEQERR; 00304300 STREAM PROCEDURE DCMOVE(E,C,A,N); VALUE A,N; 00304400 BEGIN SI~C; DI~E; DS~10WDS; DS~4CHR; SI~LOC A; DS~4DEC; 00304500 N(DS~8LIT" PATCH"); END; 00304600 REAL BUF,ID; 00304700 BOOLEAN NOWRI; LABEL ENDPB, E4B; 00304800 LABEL LIBADD, ENDPA, E4A, E4, STRTA; 00304900 LABEL E1,E2,E3,STRT,ENDP,XIT; 00305000 UNPRINTED~TRUE; 00305100 GO TO STRT; 00305200 LIBADD: 00305300 XTA := BLANKS; 00305400 IF INSERTDEPTH = -1 THEN SAVECARD ~ NEXTCARD; 00305500 MOVE (CRD[9],BUFL); 00305600 00305700 IF (INSERTDEPTH ~ INSERTDEPTH + 1) GTR INSERTMAX THEN 00305800 FLAG(158); 00305900 NEWTPTOG ~ FALSE; 00306000 INSERTINX ~ -1; 00306100 INSERTCOP ~ 0; 00306200 BLANKIT(SSNM[5],1,0); 00306300 BUF ~ SCANINC(BUF,INSERTMID,RESULT,1,0); 00306400 IF RESULT = 1 AND INSERTMID = "+ "THEN 00306500 BEGIN BUF~SCANINC(BUF,ID,RESULT,1,0); 00306600 IF ID = "COPY " THEN INSERTCOP ~ 1 00306700 ELSE FLAG(155); 00306800 BUF~SCANINC(BUF,INSERTMID,RESULT,1,0); 00306900 END; 00307000 IF RESULT NEQ 2 THEN FLAGI (155); 00307100 BUF := SCANINC(BUF,ID,RESULT,0,1); %107-00307200 IF RESULT = 1 THEN IF ID = "/ " THEN 00307300 BEGIN BUF := SCANINC(BUF,INSERTFID,RESULT,1,0); 00307400 IF RESULT NEQ 2 THEN FLAGI(155); 00307500 BUF := SCANINC(BUF,ID,RESULT,0,1); 00307600 END ELSE INSERTFID := TIME(-1) ELSE INSERTFID := TIME(-1); 00307700 IF RESULT = 3 THEN 00307800 BEGIN NEWSEQ(SSNM[5],ID); 00307900 BUF := SCANINC(BUF,ID,RESULT,0,1); 00308000 IF RESULT NEQ 1 THEN FLAGI(156); 00308100 IF ID = "] " THEN NEWSEQ (INSERTSEQ,99999999) %400-00308200 ELSE BEGIN %400-00308300 BUF ~ SCANINC(BUF,ID,RESULT,0,1); 00308400 IF RESULT NEQ 3 THEN FLAGI(157); 00308500 NEWSEQ (INSERTSEQ,ID); 00308600 END %400-00308700 END ELSE IF ID = "] " THEN NEWSEQ(INSERTSEQ,999999999) 00308800 ELSE FLAGI(157); 00308900 IF INSERTDEPTH > 0 THEN CLOSE (LF,RELEASE); 00309000 FILL LF WITH INSERTMID,INSERTFID; 00309100 DO BEGIN 00309200 READ (LF[INSERTINX ~ INSERTINX+1],10,DB[*])[E4]; 00309300 END UNTIL SEQCHK(SSNM[5],DB[9]) NEQ 3; 00309400 NEWTPTOG ~ BOOLEAN(INSERTCOP); 00309500 IF NOT NEWTPTOG THEN 00309600 BEGIN 00309700 IF SEQTOG THEN 00309800 BEGIN NEWSEQ(CRD[9],SEQBASE); MOVE(CRD[9],BUFL); 00309900 SEQBASE~SEQBASE+SEQINCR; 00310000 END; MOVEC(CRD[9],BUFL); 00310100 IF LIBTAPE AND(INSERTDEPTH = 0 ) THEN WRITE(NEWTAPE,10,CRD[*]); 00310200 END; %511- 00310300 IF LISTOG OR DOLIST THEN PRINTCARD; %511- 00310400 NEXTCARD~7; 00310500 GO TO STRT; 00310600 E1: IF NEXTCARD=1 THEN IF TAPETOG THEN 00310700 BEGIN 00310800 NEXTCARD~5; READ(TP,10,TB[*])[E2]; GO TO STRT ; 00310900 END 00311000 ELSE 00311100 BEGIN 00311200 NEXTCARD:=6; 00311300 IF GETCOL1(CRD[0]) THEN BEGIN BUF := MKABS(CRD[0]); 00311400 BUF:=SCANINC(BUF,ID,RESULT,1,0); IF ID NEQ INCLUDE 00311500 THEN BLANKIT(CRD,9,1); END; 00311600 GO TO ENDP ; 00311700 END ; 00311800 NEXTCARD ~ 5; GO TO ENDP; 00311900 E2: IF NEXTCARD = 5 THEN 00312000 BEGIN 00312100 NEXTCARD:=6; 00312200 IF GETCOL1(CRD[0]) THEN BEGIN BUF := MKABS(CRD[0]); 00312300 BUF:=SCANINC(BUF,ID,RESULT,1,0); IF ID NEQ INCLUDE 00312400 THEN BLANKIT(CRD,9,1); END; 00312500 END 00312600 ELSE IF NEXTCARD!2 THEN NEXTCARD~1 ELSE 00312700 BEGIN 00312800 NEXTCARD~1; TAPETOG~BOOLEAN(2); READ(CR,10,CB[*])[E1] ; 00312900 END ; 00313000 IF VOIDTTOG THEN IF SEQCHK(CRD[0],VOIDTSEQ) < 4 %114-01313100 THEN VOIDTTOG~FALSE %114-01313200 ELSE BEGIN VOIDTTOG~FALSE; GO TO STRT; END; %114-01313300 GO TO ENDP ; 00313400 E4B: NOWRI ~TRUE; 00313500 IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); 00313600 IF NEWTPTOG THEN IF TSSEDITOG THEN 00313700 BEGIN TSSEDITS(CRD,PRINTBUFF); WRITE(NEWTAPE,10,PRINTBUFF[*]); 00313800 END ELSE WRITE(NEWTAPE,10,CRD[*]); 00313900 E4: CLOSE (LF,RELEASE); 00314000 NEWTPTOG~ SAVETOG; 00314100 IF (INSERTDEPTH := INSERTDEPTH - 1) = -1 THEN 00314200 BEGIN NEXTCARD ~ SAVECARD; GO TO ENDPA; END 00314300 ELSE NEWTPTOG ~ BOOLEAN(INSERTCOP); 00314400 FILL LF WITH INSERTMID,INSERTFID; 00314500 READ(LF[INSERTINX := INSERTINX + 1],10,DB[*])[E4]; 00314600 IF SEQCHK(INSERTSEQ,DB[9]) = 4 THEN GO TO E4; 00314700 GO TO ENDP; 00314800 E4A: 00314900 NEWTPTOG~SAVETOG; 00315000 IF (INSERTDEPTH ~ INSERTDEPTH-1) = -1 THEN NEXTCARD~SAVECARD 00315100 ELSE NEWTPTOG ~ BOOLEAN(INSERTCOP); 00315200 STRT: 00315300 STRTA: 00315400 IF NEXTCARD=6 THEN GO XIT ; 00315500 CARDCOUNT ~ CARDCOUNT+1; 00315600 IF NEXTCARD = 1 THEN 00315700 BEGIN % CARD ONLY 00315800 IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG 00315900 THEN MOVEW(CB,CRD,HOLTOG,IF DCINPUT THEN "D" ELSE "R") 00316000 ELSE IF SSNM[4]~DCMOVEW(CB,CRD,HOLTOG,"FILE ",IF FREEFTOG 00316100 THEN " R" ELSE " D") ! " " THEN 00316200 BEGIN XTA~SSNM[4] ; 00316300 MOVESEQ(SSNM[4],LASTSEQ); MOVESEQ(LASTSEQ,CRD[9]) ; 00316400 IF LISTOG THEN 00316500 BEGIN IF FIRSTCALL THEN DATIME ; 00316600 DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],0); 00316700 WRITAROW(11,PRINTBUFF); UNPRINTED~FALSE ; 00316800 END ; 00316900 FLOG(149); MOVESEQ(LASTSEQ,SSNM[4]) ; 00317000 END ; 00317100 IF GETCOL1(CRD[0]) THEN 00317200 BEGIN 00317300 BUF := MKABS(CRD[0]); 00317400 BUF := SCANINC(BUF,ID,RESULT,1,0); 00317500 IF ID NEQ INCLUDE THEN 00317600 BEGIN 00317700 DOLOPT; 00317800 IF REAL(TAPETOG)=3 THEN READ(TP) ; 00317900 READ(CR,10,CB[*])[E1]; 00318000 IF NOT TAPETOG THEN GO TO STRT; 00318100 READ(TP,10,TB[*])[E2]; 00318200 NEXTCARD ~ SEQCHK(TB[9], CB[9]); 00318300 GO TO STRT; 00318400 END; 00318500 END; 00318600 IF LISTPTOG THEN 00318700 BEGIN IF FIRSTCALL THEN DATIME; 00318800 IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); 00318900 DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],1); 00319000 WRITAROW (12,PRINTBUFF); UNPRINTED ~ FALSE; 00319100 END; 00319200 READ(CR,10,CB[*])[E1]; 00319300 GO TO ENDP; 00319400 END; 00319500 IF NEXTCARD = 5 THEN 00319600 BEGIN 00319700 MOVEW(TB,CRD,HOLTOG,"T") ; 00319800 READ(TP, 10, TB[*])[E2]; 00319900 IF VOIDTTOG THEN IF SEQCHK(CRD[9],VOIDTSEQ) < 4 THEN 00320000 VOIDTTOG ~ FALSE ELSE GO TO STRT; 00320100 GO TO ENDP; 00320200 END; 00320300 IF NEXTCARD { 3 THEN 00320400 BEGIN % CARD OVER TAPE 00320500 IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG 00320600 THEN MOVEW(CB,CRD,HOLTOG,IF DCINPUT THEN "D" ELSE "R") 00320700 ELSE IF SSNM[4]~DCMOVEW(CB,CRD,HOLTOG,"FILE ",IF FREEFTOG 00320800 THEN " R" ELSE " D") ! " " THEN 00320900 BEGIN XTA~SSNM[4] ; 00321000 MOVESEQ(SSNM[4],LASTSEQ); MOVESEQ(LASTSEQ,CRD[9] ); 00321100 IF LISTOG THEN 00321200 BEGIN IF FIRSTCALL THEN DATIME; 00321300 DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],0); 00321400 WRITAROW(11,PRINTBUFF); UNPRINTED~FALSE ; 00321500 END; 00321600 FLOG(149); MOVESEQ(LASTSEQ,SSNM[4]) ; 00321700 END; 00321800 IF NEXTCARD =2 THEN READ(TP,10,TB[*])[E2]; 00321900 IF GETCOL1(CRD) THEN 00322000 BEGIN 00322100 BUF ~ MKABS(CRD[0]); 00322200 BUF ~ SCANINC(BUF,ID,RESULT,1,0); 00322300 IF ID NEQ INCLUDE THEN 00322400 BEGIN 00322500 DOLOPT; 00322600 READ(CR,10,CB[*])[E3]; 00322700 NEXTCARD ~ SEQCHK(TB[9], CB[9]); 00322800 GO TO STRT; 00322900 E3: NEXTCARD~5; GO TO STRT; 00323000 END; 00323100 END; 00323200 IF LISTPTOG THEN 00323300 BEGIN IF FIRSTCALL THEN DATIME; 00323400 IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); 00323500 DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],1); 00323600 WRITAROW (12,PRINTBUFF); UNPRINTED ~ FALSE; 00323700 END; 00323800 READ(CR,10,CB[*])[E1]; 00323900 NEXTCARD ~ SEQCHK(TB[9], CB[9]); 00324000 GO TO ENDP; 00324100 END; 00324200 % TAPE BEFORE CARD 00324300 IF NEXTCARD = 7 THEN 00324400 BEGIN 00324500 IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG 00324600 THEN MOVEW(DB,CRD,HOLTOG,"L") ELSE IF XTA~DCMOVEW(DB,CRD, 00324700 HOLTOG,"FILE ",IF FREEFTOG THEN " R" ELSE " D") 00324800 ! " " THEN FLOG(149); 00324900 IF GETCOL1(CRD[0]) THEN 00325000 BEGIN 00325100 BUF ~ MKABS(CRD[0]); 00325200 BUF ~ SCANINC(BUF,ID,RESULT,1,0); 00325300 IF ID = INCLUDE THEN GO TO LIBADD; 00325400 END; 00325500 READ(LF[INSERTINX~INSERTINX+1],10,DB[*])[E4B]; 00325600 IF SEQCHK(INSERTSEQ,DB[9]) = 4 THEN GO TO E4B; 00325700 IF GETCOL1(CRD[0]) THEN BEGIN DOLOPT; GO TO STRT; END; 00325800 GO TO ENDP; 00325900 END; 00326000 MOVEW(TB,CRD,HOLTOG,"T") ; 00326100 READ(TP,10,TB[*])[E2]; 00326200 IF VOIDTTOG THEN IF SEQCHK(CRD[9],VOIDTSEQ) < 4 THEN 00326300 VOIDTTOG~FALSE ELSE BEGIN NEXTCARD~SEQCHK(TB[9],CB[9]); %114-00326400 GO TO STRT; END; %114-00326500 NEXTCARD ~ SEQCHK(TB[9], CB[9]); 00326600 ENDP: 00326700 IF NEXTCARD NEQ 7 THEN 00326800 IF VOIDTOG THEN IF SEQCHK(CRD[9],VOIDSEQ) < 4 THEN 00326900 VOIDTOG ~ FALSE ELSE GO TO STRT; 00327000 IF GETCOL1(CRD[0]) THEN 00327100 BEGIN 00327200 BUF ~ MKABS(CRD[0]); 00327300 BUF ~ SCANINC(BUF,ID,RESULT,1,0); 00327400 IF ID = INCLUDE THEN GO TO LIBADD ELSE GO TO STRT; 00327500 END; 00327600 SEQERRORS ~ FALSE; 00327700 IF NEXTCARD = 7 THEN 00327800 BEGIN MOVESEQ(LASTSEQ,CRD[9]); GO TO ENDPA; END; 00327900 IF CHECKTOG AND SEQERRCT=0 THEN SEQERRCT~1 ; 00328000 IF CHECKTOG THEN IF SEQCHK(LASTSEQ,CRD[9])=3 THEN 00328100 BEGIN 00328200 SEQERR(ERRORBUFF,CRD[9],LASTSEQ) ; 00328300 MOVESEQ(LASTSEQ,CRD[9]) ; 00328400 IF SEQTOG THEN 00328500 BEGIN NEWSEQ(CRD[9],SEQBASE);SEQBASE~SEQBASE+SEQINCR END;00328600 MOVESEQ(LINKLIST,CRD[9]); 00328700 MOVE(CRD[9],BUFL) ; 00328800 SEQERRCT~SEQERRCT+1 ; 00328900 SEQERRORS~TRUE ; 00329000 IF NOT LISTOG THEN PRINTCARD ; 00329100 END 00329200 ELSE MOVESEQ(LASTSEQ,CRD[9]) ELSE MOVESEQ(LASTSEQ,CRD[9]) ; 00329300 00329400 00329500 00329600 00329700 00329800 00329900 00330000 00330100 ENDPA: 00330200 IF SEQTOG THEN 00330300 BEGIN 00330400 NEWSEQ(CRD[9],SEQBASE); 00330500 SEQBASE ~ SEQBASE + SEQINCR; 00330600 END; 00330700 IF NOWRI THEN GO TO ENDPB; 00330800 IF NEWTPTOG THEN IF TSSEDITOG THEN BEGIN TSSEDITS(CRD,PRINTBUFF) ; 00330900 WRITE(NEWTAPE,10,PRINTBUFF[*]) END ELSE WRITE(NEWTAPE,10,CRD[*]) ; 00331000 ENDPB: 00331100 IF NOT SEQERRORS THEN 00331200 BEGIN 00331300 MOVESEQ(LINKLIST,CRD[9]) ; 00331400 MOVE(CRD[9],BUFL) ; 00331500 END ; 00331600 NCR ~ INITIALNCR; 00331700 READACARD ~ TRUE; 00331800 XIT: 00331900 SEGSWFIXED ~ TRUE ; 00332000 REMFIXED~TRUE ; 00332100 IF TSSEDITOG THEN WARNED~TRUE ; 00332200 IF LISTOG AND FIRSTCALL THEN DATIME; 00332300 IF SEGSW THEN %%% ENTER SEQ# AND ADR TO LINESEG ARRAY. 00332400 BEGIN IF LASTADDR!ADR THEN BEGIN NOLIN~NOLIN+1; LASTADDR~ADR END;00332500 LINESEG[NOLIN.IR,NOLIN.IC]~0 & D2B(LASTSEQ)[10:20:28] & (ADR+3) 00332600 [38:36:10] ; 00332700 END ; 00332800 END READACARD; 00332900 00333000 INTEGER STREAM PROCEDURE CONVERT(NUB,SIZE,P,CHAR); VALUE P; 00333100 BEGIN 00333200 LOCAL T; 00333300 SI ~ P; 00333400 8(IF SC < "0" THEN JUMP OUT; 00333500 SI ~ SI + 1; TALLY ~ TALLY + 1); 00333600 CONVERT ~ SI; 00333700 DI ~ CHAR; DS ~ 7 LIT "0"; DS ~ CHR; 00333800 T ~ TALLY; 00333900 SI ~ P; DI ~ NUB; DS ~ T OCT; 00334000 DI ~ SIZE ; SI ~ LOC T; DS ~ WDS; 00334100 END CONVERT; 00334200 PROCEDURE SCAN; 00334300 BEGIN 00334400 BOOLEAN STREAM PROCEDURE ADVANCE(NCR, ACR, CHAR, NCRV, ACRV); 00334500 VALUE NCRV, ACRV, CHAR; 00334600 BEGIN LABEL LOOP; 00334700 LABEL DIG, ALPH, BK1, BK2, SPEC; 00334800 DI ~ ACRV; 00334900 SI ~ CHAR; SI ~ SI+8; 00335000 IF SC ! " " THEN 00335100 IF SC } "0" THEN BEGIN SI ~ NCRV; GO TO BK1 END ELSE 00335200 BEGIN SI ~ NCRV; GO TO BK2 END; 00335300 SI ~ NCRV; 00335400 LOOP: 00335500 IF SC = " " THEN BEGIN SI~SI+1; GO TO LOOP END; 00335600 IF SC } "0" THEN 00335700 BEGIN 00335800 DIG: DS ~ CHR; 00335900 BK1: IF SC = " " THEN BEGIN SI ~ SI+1; GO TO BK1 END; 00336000 IF SC } "0" THEN GO TO DIG; 00336100 GO TO SPEC; 00336200 END; 00336300 IF SC = ALPHA THEN 00336400 BEGIN 00336500 ALPH: DS ~ CHR; 00336600 BK2: IF SC = " " THEN BEGIN SI ~ SI+1; GO TO BK2 END; 00336700 IF SC = ALPHA THEN GO TO ALPH; 00336800 END; 00336900 SPEC: 00337000 ACRV ~ DI; 00337100 DS ~ 6 LIT " "; 00337200 IF SC = "]" THEN 00337300 BEGIN TALLY ~ 1; SI ~ LOC ACRV; 00337400 DI ~ ACR; DS ~ WDS; 00337500 DI ~ CHAR; DS ~ LIT ";"; 00337600 END ELSE 00337700 BEGIN DI ~ CHAR; DS ~ CHR; 00337800 ACRV ~ SI; SI ~ LOC ACRV; 00337900 DI ~ NCR; DS ~ WDS; 00338000 END; 00338100 ADVANCE ~ TALLY; 00338200 END ADVANCE; 00338300 BOOLEAN PROCEDURE CONTINUE; 00338400 BEGIN 00338500 LABEL LOOP; 00338600 00338700 BOOLEAN STREAM PROCEDURE CONTIN(CD); 00338800 BEGIN SI~CD; IF SC!"C" THEN IF SC!"$" THEN BEGIN SI~SI+5; IF SC!" " 00338900 THEN IF SC!"0" THEN BEGIN TALLY~1; CONTIN~TALLY END END END OF CONTIN ;00339000 BOOLEAN STREAM PROCEDURE COMNT(CD,T); VALUE T; 00339100 BEGIN LABEL L ; 00339200 SI ~ CD; IF SC = "C" THEN BEGIN T(SI~SI+1; IF SC="-" THEN TALLY~1 00339300 ELSE JUMP OUT TO L); TALLY~1; L: END; COMNT~TALLY ; 00339400 END COMNT; 00339500 BOOLEAN STREAM PROCEDURE DCCONTIN(CD); 00339600 BEGIN 00339700 SI ~ CD; IF SC = "-" THEN TALLY ~ 1; 00339800 DCCONTIN ~ TALLY; 00339900 END DCCONTIN; 00340000 LOOP: IF NOT(CONTINUE ~ 00340100 IF(DCINPUT AND NOT TSSEDITOG)OR FREEFTOG THEN 00340200 IF NEXTCARD < 4 THEN DCCONTIN(CB) 00340300 ELSE IF NEXTCARD = 7 THEN DCCONTIN(DB)ELSE CONTIN(TB) 00340400 ELSE IF NEXTCARD = 7 THEN CONTIN(DB) 00340500 ELSE IF NEXTCARD < 4 THEN CONTIN(DB) ELSE 00340600 CONTIN(TB)) THEN 00340700 IF(IF NEXTCARD < 4 THEN 00340800 COMNT(CB,(DCINPUT AND NOT TSSEDITOG) OR FREEFTOG) 00340900 ELSE IF NEXTCARD = 7 THEN 00341000 COMNT(CB,(DCINPUT AND NOT TSSEDITOG) OR FREEFTOG) 00341100 ELSE COMNT(TB,0) AND NEXTCARD ! 6) THEN 00341200 BEGIN 00341300 IF READACARD THEN IF LISTOG THEN PRINTCARD; 00341400 GO TO LOOP; 00341500 END; 00341600 END CONTINUE; 00341700 00341800 PROCEDURE SCANX(EOF1, EOF2, EOS1, EOS2, OK1, OK2); 00341900 VALUE EOF1, EOF2, EOS1, EOS2, OK1, OK2; 00342000 INTEGER EOF1, EOF2, EOS1, EOS2, OK1, OK2; 00342100 BEGIN LABEL LOOP, LOOP0 ; 00342200 LOOP0: 00342300 EXACCUM[1] ~ BLANKS; 00342400 ACR ~ ACR1; 00342500 LOOP: 00342600 IF ADVANCE(NCR, ACR, CHR1, NCR, ACR) THEN 00342700 IF CONTINUE THEN 00342800 IF READACARD THEN 00342900 BEGIN 00343000 IF LISTOG THEN PRINTCARD ; 00343100 IF ACR.[33:15]}EXACCUMSTOP THEN 00343200 BEGIN XTA~BLANKS; FLOG(175); GO LOOP0 END ; 00343300 GO LOOP ; 00343400 END 00343500 ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN EOF1 ELSE EOF2 00343600 ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN EOS1 ELSE EOS2 00343700 ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN OK1 ELSE OK2; 00343800 END SCANX; 00343900 00344000 DEFINE CHAR = ACCUM[0]#; 00344100 DEFINE T=SYMBOL#; 00344200 INTEGER N; 00344300 BOOLEAN STREAM PROCEDURE CHECKEXP(NCR, NCRV, A); VALUE NCRV; 00344400 BEGIN 00344500 SI ~ NCRV; 00344600 IF SC = "*" THEN 00344700 BEGIN DI ~ A; DI ~ DI+2; DS ~ 2 LIT "*"; SI ~ SI+1; NCRV ~ SI; 00344800 TALLY ~ 1; CHECKEXP ~ TALLY; 00344900 SI ~ LOC NCRV; DI ~ NCR; DS ~ WDS END; 00345000 END CHECKEXP; 00345100 PROCEDURE CHECKRESERVED; 00345200 BEGIN LABEL RESWD, XIT, FOUND1, FOUND2, DONE; 00345300 BOOLEAN STREAM PROCEDURE COMPLETECHECK(A,B,N); VALUE N ; 00345400 BEGIN LABEL L ; 00345500 SI~A; SI~SI-2; DI~B; N(IF SC!DC THEN JUMP OUT TO L); TALLY~1; 00345600 L: COMPLETECHECK~TALLY ; 00345700 END OF COMPLETECHECK; 00345800 STREAM PROCEDURE XFER(FROM, T1, T2, N, M); VALUE FROM, N, M; 00345900 BEGIN SI ~ FROM; DI ~ T1; DI ~ DI+2; 00346000 DS ~ M CHR; 00346100 SI ~ FROM; SI ~ SI+N; 00346200 DI ~ T2; DI ~ DI+2; 00346300 DS ~ 6 CHR; 00346400 END XFER; 00346500 STREAM PROCEDURE XFERA(FROM, NEXT1, NEXT2); 00346600 VALUE FROM; 00346700 BEGIN SI ~ FROM; SI ~ SI+6; 00346800 DI ~ NEXT1; DI ~ DI+2; 00346900 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); 00347000 SI ~ SI+2; 00347100 DI ~ NEXT2; DI ~ DI+2; 00347200 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); 00347300 END XFERA; 00347400 BOOLEAN STREAM PROCEDURE CHECKFUN(FROM, TOO, N); VALUE FROM, N; 00347500 BEGIN SI ~ FROM; SI ~ SI +N; 00347600 IF SC = "O" THEN 00347700 BEGIN SI ~ SI+1; 00347800 IF SC = "N" THEN 00347900 BEGIN SI ~ SI+1; TALLY ~ 1; 00348000 DI ~ TOO; DI ~ DI+2; 00348100 DS ~ 6 CHR; 00348200 END; 00348300 END; 00348400 CHECKFUN ~ TALLY; 00348500 END CHECKFUN; 00348600 BOOLEAN STREAM PROCEDURE MORETHAN6(P); 00348700 BEGIN SI ~ P; 00348800 IF SC ! " " THEN TALLY ~ 1; 00348900 MORETHAN6 ~ TALLY; 00349000 END MORETHAN6; 00349100 INTEGER I; ALPHA ID; 00349200 INTEGER STOR ; 00349300 IF ACCUM[1] = " " THEN 00349400 BEGIN XTA ~ CHAR; FLOG(16); GO TO XIT END; 00349500 IF CHAR = "= " OR CHAR = "# " THEN GO TO XIT; 00349600 IF CHAR = "~ " THEN GO TO XIT; 00349700 IF CHAR ! "( " AND CHAR ! "% " THEN GO TO RESWD; 00349800 IF MORETHAN6(ACCUM[2]) THEN GO TO RESWD; 00349900 COMMENT AT THIS POINT WE HAVE ( . 00350000 THIS MUST BE ONE OF THE FOLLOWING: 00350100 ASSIGNEMNT STATEMENT WITH SUBSCRIPTED VARIABLE AT THE LEFT. 00350200 STATEMENT FUNCTION DECLARATION. 00350300 CALL, REAL, ENTRY, GO TO, READ, WRITE, FORMAT, IF, DATA, CHAIN, PRINT OR00350400 PUNCH; 00350500 IF I ~ SEARCH(T) > 0 THEN 00350600 IF GET(I).CLASS = ARRAYID THEN GO TO XIT; 00350700 ID ~ T; ID.[36:12] ~ " "; 00350800 FOR I~0 THRU RSP DO IF RESERVEDWORDSLP[I]=ID THEN IF (IF STOR 00350900 ~RESLENGTHLP[I]-4<1 THEN TRUE ELSE COMPLETECHECK(ACCUM[2], 00351000 RESERVEDWORDSLP[I+RSP1],STOR)) THEN GO FOUND1 ; 00351100 GO TO XIT; 00351200 FOUND1: 00351300 NEXT ~ LPGLOBAL[I]; 00351400 T ~ " "; 00351500 XFER(ACR0, T, NEXTACC, I~RESLENGTHLP[I], IF I> 6 THEN 6 ELSE I); 00351600 GO TO DONE; 00351700 RESWD: 00351800 COMMENT AT THIS POINT WE KNOW THE MUST BE A SPECIAL WORD 00351900 TO IDENTIFY THE STATEMENT TYPE; 00352000 ID ~ T; ID.[36:12] ~ " "; 00352100 IF T = "ASSIGN" THEN 00352200 BEGIN 00352300 NEXTSCN ~ SCN; SCN ~ 14; 00352400 NEXTACC ~ NEXTACC2 ~ " "; 00352500 XFERA(ACR0, NEXTACC, NEXTACC2); 00352600 NEXT ~ 1; 00352700 GO TO XIT; 00352800 END; 00352900 FOR I~1 THRU RSH DO IF RESERVEDWORDS[I]=ID THEN IF (IF STOR~ 00353000 RESLENGTH[I]-4<1 THEN TRUE ELSE COMPLETECHECK(ACCUM[2],RESERVEDWORDS00353100 [I+RSH1],IF STOR>8 THEN 8 ELSE STOR)) THEN GO FOUND2 ; 00353200 XTA ~ T; FLOG(16); GO TO XIT; 00353300 FOUND2: 00353400 NEXT ~ I+1; 00353500 T ~ " "; 00353600 XFER(ACR0, T, NEXTACC, I~RESLENGTH [I], IF I> 6 THEN 6 ELSE I); 00353700 DONE: NEXTSCN ~ SCN; 00353800 SCN ~ 6; 00353900 IF NEXTACC = "FUNCTI" THEN 00354000 IF CHECKFUN(ACR0, NEXTACC, I+6) THEN SCN ~ 13; 00354100 XIT: 00354200 EOSTOG~FALSE; 00354300 END CHECKRESERVED; 00354400 00354500 BOOLEAN PROCEDURE CHECKOCTAL; 00354600 BEGIN 00354700 INTEGER S, T; LABEL XIT; 00354800 INTEGER STREAM PROCEDURE COUNT(ACRV,T); VALUE ACRV,T ; 00354900 BEGIN 00355000 LOCAL A,B; SI~LOC T; SI~SI+7 ; 00355100 IF SC="1" THEN BEGIN SI~ACRV;IF SC="O" THEN SI~SI+1 END ELSE SI~ACRV;00355200 IF SC!" " THEN 00355300 BEGIN A~SI; 00355400 17(IF SC>"7" THEN BEGIN TALLY~17; JUMP OUT END ELSE IF SC < "0" THEN00355500 BEGIN IF SC!" " THEN TALLY~17; JUMP OUT END; SI~SI+1; 00355600 TALLY~TALLY+1) ; 00355700 B~TALLY; SI~LOC B; SI~SI+7 ; 00355800 IF SC="+" THEN BEGIN SI~A; IF SC>"3" THEN TALLY~17 END; 00355900 END ; 00356000 COUNT~TALLY ; 00356100 END OF COUNT ; 00356200 ALPHA STREAM PROCEDURE CONV(ACRV, S, T); VALUE ACRV, S, T; 00356300 BEGIN SI ~ ACRV; IF SC = "O" THEN SI ~ SI+1; 00356400 DI ~ LOC CONV; SKIP S DB; 00356500 T(SKIP 3 SB; 3(IF SB THEN DS ~ SET ELSE DS ~ RESET; SKIP 1 SB)); 00356600 END CONV; 00356700 IF T~COUNT(ACR0,1) = 0 THEN 00356800 BEGIN S ~ 1; 00356900 IF T ~ CHAR ! "+ " AND T ! "& " THEN 00357000 IF T = "- " THEN S ~ -1 ELSE GO TO XIT; 00357100 SCANX(4, 4, 3, 3, 10, 10); 00357200 IF SCN ! 10 THEN GO TO XIT; 00357300 IF T~COUNT(ACR1,2) = 0 OR T > 16 THEN GO TO XIT ; 00357400 FNEXT ~ CONV(ACR1, (16-T)|3, T); 00357500 IF S < 0 THEN FNEXT ~ -FNEXT; 00357600 END ELSE IF T < 17 THEN FNEXT~CONV(ACR0,(16-T)|3,T) ELSE GO TO XIT ; 00357700 CHECKOCTAL ~ TRUE; 00357800 NEXT ~ NUM; 00357900 NUMTYPE ~ REALTYPE; 00358000 XIT: 00358100 END CHECKOCTAL; 00358200 00358300 PROCEDURE HOLLERITH; 00358400 BEGIN 00358500 REAL T, COL1, T2, ENDP; 00358600 LABEL XIT; 00358700 INTEGER STREAM PROCEDURE STRCNT(S,D,SZ); VALUE S,SZ; 00358800 BEGIN 00358900 SI ~ S; DI ~ D;DS ~ 8 LIT "00 "; DI ~ D; 00359000 DI ~ D; DI ~ DI + 2; DS ~SZ CHR; STRCNT ~ SI; 00359100 END STRCNT; 00359200 INTEGER STREAM PROCEDURE RSTORE(S,D,SKP,SZ); 00359300 VALUE S, SKP, SZ; 00359400 BEGIN 00359500 DI ~ D; 00359600 SI ~ S; DI ~DI + SKP; DS ~ SZ CHR; RSTORE ~ SI; 00359700 END RSTORE; 00359800 F1 ~ FNEXT; 00359900 NUMTYPE ~ STRINGTYPE; 00360000 T ~ 0 & NCR[30:33:15] & NCR[45:30:3]; 00360100 COL1 ~ 0 & INITIALNCR[30:33:15]; 00360200 ENDP ~ COL1 + 72; 00360300 STRINGSIZE ~ 0; 00360400 WHILE F1 >0 DO 00360500 BEGIN 00360600 T2 ~ IF F1 > 6 THEN 6 ELSE F1; 00360700 IF STRINGSIZE > MAXSTRING THEN 00360800 BEGIN FLAG(120); STRINGSIZE ~ 0 END; 00360900 IF T+T2> ENDP THEN IF DCINPUT OR FREEFTOG THEN 00361000 BEGIN XTA~BLANKS; FLOG(150); GO TO XIT END 00361100 ELSE BEGIN 00361200 IF TSSEDITOG THEN IF NOT DCINPUT THEN TSSED(BLANKS,1) ; 00361300 NCR ~ STRCNT(NCR, STRINGARRAY[STRINGSIZE], ENDP-T); 00361400 IF NOT CONTINUE THEN 00361500 BEGIN FLOG(43); GO TO XIT END; 00361600 IF READACARD THEN; 00361700 IF LISTOG THEN PRINTCARD; 00361800 NCR ~ RSTORE(NCR,STRINGARRAY[STRINGSIZE],ENDP-T+2,T2-(ENDP-T)); 00361900 STRINGSIZE ~ STRINGSIZE+1; 00362000 F1 ~ F1 - T2; 00362100 T ~ COL1 + 6 + T2 - (ENDP - T); 00362200 END ELSE 00362300 BEGIN 00362400 NCR ~ STRCNT(NCR, STRINGARRAY[STRINGSIZE], T2); 00362500 STRINGSIZE ~ STRINGSIZE +1; 00362600 T ~ T +T2; 00362700 F1 ~ F1 - T2; 00362800 END; 00362900 END; 00363000 NUMTYPE ~ STRINGTYPE; 00363100 SCN ~ 1; 00363200 XIT: 00363300 END HOLLERITH; 00363400 PROCEDURE QUOTESTRING; 00363500 BEGIN 00363600 REAL C; 00363700 LABEL XIT; 00363800 ALPHA STREAM PROCEDURE STRINGWORD(S,D,SKP,SZ,C); 00363900 VALUE S,SKP,SZ; 00364000 BEGIN 00364100 LABEL QT, XIT; 00364200 DI ~ D; SI ~ S; 00364300 DI ~ DI+SKP; DI ~ DI+2; 00364400 TALLY ~ SKP; 00364500 SZ( IF SC = """ THEN JUMP OUT TO QT; 00364600 IF SC = ":" THEN JUMP OUT TO QT; 00364700 IF SC = "@" THEN JUMP OUT TO QT; 00364800 IF SC = "]" THEN JUMP OUT TO XIT; 00364900 DS ~ CHR; TALLY ~ TALLY+1); 00365000 GO TO XIT; 00365100 QT: TALLY ~ TALLY+7; SI ~ SI+1; 00365200 XIT: STRINGWORD ~ SI; S ~ TALLY; 00365300 SI ~ LOC S; DI ~ C; DS ~ WDS; 00365400 END STRINGWORD; 00365500 STRINGSIZE ~ 0; 00365600 DO 00365700 BEGIN 00365800 IF STRINGSIZE > MAXSTRING THEN 00365900 BEGIN FLAG(120); STRINGSIZE ~ 0 END; 00366000 STRINGARRAY[STRINGSIZE] ~ BLANKS; 00366100 NCR ~ STRINGWORD(NCR, STRINGARRAY[STRINGSIZE], 0, 6, C); 00366200 IF C<6 THEN IF DCINPUT OR FREEFTOG 00366300 THEN BEGIN XTA~BLANKS; FLOG(150); GO TO XIT END 00366400 ELSE BEGIN 00366500 IF TSSEDITOG THEN IF NOT DCINPUT THEN TSSED(BLANKS,1) ; 00366600 IF NOT CONTINUE THEN 00366700 BEGIN FLOG(121); GO TO XIT END; 00366800 IF READACARD THEN; 00366900 IF LISTOG THEN PRINTCARD; 00367000 NCR ~ STRINGWORD(NCR, STRINGARRAY[STRINGSIZE ],C,6-C,C); 00367100 END; 00367200 STRINGSIZE ~ STRINGSIZE + 1; 00367300 END UNTIL C } 7; 00367400 IF C = 7 THEN STRINGSIZE ~ STRINGSIZE-1; 00367500 FNEXT ~ STRINGSIZE; 00367600 NEXT ~ NUM; 00367700 SYMBOL ~ NAME ~ STRINGARRAY[0]; 00367800 NUMTYPE ~ STRINGTYPE; 00367900 SCN ~ 1; 00368000 XIT: 00368100 END QUOTESTRING; 00368200 00368300 PROCEDURE CHECKPERIOD; 00368400 BEGIN 00368500 LABEL FRACTION, XIT, EXPONENT, EXPONENTSIGN; 00368600 LABEL NUMFINI, FPLP, CHKEXP; 00368700 ALPHA S, T, I, TS; 00368800 INTEGER C2; 00368900 BOOLEAN CON; 00369000 IF T ~ CHAR ! ". " THEN GO TO CHKEXP; 00369100 SCANX(4, 9, 3, 8, 10, 11); 00369200 IF T ~ EXACCUM[1] = " " THEN 00369300 BEGIN IF NUMTYPE ! DOUBTYPE THEN NUMTYPE ~ REALTYPE; GO TO XIT END; 00369400 IF T = "E " OR T = "D " THEN GO TO EXPONENTSIGN; 00369500 IF T.[12:6] { 9 THEN GO TO FRACTION; 00369600 IF T.[18:6] { 9 THEN 00369700 BEGIN 00369800 IF S ~ T.[12:6] ! "E" AND S ! "D" THEN 00369900 BEGIN XTA ~ T; FLOG(63); GO TO XIT END; 00370000 EXACCUM[1].[12:6] ~ 0; 00370100 I ~ 1; GO TO EXPONENT; 00370200 END; 00370300 IF EXACCUM[0] ! ". " THEN GO TO XIT; 00370400 FOR I ~ 0 STEP 1 UNTIL 10 DO 00370500 IF T = PERIODWORD[I] THEN 00370600 BEGIN EXACCUM[2] ~ I; SCN ~ 12; GO TO XIT END; 00370700 GO TO XIT; 00370800 FRACTION: NEXT ~ NUM; 00370900 IF NUMTYPE !DOUBTYPE THEN NUMTYPE ~ REALTYPE; XTA ~ ACR1; 00371000 FPLP: 00371100 F1 ~ 0; 00371200 XTA ~ CONVERT(F1,C1,XTA ,TS); 00371300 C2 ~ C2 + C1; 00371400 IF (F2 ~ FNEXT|TEN[C1]+F1) { MAX 00371500 THEN FNEXT ~ F2 00371600 ELSE BEGIN 00371700 NUMTYPE ~ DOUBTYPE; 00371800 CON ~ TRUE; 00371900 DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|, 00372000 F1,0,+,~,FNEXT,DBLOW); 00372100 END; 00372200 IF TS { 9 THEN GO TO FPLP; 00372300 F1 ~ 0; 00372400 IF T ~ EXACCUM[0] ! "E " AND T ! "D " THEN 00372500 BEGIN IF SCN = 8 THEN SCN ~ 3 ELSE SCN ~ 10; 00372600 GO TO NUMFINI; 00372700 END; 00372800 CHKEXP: FNEXT ~ FNEXT | 1.0; 00372900 F1 ~ 0; 00373000 I ~ 1; 00373100 SCANX(4, 4, 3, 3, 20, 10); 00373200 IF SCN = 20 THEN 00373300 EXPONENTSIGN: 00373400 BEGIN IF S ~ EXACCUM[0] ! "+ " AND S ! "& " THEN 00373500 IF S = "- " THEN I ~ -1 ELSE 00373600 BEGIN XTA ~ S; FLOG(63); SCN ~ 10; GO TO XIT END; 00373700 SCANX(4, 4, 3, 3, 10, 10); 00373800 END; 00373900 IF (S ~ EXACCUM[1]).[12:6] > 9 THEN 00374000 BEGIN XTA ~ IF S ! BLANKS THEN S ELSE T; FLOG(63); GO TO XIT END; 00374100 EXPONENT: 00374200 IF NUMTYPE ! DOUBTYPE THEN NUMTYPE ~ REALTYPE; 00374300 IF T.[12:6] = "D" THEN NUMTYPE ~ DOUBTYPE; 00374400 IF SCN = 8 THEN SCN ~ 3 ELSE IF SCN = 11 THEN SCN ~ 10; 00374500 XTA ~ ACR1; 00374600 XTA ~ CONVERT(F1,C1,XTA ,TS); 00374700 IF I < 0 THEN F1 ~ -F1; 00374800 NUMFINI: 00374900 C1 ~ F1 - C2; 00375000 IF I ~ (ABS(C1+(FNEXT.[3:6]&FNEXT[1:2:1]))) > 63 OR((ABS(C1) = I OR 00375100 FNEXT } 5) AND ABS(F1) } 69) 00375200 THEN BEGIN XTA ~ T; FLOG(87); GO TO XIT; END; 00375300 IF NUMTYPE ! DOUBTYPE THEN 00375400 BEGIN 00375500 IF C1} 0 THEN FNEXT ~ FNEXT | TEN[C1] 00375600 ELSE FNEXT ~ FNEXT / TEN[-C1]; 00375700 END ELSE 00375800 BEGIN 00375900 IF C1 } 0 00376000 THEN DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|,~,FNEXT,DBLOW) 00376100 ELSE DOUBLE(FNEXT,DBLOW,TEN[-C1],TEN[69-C1],/,~,FNEXT,DBLOW); 00376200 IF CON THEN IF DBLOW.[9:33] = MAX.[9:33] THEN 00376300 IF FNEXT.[3:6] LSS 14 00376400 THEN IF BOOLEAN(FNEXT.[2:1]) THEN 00376500 BEGIN DBLOW ~ 0; FNEXT ~ FNEXT + 1&FNEXT[2:2:7]; END; 00376600 END; 00376700 XIT: 00376800 END CHECKPERIOD; 00376900 00377000 LABEL LOOP0, NUMBER ; 00377100 LABEL L,XIT; 00377200 LABEL L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15,L16,L17, 00377300 L18,L19,L20,L21,BK ; 00377400 SWITCH CASEL~L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15, 00377500 L16,L17,L18,L19,L20,L21 ; 00377600 LABEL LOOP, CASESTMT; %994-00377700 LABEL CASE0,CASE1,CASE2,CASE3,CASE4,CASE5,CASE6,CASE7; %994-00377800 LABEL CASE8,CASE9,CASE10,CASE11,CASE12,CASE13,CASE14; %994-00377900 PREC~NEXT~FNEXT~REAL(SCANENTER~FALSE) ; 00378000 CASESTMT: 00378100 CASE SCN OF 00378200 BEGIN 00378300 CASE0: %994-00378400 GO TO IF LABELR THEN CASE5 ELSE CASE1; 00378500 CASE1: 00378600 BEGIN 00378700 LOOP0: 00378800 ACR ~ ACR0; 00378900 ACCUM[1] ~ BLANKS; 00379000 LOOP: 00379100 IF ADVANCE(NCR, ACR, CHR0, NCR, ACR) THEN 00379200 IF CONTINUE THEN 00379300 IF READACARD THEN 00379400 BEGIN 00379500 IF LISTOG THEN PRINTCARD ; 00379600 IF ACR.[33:15]}ACCUMSTOP THEN 00379700 BEGIN XTA~BLANKS; FLOG(175); GO LOOP0 END ; 00379800 GO LOOP ; 00379900 END 00380000 ELSE IF T ~ ACCUM[1] = " " THEN GO TO CASE5 ELSE SCN ~ 4 00380100 ELSE IF T ~ ACCUM[1] = " " THEN 00380200 GO TO CASE3 ELSE SCN ~ 3 00380300 ELSE IF T ~ ACCUM[1] = " " THEN GO TO CASE2 ELSE SCN ~ 2; 00380400 END; 00380500 CASE2: 00380600 BEGIN T ~ CHAR; SCN ~ 1 END; 00380700 CASE3: 00380800 BEGIN T ~ "; "; NEXT ~ SEMI; SCN ~ 0; 00380900 IF EOSTOG THEN IF LOGIFTOG THEN BEGIN LOGIFTOG ~ FALSE; XTA ~ T; 00381000 FLAG(101); END; 00381100 GO TO XIT; 00381200 END; 00381300 CASE4: %994-00381400 BEGIN T ~ "; "; NEXT ~ SEMI; SCN ~ 5; GO TO XIT END; 00381500 CASE5: 00381600 BEGIN T ~ " "; NEXT ~ EOF; EOSTOG ~ FALSE; GO TO XIT END; 00381700 CASE6: %994-00381800 BEGIN T ~ ACCUM[1] ~ NEXTACC; SCN ~ NEXTSCN; 00381900 IF T = " " THEN GO TO CASESTMT; 00382000 END; 00382100 CASE7: %994-00382200 BEGIN EOSTOG ~ TRUE; 00382300 IF LABELR THEN GO TO CASE5 ELSE GO TO CASE1; 00382400 END; 00382500 CASE8: %994-00382600 BEGIN T ~ EXACCUM[1]; SCN ~ 3 END; 00382700 CASE9: %994-00382800 BEGIN T ~ EXACCUM[1]; SCN ~ 4 END; 00382900 CASE10: %994-00383000 BEGIN T ~ CHAR ~ EXACCUM[0]; SCN ~ 1 END; 00383100 CASE11: %994-00383200 BEGIN T ~ EXACCUM[1]; SCN ~ 10 END; 00383300 CASE12: %994-00383400 BEGIN T ~ EXACCUM[1]; SCN ~ 1; 00383500 IF N ~ EXACCUM[2] { 1 THEN 00383600 BEGIN NEXT ~ NUM; FNEXT ~ N; GO TO XIT END; 00383700 NEXT ~ 0; 00383800 OP ~ N-1; 00383900 PREC ~ IF N { 4 THEN N-1 ELSE 4; 00384000 GO TO XIT; 00384100 END; 00384200 CASE13: %994-00384300 BEGIN T ~ "FUNCTI"; NEXT ~ 16; SCN ~ 6; GO TO XIT END; 00384400 CASE14: %994-00384500 BEGIN T ~ ACCUM[1] ~ NEXTACC; 00384600 NEXTACC ~ NEXTACC2; SCN ~ 6; 00384700 END; 00384800 END OF CASE STATEMENT; 00384900 IF NOT FILETOG THEN 00385000 IF EOSTOG THEN 00385100 BEGIN 00385200 NEXT ~ 0; 00385300 IF T = "; " THEN GO TO CASESTMT; 00385400 CHECKRESERVED; 00385500 IF NEXT > 0 THEN GO TO XIT; 00385600 END; 00385700 IF (IDINFO~TIPE[T.[12:6]])>0 THEN 00385800 BEGIN 00385900 BK: NEXT~ID ; 00386000 IF NOT FILETOG THEN 00386100 IF SCANENTER~((FNEXT~SEARCH(T))=0) THEN FNEXT~ENTER(IDINFO,T) 00386200 ELSE IF GET(FNEXT).CLASS=DUMMY THEN FNEXT~GET(FNEXT+2).BASE ; 00386300 GO XIT ; 00386400 END ; 00386500 GO CASEL[-IDINFO]; % SEE INITIALIZATION OF "TIP". LINE 03433100%993- 00386600 L1: %DIGITS %993- 00386700 BEGIN NUMTYPE ~ INTYPE; NEXT ~ NUM; XTA ~ ACR0; 00386800 FNEXT ~ DBLOW ~ C1 ~ 0; 00386900 XTA ~ CONVERT(FNEXT,C1,XTA ,TS); 00387000 WHILE TS { 9 DO 00387100 BEGIN 00387200 XTA ~ CONVERT(F1,C1,XTA ,TS); 00387300 IF (F2 ~ FNEXT|TEN[C1]+F1) { MAX 00387400 THEN FNEXT ~ F2 00387500 ELSE BEGIN 00387600 NUMTYPE ~ DOUBTYPE; 00387700 DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|, 00387800 F1,0,+,~,FNEXT,DBLOW); 00387900 END; 00388000 END; 00388100 IF CHAR = ". " OR CHAR = "E " OR CHAR = "D " THEN 00388200 CHECKPERIOD 00388300 ELSE IF CHAR = "H " THEN HOLLERITH; 00388400 GO TO XIT; 00388500 END; 00388600 L2: % > %993- 00388700 BEGIN PREC ~ 4; OP ~ 7; GO TO XIT END; 00388800 L3: % } %993- 00388900 BEGIN PREC ~ 4; OP ~ 8; GO TO XIT END; 00389000 L4: % & OR + %993- 00389100 BEGIN PREC ~ 5; OP ~ 10; NEXT ~ PLUS; GO TO XIT END; 00389200 L5: % . %993- 00389300 BEGIN 00389400 FNEXT ~ DBLOW ~ C1 ~ 0; NUMTYPE ~ REALTYPE; 00389500 CHECKPERIOD; 00389600 T ~ EXACCUM[1]; 00389700 IF SCN = 12 THEN 00389800 BEGIN SCN ~ 1; 00389900 IF N ~ EXACCUM[2] { 1 THEN 00390000 BEGIN 00390100 NEXT ~ NUM; FNEXT ~ N; 00390200 NUMTYPE ~ LOGTYPE; GO TO XIT; 00390300 END; 00390400 NEXT ~ 0; 00390500 OP ~ N-1; 00390600 PREC ~ IF N { 4 THEN N-1 ELSE 4; 00390700 GO TO XIT; 00390800 END; 00390900 IF NEXT ! NUM THEN BEGIN NEXT ~ NUM; XTA ~ T; FLOG(141) END; 00391000 GO TO XIT; 00391100 END; 00391200 L6: % % OR ( %993-00391300 BEGIN NEXT ~ LPAREN; GO TO XIT END; 00391400 L7: % < %993-00391500 BEGIN PREC ~ OP ~ 4; GO TO XIT END; 00391600 L8: % LETTER 0 %993-00391700 BEGIN IF DATATOG THEN IF CHECKOCTAL THEN GO TO XIT; 00391800 IDINFO~TIPE[12]; GO BK ; 00391900 END; 00392000 L9: % $ %993-00392100 BEGIN NEXT ~ DOLLAR; GO TO XIT END; 00392200 L10: % * %993-00392300 IF CHECKEXP(NCR, NCR, T) THEN 00392400 BEGIN PREC ~ 9; OP ~ 15; NEXT ~ UPARROW; GO TO XIT END ELSE 00392500 L11: 00392600 BEGIN PREC ~ 7; OP ~ 13; NEXT ~ STAR; GO TO XIT END; 00392700 L12: % - %993-00392800 BEGIN PREC ~ 5; OP ~ 11; NEXT ~ MINUS; GO TO XIT END; 00392900 L13: % ) OR [ %993-00393000 BEGIN NEXT ~ RPAREN; GO TO XIT END; 00393100 L14: % ; %993-00393200 BEGIN NEXT ~ SEMI; GO TO XIT END; 00393300 L15: % { %993-00393400 BEGIN PREC ~ 4; OP ~ 5; GO TO XIT END; 00393500 L16: % / %993-00393600 BEGIN PREC ~ 7; OP ~ 14; NEXT ~ SLASH; GO TO XIT END; 00393700 L17: % , %993-00393800 BEGIN NEXT ~ COMMA; GO TO XIT END; 00393900 L18: % ! %993-00394000 BEGIN PREC ~ 4; OP ~ 9; GO TO XIT END; 00394100 L19: % = OR ~ OR # %993- 00394200 BEGIN NEXT ~ EQUAL; GO TO XIT END; 00394300 L20: % ] %993-00394400 BEGIN XTA ~ T; FLAG(0); GO TO CASESTMT END; 00394500 L21: % " OR : OR @ %993-00394600 BEGIN QUOTESTRING; GO TO XIT END; 00394700 XIT: 00394800 IF DEBUGTOG THEN WRITALIST(FD,3,NEXT,T," ",0,0,0,0,0) ; 00394900 XTA ~ NAME ~ T; 00395000 END SCAN; 00395100 00395200 PROCEDURE WRAPUP; 00395300 COMMENT WRAPUP OF COMPILIATION; 00395400 BEGIN 00395500 ARRAY PRT[0:7,0:127], 00395600 SEGDICT[0:7,0:127], 00395700 SEG0[0:29]; 00395800 ARRAY FILES[0:BIGGESTFILENB]; 00395900 INTEGER THEBIGGEST; 00396000 SAVE ARRAY FPB[0:1022]; % FILE PARAMETER BLOCK 00396100 REAL FPS,FPE; % START AND END OF FPB 00396200 REAL GSEG,PRI,FID,MFID,IDNM,FILTYP,FPBI; 00396300 BOOLEAN ALF; 00396400 REAL PRTADR, SEGMNT, LNK, TSEGSZ, T1, I, FPBSZ; 00396500 DEFINE 00396600 SPDEUN= FPBSZ#, 00396700 ENDDEF=#; 00396800 ARRAY INTLOC[0:150]; 00396900 REAL J; 00397000 FORMAT SEGUS(A6, " IS SEGMENT ", I4, 00397100 ", PRT IS ", A4, "."); 00397200 LIST SEGLS(IDNM,NXAVIL,T1); 00397300 LABEL LA, ENDWRAPUP; 00397400 LABEL QQQDISKDEFAULT; %503-00397500 COMMENT FORMAT OF SEGMENT DICTIONARY -RUN TIME ; 00397600 DEFINE SGTYPF= [1:2]#, %0 = PROGRAM SEGMENTS 00397700 SGTYPC= 1:46:2#,%1 = MCP INTRINSIC 00397800 %2 = DATA SEGMENT 00397900 PRTLINKF= [8:10]#, % LINK TO FIRT PRT ENTRY 00398000 PRTLINKC= 8:38:10#, 00398100 SGLCF = [18:15]#, % SEGMENT SIZE 00398200 SGLCC = 23:38:10#, 00398300 DKADRF = [33:15]#, % RELATIVE DISK ADDRESS OF SEGMENT 00398400 % OR MCP INTRINSIC NUMBER 00398500 DKADRC = 33:13:15#; 00398600 COMMENT FORMAT OF FIRST SEGMENT OF CODE FILE- RUN TIME; 00398700 COMMENT SEGO[0:29] 00398800 WORD CONTENTS 00398900 0 LOCATION OF SEGMENT DICTIONARY 00399000 1 SIZE OF SEGMENT DICTIONARY 00399100 2 LOCATION OF PRT 00399200 3 SIZE OF PRT 00399300 4 LOCATION OF FILE PARAMETER BLOCK 00399400 5 SIZE OF FILE PARAMETER BLOCK 00399500 6 STARTING SEGMENT NUMBER 00399600 7-[2:1] IND FORTRAN FAULT DEC 00399700 7-[18:15] NUMBER OF FILES 00399800 7-[33:15] CORE REQUIRED/64 00399900 ; 00400000 COMMENT FORMAT OF PRT; 00400100 % FLGF = [0:4] = 1101 = SET BY STREAM 00400200 DEFINE MODEF =[4:2]#, % 0 = THUNK 00400300 MODEC=4:46:2#, % 1 = WORD MODE PROGRAM DESCRIPTOR 00400400 % 2 = LABEL DESCRIPTOR 00400500 % 3 = CHARACTER MODE PROGRAM DESCRIPTOR 00400600 STOPF =[6:1]#, % STOPPER = 1 FOR LAST DESCRIPTOR IN 00400700 STOPC=6:47:1#, % CHAIN OF SAME SEGMENT DESCRIPTORS 00400800 LINKF =[7:11]#, % IF STOP = 0 THEN PRTLINK 00400900 LINKC=7:37:11#, % ELSE LINK TO SEGDICT 00401000 FFF =[18:15]#,% INDEX INTO SEGMENT DICTIONARY 00401100 FFC =18:33:15#, 01401200 SINX = [33:15]#;% RELATIVE ADDRESS INTO SEGMENT 00401300 DEFINE PDR = [37:5]#, 00401400 PDC = [42:6]#; 00401500 REAL STREAM PROCEDURE MKABS(F); 00401600 BEGIN 00401700 SI ~ F; MKABS ~ SI; 00401800 END MKABS; 00401900 REAL STREAM PROCEDURE BUILDFPB(DEST,FILNUM,FILTYP,MFID,FID,IDSZ, 00402000 IDNM,SPDEUN); 00402100 VALUE DEST,IDSZ,SPDEUN; 00402200 BEGIN 00402300 DI ~ DEST; 00402400 SI ~ FILNUM; SI ~ SI + 6; DS ~ 2 CHR; 00402500 SI ~ FILTYP; SI ~ SI + 7; DS ~ CHR; 00402600 SI ~ MFID; SI ~ SI + 1; DS ~ 7 CHR; 00402700 SI ~ FID; SI ~ SI + 1; DS ~ 7 CHR; 00402800 SI ~ LOC IDSZ; SI ~ SI + 1; DS ~ IDSZ CHR; 00402900 SI~LOC SPDEUN;SI~SI+6;DS~2 CHR;% DISK SPEED & EU NUMBER+1 00403000 BUILDFPB ~ DI; 00403100 DS ~ 2 LIT "0"; 00403200 END BUILDFPB; 00403300 REAL STREAM PROCEDURE GITSZ(F); 00403400 BEGIN 00403500 SI ~ F; SI ~SI + 7; TALLY ~ 7; 00403600 3(IF SC ! " " THEN JUMP OUT; 00403700 SI ~SI - 1; TALLY ~ TALLY + 63;); 00403800 GITSZ ~ TALLY; 00403900 END GITSZ; 00404000 STREAM PROCEDURE MOVE(F,T,SZ); VALUE SZ; 00404100 BEGIN 00404200 SI ~ F; DI ~T; DS ~ SZ WDS; 00404300 END MOVE; 00404400 INTEGER PROCEDURE MOVEANDBLOCK(FROM,SIZE); VALUE SIZE; 00404500 ARRAY FROM[0,0]; INTEGER SIZE; 00404600 BEGIN 00404700 REAL T,NSEGS,J,I; 00404800 STREAM PROCEDURE M2(F,T); BEGIN SI~F; DI~T; DS ~ 2 WDS; END M2; 00404900 NSEGS ~ (SIZE+29) DIV 30; 00405000 IF DALOC DIV CHUNK < T ~ (DALOC + NSEGS) DIV CHUNK 00405100 THEN DALOC ~ CHUNK | T; 00405200 MOVEANDBLOCK ~ DALOC; 00405300 DO BEGIN FOR J ~ 0 STEP 2 WHILE J < 30 AND I 0 THEN 00408700 BEGIN T1 ~ GET(T ~ GLOBALSEARCH(".SUBAR")+2); 00408800 PUT(T,T1~T1&SAVESUBS[TOSIZE]); 00408900 END; 00409000 T1~PRGDESCBLDR(1,23,0,NSEG~NXAVIL~NXAVIL+1) ; % BUILD TPAR 00409100 FILL LSTT[*] WITH 21(0),8(" ") ; % R+23 00409200 WRITEDATA(29,NXAVIL,LSTT) ; 00409300 PDPRT[(PDINX-1).[37:5],(PDINX-1).[42:6]].[6:1]~1 ; % SAVE BIT 00409400 T1 ~ PRGDESCBLDR(1,22,0,NSEG ~ NXAVIL ~ NXAVIL + 1); 00409500 WRITEDATA (138,NXAVIL,TEN); % POWERS OF TEN TABLE 00409600 IF LSTI > 0 THEN 00409700 BEGIN 00409800 WRITEDATA(LSTI, NXAVIL ~ NXAVIL+1, LSTP); 00409900 LSTA ~ PRGDESCBLDR(1, LSTA, 0, NXAVIL); 00410000 END; 00410100 IF TWODPRTX ! 0 THEN 00410200 BEGIN 00410300 FILL LSTT[*] WITH 00410400 OCT0000000421410010, 00410500 OCT0301001301412025, 00410600 OCT2021010442215055, 00410700 OCT2245400320211025, 00410800 OCT0106177404310415, 00410900 OCT1025042112350000; 00411000 T ~ PRGDESCBLDR(0, TWODPRTX, 0, NXAVIL ~ NXAVIL+1); 00411100 WRITEDATA(-6, NXAVIL, LSTT); 00411200 END; 00411300 COMMENT DECLARE GLOBAL FILES AND ARRAYS; 00411400 FPS ~ FPE ~ MKABS(FPB); 00411500 SEGMENTSTART; 00411600 F2TOG ~ TRUE; 00411700 GSEG ~ NSEG; 00411800 FPBI ~ 0; 00411900 EMITL(0); EMITL(2); EMITO(SSF); 00412000 EMITL(1); % SET BLOCK COUNTER TO 1 00412100 EMITL(16); EMITO(STD); 00412200 EMITL(0); EMITOPDCLIT(23); EMITO(DEL); 00412300 EMITL(REAL(HOLTOG)); EMITPAIR(21,STD); 00412400 I ~ GLOBALNEXTINFO; WHILE I < 4093 DO 00412500 BEGIN 00412600 I ~ I+3; 00412700 GETALL(I,INFA,INFB,INFC); 00412800 IF INFA.CLASS = FILEID THEN %SEE COMMENTS ON LINE 02118000 %992-00412900 BEGIN 00413000 FPBI ~ FPBI + 1; 00413100 PRI ~ INFA .ADDR; 00413200 IF (XTA ~ INFB ).[18:6] < 10 THEN 00413300 BEGIN 00413400 IF XTA ~ MAKEINT(XTA) > BIGGESTFILENB THEN FLAG(77) ELSE 00413500 FILES[XTA] ~ PRI; 00413600 IF XTA > THEBIGGEST THEN THEBIGGEST ~ XTA; 00413700 END; 00413800 EMITO(MKS); 00413900 IF J ~ INFC .ADINFO ! 0 THEN % OPTION FILE 00414000 BEGIN FILTYP ~ INFC .LINK; 00414100 IDNM ~ " "&"FILE"[6:24:24]&INFB[30:18:18]; 00414200 T1 ~ GITSZ(IDNM); 00414300 FID ~ FILEINFO[2,J]; 00414400 MFID ~ FILEINFO[1,J]; 00414500 IF FILTYP}10 AND (T~FILEINFO[3,J].DKAREASZ)!0 THEN 00414600 BEGIN %%% SET UP ; 00414700 SPDEUN~FILEINFO[3,J].SENSPDEUNF; 00414800 B~IF (B~((J~FILEINFO[0,J]).[18:12])/(IF A~J.[30:12]{0 THEN00414900 1 ELSE A)){0 THEN 1 ELSE B ; 00415000 %%% B=ORIGINAL "BLOCKING" SIZE = # LOGRECS/PHYSREC. 00415100 A~ENTIER(B|ENTIER(T/(20|B)+.999999999)+.5) ; 00415200 %%% T="AREA" SIZE = # LOGRECS IN TOTAL FILE. 00415300 %%% A=# LOGRECS PER ROW. 00415400 B~ENTIER(T/A+.999999999) ; 00415500 %%% B = # ROWS IN FILE. 00415600 %%% EQUIVALENT ALGOL FILE DESCRIPTION = [B:A]. 00415700 %%% THE ABOVE LOGIC YIELDS: SHORTEST ROW CONTAINING 00415800 %%% AN INTEGER NUMBER OF PHYSICAL RECORDS AND WHICH 00415900 %%% REQUIRES 20 OR FEWER ROWS FOR THE TOTAL AREA, T.00416000 EMITNUM(B); EMITNUM(A) ; 00416100 END ELSE 00416200 BEGIN EMITL(0); EMITL(0); 00416300 J ~ FILEINFO[0,J]; % THIS ONE HAS ALL THE GOODIES 00416400 END; 00416500 QQQDISKDEFAULT: %503-00416600 ESTIMATE~ESTIMATE+(J.[42:6])|(IF A~J.[18:12]=0 THEN J.[30:12] 00416700 ELSE A) ; 00416800 EMITL(J.[4:2]); % LOCK 00416900 EMITL(FPBI); % FILE PARAM INDEX 00417000 EMITDESCLIT(PRI); % PRT OF FILE 00417100 EMITL(J.[42:6]); % # BUFFERS 00417200 EMITL(J.[3:1]); % RECORDING MODE 00417300 EMITNUM(J.[30:12]) ; % RECORD SIZE 00417400 EMITNUM(J.[18:12]) ; % BLOCK SIZE 00417500 EMITNUM(J.[ 6:12]) ; % SAVE FACTOR 00417600 END ELSE 00417700 BEGIN 00417800 ALF ~TRUE; 00417900 IF(FILTYP~INFC.LINK=2 OR FILTYP=12) AND INFB.[18:6]{9 THEN 00418000 IDNM ~ 0&"FILE"[6:24:24]&INFB[30:18:18] 00418100 ELSE 00418200 BEGIN 00418300 ALF ~ FALSE; 00418400 IF (IDNM ~ " "&INFB[6:18:30]) = "READR " THEN 00418500 IDNM ~ "READER "; 00418600 END; 00418700 IF IDNM="READER " OR IDNM="FILE5 " THEN IDNM~"CARD " ELSE %503-00418800 IF IDNM="FILE6 " THEN BEGIN IDNM~"PRINTER";FILTYP~18;END ELSE %503-00418900 BEGIN %503-00419000 EMITL(20); EMITL(600); FILTYP~12; %20 | 600 REC DISK %503-00419100 J~0&2[42:42:6]&10[30:36:12]&300[18:36:12]; %503-00419200 FID~IDNM; MFID~"FORTEMP"; T1~GITSZ(IDNM); %503-00419300 GO TO QQQDISKDEFAULT; %503-00419400 END; %503-00419500 T1 ~ GITSZ(IDNM); 00419600 FID ~ IDNM; 00419700 MFID ~ 0; 00419800 IF DCINPUT AND ALF THEN BEGIN 00419900 EMITL(20); % DISK ROWS 00420000 EMITL(100); % DISK RECORD PER ROW 00420100 EMITL(2); % REWIND AND LOCK 00420200 EMITL(FPBI); % FILE NUMBER 00420300 EMITDESCLIT(PRI); % PRT OF FILE 00420400 EMITL(2); % NUMBER OF BUFFERS 00420500 EMITL(1); % RECORDING MODE 00420600 EMITL(10); % RECORD SIZE 00420700 EMITL(30); % BLOCK SIZE 00420800 EMITL(1); % SAVE FACTOR 00420900 END ELSE 00421000 BEGIN 00421100 EMITL(0); % DISK ROWS 00421200 EMITL(0); % DISK RECORDS PER ROW 00421300 EMITL(0); % REWIND & RELEASE 00421400 EMITL(FPBI); % FILE NUMBER 00421500 EMITDESCLIT(PRI); % PRT OF FILE 00421600 EMITL(2); % 2 BUFFERS 00421700 EMITL(REAL(ALF)); 00421800 EMITL(IF FILTYP = 0 THEN 10 ELSE 17); 00421900 EMITL(0); % 15 WORD BUFFERS 00422000 EMITL(0); % SAVE FACTOR (SCRATCH BY DEFAULT) 00422100 END; 00422200 END; 00422300 EMITL(11); % INPUT OR OUTPUT 00422400 EMITL(8); % SWITCH CODE FOR BLOCK 00422500 EMITOPDCLIT(5); % CALL BLOCK 00422600 FPE~BUILDFPB(FPE,FPBI,FILTYP,MFID,FID,T1,IDNM,SPDEUN); 00422700 IF PRTOG THEN WRITALIST(FILEF,3,IDNM.[6:6],IDNM,B2D(PRI), 00422800 0,0,0,0,0) ; 00422900 END 00423000 ELSE 00423100 IF INFA.CLASS = BLOCKID THEN 00423200 BEGIN 00423300 IF PRTOG THEN WRITALIST(BLOKF,3,INFB,B2D(INFA.ADDR), 00423400 INFC.SIZE,0,0,0,0,0) ; 00423500 IF INFA < 0 THEN ARRAYDEC(I); 00423600 END; 00423700 IF (T1 ~ INFA .CLASS) } FUNID 00423800 AND T1 { SUBRID THEN 00423900 BEGIN 00424000 PRI ~ 0; 00424100 IF INFA .SEGNO = 0 THEN 00424200 BEGIN 00424300 A~0; B~NUMINTM1 ; 00424400 WHILE A+1 < B DO 00424500 BEGIN 00424600 PRI ~ REAL(BOOLEAN(A+B) AND BOOLEAN(1022)); 00424700 IF IDNM ~ INT[PRI] = INFB THEN GO TO FOUND; 00424800 IF INFB < IDNM THEN B ~ PRI.[36:11] ELSE A ~ PRI.[36:11]; 00424900 END; 00425000 IF IDNM ~ INT[PRI~(A+B)|2-PRI] = INFB THEN GO TO FOUND; 00425100 XTA ~ INFB; FLAG(30); 00425200 GO TO LA; 00425300 FOUND: 00425400 IF (T1~INT[PRI+1].INTPARMS)!0 00425500 AND INFC < 0 00425600 THEN IF T1 ! INFC.NEXTRA THEN 00425700 BEGIN XTA ~ INFB ; FLAG(28); END; 00425800 IF (FID~INTLOC[MFID~INT[PRI+1].INTNUM])=0 THEN 00425900 BEGIN 00426000 PDPRT[PDIR,PDIC] ~ 00426100 0&1[STYPC] 00426200 &(FID ~ INTLOC[MFID] ~ NXAVIL ~ NXAVIL + 1)[SGNOC] 00426300 &1[SEGSZC]; 00426400 PDINX ~ PDINX + 1; 00426500 END; 00426600 T1 ~ PRGDESCBLDR(1,INFA .ADDR,0,FID); 00426700 IF PRTOG THEN WRITALIST(SEGUS,3,IDNM,FID,B2D(T1),0,0,0,0,0) ; 00426800 IF INT[PRI+1] < 0 THEN 00426900 BEGIN 00427000 T1 ~ PRGDESCBLDR(1,INT[PRI+1].INTPRT,0,FID); 00427100 INT[PRI+1] ~ ABS(INT[PRI + 1]); 00427200 END; 00427300 END 00427400 ELSE IF PRTOG THEN WRITALIST(SEGUS,3,INFB, 00427500 INFA.SEGNO,B2D(INFA.ADDR),0,0,0,0,0) ; 00427600 END; 00427700 LA: 00427800 END; 00427900 COMMENT MUST FOLLOW THE FOR STATEMENT; 00428000 IF FILEARRAYPRT ! 0 THEN 00428100 BEGIN % BUILDING OBJECT TIME FILE SEARCH ARRAY 00428200 J ~ PRGDESCBLDR(1,FILEARRAYPRT,0,NXAVIL ~ NXAVIL + 1); 00428300 WRITEDATA(THEBIGGEST + 1,NXAVIL,FILES); 00428400 END; 00428500 XTA ~ BLANKS; 00428600 IF NXAVIL > 1023 THEN FLAG(45); 00428700 IF PRTS > 1023 THEN FLAG(46); 00428800 IF STRTSEG = 0 THEN FLAG(65); 00428900 PRI ~ 0; 00429000 WHILE (IDNM ~ INT[PRI]) ! 0 DO 00429100 IF INT[PRI+1] } 0 THEN PRI ~ PRI + 2 ELSE 00429200 BEGIN 00429300 IF (FID~INTLOC[MFID~INT[PRI+1].INTNUM])=0 THEN 00429400 BEGIN 00429500 PDPRT[PDIR,PDIC] ~ 00429600 0&1[STYPC] 00429700 &MFID[DKAC] 00429800 &(FID ~ INTLOC[MFID] ~ NXAVIL ~ NXAVIL + 1)[SGNOC] 00429900 &1[SEGSZC]; 00430000 PDINX ~ PDINX + 1; 00430100 END; 00430200 T1 ~ PRGDESCBLDR(1,INT[PRI + 1].INTPRT,0,FID); 00430300 PRI ~ PRI+2; 00430400 END; 00430500 FOR I ~ 1 STEP 1 UNTIL BDX DO 00430600 BEGIN EMITO(MKS); EMITOPDCLIT(BDPRT[I]) END; 00430700 EMITO(MKS); 00430800 EMITOPDCLIT(STRTSEG.[18:15]); 00430900 T ~ PRGDESCBLDR(1,0,0,NSEG); 00431000 SEGMENT((ADR+4) DIV 4,NSEG,FALSE,EDOC); 00431100 IF ERRORCT ! 0 THEN GO TO ENDWRAPUP; 00431200 FILL SEG0[*] WITH 00431300 OCT020005, % BLOCK 00431400 OCT220014, % WRITE 00431500 OCT230015, % READ 00431600 OCT240016; % FILE CONTROL 00431700 COMMENT INTRINSIC FUNCTIONS; 00431800 FOR I ~ 0 STEP 1 UNTIL 3 DO 00431900 BEGIN 00432000 T1 ~ PRGDESCBLDR(1,SEG0[I].[36:12],0, 00432100 NSEG ~ NXAVIL ~ NXAVIL + 1); 00432200 PDPRT[PDIR,PDIC] ~ 00432300 0&1[STYPC] 00432400 &(SEG0[I].[30:6])[DKAC] 00432500 &NXAVIL[SGNOC] 00432600 &1[SEGSZC]; 00432700 PDINX ~ PDINX + 1; 00432800 END; 00432900 COMMENT GENERATE PRT AND SEGMENT DICTIONARY; 00433000 PRT[0,41] ~ PDPRT[0,0] & 63[10:42:6]; % USED FOR FAULT OPTN 00433100 FOR I ~ 1 STEP 1 UNTIL PDINX-1 DO 00433200 IF (T1~PDPRT[I.PDR,I.PDC]).SEGSZF = 0 THEN 00433300 BEGIN % PRT ENTRY 00433400 PRTADR ~T1.PRTAF; 00433500 SEGMNT ~T1.SGNOF; 00433600 LNK ~ SEGDICT[SEGMNT.[36:5], SEGMNT.[41:7]].PRTAF; 00433700 MDESC(T1.RELADF&SEGMNT[FFC] 00433800 &(REAL(LNK=0))[STOPC] 00433900 &(IF LNK=0 THEN SEGMNT ELSE LNK)[LINKC] 00434000 &(T1.DTYPF)[MODEC] 00434100 &5[1:45:3], 00434200 PRT[PRTADR.[36:5],PRTADR.[41:7]]); 00434300 SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]].PRTLINKF ~ PRTADR; 00434400 END 00434500 ELSE 00434600 BEGIN % SEGMENT DICTIONARY ENTRY 00434700 SEGMNT ~ T1.SGNOF; 00434800 SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]]~ 00434900 SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]] 00435000 &T1[SGLCC] 00435100 &T1[DKADRC] 00435200 & T1[4:12:1] 00435300 &T1[6:6:1] 00435400 &T1[1:1:2]; 00435500 TSEGSZ ~ TSEGSZ + T1.SEGSZF; 00435600 END; 00435700 COMMENT WRITE OUT FILE PARAMETER BLOCK; 00435800 FPBSZ ~ ((FPE.[33:15] - FPS) | 8 + FPE.[30:3] + 9) DIV 8; 00435900 I ~ (FPBSZ + 29) DIV 30; 00436000 IF DALOC DIV CHUNK < T1 ~ (DALOC +I) DIV CHUNK 00436100 THEN DALOC ~ CHUNK | T1; 00436200 SEG0[4] ~ DALOC; 00436300 SEG0[5] ~ FPBSZ; 00436400 SEG0[5].FPBVERSF~FPBVERSION; 00436500 FOR I ~ 0 STEP 30 WHILE I < FPBSZ DO 00436600 BEGIN 00436700 MOVE(FPB[I],CODE(0),IF (FPBSZ-I) } 30 00436800 THEN 30 ELSE (FPBSZ-I)); 00436900 WRITE(CODE[DALOC]); 00437000 DALOC ~ DALOC + 1; 00437100 END; 00437200 SEG0[2] ~ MOVEANDBLOCK(PRT,PRTS+1); % WRITES OUT PRT 00437300 % SAVES ADDRESS OF PRT 00437400 SEG0[3] ~ PRTS + 1; % SIZE OF PRT 00437500 SEG0[0] ~ MOVEANDBLOCK(SEGDICT,NXAVIL + 1); % WRITE SEG DICT 00437600 SEG0[1] ~ NXAVIL + 1; % SIZE OF SEGMENT DICTIONARY 00437700 SEG0[6] ~ -GSEG; % FIRST SEGMENT TO EXECUTE 00437800 SEG0[7].[33:15] ~ FPBI; % NUMBER OF FILES 00437900 SEG0[7].[18:15] ~ ESTIMATE ~ IF % CORE ESTIMATE 00438000 ( I ~ 00438100 ESTIMATE+60+ %%% OPTION FILE BUFF SIZES + DEFAULT BUFF SIZES.00438200 PRTS + 512 % PRT AND STACK SIZE 00438300 +TSEGSZ % TOTAL SIZE OF CODE 00438400 + 1022 % FOR INTRINSICS 00438500 +ARYSZ % TOTAL ARRAY SIZE 00438600 + (MAXFILES | 28) % SIZE OF ALL FIBS 00438700 +FPBSZ % SIZE OF FILE PARAMETER BLOCK 00438800 + (IF ESTIMATE = 0 THEN 0 ELSE (ESTIMATE + 1000)) 00438900 + (NXAVIL + 1) % SIZE OF SEGMENT DICTIONARY 00439000 ) > 32768 THEN 510 ELSE (I DIV 64); 00439100 COMMENT IF SEGSW THEN UPDATE LINDICT, SEG0[0] & WRITE IT ; 00439200 SEG0[7].[2:1] ~ 1; % USED FOR FORTRAN FAULT DEC; 00439300 IF SEGSW THEN 00439400 BEGIN 00439500 FOR I ~ NXAVIL + 1 STEP -1 UNTIL 1 DO 00439600 IF LINEDICT[I.IR,I.IC] = 0 THEN % INDICATE NO LINE SEGMENT 00439700 LINEDICT[I.IR,I.IC] ~ -1; % FOR THIS SEGMENT 00439800 SEG0[0] ~ SEG0[0] & (MOVEANDBLOCK(LINEDICT,NXAVIL+1))[TOBASE]; 00439900 END; 00440000 WRITE(CODE[0],30,SEG0[*]); 00440100 IF ERRORCT = 0 AND SAVETIME } 0 THEN LOCK(CODE); 00440200 ENDWRAPUP: 00440300 LOCK(TAPE); %RW/L TAPE FILE OR LOCK DISK %502-00440400 IF NTAPTOG THEN LOCK(NEWTAPE,*); %RW/L TAPE OR CRUNCH DISK%502-00440500 END WRAPUP; 00440600 PROCEDURE INITIALIZATION; 00440700 BEGIN COMMENT INITIALIZATION; 00440800 ALPHA STREAM PROCEDURE MKABS(P); 00440900 BEGIN SI ~ P; MKABS ~ SI END; 00441000 STREAM PROCEDURE BLANKOUT(CRD, N); VALUE N; 00441100 BEGIN DI ~ CRD; N(DS ~ LIT " ") END; 00441200 BLANKOUT(CRD[10], 40); 00441300 BLANKOUT(LASTSEQ, 8); 00441400 BLANKOUT(LASTERR, 8); 00441500 INITIALNCR ~ MKABS(CRD[0])&6[30:45:3]; 00441600 CHR0 ~ MKABS(ACCUM[0])& 2[30:45:3]; 00441700 ACR0 ~ CHR0+1; 00441800 ACR1 ~ (CHR1~MKABS(EXACCUM[0]) & 2[30:45:3]) +1; 00441900 ACCUMSTOP~MKABS(ACCUM[11]); EXACCUMSTOP~MKABS(EXACCUM[11]) ; 00442000 BUFL ~ MKABS(BUFF) & 2[30:45:3]; 00442100 NEXTCARD ~ 1; 00442200 GLOBALNEXTINFO ~ 4093; 00442300 PDINX ~ 1; 00442400 LASTNEXT~1000 ; 00442500 PRTS ~ 41; % CURRENTLY . . . . . LAST USED PRT 00442600 READ(CR, 10, CB[*]); 00442700 LISTOG~TRUE; SINGLETOG~TRUE; CHECKTOG ~ FALSE; %DEFAULT %501- 00442800 FIRSTCALL ~ TRUE; 00442900 IF BOOLEAN(ERRORCT.[46:1]) THEN LISTOG ~ FALSE; 00443000 IF BOOLEAN(ERRORCT.[47:1]) THEN DCINPUT ~ TRUE; 00443100 ERRORCT ~ 0; 00443200 IF DCINPUT THEN SEGSW ~ TRUE; 00443300 IF DCINPUT THEN REMOTETOG ~ TRUE; 00443400 LIMIT~IF DCINPUT THEN 20 ELSE 100 ; 00443500 IF SEGSW THEN SEGSWFIXED ~ TRUE; 00443600 EXTRAINFO[0,0] ~ 0 & EXPCLASS[TOCLASS]; 00443700 NEXTEXTRA ~ 1; 00443800 LASTMODE ~ 1; 00443900 DALOC ~ 1; 00444000 TYPE ~ -1; 00444100 MAP[0] ~ MAP[2] ~ MAP[4] ~ MAP[7] ~ -10; 00444200 MAP[5] ~ 1; MAP[6] ~ 2; 00444300 FILL XR[*] WITH 0,0,0,0,0,0,0, 00444400 "INTEGE","R R"," "," "," REAL "," ", 00444500 "LOGICA","L L","DOUBLE"," ","COMPLE","X X", 00444600 "------","- -"," "," "," ---- "," ", 00444700 "------","- -","------"," ","------","- -"; 00444800 FILL TYPES[*] WITH " ","INTGER"," ","REAL ", 00444900 "LOGCAL", "DOUBLE", "COMPLX"; 00445000 FILL KLASS[*] WITH 00445100 "NULL ", "ARRAY ", "VARBLE", "STFUN ", 00445200 "NAMLST", "FORMAT", "ERROR ", "FUNCTN", 00445300 "INTRSC", "EXTRNL", "SUBRTN", "COMBLK", 00445400 "FILE "; 00445500 FILL RESERVEDWORDSLP[*] WITH 00445600 "CALL ","ENTR ","FORM ","GOTO ","IF ","READ ", 00445700 "REAL ","WRIT ","DATA ","CLOS ","LOCK ","PURG ","CHAI ", 00445800 "PRIN ","PUNC ", 00445900 0,"Y ","AT ",0,0,0,0,"E ",0,"E ",0,"E ",00446000 "N ","T ","H "; 00446100 FILL RESERVEDWORDS[*] WITH 00446200 "ASSI ","BACK ","BLOC ","CALL ","COMM ","COMP ","CONT ", 00446300 "DATA ","DIME ","DOUB ","END ","ENDF ","ENTR ","EQUI ", 00446400 "EXTE ","FUNC ","GOTO ","INTE ","LOGI ","NAME ","PAUS ", 00446500 "PRIN ","PROG ","PUNC ","READ ","REAL ","RETU ","REWI ", 00446600 "STOP ","SUBR ","WRIT ", 00446700 "CLOS ","LOCK ","PURG ", 00446800 0,0,0, 00446900 "FIXF ","VARY ","AUXM ","RELE ", 00447000 "IMPL ", 00447100 "GN ","SPACE ","KDATA ",0,"ON ","LEX ","INUE ", 00447200 0,"NSION ","LEPRECIS",0,"ILE ","Y ","VALENCE ","RNAL " 00447300 ,"TION ",0,"GER ","CAL ","LIST ","E ","T ",00447400 "RAM ","H ",0,0,"RN ","ND ",0,"OUTINE ", 00447500 "E ","E ",0,"E ",0,0,0,"D ","ING ", 00447600 "EM ","ASE " 00447700 ,"ICIT " 00447800 ; 00447900 FILL RESLENGTHLP[*] WITH 00448000 4,5,6,4,2,4,4,5,4,5,4,5,5,5,5; 00448100 FILL LPGLOBAL[*] WITH 00448200 4, 13, 36, 17, 35, 25, 00448300 26, 31, 8, 32, 33, 34, 37, 22, 24; 00448400 FILL RESLENGTH[*] WITH 00448500 0, 9, 9, 4, 6, 00448600 7, 8, 4, 9, 15, 00448700 3, 7, 5, 11, 8, 00448800 8, 4, 7, 7, 8, 00448900 5, 5, 7, 5, 4, 00449000 4, 6, 6, 4, 10, 5, 00449100 5, 4, 5, 0, 0, 0, 5, 7, 6, 7 00449200 ,8 00449300 ; 00449400 FILL WOP[*] WITH 00449500 "LITC"," ", 00449600 "OPDC","DESC", 00449700 10,"DEL ", 11,"NOP ", 12,"XRT ", 16,"ADD ", 17,"AD2 ", 18,"PRL ", 00449800 19,"LNG ", 21,"GEQ ", 22,"BBC ", 24,"INX ", 35,"LOR ", 37,"GTR ", 00449900 38,"BFC ", 39,"RTN ", 40,"COC ", 48,"SUB ", 49,"SB2 ", 64,"MUL ", 00450000 65,"ML2 ", 67,"LND ", 68,"STD ", 69,"NEQ ", 70,"SSN ", 71,"XIT ", 00450100 72,"MKS ", 00450200 128,"DIV ",129,"DV2 ",130,"COM ",131,"LQV ",132,"SND ",133,"XCH ", 00450300 134,"CHS ",167,"RTS ",168,"CDC ",197,"FTC ",260,"LOD ",261,"DUP ", 00450400 278,"GBC ",280,"SSF ",294,"GFC ",322,"ZP1 ",384,"IDV ",453,"FTF ", 00450500 515,"MDS ",532,"ISD ",533,"LEQ ",534,"BBW ",548,"ISN ",549,"LSS ", 00450600 550,"BFW ",581,"EQL ",582,"SSP ",584,"ECM ",709,"CTC ",790,"GBW ", 00450700 806,"GFW ",896,"RDV ",965,"CTF ", 00450800 1023,1023,1023,1023,1023,1023,1023,1023,1023,1023,1023, 1023; 00450900 FILL TIPE[*] WITH 10(-1),-19,-21,OCT300000000,-21,-2,-3,-4, 00451000 8(OCT300000000),OCT100000000,-5,-13,-4,-6,-7,-19,-11, 00451100 5(OCT100000000),-8,3(OCT300000000),-9,-10,-12,-13,-14,00451200 -15,-100,-16,8(OCT300000000),-17,-6,-18,-19,-20,-21 ; 00451300 FILL PERIODWORD[*] WITH 00451400 "FALSE ", "TRUE ", "OR ", "AND ", "NOT ", 00451500 "LT ", "LE ", "EQ ", "GT ", "GE ", "NE "; 00451600 ACCUM[0] ~ EXACCUM[0] ~ "; "; 00451700 INCLUDE ~ "NCLUDE" & "I"[6:42:6]; 00451800 INSERTDEPTH ~ -1; 00451900 FILL TEN[*] WITH % POWERS OF TEN TO PRT 22 00452000 OCT1141000000000000, OCT1131200000000000, OCT1121440000000000,00452100 OCT1111750000000000, OCT1102342000000000, OCT1073032400000000,00452200 OCT1063641100000000, OCT1054611320000000, OCT1045753604000000,00452300 OCT1037346545000000, OCT1011124027620000, OCT0001351035564000,00452400 OCT0011643245121000, OCT0022214116345200, OCT0032657142036440,00452500 OCT0043432772446150, OCT0054341571157602, OCT0065432127413542,00452600 OCT0076740555316473, OCT0111053071060221, OCT0121265707274265,00452700 OCT0131543271153342, OCT0142074147406233, OCT0152513201307702,00452800 OCT0163236041571663, OCT0174105452130240, OCT0205126764556310,00452900 OCT0216354561711772, OCT0231004771627437, OCT0241206170175346,00453000 OCT0251447626234640, OCT0261761573704010, OCT0272356132665012,00453100 OCT0303051561442215, OCT0313664115752660, OCT0324641141345435,00453200 OCT0336011371636744, OCT0347413670206535, OCT0361131664625026,00453300 OCT0371360241772234, OCT0401654312370703, OCT0412227375067064,00453400 OCT0422675274304701, OCT0433454553366061, OCT0444367706263475,00453500 OCT0455465667740415, OCT0467003245730520, OCT0501060411731664,00453600 OCT0511274514320241, OCT0521553637404312, OCT0532106607305374,00453700 OCT0542530351166673, OCT0553256443424452, OCT0564132154331565,00453800 OCT0575160607420123, OCT0606414751324147, OCT0621012014361120,00453900 OCT0631214417455344, OCT0641457523370635, OCT0651773450267004,00454000 OCT0662372362344605, OCT0673071057035747, OCT0703707272645341,00454100 OCT0714671151416631, OCT0726047403722377, OCT0737461304707077,00454200 OCT0751137556607071, OCT0761367512350710, OCT0771665435043072,00454300 OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,00454400 OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,00454500 OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,00454600 OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,00454700 OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,00454800 OCT0000000000000000, OCT0000000000000000, OCT0004000000000000,00454900 OCT0001000000000000, OCT0001720000000000, OCT0004304000000000,00455000 OCT0007365000000000, OCT0005262200000000, OCT0004536640000000,00455100 OCT0001666410000000, OCT0000244112000000, OCT0000315134400000,00455200 OCT0000400363500000, OCT0000450046042000, OCT0006562057452400,00455300 OCT0004316473365100, OCT0005402212262320, OCT0006702654737004,00455400 OCT0004463430126605, OCT0007600336154346, OCT0001540425607437,00455500 OCT0004070533151347, OCT0005106662003641, OCT0005033043640461,00455600 OCT0002241654610575, OCT0002712227752734, OCT0001474675745524,00455700 OCT0002014055337051, OCT0004417070626663, OCT0007522706774440,01455800 OCT0003447470573550, OCT0006361406732502, OCT0005005571052122,00455900 OCT0006207127264547, OCT0001650755141700, OCT0006223150372260,00456000 OCT0007670002470733, OCT0007646003207120, OCT0005617404050743,00456100 OCT0001163305063137, OCT0007420166277771, OCT0001732422375777,00456200 OCT0002321127075377, OCT0003005354714677, OCT0005606650100057,00456300 OCT0007150422120072, OCT0003002526544103, OCT0001603254275130,00456400 OCT0004144127354356, OCT0007175155247451, OCT0007034410521363,00456500 OCT0007664351264566, OCT0003641443541723, OCT0004611754472310;00456600 FILL INLINEINT[*] WITH % FILLS MUST BE IN ASCENDING ORDER FOR 00456700 % BINARY SEARCH IN FUNCTION AND DOITINLINE. 00456800 % INLINEINT[I].[1:1] = 1 ONCE CODE FOR INTRINSIC 00456900 % HAS BEEN EMITTED INLINE.00457000 % INLINEINT[I].[2:10]=INDEX INTO 2-ND WORD OF THE00457100 % CORR ENTRY IN INT. 00457200 % INLINEINT[I].[12:36]=NAME OF INTRINSIC. 00457300 %********FIRST FILL MUST BE NUMBER OF INTRINSICS ****************** 00457400 34, 00457500 "00ABS ", 00457600 "00AIMAG ", 00457700 "00AINT ", 00457800 "00AMAX0 ", 00457900 "00AMAX1 ", 00458000 "00AMIN0 ", 00458100 "00AMIN1 ", 00458200 "00AMOD ", 00458300 "00AND ", 00458400 "00CMPLX ", 00458500 "00COMPL ", 00458600 "00CONJG ", 00458700 "00DABS ", 00458800 "00DBLE ", 00458900 "00DIM ", 00459000 "00DSIGN ", 00459100 "00EQUIV ", 00459200 "00FLOAT ", 00459300 "00IABS ", 00459400 "00IDIM ", 00459500 "00IDINT ", 00459600 "00IFIX ", 00459700 "00INT ", 00459800 "00ISIGN ", 00459900 "00MAX0 ", 00460000 "00MAX1 ", 00460100 "00MIN0 ", 00460200 "00MIN1 ", 00460300 "00MOD ", 00460400 "00OR ", 00460500 "00REAL ", 00460600 "00SIGN ", 00460700 "00SNGL ", 00460800 "00TIME ", 00460900 0 ; 00461000 FILL INT [*] WITH 00461100 COMMENT THESE NAMES (1-ST WORD OF EACH TWO-WORD ENTRY) MUST BE IN 00461200 ASCENDING ORDER FOR BINARY LOOKUPS. 00461300 THE SECOND WORD HAS THE FOLLOWING FORMAT: 00461400 .[1:1] = 0 IF THE INTRINSIC DOES NOT HAVE A PERMANENT PRT 00461500 LOCATION, OTHERWISE = 1. MAY BE RESET BY 00461600 WRAPUP. SEE .[18:6] BELOW. 00461700 .[2:1] = .INTSEEN = 1 IFF INTRINSICS FUNCTION HAS BEEN SEEN. 00461800 .[6:3] = .INTCLASS = CLASS OF THE INTRINSIC. 00461900 .[9:3] = .INTPARMCLASS = CLASS OF PARAMETERS. 00462000 .[12:6] = .INTINLINE = INDEX FOR DOITINLINE IF !0, OTHERWISE 00462100 DO IT VIA INTRINSIC CALL. 00462200 .[24:6] = .INTPRT = FIXED PRT LOCATION. SEE .[1:1] ABOVE. 00462300 .[30:6] = .INTPARMS = NUMBER OF PARAMETERS REQUIRED BY THE INT.00462400 .[36:12] = .INTNUM = INTRINSICS NUMBER. 00462500 THE FIELDS .[3:3] AND .[18:6] ARE SO FAR UNUSED. 00462600 ; 00462700 % 00462800 %***********************************************************************00462900 %********* IF YOU ADD AN INTRINSIC, BE SURE TO CHANGE NUMINTM1 *******00463000 %********* AT SEQUENCE NUMBER 00155211.......THANK YOU. *******00463100 %***********************************************************************00463200 % 00463300 "ABS ", OCT0033010000010007, 00463400 "AIMAG ", OCT0036020000010074, 00463500 "AINT ", OCT0033030000010054, 00463600 "ALGAMA", OCT0033000000010127, 00463700 "ALOG10", OCT0033000000010103, 00463800 "ALOG ", OCT2033000035010017, 00463900 "AMAX0 ", OCT0031250000000031, 00464000 "AMAX1 ", OCT0033250000000031, 00464100 "AMIN0 ", OCT0031250000000032, 00464200 "AMIN1 ", OCT0033250000000032, 00464300 "AMOD ", OCT0033040000020063, 00464400 "AND ", OCT0033050000020130, 00464500 "ARCOS ", OCT0033000000010117, 00464600 "ARSIN ", OCT2033000032010116, 00464700 "ATAN2 ", OCT2033000044020114, 00464800 "ATAN ", OCT2033000037010016, 00464900 "CABS ", OCT2036000045010053, 00465000 "CCOS ", OCT0066000000010110, 00465100 "CEXP ", OCT0066000000010100, 00465200 "CLOG ", OCT0066000000010102, 00465300 "CMPLX ", OCT0063060000020075, 00465400 "COMPL ", OCT0033070000010132, 00465500 "CONCAT", OCT0033000000050140, 00465600 "CONJG ", OCT0066110000010076, 00465700 "COSH ", OCT0033000000010121, 00465800 "COS ", OCT0033000000010015, 00465900 "COTAN ", OCT0033000000010112, 00466000 "CSIN ", OCT0066000000010106, 00466100 "CSQRT ", OCT0066000000010124, 00466200 "DABS ", OCT0055010000010052, 00466300 "DATAN2", OCT0055000000020115, 00466400 "DATAN ", OCT2055000041010113, 00466500 "DBLE ", OCT0053120000010062, 00466600 "DCOS ", OCT0055000000010107, 00466700 "DEXP ", OCT2055000047010077, 00466800 "DIM ", OCT0033100000020072, 00466900 "DLOG10", OCT0055000000010104, 00467000 "DLOG ", OCT2055000042010101, 00467100 "DMAX1 ", OCT0055000000000066, 00467200 "DMIN1 ", OCT0055000000000067, 00467300 "DMOD ", OCT2055000046020065, 00467400 "DSIGN ", OCT0055130000020071, 00467500 "DSIN ", OCT2055000043010105, 00467600 "DSQRT ", OCT2055000050010123, 00467700 "EQUIV ", OCT0033140000020133, 00467800 "ERF ", OCT0033000000010125, 00467900 "EXP ", OCT2033000033010020, 00468000 "FLOAT ", OCT0031150000010060, 00468100 "GAMMA ", OCT2033000040010126, 00468200 "IABS ", OCT0011010000010007, 00468300 "IDIM ", OCT0011100000020072, 00468400 "IDINT ", OCT0015240000010057, 00468500 "IFIX ", OCT0013030000010054, 00468600 "INT ", OCT0013030000010054, 00468700 "ISIGN ", OCT0011160000020070, 00468800 ".ERR. ", OCT2000000030000134, 00468900 ".FBINB", OCT0000000000000160, 00469000 ".FINAM", OCT0000000000000154, 00469100 ".FONAM", OCT0000000000000155, 00469200 ".FREFR", OCT0000000000000146, 00469300 ".FREWR", OCT0000000000000153, 00469400 ".FTINT", OCT0000000000000050, 00469500 ".FTNIN", OCT0000000000000156, 00469600 ".FTNOU", OCT0000000000000157, 00469700 ".FTOUT", OCT0000000000000051, 00469800 ".LABEL", OCT0000000000000021, 00469900 ".MATH ", OCT0000000000000055, 00470000 ".MEMHR", OCT0000000000000164, 00470100 ".XTOI ", OCT0000000000000056, 00470200 "MAX0 ", OCT0011250000000135, 00470300 "MAX1 ", OCT0013250000000135, 00470400 "MIN0 ", OCT0011250000000136, 00470500 "MIN1 ", OCT0013250000000136, 00470600 "MOD ", OCT0011170000020137, 00470700 "OR ", OCT0033200000020131, 00470800 "REAL ", OCT0036210000010073, 00470900 "SIGN ", OCT0033160000020070, 00471000 "SINH ", OCT0033000000010120, 00471100 "SIN ", OCT2033000034010014, 00471200 "SNGL ", OCT0035230000010061, 00471300 "SQRT ", OCT2033000031010013, 00471400 "TANH ", OCT0033000000010122, 00471500 "TAN ", OCT2033000036010111, 00471600 "TIME ", OCT0031220000010064, 00471700 0; 00471800 BLANKS~INLINEINT[MAX~0] ; 00471900 FOR SCN~1 STEP 1 UNTIL BLANKS DO 00472000 BEGIN 00472100 EQVID~INLINEINT[SCN]; WHILE INT[MAX]!EQVID DO MAX~MAX+2 ; 00472200 INLINEINT[SCN].INTX~MAX+1 ; 00472300 END ; 00472400 INTID.SUBCLASS ~ INTYPE; 00472500 REALID.SUBCLASS ~ REALTYPE; 00472600 EQVID ~ ".EQ000"; 00472700 LISTID ~ ".LI000"; 00472800 BLANKS ~ " "; 00472900 ENDSEGTOG ~ TRUE; 00473000 SCN ~ 7; 00473100 MAX ~ REAL(NOT FALSE).[9:39]; 00473200 SUPERMAXCOM~128|(MAXCOM+1) ; 00473300 SEGPTOG ~ FALSE; %INHIBIT PAGE SKIP AFTER SUBROUTINES %501- 00473400 END INITIALIZATION; 00473500 00473600 ALPHA PROCEDURE NEED(T, C); VALUE T, C; ALPHA T, C; 00473700 BEGIN INTEGER N; REAL ELBAT; 00473800 REAL X; 00473900 LABEL XIT, CHECK; 00474000 ALPHA INFA, INFB, INFC; 00474100 COMMENT NEED RETURNS THE ELBAT WORD FOR THE IDENTIFIER T. 00474200 IF THIS IS THE FIRST OCCURRENCE OF T THEN AN INFO WORD IS BUILT AND 00474300 GIVEN THEN CLASS C; 00474400 ELBAT.CLASS ~ C; 00474500 XTA ~ T; 00474600 IF C { LABELID THEN 00474700 BEGIN 00474800 IF N ~ SEARCH(T) = 0 THEN N ~ ENTER(ELBAT, T) ELSE 00474900 IF ELBAT ~ GET(N).CLASS = UNKNOWN 00475000 THEN PUT(N,GET(N)&C[TOCLASS]) 00475100 ELSE IF ELBAT ! C THEN FLOG(21); 00475200 GO TO XIT; 00475300 END; 00475400 IF N ~ SEARCH(T) = 0 THEN 00475500 BEGIN 00475600 IF N ~ GLOBALSEARCH(T) ! 0 THEN GO TO CHECK; 00475700 N ~ GLOBALENTER(ELBAT, T); 00475800 GO TO XIT; 00475900 END; 00476000 GETALL(N,INFA,INFB,INFC); 00476100 IF INFA.CLASS = DUMMY THEN BEGIN N ~ INFC.BASE; GO TO CHECK END; 00476200 IF BOOLEAN(INFA. FORMAL) THEN GO TO CHECK; 00476300 IF INFA.CLASS ! UNKNOWN THEN 00476400 BEGIN 00476500 IF N ~ GLOBALSEARCH(T) ! 0 THEN GO TO CHECK; 00476600 ELBAT.SUBCLASS ~ INFA.SUBCLASS; 00476700 N ~ GLOBALENTER(ELBAT, T); 00476800 GO TO XIT; 00476900 END; 00477000 PUT(N, INFA & DUMMY[TOCLASS]); 00477100 ELBAT.SUBCLASS ~ INFA .SUBCLASS; 00477200 IF X ~ GLOBALSEARCH(T) = 0 THEN X ~ GLOBALENTER(ELBAT, T); 00477300 PUT(N+2, INFC & X[TOBASE]); N ~ X; 00477400 CHECK: 00477500 INFA ~ GET(N); 00477600 IF ELBAT ~ INFA .CLASS = UNKNOWN THEN 00477700 BEGIN INFO[N.IR,N.IC].CLASS ~ C; GO TO XIT END; 00477800 IF ELBAT ! C THEN 00477900 IF ELBAT = EXTID AND 00478000 (C = SUBRID OR C = FUNID) THEN 00478100 INFO[N.IR,N.IC].CLASS ~ C 00478200 ELSE IF (ELBAT=SUBRID OR ELBAT= FUNID) AND C = EXTID THEN 00478300 ELSE FLOG(21); 00478400 XIT: NEED ~ GETSPACE(N); 00478500 XTA ~ NAME; % RESTORE XTA FOR DIAGNOSTIC PURPOSES 00478600 END NEED; 00478700 00478800 INTEGER PROCEDURE EXPR(B); VALUE B; BOOLEAN B; FORWARD; 00478900 00479000 PROCEDURE SPLIT(A); VALUE A; REAL A; 00479100 BEGIN 00479200 EMITPAIR(JUNK, ISN); 00479300 EMITD(40, DIA); 00479400 EMITD(18, ISO); 00479500 EMITDESCLIT(A); 00479600 EMITO(LOD); 00479700 EMITOPDCLIT(JUNK); 00479800 EMITPAIR(255,CHS); 00479900 EMITO(LND); 00480000 END SPLIT; 00480100 BOOLEAN PROCEDURE SUBSCRIPTS(LINK,FROM); VALUE LINK,FROM; 00480200 INTEGER LINK, FROM; 00480300 BEGIN INTEGER I, NSUBS, BDLINK; 00480400 LABEL CONSTRUCT, XIT; 00480500 REAL SUM, PROD, BOUND; 00480600 REAL INFA,INFB,INFC; 00480700 REAL SAVENSEG,SAVEADR ; 00480800 INTEGER INDX; 00480900 REAL INFD; 00481000 BOOLEAN TOG, VARF; 00481100 REAL SAVIT; 00481200 DEFINE SS = LSTT#; 00481300 IF DEBUGTOG THEN FLAGROUTINE(" SUBSC","RIPTS ",TRUE ) ; 00481400 SAVIT ~ IT; 00481500 LINK ~ GETSPACE(LINK); 00481600 GETALL(LINK,INFA,INFB,INFC); 00481700 IF INFA.CLASS ! ARRAYID THEN 00481800 BEGIN XTA ~ INFB; FLOG(35); GO TO XIT END; 00481900 NSUBS ~ INFC.NEXTRA; 00482000 IF FROM = 4 THEN 00482100 BEGIN IF NSUBS GTR SAVESUBS THEN SAVESUBS ~ NSUBS; 00482200 IF NSUBS GTR NAMLIST[0] THEN NAMLIST[0] ~ NSUBS; 00482300 NAMLIST[NAMEIND].[1:8] ~ NSUBS; 00482400 INFD ~ GET(NEED(".SUBAR",BLOCKID)).ADDR; 00482500 END; 00482600 BDLINK ~ INFC.ADINFO-NSUBS+1; 00482700 VARF ~ INFC < 0; 00482800 FOR I ~ 1 STEP 1 UNTIL NSUBS DO 00482900 BEGIN 00483000 IT~IT+1; SAVENSEG~NSEG; SAVEADR~ADR ; 00483100 IF EXPR(TRUE) > REALTYPE THEN FLAG(98); 00483200 IF ADR=SAVEADR THEN FLAG(36) ; 00483300 IF VARF THEN 00483400 IF EXPRESULT=NUMCLASS AND NSEG=SAVENSEG THEN 00483500 BEGIN 00483600 ADR~SAVEADR ; 00483700 EMITNUM(EXPVALUE-1); 00483800 END ELSE EMITPAIR(1, SUB) 00483900 ELSE 00484000 IF EXPRESULT=NUMCLASS AND NSEG = SAVENSEG AND FROM NEQ 4 THEN 00484100 BEGIN 00484200 ADR~SAVEADR; IF SS[IT]~EXPVALUE{0 THEN FLAG(154) ; 00484300 END 00484400 ELSE SS[IT] ~ @9; 00484500 IF FROM = 4 THEN 00484600 BEGIN IF VARF THEN BEGIN EMITO(DUP); EMITPAIR(1,ADD); END; 00484700 EMITL(INDX); INDX ~ INDX+1; 00484800 EMITDESCLIT(INFD); 00484900 EMITO(IF VARF THEN STD ELSE STN); 00485000 END; 00485100 IF I < NSUBS THEN 00485200 BEGIN 00485300 IF GLOBALNEXT ! COMMA THEN 00485400 BEGIN XTA ~ INFB; FLOG(23) END; 00485500 SCAN; 00485600 END; 00485700 END; 00485800 IF GLOBALNEXT ! RPAREN THEN BEGIN XTA ~ INFB; FLOG(24); END 00485900 ELSE IF FROM < 2 THEN 00486000 BEGIN SCAN; IF PREC > 0 THEN FROM ~ 1; END; 00486100 SUM ~ 0; 00486200 TOG ~ VARF; 00486300 IF VARF THEN 00486400 FOR I ~ NSUBS-1 STEP -1 UNTIL 1 DO 00486500 BEGIN 00486600 IF BOUND ~ EXTRAINFO[(BDLINK~BDLINK+1).IR,BDLINK.IC] < 0 THEN 00486700 EMITOPDCLIT(BOUND) ELSE EMITNUM(BOUND); 00486800 EMITO(MUL); 00486900 EMITO(ADD); 00487000 END 00487100 ELSE 00487200 FOR I ~ NSUBS STEP -1 UNTIL 1 DO 00487300 BEGIN 00487400 IF I = 1 THEN BOUND ~ 1 ELSE 00487500 BOUND ~ EXTRAINFO[(BDLINK~BDLINK+1).IR,BDLINK.IC]; 00487600 IF T ~ SS[SAVIT+I] < @9 THEN 00487700 BEGIN 00487800 SUM ~ (SUM+T-1)|BOUND; 00487900 IF TOG THEN PROD ~ PROD|BOUND; 00488000 END 00488100 ELSE 00488200 BEGIN 00488300 IF TOG THEN BEGIN EMITNUM(PROD); EMITO(MUL); EMITO(ADD) END 00488400 ELSE TOG ~ TRUE; 00488500 PROD ~ BOUND; 00488600 SUM ~ (SUM-1)|BOUND; 00488700 END; 00488800 END; 00488900 IF VARF THEN T ~ @9; 00489000 IF INFA.SUBCLASS } DOUBTYPE THEN 00489100 BEGIN 00489200 IF TOG THEN 00489300 BEGIN 00489400 IF T < @9 THEN EMITNUM(2|PROD) ELSE EMITL(2); 00489500 EMITO(MUL); 00489600 END; 00489700 SUM ~ SUM|2; 00489800 END ELSE 00489900 IF T < @9 AND TOG THEN BEGIN EMITNUM(PROD); EMITO(MUL) END; 00490000 IF BOOLEAN(INFA.CE) THEN 00490100 SUM ~ SUM + INFC.BASE ELSE 00490200 IF BOOLEAN(INFA.FORMAL) THEN 00490300 BEGIN EMITOPDCLIT(INFA.ADDR-1); 00490400 IF TOG THEN EMITO(ADD) ELSE TOG ~ TRUE; 00490500 END; 00490600 IF BOOLEAN(INFA.TWOD) AND FROM > 0 THEN 00490700 BEGIN 00490800 IF SUM = 0 THEN 00490900 IF TOG THEN ELSE 00491000 BEGIN 00491100 EMITL(0); 00491200 EMITDESCLIT(INFA.ADDR); 00491300 EMITO(LOD); 00491400 EMITL(0); 00491500 GO TO CONSTRUCT; 00491600 END 00491700 ELSE 00491800 IF TOG THEN 00491900 BEGIN 00492000 EMITNUM(ABS(SUM)); 00492100 IF SUM < 0 THEN EMITO(SUB) ELSE EMITO(ADD); 00492200 END ELSE 00492300 BEGIN 00492400 EMITL(SUM.[33:7]); 00492500 EMITDESCLIT(INFA.ADDR); 00492600 EMITO(LOD); 00492700 EMITL(SUM.[40:8]); 00492800 GO TO CONSTRUCT; 00492900 END; 00493000 SPLIT(INFA.ADDR); 00493100 CONSTRUCT: 00493200 IF BOOLEAN(FROM) THEN 00493300 BEGIN 00493400 IF INFA.SUBCLASS } DOUBTYPE THEN 00493500 BEGIN 00493600 EMITO(CDC); 00493700 EMITO(DUP); 00493800 EMITPAIR(1, XCH); 00493900 EMITO(INX); 00494000 EMITO(LOD); 00494100 EMITO(XCH); 00494200 EMITO(LOD); 00494300 END ELSE EMITO(COC); 00494400 END ELSE 00494500 BEGIN 00494600 IF SUM = 0 THEN IF NOT TOG THEN EMITL(0) ELSE 00494700 ELSE 00494800 BEGIN 00494900 IF TOG THEN 00495000 BEGIN 00495100 EMITNUM(ABS(SUM)); 00495200 IF SUM < 0 THEN EMITO(SUB) ELSE EMITO(ADD); 00495300 END 00495400 ELSE EMITNUM(SUM); 00495500 END; 00495600 IF FROM > 0 THEN 00495700 IF BOOLEAN (FROM) THEN 00495800 IF INFA.SUBCLASS } DOUBTYPE THEN 00495900 BEGIN 00496000 EMITDESCLIT(INFA.ADDR); 00496100 EMITO(DUP); 00496200 EMITPAIR(1,XCH); 00496300 EMITO(INX); 00496400 EMITO(LOD); 00496500 EMITO(XCH); 00496600 EMITO(LOD); 00496700 END ELSE EMITV(LINK) ELSE 00496800 BEGIN DESCREQ ~ TRUE; EMITN(LINK); DESCREQ ~ FALSE END; 00496900 END; 00497000 XIT: 00497100 IT ~ SAVIT; 00497200 SUBSCRIPTS ~ BOOLEAN(FROM); 00497300 IF DEBUGTOG THEN FLAGROUTINE(" SUBSC","RIPTS ",FALSE) ; 00497400 END SUBSCRIPTS; 00497500 00497600 BOOLEAN PROCEDURE BOUNDS(LINK); VALUE LINK; REAL LINK; 00497700 BEGIN 00497800 COMMENT CALLED TO PROCESS ARRAY BOUNDS; 00497900 BOOLEAN VARF, SINGLETOG; %109-00498000 DEFINE FNEW = LINK#; 00498100 REAL T, NSUBS, INFA, INFB, INFC, FIRSTSS; 00498200 LABEL LOOP; 00498300 IF DEBUGTOG THEN FLAGROUTINE(" BOU","NDS ",TRUE ); 00498400 GETALL(FNEW, INFA, INFB, INFC); 00498500 FIRSTSS ~ NEXTSS; 00498600 IF LINK < 0 THEN BEGIN SINGLETOG ~ TRUE; LINK ~ ABS(LINK) END; %109-00498700 LOOP: 00498800 IF NEXT = ID THEN 00498900 BEGIN 00499000 T ~ GET(FNEXT ~ GETSPACE(FNEXT)); 00499100 IF T.CLASS ! VARID OR NOT BOOLEAN(T.FORMAL) THEN FLAG(92) ELSE 00499200 IF T.SUBCLASS > REALTYPE THEN FLAG(93); 00499300 T ~ -T.ADDR; 00499400 VARF ~ TRUE; 00499500 END ELSE 00499600 IF NEXT = NUM THEN 00499700 BEGIN 00499800 IF NUMTYPE!INTYPE THEN FLAG(113); 00499900 IF T~FNEXT=0 THEN FLAG(122) ; 00500000 IF NOT VARF THEN IF NSUBS = 0 THEN LENGTH ~ FNEXT ELSE 00500100 LENGTH ~ LENGTH|FNEXT; 00500200 END ELSE FLOG(122); 00500300 EXTRAINFO[NEXTSS.IR,NEXTSS.IC] ~ T; 00500400 NEXTSS ~ NEXTSS-1; 00500500 NSUBS ~ NSUBS+1; 00500600 SCAN; 00500700 IF NEXT = COMMA THEN BEGIN SCAN; GO TO LOOP END; 00500800 IF NEXT ! RPAREN THEN FLOG(94); 00500900 XTA ~ INFB; 00501000 IF INFA.CLASS = ARRAYID THEN FLAG(95); 00501100 INFA.CLASS ~ ARRAYID; 00501200 IF VARF THEN 00501300 BEGIN 00501400 IF NOT BOOLEAN(INFA.FORMAL) THEN FLAG(96); 00501500 IF NSUBS > 1 OR INFA .SUBCLASS } DOUBTYPE THEN 00501600 BEGIN BUMPLOCALS;LENGTH~LOCALS + 1536;BOUNDS~TRUE END ELSE 00501700 LENGTH ~-EXTRAINFO[FIRSTSS.IR,FIRSTSS.IC]; 00501800 END ELSE 00501900 IF NOT SINGLETOG AND INFA.SUBCLASS > LOGTYPE THEN %109-00502000 BEGIN LENGTH ~ 2 | LENGTH; BOUNDS ~ TRUE END; %109-00502100 IF LENGTH > 32767 THEN FLAG(99); 00502200 INFC ~ LENGTH & NSUBS[TONEXTRA] & FIRSTSS[TOADINFO]; 00502300 IF VARF THEN INFC ~ -INFC; 00502400 PUT(FNEW, INFA); PUT(FNEW+2, INFC); 00502500 SCAN; 00502600 IF DEBUGTOG THEN FLAGROUTINE(" BOU","NDS ",FALSE) ; 00502700 END BOUNDS; 00502800 00502900 PROCEDURE PARAMETERS(LINK); VALUE LINK; REAL LINK; 00503000 BEGIN 00503100 LABEL LOOP; 00503200 REAL NPARMS, EX, INFC, PTYPE; 00503300 ALPHA EXPNAME; 00503400 BOOLEAN CHECK, INTFID; 00503500 BOOLEAN NOTZEROP; 00503600 REAL SAVIT; 00503700 DEFINE PARMTYPE = LSTT#; 00503800 SAVIT ~ IT ~ IT+1; 00503900 IF DEBUGTOG THEN FLAGROUTINE(" PARAM","ETERS ",TRUE ) ; 00504000 INFC ~ GET(LINK+2); 00504100 IF CHECK ~ BOOLEAN(INFC.[1:1]) THEN 00504200 BEGIN 00504300 EX ~ INFC.ADINFO; 00504400 NOTZEROP ~ INFC.NEXTRA ! 0; 00504500 INTFID ~ INFC.[36:12] = 1; 00504600 END; 00504700 LOOP: 00504800 BEGIN SCAN; 00504900 EXPNAME ~ NAME; 00505000 IF GLOBALNEXT = 0 AND NAME = "$ " THEN 00505100 BEGIN EXPRESULT ~ LABELID; SCAN; 00505200 IF GLOBALNEXT ! NUM THEN FLAG(44); 00505300 EMITLABELDESC(NAME); 00505400 PTYPE ~ 0; 00505500 SCAN; 00505600 END 00505700 ELSE PTYPE ~ EXPR(CHECK AND EXTRAINFO[EX.IR,EX.IC].CLASS 00505800 = EXPCLASS AND INTFID); 00505900 IF EXPRESULT = NUMCLASS THEN 00506000 IF PTYPE = STRINGTYPE THEN 00506100 BEGIN 00506200 ADR ~ ADR - 1; 00506300 PTYPE ~ INTYPE; 00506400 EXPRESULT ~ SUBSVAR; 00506500 IF STRINGSIZE = 1 AND 00506600 (T ~ EXTRAINFO[EX.IR,EX.IC].CLASS = VARID OR 00506700 T = EXPCLASS) THEN 00506800 BEGIN 00506900 EXPRESULT ~ EXPCLASS; 00507000 EMITNUM(STRINGARRAY[0]); 00507100 END ELSE 00507200 BEGIN 00507300 EXPRESULT~ARRAYID; 00507400 EMITPAIR(PRGDESCBLDR(1,0,0,NXAVIL~NXAVIL+1), LOD); 00507500 EMITL(0); 00507600 WRITEDATA(STRINGSIZE, NXAVIL, STRINGARRAY); 00507700 END; 00507800 END ELSE EXPRESULT ~ EXPCLASS; 00507900 PARMTYPE[IT] ~ 0 & EXPRESULT[TOCLASS] & PTYPE[TOSUBCL]; 00508000 XTA ~ EXPNAME; 00508100 IF TSSEDITOG THEN IF (EXPRESULT=FUNID OR EXPRESULT=SUBRID OR 00508200 EXPRESULT=EXTID) AND NOT DCINPUT THEN TSSED(XTA,2); 00508300 IF DCINPUT THEN IF EXPRESULT=FUNID OR EXPRESULT=SUBRID 00508400 OR EXPRESULT=EXTID THEN FLAG(151) ; 00508500 IF CHECK THEN 00508600 BEGIN 00508700 IF T ~ EXTRAINFO[EX.IR,EX.IC].CLASS ! EXPRESULT THEN 00508800 CASE T OF 00508900 BEGIN 00509000 EXTRAINFO[EX.IR,EX.IC] ~ 0 & EXPRESULT[TOCLASS] 00509100 & PTYPE[TOSUBCL]; 00509200 IF EXPRESULT ! SUBSVAR THEN FLAG(66); 00509300 IF EXPRESULT = SUBSVAR THEN 00509400 IF NOT INTFID THEN 509500 BEGIN EMITO(CDC); 00509600 IF PTYPE } DOUBTYPE THEN EMITL(0); 00509700 END ELSE 00509800 ELSE 00509900 IF EXPRESULT = EXPCLASS THEN 00510000 BEGIN IF PTYPE } DOUBTYPE THEN EMITO(XCH); 00510100 EXTRAINFO[EX.IR,EX.IC].CLASS ~ EXPCLASS 00510200 END ELSE FLAG(67); 00510300 ; ; ; 00510400 FLAG(68); 00510500 IF EXPRESULT = EXTID THEN 00510600 PUT(EXPLINK,GET(EXPLINK)&FUNID[TOCLASS]) ELSE 00510700 FLAG(69); 00510800 ; 00510900 IF EXPRESULT = FUNID OR EXPRESULT = SUBRID THEN 00511000 EXTRAINFO[EX.IR,EX.IC] ~ EXPRESULT ELSE FLAG(70); 00511100 IF EXPRESULT = EXTID THEN 00511200 PUT(EXPLINK,GET(EXPLINK)&SUBRID[TOCLASS]) ELSE 00511300 FLAG(71); 00511400 ; ; 00511500 IF EXPRESULT = ARRAYID THEN EXTRAINFO[EX.IR,EX.IC].CLASS 00511600 ~ ARRAYID ELSE 00511700 IF EXPRESULT = VARID THEN 00511800 BEGIN 00511900 EXTRAINFO[EX.IR,EX.IC].CLASS ~ SBVEXP; 00512000 EMITL(0) 00512100 END ELSE 00512200 IF EXPRESULT = EXPCLASS THEN 00512300 BEGIN 00512400 EXTRAINFO[EX.IR,EX.IC].CLASS ~ SBVEXP; 00512500 IF PTYPE } DOUBTYPE THEN EMITO(XCH) ELSE EMITL(0); 00512600 END ELSE FLAG(72); 00512700 IF EXPRESULT = SUBSVAR THEN 00512800 IF NOT INTFID THEN 00512900 BEGIN EMITO(CDC); 00513000 IF PTYPE } DOUBTYPE THEN EMITL(0) 00513100 END 00513200 ELSE 00513300 ELSE IF EXPRESULT = VARID THEN 00513400 IF NOT INTFID THEN 00513500 IF PTYPE } DOUBTYPE THEN EMITL(0) ELSE ELSE 00513600 ELSE FLAG(67); 00513700 IF EXPRESULT = VARID THEN 00513800 EMITL(0) ELSE 00513900 IF EXPRESULT = EXPCLASS THEN 00514000 IF PTYPE } DOUBTYPE THEN EMITO(XCH) ELSE EMITL(0) 00514100 ELSE IF EXPRESULT ! SUBSVAR THEN FLAG(67); 00514200 END OF CASE STATEMENT 00514300 ELSE IF PTYPE } DOUBTYPE THEN 00514400 IF EXPRESULT = VARID THEN EMITL(0) 00514500 ELSE IF EXPRESULT = EXPCLASS AND NOT INTFID 00514600 THEN EMITO(XCH); 00514700 IF T ~ EXTRAINFO[EX.IR,EX.IC].SUBCLASS = 0 OR 00514800 (T = INTYPE AND PTYPE = REALTYPE AND 00514900 GET(LINK).SEGNO = 0) THEN 00515000 EXTRAINFO[EX.IR,EX.IC].SUBCLASS ~ PTYPE ELSE 00515100 IF NOT(T = PTYPE OR T = REALTYPE AND PTYPE = INTYPE ) THEN 00515200 FLAG(88); 00515300 END OF CHECK 00515400 ELSE IF PTYPE } DOUBTYPE THEN 00515500 IF EXPRESULT = VARID THEN EMITL(0) 00515600 ELSE IF EXPRESULT = EXPCLASS THEN EMITO(XCH); 00515700 IF NOTZEROP THEN EX ~ EX+1; 00515800 IT ~ IT+1; 00515900 END; 00516000 IF GLOBALNEXT = COMMA THEN GO TO LOOP; 00516100 NPARMS ~ IT - SAVIT; 00516200 IF GLOBALNEXT ! RPAREN THEN FLOG(108); 00516300 IF NOT CHECK THEN 00516400 BEGIN 00516500 INFC ~ GET(LINK+2); 00516600 INFC ~ -(INFC & NPARMS[TONEXTRA] 00516700 & NEXTEXTRA[TOADINFO]); 00516800 PUT(LINK+2,INFC); 00516900 FOR I ~ SAVIT STEP 1 UNTIL IT-1 DO 00517000 BEGIN 00517100 EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ PARMTYPE[I]; 00517200 NEXTEXTRA ~ NEXTEXTRA+1; 00517300 END; 00517400 END 00517500 ELSE 00517600 IF T ~ GET(LINK+2).NEXTRA > 0 AND T ! NPARMS OR 00517700 T=0 AND INTFID AND NPARMS < 2 OR 00517800 T = 0 AND NOT INTFID THEN 00517900 BEGIN XTA ~ GET(LINK+1); FLAG(28) END; 00518000 IF DEBUGTOG THEN FLAGROUTINE(" PARAM","ETERS ",FALSE) ; 00518100 IT ~ SAVIT-1; 00518200 END PARAMETERS; 00518300 00518400 PROCEDURE STMTFUNREF(LINK); VALUE LINK; REAL LINK; 00518500 BEGIN 00518600 REAL I, PARMLINK, NPARMS, SEG; 00518700 IF DEBUGTOG THEN FLAGROUTINE(" STMTF","UNREF ",TRUE); 00518800 PARMLINK ~ GET(LINK+2).[36:12]; 00518900 DO 00519000 BEGIN 00519100 SCAN; 00519200 IF A~EXPR(TRUE) ! B~GET(PARMLINK).SUBCLASS THEN 00519300 IF A > REALTYPE OR B > REALTYPE THEN %108-00519400 BEGIN XTA ~ NNEW; FLAG(88) END; 00519500 PARMLINK ~ PARMLINK-3; 00519600 NPARMS ~ NPARMS+1; 00519700 END UNTIL NEXT ! COMMA; 00519800 IF NEXT ! RPAREN THEN FLAG(108); 00519900 SCAN; 00520000 GETALL(LINK, INFA, XTA, INFC); 00520100 IF NPARMS ! INFC.NEXTRA THEN FLAG(28); 00520200 SEG ~ INFA.SEGNO; 00520300 BRANCHLIT(INFC.BASE&SEG[TOSEGNO],FALSE); 00520400 EMITB(INFA.ADDR & SEG[TOSEGNO], FALSE); 00520500 ADJUST; 00520600 IF DEBUTOG THEN FLAGROUTINE(" STMTF","UNREF ",FALSE); 00520700 END STMTFUNREF; 00520800 00520900 BOOLEAN PROCEDURE DOITINLINE(LNK); VALUE LNK; REAL LNK ; 00521000 BEGIN 00521100 REAL C,I,C1,C2,C3,C4,C5 ; 00521200 LABEL HUNT,FOUND,XIT,AIMAG,AINT,CMPLX,LOOP,DDT111,SNGL ; 00521300 DEFINE OPTYPE=LSTT#, E0=EMITO#, EP=EMITPAIR#, EOL=EMITOPDCLIT# ;00521400 IF DEBUGTOG THEN FLAGROUTINE("DOITIN","LINE ",TRUE); 00521500 C1~1; C2~INLINEINT[0]; C3~GET(ABS(LNK)+1) ; 00521600 HUNT: 00521700 IF (C~INLINEINT[I~(C1+C2).[36:11]].INAM)C3 THEN C2~I-1 ELSE GO FOUND ; 00521900 IF C10 THEN INLINEINT[I]~-C4; I~0 ; 00524600 IF XREF THEN ENTERX(C3,0&FUNID[TOCLASS]&C[21:6:3]); 00524700 IF GLOBALNEXT!LPAREN THEN BEGIN FLOG(106); GO XIT END ; 00524800 LOOP: SCAN; C5~XTA ; 00524900 IF I=0 THEN 00525000 IF LNK=10 THEN EMITL(0) ELSE IF LNK=21 THEN EMITDESCLIT(2) ; 00525100 IF (C4~EXPR(TRUE))!C1 AND (C1!REALTYPE OR C4!INTYPE) THEN 00525200 BEGIN XTA~C5; FLAG(88); C2~-2 END ; 00525300 I~I+1; IF GLOBALNEXT=COMMA THEN GO LOOP ; 00525400 IF GLOBALNEXT!RPAREN THEN BEGIN FLOG(108); C2~-2 END; SCAN ; 00525500 IF I!C.INTPARMS THEN IF C.INTPARMS!0 OR I<2 THEN 00525600 BEGIN XTA~C3; FLAG(28); C2~-2 END ; 00525700 OPTYPE[IT]~C.INTCLASS; IF C2<0 THEN GO XIT ; 00525800 CASE (LNK-1) OF 00525900 BEGIN 00526000 E0(SSP) ; % @1: ABS, DABS, IABS. 00526100 AIMAG: E0(DEL) ; % @2: AIMAG. 00526200 AINT: EP(1,IDV) ; % @3: AINT, IFIX, INT. 00526300 E0(RDV) ; % @4: AMOD. 00526400 E0(LND) ; % @5: LOGICAL AND. 00526500 CMPLX: E0(XCH) ; % @6: CMPLX. 00526600 E0(LNG) ; % @7: LOGICAL COMPLIMENT (NEGATION). 00526700 BEGIN % @10: DIM, IDIM. 00526800 E0(SUB); E0(DUP); EP(0,LESS) ; 00526900 IF ADR>4082 THEN BEGIN ADR~ADR+1; SEGOVF END ; 00527000 EP(2,BFC); E0(DEL); EMITL(0) ; 00527100 END ; 00527200 BEGIN E0(XCH); E0(CHS); GO CMPLX END ; % @11: CONJG. 00527300 ; % @12: DBLE (SOME CODE ALREADY EMITTED ABOVE). 00527400 BEGIN E0(XCH); E0(DEL) ; % @13: DSIGN. 00527500 DDT111: EMITDDT(1,1,1) ; 00527600 END; 00527700 E0(LQV) ; % @14: LOGICAL EQUIVALENCE. 00527800 ; % @15: FLOAT. 00527900 GO DDT111 ; % @16: ISIGN, SIGN. 00528000 BEGIN E0(RDV); GO AINT END ; % @17: MOD. 00528100 E0(LOR) ; % @20: LOGICAL OR. 00528200 BEGIN E0(XCH); GO AIMAG END ; % @21: REAL. 00528300 EP(1,KOM) ; % @22: TIME. 00528400 BEGIN % @23: SNGL. 00528500 SNGL: EP(9,SND); E0(XCH); EMITDDT(47,9,1); EMITL(0) ; 00528600 EMITDDT(9,9,38); EOL(9); EMITO(ADD); IF LNK=20 THEN GO AINT ; 00528700 END ; 00528800 GO SNGL ; % @24: IDINT. 00528900 00529000 BEGIN % @25: AMAX0,AMAX1,AMIN0,AMIN1,MAX0,MAX1,MIN0,MIN1. 00529100 % SOME CODE ALREADY EMITTED ABOVE. 00529200 IF ADR>4068 THEN BEGIN ADR~ADR+1; SEGOVF END ; 00529300 EP(9,STD); E0(DUP); EOL(9) ; 00529400 E0(IF C3.[24:6]="A" OR C3.[24:6]="X" THEN LESS ELSE GRTR) ; 00529500 EP(2,BFC); E0(DEL); EOL(9); E0(XCH); E0(TOP); E0(LNG) ; 00529600 EP(14,BBC); E0(DEL); IF C3="MIN1 " OR C3="MAX1 " THEN GO AINT00529700 END ; 00529800 00529900 END OF CASE STATEMENT ; 00530000 XIT: 00530100 IF DEBUGTOG THEN FLAGROUTINE("DOITIN","LINE ",FALSE) ; 00530200 END OF DOITINLINE ; 00530300 00530400 REAL PROCEDURE LOOKFORINTRINSIC(L); VALUE L; REAL L; 00530500 BEGIN 00530600 ALPHA ID, I, X, NPARMS; 00530700 REAL T; 00530800 LABEL FOUND, XIT; 00530900 IF DEBUGTOG THEN FLAGROUTINE("LOOKFO","RINTRN",TRUE); 00531000 LOOKFORINTRINSIC ~ L ~ NEED(ID ~ GET(L+1),FUNID); 00531100 IF GET(L+2) < 0 THEN GO TO XIT; % PARAMETER INFO KNOWN 00531200 COMMENT B MUST BE SET TO K/2, WHERE K IS THE INDEX OF THE LAST 00531300 INTRINSIC NAME IN THE ARRAY INT; 00531400 A~0; B~NUMINTM1 ; 00531500 WHILE A+1 < B DO 00531600 BEGIN 00531700 I ~ REAL(BOOLEAN(A+B) AND BOOLEAN(1022)); 00531800 IF Z ~ INT[I] = ID THEN GO TO FOUND; 00531900 IF ID < Z THEN B ~ I.[36:11] ELSE A ~ I.[36:11]; 00532000 END; 00532100 IF ID = INT[I~(A+B)|2-I] THEN GO TO FOUND; 00532200 GO TO XIT; 00532300 FOUND: 00532400 NPARMS~(X~INT[I+1]).INTPARMS; INT[I+1].INTSEEN~1 ; 00532500 INFO[L.IR,L.IC].SUBCLASS~X.INTCLASS ; 00532600 PUT(L+2,-(1&NEXTEXTRA[TOADINFO]&NPARMS[TONEXTRA])); 00532700 IF NPARMS = 0 THEN NPARMS ~ 1; 00532800 T~X.INTPARMCLASS ; 00532900 FOR I ~ 1 STEP 1 UNTIL NPARMS DO 00533000 BEGIN 00533100 EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ 00533200 0 & EXPCLASS[TOCLASS] & T[TOSUBCL]; 00533300 NEXTEXTRA ~ NEXTEXTRA + 1; 00533400 END; 00533500 XIT: 00533600 IF DEBUGTOG THEN FLAGROUTINE("LOOKFO","RINTRN",FALSE ) ; 00533700 END LOOKFORINTRINSIC; 00533800 INTEGER PROCEDURE EXPR(VALREQ); VALUE VALREQ; BOOLEAN VALREQ; 00533900 BEGIN LABEL LOOP, STACK, XIT, NOSCAN; REAL T; 00534000 00534100 LABEL ARRY; 00534200 LABEL HERE ; 00534300 REAL SAVIT, SAVIP; 00534400 BOOLEAN CNSTSEENLAST; %FOR HANDLING CONSTANT %113-00534500 REAL SAVEADR; %EXPONENTS %113-00534600 DEFINE OPTYPE = LSTT#; 00534700 REAL EXPRESLT,EXPLNK; 00534800 REAL EXPV; 00534900 REAL TM ; 00535000 DEFINE E0=EMITO#, EP=EMITPAIR#, EOL=EMITOPDCLIT#, 00535100 ES1(OP)=BEGIN E0(XCH); EP(9,STD); E0(OP) END #, 00535200 ES2=BEGIN EP(9,STD); E0(XCH); EP(17,SND); E0(MUL) END # ; 00535300 LABEL CTYP, DTYP, RLESSC, DLESSC, CLESSD, CLESSC, RPLUSD, DTIMESC, 00535400 CTIMESR, CDIVBYD, CTIMESR1, CTIMESR2, DLESSC1 ; 00535500 LABEL SPECCHAR, RELATION; 00535600 REAL LINK; 00535700 DEFINE T1 = EXPT1#, T2 = EXPT2#, CODE = EXPT3#; 00535800 COMMENT THE FOLLOWING TABLE GIVES THE PRECEDENCE (PREC) AND 00535900 OPERATOR NUMBER (OP) OF THE ARITHMETIC AND LOGICAL OPERATORS. 00536000 OPERATOR PREC OP 00536100 ** 9 15 00536200 UNARY - 8 12 00536300 / 7 14 00536400 * 7 13 00536500 - 5 11 00536600 + 5 10 00536700 .NE. 4 9 00536800 .GE. 4 8 00536900 .GT. 4 7 00537000 .EQ. 4 6 00537100 .LE. 4 5 00537200 .LT. 4 4 00537300 .NOT. 3 3 00537400 .AND. 2 2 00537500 .OR. 1 1 00537600 THE UNARY PLUS IS IGNORED; 00537700 PROCEDURE MATH(D, C, T); VALUE D, C, T; REAL D, C, T; 00537800 BEGIN 00537900 EMITO(MKS); 00538000 EMITL(C); 00538100 EMITV(NEED(".MATH ", INTRFUNID)); 00538200 EMITO(DEL); 00538300 IF D = 2 THEN EMITO(DEL); 00538400 OPTYPE[IT~IT-1] ~ T; 00538500 END MATH; 00538600 NNEW ~ NAME; 00538700 IF DEBUGTOG THEN FLAGROUTINE(" EXPRE","SSION ",TRUE ) ; 00538800 OPTYPE[SAVIT ~IT ~ IT+1] ~ 00538900 PR[SAVIP~IP~IP+1] ~ OPST[IP] ~ 0; 00539000 IF GLOBALNEXT = PLUS THEN GO TO LOOP; 00539100 IF GLOBALNEXT = MINUS THEN 00539200 BEGIN PREC ~ 8; OP ~ 12; GO TO STACK END; 00539300 IF PREC > 0 THEN GO TO STACK; 00539400 LINK~(EXPLNK~FNEXT)&REAL(SCANENTER)[2:47:1] ; 00539500 GO TO NOSCAN; 00539600 LOOP: SCAN; 00539700 LINK ~ FNEXT; 00539800 NOSCAN: 00539900 CNSTSEENLAST~FALSE; %113- 00540000 IF GLOBALNEXT = ID THEN 00540100 BEGIN 00540200 IF IP ! SAVIP THEN EXPRESLT ~ EXPCLASS; 00540300 OPTYPE[IT~IT+1] ~ (A~GET(LINK)).SUBCLASS; 00540400 SCAN; 00540500 IF NOT RANDOMTOG THEN 00540600 IF NEXT=EQUAL THEN BEGIN NEXT~0; OP~6; PREC~4 END ; 00540700 IF GLOBALNEXT = ID OR GLOBALNEXT = NUM THEN 00540800 BEGIN FLOG(1); GO TO XIT END; 00540900 IF NOT VALREQ AND PREC > 0 THEN VALREQ ~ TRUE; 00541000 IF GLOBALNEXT ! LPAREN THEN 00541100 BEGIN 00541200 LINK ~ GETSPACE(LINK); 00541300 T ~ (A~GET(LINK)).CLASS; 00541400 IF XREF THEN ENTERX(GET(LINK+1),0&A[15:15:9]); 00541500 IF EXPRESLT = 0 THEN EXPRESLT ~ T; 00541600 IF VALREQ THEN 00541700 IF T = VARID THEN EMITV(LINK) ELSE 00541800 BEGIN XTA ~ GET(LINK+1); FLAG(50) END 00541900 ELSE 00542000 BEGIN 00542100 IF T = VARID THEN 00542200 IF GLOBALNEXT > SLASH AND EXPRESLT = VARID THEN 00542300 BEGIN 00542400 DESCREQ~TRUE; EMITN(LINK); DESCREQ ~ FALSE; 00542500 GO TO XIT; 00542600 END ELSE EMITV(LINK) 00542700 ELSE 00542800 BEGIN 00542900 IF T = ARRAYID THEN 00543000 BEGIN 00543100 IF BOOLEAN(A.CE) THEN 00543200 EMITNUM(GET(LINK+2).BASE) ELSE 00543300 IF BOOLEAN(A.FORMAL) THEN 00543400 EMITOPDCLIT(A.ADDR-1) ELSE 00543500 EMITL(0); 00543600 GO TO ARRY; 00543700 END ELSE EMITPAIR(A.ADDR,LOD); 00543800 GO TO XIT; 00543900 END; 00544000 END; 00544100 GO TO SPECCHAR; 00544200 END; 00544300 IF A.CLASS ! ARRAYID THEN 00544400 BEGIN COMMENT FUNCTION REFERENCE; 00544500 EXPRESLT ~ EXPCLASS; 00544600 IF A.CLASS = STMTFUNID THEN 00544700 BEGIN 00544800 IF XREF THEN ENTERX(GET(LINK+1),0&A[15:15:9]); 00544900 STMTFUNREF(LINK) ; 00545000 IF NEXT=EQUAL THEN IF NOT RANDOMTOG THEN 00545100 BEGIN NEXT~0; OP~6; PREC~4 END ; 00545200 GO TO SPECCHAR ; 00545300 END ; 00545400 IF A.CLASS=EXTID OR GET(TM~GLOBALSEARCH(GET(LINK+1))).CLASS=00545500 EXTID THEN LINK~REAL(DOITINLINE(-LINK)) ELSE 00545600 IF A.CLASS SLASH AND EXPRESLT = SUBSVAR THEN 00548100 BEGIN 00548200 ARRY: 00548300 IF BOOLEAN((A~GET(LINK)).TWOD) THEN 00548400 BEGIN 00548500 EMITPAIR(TWODPRT, LOD); 00548600 T ~ A.ADDR; 00548700 IF T { 1023 THEN 00548800 BEGIN 00548900 EMITL(T.[38:10]); 00549000 EMITDESCLIT(10); 00549100 END ELSE 00549200 BEGIN 00549300 EMITL(T.[40:8]); 00549400 EMITDESCLIT(1536); 00549500 EMITO(INX); 00549600 END; 00549700 EMITO(CTF); 00549800 END ELSE EMITPAIR(A.ADDR,LOD); 00549900 EMITO(XCH); 00550000 GO TO XIT; 00550100 END; 00550200 IF BOOLEAN((A~GET(LINK)).TWOD) THEN 00550300 BEGIN 00550400 SPLIT(A.ADDR); 00550500 IF A.SUBCLASS } DOUBTYPE THEN 00550600 BEGIN 00550700 EMITO(CDC); 00550800 EMITO(DUP); 00550900 EMITPAIR(1, XCH); 00551000 EMITO(INX); 00551100 EMITO(LOD); 00551200 EMITO(XCH); 00551300 EMITO(LOD); 00551400 END ELSE EMITO(COC); 00551500 END ELSE 00551600 EMITV(LINK); 00551700 END; 00551800 END ARRAY REFERENCE; 00551900 GO TO SPECCHAR; 00552000 END; 00552100 IF GLOBALNEXT = NUM THEN 00552200 BEGIN 00552300 IF NUMTYPE = STRINGTYPE THEN 00552400 IF VALREQ THEN 00552500 BEGIN 00552600 NUMTYPE~INTYPE ; 00552700 IF STRINGSIZE=1 THEN FNEXT~STRINGARRAY[0] 00552800 ELSE BEGIN 00552900 IF STRINGSIZE>2 OR STRINGARRAY[1].[18:30]!" " THEN 00553000 FLAG(162) ; 00553100 IF (FNEXT~STRINGARRAY[1].[12:6]&STRINGARRAY[0][6:12:36]) 00553200 .[6:6]>7 THEN NUMTYPE~REALTYPE ; 00553300 END ; 00553400 END; 00553500 SAVEADR~ADR; CNSTSEENLAST~TRUE; %113-00553600 IF NUMTYPE = DOUBTYPE THEN 00553700 EMITNUM2(FNEXT,DBLOW) ELSE EMITNUM (FNEXT); 00553800 OPTYPE[IT~IT+1] ~ NUMTYPE; 00553900 IF EXPRESLT = 0 THEN 00554000 BEGIN EXPRESLT ~ NUMCLASS; EXPV ~ FNEXT END; 00554100 SCAN; 00554200 IF NOT RANDOMTOG THEN 00554300 IF NEXT=EQUAL THEN BEGIN NEXT~0; OP~6; PREC~4 END; 00554400 IF NOT VALREQ AND PREC > 0 THEN VALREQ ~ TRUE; 00554500 IF GLOBALNEXT = ID OR GLOBALNEXT = NUM THEN 00554600 BEGIN FLOG(1); GO TO XIT END; 00554700 END; 00554800 SPECCHAR: 00554900 IF GLOBALNEXT = LPAREN THEN 00555000 BEGIN 00555100 SCAN; 00555200 OPTYPE[IT~IT+1] ~ EXPR(TRUE); 00555300 IF GLOBALNEXT = COMMA AND EXPRESULT = NUMCLASS THEN 00555400 BEGIN 00555500 IF OPTYPE[IT] > REALTYPE THEN FLAG(85); 00555600 SCAN; 00555700 IF EXPR(TRUE) > REALTYPE 00555800 OR EXPRESULT ! NUMCLASS THEN FLAG(85); 00555900 EMITO(XCH); 00556000 OPTYPE[IT] ~ COMPTYPE; 00556100 IF EXPRESLT = 0 THEN EXPRESLT ~ NUMCLASS; 00556200 END ELSE EXPRESLT ~ EXPCLASS; 00556300 IF GLOBALNEXT ! RPAREN THEN 00556400 BEGIN FLOG(108); GO TO XIT END; 00556500 GO TO LOOP; 00556600 END; 00556700 WHILE PR[IP] } PREC DO 00556800 BEGIN 00556900 IF IT { SAVIT THEN GO TO XIT; 00557000 CODE ~ MAP[T1~OPTYPE[IT-1]]|3 + MAP[T2~OPTYPE[IT]]; 00557100 CASE OPST[IP] OF 00557200 BEGIN 00557300 GO TO XIT; 00557400 BEGIN 00557500 IF T1 = LOGTYPE AND T2 = LOGTYPE THEN EMITO(LOR) 00557600 ELSE FLAG(51); 00557700 IT ~ IT-1; 00557800 END; 00557900 BEGIN 00558000 IF T1 = LOGTYPE AND T2 = LOGTYPE THEN EMITO(LND) 00558100 ELSE FLAG(52); 00558200 IT ~ IT-1; 00558300 END; 00558400 IF T2 = LOGTYPE THEN EMITO(LNG) ELSE FLAG(53); 00558500 BEGIN T ~ LESS; GO TO RELATION END; 00558600 BEGIN T ~ LEQL; GO TO RELATION END; 00558700 BEGIN T ~ EQUL; GO TO RELATION END; 00558800 BEGIN T ~ GRTR; GO TO RELATION END; 00558900 BEGIN T ~ GEQL; GO TO RELATION END; 00559000 BEGIN T ~ NEQL; 00559100 RELATION: 00559200 IF CODE < 0 THEN FLAG(54) ELSE 00559300 CASE CODE OF 00559400 BEGIN ; 00559500 BEGIN 00559600 E0(CHS); EP(9,STD); E0(XCH); EOL(9); E0(XCH); EP(0,XCH) ;00559700 E0(AD2) ; 00559800 END; 00559900 FLAG(90); 00560000 BEGIN EMITPAIR(0, XCH); EMITO(SB2) END; 00560100 EMITO(SB2); 00560200 FLAG(90); 00560300 FLAG(90); 00560400 FLAG(90); 05605000 IF T! EQUL AND T! NEQL THEN FLAG(54) %103-00560600 ELSE %103-00560700 BEGIN %103-00560800 EP(9,STD); E0(XCH); EOL(9); E0(T); %103-00560900 EP(9,STD ); E0(T); EOL(9); %103-00560910 T~(IF T=EQUL THEN LND ELSE LOR); CODE~0; %103-00561000 END; %103-00561100 END RELATION CASE STATEMENT; 00561200 IF CODE > 0 THEN 00561300 BEGIN EMITO(XCH); EMITO(DEL); EMITL(0) END; 00561400 EMITO(T); 00561500 OPTYPE[IT~IT-1] ~ LOGTYPE; 00561600 END; 00561700 IF CODE < 0 THEN BEGIN FLAG(53); IT ~ IT-1 END ELSE 00561800 CASE CODE OF 00561900 BEGIN 00562000 BEGIN 00562100 EMITO(ADD); 00562200 IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 00562300 OPTYPE[IT~IT-1] ~ REALTYPE; 00562400 END; 00562500 BEGIN TM~AD2 ; 00562600 RPLUSD: EP(9,STD); E0(XCH); EOL(9); E0(XCH); EP(0,XCH); E0(TM) ; 00562700 DTYP: OPTYPE[IT~IT-1]~DOUBTYPE ; 00562800 END ; 00562900 BEGIN TM~ADD; GO RLESSC END ; 00563000 BEGIN 00563100 EMITPAIR(0, XCH); 00563200 EMITO(AD2); 00563300 IT ~ IT-1; 00563400 END; 00563500 BEGIN EMITO(AD2); IT ~ IT-1 END; 00563600 BEGIN TM~ADD; GO DLESSC END ; 00563700 BEGIN EMITO(ADD); IT ~ IT-1 END; 00563800 BEGIN TM~ADD; GO CLESSD END ; 00563900 BEGIN TM~ADD; GO CLESSC END ; 00564000 END ADD CASE STATEMENT; 00564100 IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 00564200 CASE CODE OF 00564300 BEGIN 00564400 BEGIN 00564500 EMITO(SUB); 00564600 IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 00564700 OPTYPE[IT~IT-1] ~ REALTYPE; 00564800 END; 00564900 BEGIN E0(CHS); TM~AD2; GO RPLUSD END; 00565000 BEGIN TM~SUB ; 00565100 RLESSC: ES1(TM); GO DLESSC1 ; 00565200 END ; 00565300 BEGIN 00565400 EMITPAIR(0, XCH); 00565500 EMITO(SB2); 00565600 IT ~ IT-1; 00565700 END; 00565800 BEGIN EMITO(SB2); IT ~ IT-1 END; 00565900 BEGIN TM~SUB ; 00566000 DLESSC: ES1(TM); E0(XCH); E0(DEL) ; 00566100 DLESSC1: EOL(9); IF TM=SUB THEN E0(CHS); GO CTIMESR2 ; 00566200 END ; 00566300 BEGIN EMITO(SUB); IT ~ IT-1 END; 00566400 BEGIN TM~SUB ; 00566500 CLESSD: E0(XCH); E0(DEL); E0(TM) ; 00566600 CTYP: OPTYPE[IT~IT-1]~COMPTYPE ; 00566700 END ; 00566800 BEGIN TM~SUB ; 00566900 CLESSC: ES1(TM); GO CTIMESR1 ; 00567000 END ; 00567100 END SUBTRACT CASE STATEMENT; 00567200 BEGIN % HANDLE NEGATIVE NUMBERS CASE STATEMENT. 00567300 EXPV~-EXPV ; 00567400 IF T2 { REALTYPE THEN EMITO(CHS) ELSE 00567500 IF T2 = LOGTYPE THEN FLAG(55) ELSE 00567600 IF T2 = DOUBTYPE THEN EMITO(CHS) ELSE 00567700 IF T2 = COMPTYPE THEN 00567800 BEGIN 00567900 EMITO(CHS); EMITO(XCH); 00568000 EMITO(CHS); EMITO(XCH); 00568100 END ELSE FLAG(55); 00568200 END OF NEG NUMBERS CASE STATEMNT ; 00568300 IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 00568400 CASE CODE OF 00568500 BEGIN 00568600 BEGIN 00568700 EMITO(MUL); 00568800 IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 00568900 OPTYPE[IT~IT-1] ~ REALTYPE; 00569000 END; 00569100 BEGIN TM~ML2; GO RPLUSD END ; 00569200 BEGIN ES2; GO DTIMESC END ; 00569300 BEGIN 00569400 EMITPAIR(0, XCH); 00569500 EMITO(ML2); 00569600 IT ~ IT-1; 00569700 END; 00569800 BEGIN EMITO(ML2); IT ~ IT-1 END; 00569900 BEGIN ES2; E0(XCH); E0(DEL) ; 00570000 DTIMESC: EOL(9); EOL(17); E0(MUL); GO CTYP ; 00570100 END ; 00570200 BEGIN TM~MUL ; 00570300 CTIMESR: EP(9,SND); E0(TM) ; 00570400 CTIMESR1:E0(XCH); EOL(9); E0(TM) ; 00570500 CTIMESR2:E0(XCH); GO CTYP ; 00570600 END ; 00570700 BEGIN TM~MUL; GO CDIVBYD END ; 00570800 MATH(2, 26, COMPTYPE); 00570900 END MULTIPLY CASE STATEMENT; 00571000 00571100 IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 00571200 CASE CODE OF 00571300 BEGIN 00571400 IF T1 = INTYPE AND T2 = INTYPE THEN 00571500 BEGIN EMITO(IDV); IT ~ IT-1 END ELSE 00571600 BEGIN EMITO(DIU); OPTYPE[IT~IT-1] ~ REALTYPE END; 00571700 BEGIN 00571800 EP(9,STD); EP(17,STD); EP(0,XCH); EOL(17); EOL(9); E0(DV2) ; 00571900 GO DTYP ; 00572000 END ; 00572100 MATH(1, 29, COMPTYPE); 00572200 BEGIN 00572300 EMITPAIR(0, XCH); 00572400 EMITO(DV2); 00572500 IT ~ IT-1; 00572600 END; 00572700 BEGIN EMITO(DV2); IT ~ IT-1 END; 00572800 MATH(2, 32, COMPTYPE); 00572900 BEGIN TM~DIU; GO CTIMESR END ; 00573000 BEGIN TM~DIU ; 00573100 CDIVBYD: E0(XCH); E0(DEL); GO CTIMESR ; 00573200 END ; 00573300 MATH(2, 35, COMPTYPE); 00573400 END OF DIVIDE CASE STATEMENT; 00573500 IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 00573600 BEGIN 00573700 IF CODE = 0 AND T2 = INTYPE AND 00573800 CNSTSEENLAST THEN %113-00573900 BEGIN 00574000 IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 00574100 OPTYPE[IT~IT-1] ~ REALTYPE; 00574200 EXPV~LINK; %113- 00574300 A~1; ADR~SAVEADR; %113- 00574400 WHILE EXPV DIV 2 ! 0 DO 00574500 BEGIN 00574600 EMITO(DUP); 00574700 IF BOOLEAN(EXPV) THEN BEGIN A~A+1; EMITO(DUP) END; 00574800 EMITO(MUL); 00574900 EXPV ~ EXPV DIV 2; 00575000 END; 00575100 IF EXPV = 0 THEN BEGIN EMITO(DEL); EMITL(1) END ELSE 00575200 WHILE A ~ A-1 ! 0 DO EMITO(MUL); 00575300 END ELSE 00575400 BEGIN 00575500 EMITO(MKS); 00575600 EMITL(CODE); 00575700 EMITV(NEED(".XTOI ", INTRFUNID)); 00575800 CASE CODE OF 00575900 BEGIN 00576000 BEGIN EMITO(DEL); OPTYPE[IT~IT-1]~IF (T1=INTYPE AND T2=INTYPE)00576100 THEN INTYPE ELSE REALTYPE END; 00576200 BEGIN EMITO(DEL); OPTYPE[IT~IT-1] ~ DOUBTYPE END; 00576300 BEGIN EMITO(DEL); OPTYPE[IT~IT-1]~COMPTYPE END ; 00576400 BEGIN EMITO(DEL); IT ~ IT-1 END; 00576500 BEGIN EMITO(DEL); EMITO(DEL); IT ~ IT-1 END; 00576600 BEGIN EMITO(DEL); EMITO(DEL); OPTYPE[IT~IT-1]~COMPTYPE END ; 00576700 BEGIN EMITO(DEL); IT ~ IT-1 END; 00576800 BEGIN EMITO(DEL); EMITO(DEL); IT ~ IT-1 END; 00576900 BEGIN EMITO(DEL); EMITO(DEL); IT~IT-1 END ; 00577000 END OF POWER CASE STATEMENT; 00577100 END; 00577200 END; 00577300 END; 00577400 IP ~ IP-1; 00577500 END; 00577600 EXPRESLT ~ EXPCLASS; 00577700 STACK: 00577800 PR[IP~IP+1] ~ PREC; 00577900 OPST[IP] ~ OP; 00578000 IF PREC > 0 AND PREC { 4 THEN 00578100 BEGIN 00578200 SCAN; LINK ~ FNEXT; 00578300 IF NEXT = PLUS THEN GO TO LOOP; 00578400 IF NEXT ! MINUS THEN GO TO NOSCAN; 00578500 PREC ~ 8; OP ~ 12; 00578600 GO TO STACK; 00578700 END; 00578800 GO TO LOOP; 00578900 XIT: IF IP ! SAVIP THEN FLOG(56); 00579000 IP ~ SAVIP-1; 00579100 EXPR ~ OPTYPE[IT]; 00579200 IF OPTYPE[IT-1] ! 0 THEN FLOG(56); 00579300 IT ~ SAVIT-1; 00579400 EXPRESULT ~ EXPRESLT; 00579500 EXPVALUE ~ EXPV; 00579600 EXPLINK ~ EXPLNK; 00579700 IF DEBUGTOG THEN FLAGROUTINE(" EXPRE","SSION ",FALSE) ; 00579800 END EXPR; 00579900 00580000 PROCEDURE FAULT (X); 00580100 VALUE X; 00580200 REAL X; 00580300 BEGIN REAL LINK; LABEL XIT; 00580400 SCAN; IF GLOBALNEXT ! LPAREN THEN BEGIN FLAG(106); GO XIT END; 00580500 SCAN; IF GLOBALNEXT ! ID THEN BEGIN FLAG(66); GO TO XIT END; 00580600 IF X = 1 THEN PDPRT[0,0] ~ PDPRT[0,0] & 1[44:47:1] ELSE 00580700 PDPRT[0,0] ~ PDPRT [0,0] & 1[43 :47:1]; 00580800 EMITOPDCLIT(41); EMITO(DUP); 00580900 IF X = 1 THEN BEGIN EMITL(2); EMITO(XCH); EMITL(1) END 00581000 ELSE EMITL(6); 00581100 EMITO(LND); 00581200 IF X = 2 THEN EMITL(3); 00581300 EMITO(SUB); 00581400 IF X = 2 THEN 00581500 BEGIN EMITO(DUP); EMITL(3); EMITO(SSN) ;EMITO(EQUL); EMITL(2)00581600 ;EMITO(BFC) ; EMITO(DEL);EMITL(2); 00581700 END; 00581800 LINK ~ GET(GETSPACE(FNEXT)); EMITPAIR(LINK.ADDR,ISD); 00581900 IF X = 1 THEN EMITL(30) ELSE EMITL(25); 00582000 EMITO(LND); EMITL(41);EMITO(STD); 00582100 SCAN; IF GLOBALNEXT ! RPAREN THEN FLAG(108); 00582200 SCAN; 00582300 XIT: 00582400 END FAULT; 00582500 PROCEDURE SUBREF; 00582600 BEGIN REAL LINK,INFC; 00582700 REAL ACCIDENT; 00582800 LABEL XIT; 00582900 IF DEBUGTOG THEN FLAGROUTINE(" SUB","REF ",TRUE ) ; 00583000 IF TSSEDITOG THEN IF NAME="ZIP " AND NOT DCINPUT THEN TSSED(NAME,3) ; 00583100 IF NAME = "EXIT " THEN 00583200 BEGIN 00583300 RETURNFOUND ~ TRUE; 00583400 EMITL(1); 00583500 EMITPAIR(16,STD); 00583600 EMITPAIR(10,KOM); 00583700 EMITPAIR( 5, KOM); 00583800 PUT(FNEXT+1, "......"); 00583900 SCAN; 00584000 END ELSE IF NAME="ZIP " AND NOT DCINPUT THEN 00584100 BEGIN 00584200 EMITO(MKS); 00584300 EMITL(0); EMITL(0); % DUMMY FILE AND FORMAT 00584400 EMITPAIR(-1,SSN); 00584500 EMITB(-1,FALSE); LADR1~LAX; ADJUST; DESCREQ~FALSE; 00584600 IF ADR } 4085 THEN BEGIN ADR~ADR+1; SEGOVF END; 00584700 ACCIDENT~PRGDESCBLDR(0,0,ADR.[36:10]+1,NSEG); 00584800 EMITOPDCLIT(19); 00584900 EMITO(GFW); 00585000 LISTART ~ ADR&NSEG[TOSEGNO]; ADJUST;SCAN; 00585100 IF GLOBALNEXT!LPAREN THEN BEGIN FLAG(106);GO TO XIT END; 00585200 SCAN; IF GLOBALNEXT!ID THEN BEGIN FLAG(66); GO TO XIT END; 00585300 LINDX ~ FNEXT; SCAN; XTA ~ GET(LINDX+1); 00585400 IF GLOBALNEXT!RPAREN THEN BEGIN FLAG(108); GO TO XIT END; 00585500 LINDX ~ GETSPACE(LINDX); 00585600 IF T~(LINFA~GET(LINDX)).CLASS!ARRAYID THEN 00585700 BEGIN FLAG(66); GO TO XIT END; 00585800 IF XREF THEN ENTERX(XTA,0&LINFA[15:15:9]); 00585900 EMITPAIR(LADDR~LINFA.ADDR,LOD); 00586000 IF BOOLEAN(LINFA.FORMAL) THEN 00586100 BEGIN 00586200 IF T ~ GET(LINDX+2)<0 THEN EMITOPDCLIT(T.SIZE) 00586300 ELSE EMITNUM(T.SIZE); EMITOPDCLIT(LADDR-1); EMITO(CTF) END 00586400 ELSE EMITNUM(GET(LINDX+2).BASENSIZE); EMITL(18); EMITO(STD);; 00586500 EMITL(LINFA.CLASNSUB&0[44:47:1]); EMITL(19); EMITO(STD); 00586600 BRANCHLIT(LISTART,TRUE); EMITL(19); EMITO(STD); 00586700 EMITO(RTS); ADJUST; 00586800 EMITL(1); EMITO(CHS); EMITL(19); EMITO(STD); 00586900 EMITDESCLIT(19); EMITO(RTS); FIXB(LADR1); DESCREQ~FALSE; 00587000 EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 00587100 EMITL(6); % EDITCODE 6 FOR ZIP 00587200 EMITV(NEED(".FTOUT",INTRFUNID)); SCAN 00587300 END ELSE IF NAME = "OVERFL" THEN FAULT(2) 00587400 ELSE IF NAME = "DVCHK " THEN FAULT(1) 00587500 ELSE 00587600 BEGIN 00587700 LINK ~ NEED(NAME, SUBRID); 00587800 IF XREF THEN ENTERX(XTA,0&GET(LINK)[15:15:5]); 00587900 EMITO(MKS); 00588000 SCAN; 00588100 IF GLOBALNEXT = LPAREN THEN 00588200 BEGIN PARAMETERS(LINK); SCAN END ELSE 00588300 IF NOT BOOLEAN((INFC~GET(LINK+2)).[1:1]) THEN 00588400 PUT(LINK+2,-INFC) ELSE 00588500 IF INFC.NEXTRA ! 0 THEN 00588600 BEGIN XTA ~ GET(LINK+1); FLAG(28) END; 00588700 EMITV(LINK); 00588800 END; 00588900 XIT: 00589000 IF DEBUGTOG THEN FLAGROUTINE(" SUB","REF ",FALSE) ; 00589100 END SUBREF; 00589200 00589300 PROCEDURE DECLAREPARMS(FNEW); VALUE FNEW; REAL FNEW; 00589400 BEGIN 00589500 REAL I, T, NLABELS, INFA, INFB, INFC; 00589600 IF DEBUGTOG THEN FLAGROUTINE("DECLAR","EPARMS",TRUE ) ; 00589700 INFA ~ GET(FNEW); 00589800 IF INFA.SEGNO ! 0 THEN BEGIN XTA ~ NNEW; FLAG(25) END; 00589900 INFA.SEGNO ~ NSEG; PUT(FNEW,INFA); 00590000 ENTRYLINK[ELX] ~ 0 & FNEW[TOLINK] & NEXTSS[TOADDR]; 00590100 FOR I ~ 1 STEP 1 UNTIL PARMS DO 00590200 BEGIN 00590300 EXTRAINFO[NEXTSS.IR,NEXTSS.IC] ~ PARMLINK[I]; 00590400 NEXTSS ~ NEXTSS-1; 00590500 IF T ~ PARMLINK[I] ! 0 THEN 00590600 BEGIN 00590700 GETALL(T,INFA,INFB,INFC); 00590800 IF BOOLEAN(INFA .FORMAL) THEN 00590900 BEGIN 00591000 IF INFA.SEGNO = ELX THEN 00591100 BEGIN XTA ~ INFB ; FLAG(26) END; 00591200 END ELSE IF (INFA < 0 AND INFA.ADDR < 1024) OR BOOLEAN(INFA.CE)00591300 THEN BEGIN XTA ~ INFB; FLAG(107) END; 00591400 INFA ~ INFA & 1[TOFORMAL] & ELX[TOSEGNO]; 00591500 INFC .BASE ~ I; 00591600 PUT(T,INFA); PUT(T+2,INFC); 00591700 END ELSE NLABELS ~ NLABELS+1; 00591800 END; 00591900 IF NLABELS > 0 THEN 00592000 BEGIN ENTRYLINK[ELX ].CLASS ~ NLABELS; 00592100 IF LABELMOM=0 THEN BEGIN BUMPLOCALS; LABELMOM~LOCALS+1536 END; 00592200 END; 00592300 GETALL(FNEW,INFA,INFB,INFC); 00592400 IF BOOLEAN(INFC.[1:1]) THEN 00592500 BEGIN 00592600 IF INFC.NEXTRA ! PARMS THEN 00592700 BEGIN XTA ~ INFB; FLOG(41); 00592800 PARMS ~ INFC.NEXTRA; 00592900 END; 00593000 T ~ INFC.ADINFO; 00593100 FOR I ~ 1 STEP 1 UNTIL PARMS DO 00593200 IF NOT(PARMLINK[I] = 0 EQV 00593300 EXTRAINFO[(T+I-1).IR,(T+I-1).IC].CLASS = LABELID) THEN 00593400 BEGIN IF PARMLINK[I] = 0 THEN XTA ~ "* " 00593500 ELSE XTA ~ GET(PARMLINK[I]+1); 00593600 FLAG(40); 00593700 END; 00593800 END 00593900 ELSE 00594000 BEGIN 00594100 IF PARMS = 0 THEN INFC ~ -INFC ELSE 00594200 INFC ~ -(INFC & PARMS[TONEXTRA] 00594300 & NEXTEXTRA[TOADINFO]); 00594400 PUT(FNEW+2,INFC); 00594500 FOR I ~ 1 STEP 1 UNTIL PARMS DO 00594600 BEGIN 00594700 EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ 0 & 00594800 (IF PARMLINK[I] = 0 THEN LABELID ELSE 0)[TOCLASS]; 00594900 NEXTEXTRA ~ NEXTEXTRA+1; 00595000 END; 00595100 END; 00595200 IF ELX ~ ELX+1 > MAXEL THEN BEGIN FLAG(128); ELX ~ 0 END; 00595300 IF DEBUGTOG THEN FLAGROUTINE("DECLAR","EPARMS",FALSE) ; 00595400 END DECLAREPARMS; 00595500 PROCEDURE IOLIST(LEVEL); REAL LEVEL; 00595600 BEGIN ALPHA LADR2,T; 00595700 BOOLEAN A; 00595800 INTEGER INDX,I,BDLINK,NSUBS; 00595900 LABEL ROUND,XIT,ERROR,LOOP,SCRAM; 00596000 INTEGER STREAM PROCEDURE CNTNAM(IDEN); VALUE IDEN; 00596100 BEGIN LABEL XIT; 00596200 SI ~ LOC IDEN; SI ~ SI + 3; TALLY ~ 1; 00596300 5(IF SC = " " THEN JUMP OUT TO XIT;SI ~ SI+1;TALLY ~ TALLY+1); 00596400 XIT: CNTNAM ~ TALLY; 00596500 END CNTNAM; 00596600 IF DEBUGTOG THEN FLAGROUTINE(" IOL","IST ",TRUE ) ; 00596700 ROUND: DESCREQ ~ TRUE; 00596800 LOCALNAME ~ FALSE; 00596900 IF GLOBALNEXT = SEMI THEN GO TO XIT; 00597000 IF GLOBALNEXT = STAR THEN 00597100 BEGIN IF NOT NAMEDESC THEN 00597200 TV ~ ENTER(0&LISTSID[TOCLASS],LISTID~LISTID+1); 00597300 LOCALNAME ~ TRUE; NAMEDESC ~ TRUE; SCAN; 00597400 END; 00597500 IF GLOBALNEXT = ID THEN 00597600 BEGIN LINDX ~ FNEXT; 00597700 SCAN; XTA ~ GET(LINDX+1); 00597800 IF GLOBALNEXT = EQUAL THEN %RETURN TO CALLER 00597900 BEGIN IF (LINFA~GET(GETSPACE(LINDX))).CLASS ! VARID THEN FLAG(50);00598000 SCRAM: IF (LEVEL ~ LEVEL-1) < 0 THEN FLOG(97); 00598100 GO TO XIT; 00598200 END; 00598300 00598400 IF DATASTMTFLAG AND SPLINK } 0 THEN %DECLARE OWN 00598500 BEGIN 00598600 IF BOOLEAN(GET(LINDX).FORMAL) THEN FLAG(147); 00598700 IF SPLINK>1 THEN 00598800 IF GET(LINDX).ADDR>1023 THEN FLAG(174); 00598900 LINDX ~ GETSPACE(-LINDX); 00599000 IF BOOLEAN(GET(LINDX).EQ) THEN FLAG(168); 00599100 END ELSE LINDX ~ GETSPACE(LINDX); 00599200 IF T ~ (LINFA~GET(LINDX)).CLASS > VARID THEN FLAG(50); 00599300 IF XREF THEN ENTERX(XTA,C2&LINFA[15:15:9]); 00599400 IF GLOBALNAME OR LOCALNAME THEN 00599500 IF NAMEIND~ NAMEIND+1 GTR LSTMAX THEN FLOG(161) 00599600 ELSE NAMLIST[NAMEIND] ~ XTA & CNTNAM(XTA)[9:45:3]; 00599700 IF T = ARRAYID THEN 00599800 IF GLOBALNEXT ! LPAREN THEN 00599900 BEGIN IF SPLINK ! 1 THEN 00600000 BEGIN 00600100 EMITL(0); 00600200 EMITPAIR(LADDR ~ LINFA.ADDR,LOD); 00600300 EMITO(FTC); 00600400 EMITDESCLIT(2); 00600500 EMITO(INX); 00600600 EMITO(LOD); 00600700 END ELSE EMITPAIR(LADDR-LINFA.ADDR,LOD); 00600800 NSUBS ~ (T ~ GET (LINDX+2)).NEXTRA; 00600900 IF GLOBALNAME OR LOCALNAME THEN 00601000 BEGIN 00601100 IF NSUBS GTR SAVESUBS THEN SAVESUBS ~ NSUBS; 00601200 IF NSUBS GTR NAMLIST[0] THEN NAMLIST[0] ~ NSUBS; 00601300 NAMLIST[NAMEIND].[1:8] ~ NSUBS; 00601400 INDX ~ -1; 00601500 INFA ~ GET(NEED(".SUBAR",BLOCKID)).ADDR; 00601600 BDLINK ~ T.ADINFO+1; 00601700 END; 00601800 IF BOOLEAN (LINFA.FORMAL) THEN 00601900 BEGIN 00602000 IF T LSS 0 THEN EMITOPDCLIT(T.SIZE) 00602100 ELSE EMITNUM(T.SIZE); 00602200 EMITOPDCLIT(LADDR-1); 00602300 EMITO(CTF); 00602400 END ELSE EMITNUM(T.BASENSIZE); 00602500 IF GLOBALNAME OR LOCALNAME THEN 00602600 FOR I ~ 1 STEP 1 UNTIL NSUBS DO 00602700 BEGIN IF T ~ EXTRAINFO[(BDLINK~BDLINK-1).IR, 00602800 BDLINK.IC] LSS 0 THEN EMITOPDCLIT(T) 00602900 ELSE EMITNUM(T); 00603000 EMITNUM(INDX ~ INDX+1); 00603100 EMITDESCLIT(INFA); 00603200 EMITO(STD); 00603300 END; 00603400 EMITL(18); EMITO(STD); 00603500 END ELSE 00603600 BEGIN SCAN; 00603700 A ~(IF GLOBALNAME OR LOCALNAME 00603800 THEN SUBSCRIPTS(LINDX,4) ELSE SUBSCRIPTS(LINDX,2)); 00603900 SCAN; 00604000 END 00604100 ELSE EMITN(LINDX); 00604200 IF GLOBALNAME OR LOCALNAME THEN 00604300 BEGIN EMITOPDCLIT(18); EMITNUM(NAMEIND); 00604400 EMITD(43,DIA); EMITD(3,DIB); EMITD(15,TRB); 00604500 EMITL(18); EMITO(STD); 00604600 END; 00604700 EMITL(LINFA.CLASNSUB&0[44:47:1]); 00604800 EMITL(20); EMITO(STD); 00604900 IF ADR > 4083 THEN 00605000 BEGIN ADR~ADR+1; SEGOVF END ; 00605100 BRANCHLIT(LISTART,TRUE); 00605200 EMITL(19); EMITO(STD); 00605300 EMITO(RTS); ADJUST; 00605400 GO TO LOOP; 00605500 END; 00605600 IF GLOBALNEXT = LPAREN THEN % RECURSE ON ( 00605700 BEGIN EMITB(-1,FALSE); 00605800 ADJUST; 00605900 LADR2 ~ (ADR + 1)&LAX[TOADDR]&NSEG[TOSEGNO]; 00606000 SCAN; LEVEL ~ LEVEL + 1; 00606100 IOLIST(LEVEL); 00606200 IF GLOBALNEXT ! EQUAL THEN % PHONY IMP DO 00606300 BEGIN BRANCHES[T ~ LADR2.ADDR] ~ BRANCHX; 00606400 BRANCHX ~ T; 00606500 IF GLOBALNEXT ! RPAREN THEN GO TO ERROR; 00606600 SCAN; GO TO LOOP; 00606700 END; 00606800 IF XREF THEN ENTERX(GET(LINDX+1),1&LINFA[15:15:9]); 00606900 IF LINFA.SUBCLASS > REALTYPE THEN 00607000 BEGIN XTA ~ GET(LINDX + 1); 00607100 FLAG(84); 00607200 END; 00607300 EMITB(-1,FALSE); 00607400 LADR3 ~ LAX; 00607500 FIXB(LADR2.ADDR); 00607600 DESCREQ ~ FALSE; 00607700 SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102); % INITIAL VALUE 00607800 EMITN(LINDX); EMITO(STD); 00607900 EMITB(LADR2,FALSE); 00608000 IF GLOBALNEXT ! COMMA THEN GO TO ERROR; 00608100 ADJUST; 00608200 LADR4 ~ (ADR + 1)&NSEG[TOSEGNO]; 00608300 SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102) ELSE EMITO(GRTR); 00608400 EMITB(LADR2,TRUE); 00608500 EMITB(-1,FALSE); 00608600 LADR5 ~ LAX; 00608700 FIXB(LADR3); 00608800 IF GLOBALNEXT ! COMMA THEN EMITL(1) 00608900 ELSE BEGIN SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102); END; 00609000 EMITV(LINDX); EMITO(ADD); 00609100 EMITN(LINDX); EMITO(SND); 00609200 EMITB(LADR4,FALSE); 00609300 FIXB(LADR5); 00609400 IF GLOBALNEXT = RPAREN THEN SCAN ELSE GO TO ERROR; 00609500 LOOP: IF GLOBALNEXT = SEMI OR GLOBALNEXT = SLASH THEN GO TO XIT; 00609600 IF GLOBALNEXT = RPAREN THEN GO TO SCRAM; 00609700 IF GLOBALNEXT = COMMA THEN 00609800 BEGIN SCAN; 00609900 IF GLOBALNEXT = SEMI THEN GO TO ERROR; 00610000 GO TO ROUND; 00610100 END; 00610200 ERROR: XTA ~ NAME; 00610300 FLAG(94); 00610400 IF GLOBALNEXT = SEMI THEN GO TO XIT; 00610500 SCAN; 00610600 IF GLOBALNEXT = ID THEN GO TO ROUND; 00610700 ERRORTOG ~ TRUE; GO TO XIT; 00610800 END; 00610900 IF GLOBALNEXT = RPAREN THEN GO TO SCRAM ELSE 00611000 IF GLOBALNEXT ! SLASH THEN GO TO ERROR; 00611100 XIT: IF DEBUGTOG THEN FLAGROUTINE(" IOL","IST ",FALSE) ; 00611200 END IOLIST; 00611300 INTEGER PROCEDURE FILECHECK(FILENAME,FILETYPE); 00611400 VALUE FILENAME,FILETYPE; ALPHA FILENAME; INTEGER FILETYPE; 00611500 BEGIN COMMENT THIS PROCEDURE RETURNS THE PRT CELL ALLOCATED TO 00611600 THE FILE FILENAME... A CELL IS CREATED IF NONE EXISTS; 00611700 IF DEBUGTOG THEN FLAGROUTINE(" FILEC","HECK ",TRUE); 00611800 EMITL(IF NOTOPIO THEN 2 ELSE 5); % FOR IO DESCRIPTOR 00611900 IF T ~ GLOBALSEARCH(FILENAME) = 0 THEN % FILE UNDECLARED 00612000 BEGIN MAXFILES ~ MAXFILES + 1; 00612100 BUMPPRT; 00612200 I ~ GLOBALENTER(-0&(FILECHECK~PRTS)[TOADDR] 00612300 &FILEID[TOCLASS],FILENAME)+2; 00612400 INFO[I.IR,I.IC]. LINK ~ FILETYPE; 00612500 END ELSE % FILE ALREADY EXISTS 00612600 FILECHECK ~ GET(T).ADDR; 00612700 IF DEBUGTOG THEN FLAGROUTINE(" FILEC","HECK ",FALSE) ; 00612800 END FILECHECK; 00612900 PROCEDURE INLINEFILE; 00613000 BEGIN COMMENT THIS PROCEDURE GENERATES THE CODE TO BRING UP THE FILE...00613100 IF THE FILE IS AN INTEGER THEN FILECHECK IS CALLED, IF THE FILE 00613200 IS NOT AN INTEGER THEN IN-LINE CODE IS GENERATED FOR OBJECT TIME 00613300 ANALYSIS; 00613400 REAL TEST; 00613500 COMMENT IF LAST INSTRUCTION WAS A LIT CALL THEN WE HAVE SEEN REFERENCE 00613600 TO AN INTEGER FILE ID; 00613700 IF DEBUGTOG THEN FLAGROUTINE(" INLIN","EFILE ",TRUE ) ; 00613800 TEST~ADR ; 00613900 IF EXPR(TRUE)>REALTYPE THEN FLAG(102) 00614000 ELSE IF EXPRESULT=NUMCLASS THEN 00614100 BEGIN XTA~NNEW ; 00614200 IF EXPVALUE}1.0@5 OR EXPVALUE{0.5 THEN FLAG(33) 00614300 ELSE BEGIN 00614400 IF ADR LSTMAX THEN GO TO NUL; 00633400 WSA[TOTAL] ~ I ~ 0; GO TO ROUND; 00633500 END ELSE GO TO ROUND ELSE GO TO NUL1; 00633600 END; 00633700 IF NOT STRINGF THEN 00633800 IF SLCNT > 0 THEN 00633900 IF T = "/" THEN BEGIN SLCNT ~ SLCNT+1; GO TO ROUND; END 00634000 ELSE 00634100 BEGIN WSA[TOTAL] ~ 0 & SLCNT[TOREPEAT] & SLASH[TOCODE]; 00634200 IF NOT STR THEN 00634300 IF REPEAT < 16 AND WSA[TOTAL-1].[42:6] = 0 THEN 00634400 WSA[TOTAL~TOTAL-1] ~ WSA[TOTAL] & SLCNT[42:44:4] 00634500 & 1[46:47:1]; 00634600 COMMAS~DOLLARS~BOOLEAN(SLCNT~0); NCR~BACKNCR(NCR) ; 00634700 GO TO NUL1; 00634800 END; 00634900 IF NOT QF THEN IF T = """ THEN IF STRINGF ~ NOT STRINGF THEN 00635000 BEGIN IF CODE > 4 THEN BEGIN STRINGF ~ FALSE; 00635100 NCR ~ BACKNCR(NCR); GO TO ENDER END; 00635200 SAVTOTAL ~ TOTAL; J~0; I~3; QF ~ TRUE; 00635300 WSA[TOTAL] ~ 0 & HPHASE[TOCODE]; 00635400 GO TO ROUND; 00635500 END ELSE 00635600 BEGIN 00635700 WSA[SAVTOTAL] ~ WSA[SAVTOTAL] & J[TOREPEAT]; 00635800 IF I = 0 THEN TOTAL ~ TOTAL - 1; 00635900 CODE ~ HPHASE; 00636000 GO TO ENDER; 00636100 END; 00636200 IF STRINGF THEN 00636300 BEGIN 00636400 STORECHAR(WSA[TOTAL],I,T); 00636500 J ~ J + 1; QF ~ FALSE; 00636600 IF I ~ I+1 = 8 THEN 00636700 BEGIN 00636800 IF TOTAL ~ TOTAL +1> LSTMAX THEN GO TO NUL; 00636900 I ~ WSA[TOTAL] ~ 0; 00637000 END; 00637100 GO TO ROUND; 00637200 END; 00637300 CASE T OF 00637400 BEGIN 00637500 BEGIN ZF ~ TRUE; % 0 00637600 NUM: DECIMAL ~ 10 | DECIMAL + T; 00637700 IF ASK THEN 00637800 BEGIN FLAG(183); %111-00637900 FL: DO BEGIN NCR~GETCHAR(NCR,T); XTA~T&XTA[12:18:30] END 00638000 UNTIL T!"*" AND T>9 AND T!" " ; 00638100 NCR~BACKNCR(NCR); XTA~BLANKS&XTA[18:12:30] ; 00638200 END 00638300 ELSE 00638400 IF DECIMAL>4090 THEN BEGIN FLAG(172); DECIMAL~1 END ; 00638500 IF CODE = 0 THEN REPEAT ~ DECIMAL 00638600 ELSE IF PF THEN BEGIN IF DECIMAL>WIDTH AND WIDTH!0 AND CODE! 00638700 VPHRASE THEN FLAG(129) END ELSE WIDTH~DECIMAL ; 00638800 GO TO ROUND; 00638900 END; 00639000 GO TO NUM; GO TO NUM; GO TO NUM; % 1 2 3 00639100 GO TO NUM; GO TO NUM; GO TO NUM; % 4 5 6 00639200 GO TO NUM; GO TO NUM; GO TO NUM; % 7 8 9 00639300 ; ; ; ; ; ; % # @ Q : > } 00639400 BEGIN PLUSP ~ TRUE; GO TO ROUND; END; % + 00639500 BEGIN CODE ~ APHASE; GO TO NOEND END; % A 00639600 ; % B 00639700 BEGIN CODE ~ CPHASE; GO TO NOEND END; % C 00639800 BEGIN CODE ~ DPHASE; GO TO NOEND END; % D 00639900 BEGIN CODE ~ EPHASE; GO TO NOEND END; % E 00640000 BEGIN CODE ~ FPHASE; GO TO NOEND END; % F 00640100 BEGIN CODE ~ GPHASE; GO TO NOEND END; % G 00640200 BEGIN IF REPEAT = 0 THEN FLOG(130); % H 00640300 IF ASK THEN BEGIN FLOG(32 ); GO SEMIC END ; 00640400 HF ~ TRUE; I ~ 3; CODE ~ HPHASE; 00640500 WSA[TOTAL] ~ 0 & HPHASE[TOCODE] & REPEAT[TOREPEAT]; 00640600 GO TO ROUND; 00640700 END; 00640800 BEGIN CODE ~ IPHASE; GO TO NOEND END; % I 00640900 BEGIN IF CODE < 11 OR CODE=15 THEN FLOG(134); % . 00641000 IF CODE=0 OR PF THEN FLOG(32) ; 00641100 PF~TRUE; DECIMAL~0; ASK~ZF~FALSE ; 00641200 GO TO ROUND; 00641300 END; 00641400 GO TO RP; % [ 00641500 ; % & 00641600 LP: 00641700 BEGIN IF CODE ! 0 THEN FLOG(32); % ( 00641800 IF ASK THEN REPEAT~4095; IF REPEAT=0 AND ZF THEN FLAG(173) ;00641900 NAMLIST[SAVLASTLP ~ PARENCT ~ PARENCT+1] ~ 0 & TOTAL[TOWIDTH]00642000 &(IF REPEAT{0 AND PARENCT>1 THEN 1 ELSE REPEAT)[TOREPEAT] ; 00642100 IF ASK THEN 00642200 BEGIN ASK~VRB~FALSE ; 00642300 WSA[TOTAL]~32&LPPHRASE[TOCODE]&4095[TOREPEAT] ; 00642400 IF (TOTAL~TOTAL+1)>LSTMAX THEN GO NUL ; 00642500 END ; 00642600 ZF~BOOLEAN(REPEAT~DECIMAL~0) ; 00642700 STR ~ TRUE; 00642800 GO TO ROUND1; 00642900 END; 00643000 ; ; ; % < ~ | 00643100 BEGIN CODE~JPHASE; WIDTH~-1; GO NOEND END ; % J 00643200 BEGIN % K 00643300 IF COMMAS OR CODE!0 THEN BEGIN FLAG(32); COMMAS~TRUE END 00643400 ELSE BEGIN COMMAS~TRUE ; 00643500 KK: DO BEGIN NCR~GETCHAR(NCR,T); XTA~T&XTA[12:18:30] END 00643600 UNTIL T!" " ; 00643700 IF (T<17 OR (T>25 AND T<33) OR (T>42 AND T<50) OR T>57) 00643800 THEN BEGIN FLAG(32) ; 00643900 IF T="*" OR T<10 THEN BEGIN DECIMAL~1; GO FL END ; 00644000 END ; 00644100 NCR~BACKNCR(NCR); XTA~BLANKS&XTA[18:12:30] ; 00644200 END ; 00644300 GO ROUND ; 00644400 END OF K ; 00644500 BEGIN CODE ~ LPHASE; GO TO NOEND; END; % L 00644600 ; ; % M N 00644700 BEGIN CODE ~ OPHASE; GO TO NOEND; END; % O 00644800 BEGIN WSA[TOTAL] ~ 0 & PPHASE[TOCODE] % P 00644900 & REAL(VRB)[42:47:1] 00645000 & REAL(MINUSP)[TOSIGN] & REPEAT[TOWIDTH]&1[TOREPEAT]; 00645100 MINUSP ~ PLUSP ~ FALSE; 00645200 IF (DECIMAL = 0 AND NOT ZF) THEN FLOG(131); 00645300 GO TO NUL1; 00645400 END; 00645500 ; ; % Q R 00645600 BEGIN IF DOLLARS OR CODE!0 THEN FLAG(32) % $ 00645700 ELSE BEGIN DOLLARS~TRUE; GO KK END ; 00645800 DOLLARS~TRUE; GO ROUND ; 00645900 END OF DOLLAR SIGN ; 00646000 IF NOT ASK THEN % * 00646100 BEGIN 00646200 IF ZF OR DECIMAL NEQ 0 THEN FLAG(183); DECIMAL:=4095; %111-00646300 IF CODE=0 THEN REPEAT~DECIMAL 00646400 ELSE IF NOT PF THEN WIDTH~DECIMAL ; 00646500 VRB := ASK := LISTEL := TRUE; GO ROUND; %101-00646600 END ELSE BEGIN DECIMAL:=4095; FLAG(183); GO FL END ; %111-00646700 BEGIN MINUSP ~ TRUE; GO TO ROUND; END; % - 00646800 RP: 00646900 BEGIN IF FIELD THEN BEGIN NCR ~ BACKNCR(NCR); % ) 00647000 GO TO ENDER; END; 00647100 IF DECIMAL ! 0 THEN FLAG(32); 00647200 I ~ IF PARENCT = 1 THEN IF SAVLASTLP > 1 THEN 2 ELSE 1 00647300 ELSE PARENCT; 00647400 WSA[TOTAL]~(J~NAMLIST[I])&(TOTAL+1-J~J.[18:12])[TOLINK] 00647500 & (IF PARENCT ~ PARENCT-1 = 0 THEN 77 ELSE 0)[TODECIMAL]; 00647600 IF WSA[J].[1:5]=LPPHRASE AND PARENCT!0 THEN 00647700 BEGIN WSA[J].[18:12]~TOTAL-J; WSA[TOTAL].[18:12]~TOTAL-J ;00647800 END ; 00647900 NAMLIST[I].[6:12] ~ 0; 00648000 CODE ~ HPHASE; 00648100 GO TO NUL1; 00648200 END; 00648300 ; ; % ; LEQ 00648400 GO TO ROUND; % BLANKS 00648500 BEGIN SLCNT ~ 1; % / 00648600 SL: IF CODE=0 THEN IF ASK OR ZF OR DECIMAL!0 THEN 00648700 BEGIN FLAG(32); ASK~ZF~BOOLEAN(DECIMAL~0) END ; 00648800 IF CODE<5 THEN IF T="," THEN GO ROUND1 ELSE GO ROUND ELSE GO 00648900 ENDER ; 00649000 END; 00649100 ; % S 00649200 BEGIN IF REPEAT ! 0 THEN FLAG(32); % T 00649300 CODE ~ TPHASE; 00649400 GO TO NOEND; 00649500 END; 00649600 ; % U 00649700 BEGIN VRB~TRUE; CODE~VPHRASE; WIDTH~-1; GO NOEND END ; % V 00649800 ; % W 00649900 BEGIN IF REPEAT = 0 THEN FLOG(130); % X 00650000 IF STR THEN 00650100 NEWWD: WSA[TOTAL] ~ 0 & XPHASE[TOCODE] & REPEAT[TOWIDTH] 00650200 & 1[TOREPEAT] 00650300 & REAL(VRB)[42:47:1] 00650400 ELSE 00650500 BEGIN 00650600 IF (J~WSA[TOTAL-1]).[42:6]>0 OR (I~J.[1:5])=RTPARN 00650700 OR (REPEAT}32 AND I!XPHASE) THEN GO NEWWD ; 00650800 IF I=XPHASE AND (I~J.[18:12]+REPEAT){4090 THEN 00650900 WSA[TOTAL~TOTAL-1] ~ J & I[TOWIDTH] 00651000 ELSE IF REPEAT } 32 THEN GO TO NEWWD 00651100 ELSE WSA[TOTAL~TOTAL-1] ~ J & REPEAT[TONUM] 00651200 & 1[TOCNTRL]; 00651300 END; 00651400 GO TO NUL1; 00651500 END; 00651600 ; ; % Y Z 00651700 GO SL ; % , 00651800 GO TO LP; % % 00651900 ; ; ; % ! = ] " 00652000 END OF CASE STATEMENT; 00652100 FLOG(132); % ILLEGAL CHARACTER; 00652200 GO TO FALL; 00652300 ENDER: IF CODE > 4 THEN 00652400 BEGIN IF WIDTH=0 THEN FLAG(130) ; 00652500 IF CODE=VPHRASE THEN 00652600 BEGIN 00652700 IF WIDTH=-1 THEN IF PF THEN FLAG(130)ELSE WIDTH~ 00652800 DECIMAL~4094 ELSE 00652900 IF NOT PF THEN DECIMAL~4094 ; 00653000 END 00653100 ELSE 00653200 IF CODE > 10 AND CODE ! 15 THEN 00653300 IF (DECIMAL = 0 AND NOT ZF) OR NOT PF THEN FLAG(133) 00653400 ELSE ELSE DECIMAL ~ 0; 00653500 IF REPEAT=0 THEN REPEAT~1 ; 00653600 IF WIDTH=-1 THEN WIDTH~0 ; 00653700 WSA[TOTAL] ~ 0 & CODE[TOCODE] & WIDTH[TOWIDTH] 00653800 & REPEAT[TOREPEAT] & DECIMAL[TODECIMAL] 00653900 & REAL(COMMAS) [44:47:1] 00654000 & REAL(VRB)[42:47:1] 00654100 & REAL(DOLLARS)[45:47:1]; 00654200 END ELSE IF DECIMAL ! 0 THEN FLAG(32); 00654300 NUL1: IF PLUSP THEN FLAG(164); 00654400 IF CODE!VPHRASE THEN 00654500 BEGIN 00654600 IF DOLLARS AND(CODE < 9 OR CODE > 14) THEN FLAG(166); 00654700 IF COMMAS AND NOT(CODE = 10 OR CODE = 12 OR CODE = 9) 00654800 THEN FLAG(165); 00654900 END; 00655000 VRB~ 00655100 ERRORTOG ~ FIELD ~ PF ~ PLUSP ~ DOLLARS ~ COMMAS ~ STR ~ FALSE; 00655200 IF CODE = HPHASE THEN STR ~ TRUE; 00655300 CODE ~ REPEAT ~ WIDTH ~ 0; 00655400 XTA ~ BLANKS; 00655500 GO TO FALL; 00655600 NOEND: IF FIELD THEN FLAG(32); 00655700 IF CODE ! TPHASE THEN LISTEL ~ TRUE ELSE REPEAT ~ 1; 00655800 IF REPEAT=0 AND ZF THEN FLAG(173) ; 00655900 FIELD ~ TRUE; 00656000 FALL: IF MINUSP THEN BEGIN FLAG(32); MINUSP ~ FALSE END; 00656100 ASK~ZF~FALSE ; 00656200 NUL: DECIMAL ~ 0; 00656300 IF PARENCT = 0 THEN BEGIN SCN ~ 1; GO TO SEMIC END; 00656400 IF CODE < 5 THEN 00656500 IF TOTAL ~ TOTAL+1 > LSTMAX THEN 00656600 BEGIN FLOG(78);TOTAL ~ TOTAL-2; GO TO SEMIC; END; 00656700 GO TO ROUND; 00656800 NOPLACE: IF(DCINPUT OR FREEFTOG) AND (STRINGF OR HF) THEN FLOG(150); 00656900 IF TSSEDITOG THEN IF (STRINGF OR HF) AND NOT DCINPUT 00657000 THEN TSSED(XTA,1); 00657100 IF CONTINUE THEN IF READACARD THEN 00657200 BEGIN IF LISTOG THEN PRINTCARD; GO TO ROUND; END; 00657300 SCN ~ 0; NEXT ~ SEMI; 00657400 SEMIC: 00657500 IF SCN = 1 THEN SCAN; 00657600 IF STRINGF THEN FLAG(22); 00657700 IF NOT LISTEL THEN WSA[0] ~ 0; 00657800 IF PARENCT ! 0 THEN FLAG(IF PARENCT < 0 THEN 9 ELSE 8); 00657900 IF D ! 0 THEN PRTSAVER(D,TOTAL+1,WSA); 00658000 IF DEBUGTOG THEN BEGIN 00658100 WRITE(LINE,FM) ; 00658200 FOR I~0 STEP 1 UNTIL TOTAL DO BEGIN 00658300 WRITE(LINE,[13]//,I,(J~WSA[I]).[1:5],J.[6:12],J.[18:12],J.[30:12], 00658400 J.[41:1],J.[42:4],J.[42:5],J.[44:1],J.[45:1], 00658500 J.[46:1],J.[46:2],J.[47:1]) ; 00658600 IF J.[1:5]=2 THEN I~I+(J.[6:12]+2).[36:9] ; 00658700 END ; 00658800 WRITE(LINE[DBL]) ; 00658900 END OF DEBUGSTUFF ; 00659000 END FORMATER; 00659100 00659200 PROCEDURE EXECUTABLE; 00659300 BEGIN LABEL XIT; REAL T, J, TS, P; 00659400 IF SPLINK < 0 THEN FLAG(12); 00659500 IF LABL = BLANKS THEN GO TO XIT; 00659600 IF T ~ SEARCH(XTA ~ LABL) = 0 THEN 00659700 T ~ ENTER(-0 & LABELID[TOCLASS] & (ADR+1)[TOADDR] & 00659800 NSEG[TOSEGNO], LABL) ELSE 00659900 BEGIN IF (P ~ GET(T)).CLASS ! LABELID THEN 00660000 BEGIN FLAG(144); GO TO XIT END; 00660100 IF P < 0 THEN BEGIN FLAG(20); GO TO XIT END; 00660200 TS ~ P.ADDR; 00660300 WHILE TS ! 0 DO 00660400 BEGIN J ~ GIT(TS); FIXB(TS+10000); TS ~ J END; 00660500 PUT(T, P~-P & (ADR+1)[TOADDR] & NSEG[TOSEGNO]); 00660600 IF (T ~ GET(T+2)).BASE ! 0 THEN 00660700 T ~ PRGDESCBLDR(2, T.BASE, (ADR+1).[36:10], NSEG); 00660800 END; 00660900 IF XREF THEN ENTERX(LABL,1&LABELID[TOCLASS]); 00661000 XIT: 00661100 END EXECUTABLE; 00661200 00661300 PROCEDURE IOCOMMAND(N); VALUE N; REAL N; 00661400 COMMENT N COMMAND 00661500 0 READ 00661600 1 WRITE 00661700 2 PRINT 00661800 3 PUNCH 00661900 4 BACKSPACE 00662000 7 DATA; 00662100 BEGIN LABEL XIT,SUCH,LISTER,NOFORM,FORMER,WRAP,DAAT,NF; 00662200 LABEL LISTER1; 00662300 BOOLEAN SUCHTOG, RDTRIN, FREEREAD; 00662400 BOOLEAN FORMARY, NOFORMT; 00662500 BOOLEAN NAMETOG; 00662600 DEFINE DATATOG = DATASTMTFLAG#; 00662700 REAL T, ACCIDENT, EDITCODE; 00662800 REAL DATAB; 00662900 PROCEDURE ACTIONLABELS(UNSEEN); VALUE UNSEEN; BOOLEAN UNSEEN; 00663000 BEGIN LABEL EOF,ERR,RATA,XIT,ACTION,MULTI; 00663100 BOOLEAN BACK,GOTERR,GOTEOF; 00663200 IF UNSEEN THEN SCAN; 00663300 EOF: IF GOTEOF THEN GO TO MULTI; 00663400 IF BACK ~ NAME = "END " THEN GO TO ACTION; 00663500 ERR: IF GOTERR THEN GO TO MULTI; 00663600 IF NAME ! "ERR " THEN IF GOTEOF THEN 00663700 BEGIN MULTI: XTA ~ NAME; FLOG(137); 00663800 GO TO XIT; 00663900 END ELSE GO TO RATA; 00664000 ACTION: SCAN; 00664100 IF NEXT = EQUAL THEN SCAN ELSE GO TO RATA; 00664200 IF NEXT ! NUM THEN GO TO RATA; 00664300 IF XREF THEN ENTERX(NAME,0&LABELID[TOCLASS]); 00664400 IF BACK THEN NX1 ~ NAME ELSE NX2 ~ NAME; 00664500 SCAN; IF NEXT = RPAREN THEN GO TO XIT; 00664600 IF NEXT = COMMA THEN SCAN ELSE GO TO RATA; 00664700 IF BACK THEN 00664800 BEGIN BACK ~ NOT ( GOTEOF ~ TRUE); 00664900 GO TO ERR; 00665000 END; 00665100 GOTERR ~ TRUE; 00665200 GO TO EOF; 00665300 RATA: XTA ~ NAME; FLOG(0); 00665400 XIT: 00665500 END ACTIONLABELS; 00665600 IF DEBUGTOG THEN FLAGROUTINE(" IOCOM","MAND ",TRUE ); 00665700 EODS~N!7 ; 00665800 C2 ~ IF N = 0 OR N = 7 THEN 1 ELSE 0; 00665900 SCAN; IF NEXT = SEMI THEN BEGIN FLOG(0); GO TO XIT END; 00666000 IF N = 7 THEN 00666100 BEGIN DATATOG ~ TRUE; 00666200 IF LOGIFTOG THEN FLAG(101); 00666300 LABL ~ BLANKS; 00666400 IF SPLINK } 0 THEN %NOT BLOCK DATA STMT 00666500 BEGIN 00666600 IF DATAPRT=0 THEN BEGIN 00666700 DATAPRT~PRTS~PRTS+1; ADJUST; 00666800 DATASTRT~(ADR+1)&NSEG[TOSEGNO] END 00666900 ELSE FIXB(DATALINK); 00667000 EMITOPDCLIT(DATAPRT); EMITO(LNG); 00667100 EMITB(-1, TRUE); DATAB ~ LAX; 00667200 END; 00667300 GO TO DAAT; 00667400 END; 00667500 EXECUTABLE; 00667600 EMITO(MKS); 00667700 IF N = 4 THEN 00667800 BEGIN 00667900 INLINEFILE; 00668000 BEGIN EMITL(0); EMITL(0); EMITL(0); EMITL(0); 00668100 EMITL(5); EMITL(0); EMITL(0); 00668200 EMITV(NEED(".FBINB",INTRFUNID)); 00668300 END; 00668400 GO TO XIT; 00668500 END; 00668600 EDITCODE ~ NX1 ~ NX1 ~ 0; 00668700 IF RDTRIN ~ 00668800 N = 0 THEN IF NEXT = LPAREN THEN GO TO SUCH 00668900 ELSE EMITDESCLIT(FILECHECK(".5 ",2+17|REAL %503-00669000 (REMOTETOG))) 00669100 ELSE IF N = 1 THEN IF NEXT ! LPAREN THEN FLAG(33) 00669200 ELSE GO TO SUCH 00669300 ELSE IF N = 2 THEN %503-00669400 EMITDESCLIT(FILECHECK(".6 ",2+17|REAL %503-00669500 (REMOTETOG))) 00669600 ELSE EMITDESCLIT(FILECHECK(".PUNCH",0)); 00669700 IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 00669800 GO TO FORMER; 00669900 SUCH: SCAN; RANDOMTOG~SUCHTOG~TRUE; INLINEFILE ; 00670000 RANDOMTOG~FREEREAD~FALSE ; 00670100 IF NEXT = EQUAL THEN % RANDOM KEY 00670200 BEGIN SCAN; 00670300 IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 00670400 IF RDTRIN THEN EMITPAIR(1,ADD); 00670500 END ELSE IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 00670600 IF NEXT = RPAREN THEN GO TO NF; 00670700 IF NEXT ! COMMA THEN BEGIN FLOG(114); GO TO XIT END; 00670800 SCAN; 00670900 IF NEXT = ID THEN 00671000 IF NAME = "ERR " OR NAME = "END " THEN 00671100 BEGIN ACTIONLABELS(FALSE); 00671200 NF: IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 00671300 EMITL(0); 00671400 NOFORMT ~ TRUE; 00671500 SCAN; GO TO NOFORM; 00671600 END; 00671700 FORMER: IF ADR } 4085 THEN 00671800 BEGIN ADR ~ ADR+1; SEGOVF END; 00671900 IF NEXT = NUM THEN % FORMAT NUMBER 00672000 BEGIN EDITCODE ~ 1; 00672100 IF TEST ~ LBLSHFT(NAME) { 0 THEN 00672200 BEGIN FLAG(135); GO TO LISTER END; 00672300 IF I ~ SEARCH(TEST) = 0 THEN % NEVER SEEN 00672400 OFLOWHANGERS(I~ENTER(0&FORMATID[TOCLASS], TEST)) ELSE 00672500 IF GET(I).CLASS ! FORMATID THEN 00672600 BEGIN FLAG(143); GO TO LISTER END; 00672700 IF XREF THEN ENTERX(TEST,0&FORMATID[TOCLASS]); 00672800 IF GET(I).ADDR = 0 THEN 00672900 BEGIN EMITLINK((INFC ~ GET(I + 2)).BASE); 00673000 PUT(I + 2,INFC&ADR[TOBASE]); 00673100 EMITL(0); EMITL(0); EMITO(NOP); 00673200 END ELSE 00673300 BEGIN EMITL(GET(I+ 2).BASE); 00673400 EMITPAIR(GET(I).ADDR,LOD); 00673500 END; 00673600 GO TO LISTER; 00673700 END ELSE IF RDTRIN THEN IF(FREEREAD := NEXT=SLASH) THEN GO TO LISTER 00673800 ELSE BEGIN IF NEXT NEQ ID THEN BEGIN FLOG(116);GO TO XIT; END;END 00673900 ELSE IF NEXT NEQ ID THEN 00674000 BEGIN IF NEXT = STAR THEN 00674100 BEGIN NAMEDESC := TRUE; GLOBALNAME := TRUE; 00674200 TV := ENTER(0&LISTSID[TOCLASS],LISTID:=LISTID+1); 00674300 SCAN; 00674400 END; 00674500 IF NEXT = LPAREN THEN 00674600 BEGIN SCAN; IF EXPR(TRUE) GTR REALTYPE THEN FLAG(120) ; 00674700 SCAN; END ELSE EMITL(0); 00674800 IF GLOBALNAME AND (FREEREAD := NEXT = SLASH) OR FREEREAD THEN 00674900 GO TO LISTER ELSE BEGIN FLOG(110); GO TO XIT; END; 00675000 END; 00675100 GETALL(I ~ FNEXT,INFA,INFB,INFC); 00675200 IF T ~ INFA.CLASS = ARRAYID THEN % FORMAT ARRAY 00675300 BEGIN EDITCODE ~ 1; 00675400 FORMARY ~ TRUE; 00675500 T ~ EXPR(FALSE); 00675600 ADR ~ ADR-1; % ELIMINATE XCH EMITTED BY EXPR 00675700 IF EXPRESULT ! ARRAYID THEN FLOG(116); 00675800 GO TO LISTER1; % SCAN ALREADY DONE IN EXPR 00675900 END ELSE 00676000 IF T = NAMELIST THEN 00676100 BEGIN NAMETOG := TRUE; 00676200 IF INFA.ADDR = 0 THEN % REFERENCED, NOT DEF 00676300 BEGIN EMITLINK(INFC.BASE); 00676400 PUT(I+ 2,(INFC ~ INFC&ADR[TOBASE])); 00676500 EMITL(0); EMITL(0); EMITO(NOP); 00676600 END ELSE 00676700 BEGIN EMITL(INFC.BASE); 00676800 EMITPAIR(INFA.ADDR,LOD); 00676900 END 00677000 END 00677100 ELSE IF T = UNKNOWN THEN % ASSUME NAMELIST 00677200 BEGIN PUT(I,(INFA ~ INFA&NAMELIST[TOCLASS])); 00677300 NAMETOG := TRUE; 00677400 OFLOWHANGERS(I); 00677500 EMITLINK(0); PUT(I + 2,INFC&ADR[TOBASE]); 00677600 EMITL(0); EMITL(0); EMITO(NOP); 00677700 END ELSE BEGIN XTA ~ INFB; FLOG(116); GO TO XIT END; 00677800 SCAN; 00677900 IF NEXT = COMMA THEN ACTIONLABELS(TRUE); 00678000 IF SUCHTOG THEN 00678100 IF NEXT ! RPAREN THEN FLOG(108) ELSE SCAN; 00678200 IF NEXT ! SEMI THEN BEGIN FLOG(118); GO TO XIT END; 00678300 EMITL(0); EDITCODE ~ 4; EMITOPDCLIT(7); EMITO(FTC); 00678400 GO TO WRAP; 00678500 LISTER: SCAN; 00678600 IF FREEREAD THEN IF NOT RDTRIN THEN 00678700 BEGIN IF NEXT ! SLASH THEN EMITO(SSN) ELSE SCAN; 00678800 IF NEXT = LPAREN THEN 00678900 BEGIN SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(120);SCAN 00679000 END ELSE EMITL(0); 00679100 END; 00679200 LISTER1: 00679300 IF SUCHTOG THEN 00679400 BEGIN IF NEXT = COMMA THEN ACTIONLABELS(TRUE); 00679500 IF NEXT = RPAREN THEN SCAN ELSE BEGIN FLOG(108); GO TO XIT END; 00679600 END ELSE IF NEXT=COMMA THEN SCAN ELSE IF RDTRIN THEN 00679700 IF NEXT!SEMI THEN FLOG(114); 00679800 NOFORM: IF NEXT=SEMI THEN 00679900 BEGIN IF FREEREAD THEN FLOG(061) ELSE EMITL(0); GO TO WRAP END; 00680000 IF (NEXT NEQ LPAREN) AND (NEXT NEQ ID) AND (NEXT NEQ STAR) THEN 00680100 GO TO XIT; 00680200 EDITCODE ~ EDITCODE + 2; 00680300 DAAT: EMITB(-1,FALSE); LADR1 ~ LAX; ADJUST; DESCREQ ~ TRUE; 00680400 IF ADR } 4085 THEN 00680500 BEGIN ADR ~ ADR+1; SEGOVF; ADJUST END; 00680600 ACCIDENT ~ PRGDESCBLDR(0,0,ADR.[36:10] + 1,NSEG); 00680700 EMITOPDCLIT(19); EMITO(GFW); 00680800 LISTART ~ ADR&NSEG[TOSEGNO]; ADJUST; 00680900 LA ~ 0; IOLIST(LA); 00681000 EMITL(1); EMITO(CHS); EMITL(19); EMITO(STD); 00681100 EMITDESCLIT(19); EMITO(RTS); 0681200 FIXB(LADR1); DESCREQ ~ FALSE; 00681300 IF DATATOG THEN 00681400 BEGIN DATASET; 00681500 IF NEXT = SLASH THEN SCAN ELSE 00681600 BEGIN FLOG(110); GO TO XIT END; 00681700 IF LSTA = 0 THEN BEGIN BUMPPRT; LSTA~PRTS END; 00681800 IF (LSTMAX - LSTI) { LSTS THEN 00681900 BEGIN WRITEDATA(LSTI,NXAVIL ~ NXAVIL + 1,LSTP); 00682000 LSTA ~ PRGDESCBLDR(1,LSTA,0,NXAVIL); 00682100 LSTI ~ 0; BUMPPRT; LSTA~PRTS; 00682200 END; 00682300 MOVEW(LSTT,LSTP[LSTI],(LSTS ~ LSTS + 1).[36:6],LSTS); 00682400 EMITO(MKS); EMITL(LSTI); EMITPAIR(LSTA,LOD); 00682500 LSTI ~ LSTI + LSTS; 00682600 EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 00682700 EMITL(6); EMITL(0); EMITL(0); 00682800 EMITV(NEED(".FBINB",INTRFUNID)); 00682900 IF NEXT = COMMA THEN 00683000 BEGIN SCAN; GO TO DAAT END; 00683100 IF SPLINK } 0 THEN BEGIN 00683200 EMITB(-1,FALSE); DATALINK~LAX; 00683300 FIXB(DATAB) END; 00683400 GO TO XIT; 00683500 END; 00683600 EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 00683700 WRAP: IF NOT FREEREAD AND NOT NAMETOG THEN EMITL(EDITCODE); 00683800 IF RDTRIN THEN 00683900 BEGIN IF NX1 = 0 THEN EMITL(0) ELSE EMITLABELDESC(NX1); 00684000 IF NX2 = 0 THEN EMITL(0) ELSE EMITLABELDESC(NX2); 00684100 IF FREEREAD THEN EMITV(NEED(".FREFR", INTRFUNID)) 00684200 ELSE IF NAMETOG THEN EMITV(NEED(".FINAM",INTRFUNID)) 00684300 ELSE IF FORMARY THEN EMITV(NEED(".FTINT",INTRFUNID)) 00684400 ELSE IF NOFORMT THEN EMITV(NEED(".FBINB",INTRFUNID)) 00684500 ELSE EMITV(NEED(".FTNIN",INTRFUNID)); 00684600 END ELSE 00684700 IF FREEREAD THEN 00684800 BEGIN 00684900 IF NAMEDESC THEN 00685000 BEGIN 00685100 PRTSAVER(TV,NAMEIND+1,NAMLIST); 00685200 EMITL(GET(TV+2).BASE); 00685300 EMITPAIR(GET(TV).ADDR,LOD); 00685400 IF NAMLIST[0] = 0 THEN EMITL(0) 00685500 ELSE EMITPAIR(GET(GLOBALSEARCH(".SUBAR")).ADDR,LOD); 00685600 NAMLIST[0] := NAMEIND := 0; 00685700 END ELSE BEGIN EMITL(0);EMITL(0);EMITL(0);END; 00685800 EMITV(NEED(".FREWR",INTRFUNID)) 00685900 END ELSE IF NAMETOG THEN EMITV(NEED(".FONAM",INTRFUNID)) 00686000 ELSE IF FORMARY THEN EMITV(NEED(".FTOUT",INTRFUNID)) 00686100 ELSE BEGIN 00686200 IF NX1=0 THEN EMITL(0) ELSE EMITLABELDESC(NX1); 00686300 IF NX2=0 THEN EMITL(0) ELSE EMITLABELDESC(NX2); 00686400 IF NOFORMT THEN EMITV(NEED(".FBINB",INTRFUNID)) ELSE 00686500 EMITV(NEED(".FTNOU",INTRFUNID)); 00686600 END; 00686700 XIT: 00686800 IF NAMEDESC THEN IF RDTRIN THEN FLAG(159) 00686900 ELSE IF NOT FREEREAD THEN FLAG(160); 00687000 DATATOG := FALSE; NAMEDESC := FALSE; GLOBALNAME := FALSE; 00687100 IF DEBUGTOG THEN FLAGROUTINE(" IOCOM","MAND ",FALSE); 00687200 END IOCOMMAND; 00687300 PROCEDURE STMTFUN(LINK); VALUE LINK; REAL LINK; 00687400 BEGIN 00687500 DEFINE PARAM = LSTT#; 00687600 REAL SAVEBRAD, I; 00687700 REAL INFA, INFC, NPARMS, TYPE, PARMLINK, BEGINSUB, RETURN; 00687800 LABEL XIT,TIX ; 00687900 IF SPLINK < 0 THEN FLAG(12); 00688000 LABL ~ BLANKS; 00688100 FILETOG ~ TRUE; % PREVENTS SCANNER FROM ENTERING IDS IN INFO 00688200 IF XREF THEN ENTERX(GET(LINK+1),0&STMTFUNID[TOCLASS] 00688300 &(GET(LINK))[21:21:3]); 00688400 DO 00688500 BEGIN 00688600 SCAN; 00688700 IF NEXT ! ID THEN BEGIN FLOG(107); GO TO XIT END; 00688800 PARAM[NPARMS~NPARMS+1] ~ NAME; 00688900 SCAN; 00689000 END UNTIL NEXT ! COMMA; 00689100 IF NEXT ! RPAREN THEN FLOG(108) ELSE SCAN; 00689200 IF NEXT ! EQUAL THEN BEGIN FLOG(104); GO TO XIT END; 00689300 EMITB(-1,FALSE); SAVEBRAD ~ LAX; % BRANCH AROUND ST FUN 00689400 ADJUST; 00689500 BEGINSUB ~ ADR+1; 00689600 BUMPLOCALS; EMITPAIR(RETURN~LOCALS+1536,STD); 00689700 FOR I ~ NPARMS STEP -1 UNTIL 1 DO 00689800 BEGIN 00689900 IF T ~ SEARCH(PARAM[I]) ! 0 THEN 00690000 TYPE ~ GET(T).SUBCLASS ELSE 00690100 IF T~PARAM[I].[12:6] < "I" OR T > "N" THEN 00690200 TYPE ~ REALTYPE ELSE TYPE ~ INTYPE; 00690300 EMITSTORE( ENTER(0&VARID[TOCLASS]&1[TOTYPE] 00690400 &TYPE[TOSUBCL], PARAM[I]), TYPE); 00690500 IF XREF THEN ENTERX(NAME,0&VARID[TOCLASS]&TYPE[TOSUBCL]); 00690600 END; 00690700 PARMLINK ~ NEXTINFO-3; 00690800 GETALL(LINK, INFA, XTA, INFC); 00690900 FILETOG ~ FALSE; 00691000 SCAN; 00691100 IF (TYPE~(INFA~GET(LINK)).SUBCLASS)=LOGTYPE OR TYPE=COMPTYPE OR00691200 (I~EXPR(TRUE))=LOGTYPE OR I=COMPTYPE THEN 00691300 BEGIN IF I!TYPE THEN FLAG(139); GO TIX END ; 00691400 IF TYPE=REALTYPE OR TYPE=INTYPE THEN 00691500 BEGIN 00691600 IF I=DOUBTYPE THEN BEGIN EMITO(XCH); EMITO(DEL) END; 00691700 IF TYPE=INTYPE THEN IF I!INTYPE THEN EMITPAIR(1,IDV) ; 00691800 GO TIX ; 00691900 END ; 00692000 IF I!DOUBTYPE THEN EMITPAIR(0,XCH) ; 00692100 TIX: 00692200 EMITOPDCLIT(RETURN) ; 00692300 EMITO(GFW); 00692400 FIXB(SAVEBRAD); 00692500 IF INFA.CLASS ! UNKNOWN THEN FLAG(140); 00692600 PUT(LINK, -INFA & 1[TOTYPE] & NSEG[TOSEGNO] 00692700 & STMTFUNID[TOCLASS] & BEGINSUB[TOADDR]); 00692800 PUT(LINK+2, -(0 & NPARMS[TONEXTRA] & ADR[TOBASE] 00692900 & PARMLINK[36:36:12])); 00693000 PARMLINK ~ PARMLINK+4; 00693100 FOR I ~ 1 STEP 1 UNTIL NPARMS DO 00693200 PUT(PARMLINK ~ PARMLINK-3, "......"); 00693300 XIT: 00693400 FILETOG ~ FALSE; 00693500 END STMTFUN; 00693600 PROCEDURE ASSIGNMENT; 00693700 BEGIN 00693800 LABEL XIT; 00693900 BOOLEAN CHCK; 00694000 BOOLEAN I; 00694100 IF DEBUGTOG THEN FLAGROUTINE(" ASSIG","NMENT ",TRUE ) ; 00694200 FX1 ~ FNEXT; 00694300 SCAN; 00694400 IF NEXT = LPAREN THEN 00694500 BEGIN 00694600 CHCK~TRUE; 00694700 IF GET(FX1).CLASS = UNKNOWN THEN 00694800 IF EODS THEN 00694900 BEGIN XTA ~ GET(FX1+1); FLOG(035) ; 00695000 PUT(FX1,GET(FX1) & ARRAYID[TOCLASS]) ; 00695100 PUT(FX1+2,GET(FX1+2) & 1[TONEXTRA]) ; 00695200 END 00695300 ELSE BEGIN STMTFUN(FX1); GO TO XIT END ; 00695400 IF XREF THEN ENTERX(GET(FX1+1),1&GET(FX1) [15:15:9]); 00695500 EODS ~ TRUE ; 00695600 EXECUTABLE; 00695700 SCAN; 00695800 I ~ SUBSCRIPTS(FX1,2); 00695900 SCAN; 00696000 END ELSE 00696100 BEGIN 00696200 EODS~TRUE ; 00696300 EXECUTABLE; 00696400 IF T ~ GET(FX1).CLASS = ARRAYID THEN 00696500 BEGIN XTA ~ GET(FX1+1); FLAG(74) END; 00696600 MOVEW(ACCUM[1],HOLDID[0],0,3); 00696700 IF XREF THEN IF HOLDID[0].[12:12] ! "DO" THEN 00696800 ENTERX(GET(FX1+1),1&GET(FX1)[21:21:3]&VARID[TOCLASS]); 00696900 END; 00697000 IF NEXT ! EQUAL THEN BEGIN FLAG(104); GO TO XIT END; 00697100 SCAN; 00697200 IF NEXT=SEMI OR NEXT=COMMA THEN BEGIN FLOG(0); GO TO XIT; END; 00697300 FX2 ~ EXPR(TRUE); 00697400 IF NEXT NEQ COMMA THEN IF HOLDID[0] = "DO" THEN IF XREF THEN 00697500 ENTERX(HOLDID[0] ,1&GET(FX1)[21:21:3]&VARID[TOCLASS]); 00697600 IF NEXT = COMMA THEN IF CHCK THEN FLOG(56) ELSE 00697700 IF HOLDID[0].[12:12] ! "DO" THEN FLOG(56) ELSE 00697800 BEGIN 00697900 IF LOGIFTOG THEN FLAG(101); 00698000 IF FX2 > REALTYPE THEN FLAG(102); 00698100 IF DT ~ DT+1 > MAXDOS THEN BEGIN DT ~ 1; FLAG(138) END; 00698200 EMITN(FX1~ CHECKDO); 00698300 EMITO(STD); 00698400 SCAN; 00698500 IF NEXT=SEMI THEN BEGIN FLAG(36); GO TO XIT END; 00698600 IF (ACCUM[0] = ", " OR ACCUM[0] = "; ") AND 00698700 GLOBALNEXT=NUM AND ABS(FNEXT) > 1023 THEN 00698800 BEGIN 00698900 IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 00699000 IDINFO:=REALID;FNEXT:=ENTER(IDINFO,"2FNV00"&DT[36:36:12]);00699100 EMITN(FNEXT:=GETSPACE(FNEXT)); EMITO(STD); 00699200 EMITB(-1,FALSE); LADR1:=LAX; ADJUST; 00699300 LADR2 ~ (ADR+1) & NSEG[TOSEGNO]; EMITV(FNEXT); 00699400 END 00699500 ELSE BEGIN 00699600 EMITB(-1,FALSE); LADR1:=LAX; ADJUST; 00699700 LADR2:=(ADR+1)&NSEG[TOSEGNO]; 00699800 IF EXPR(TRUE) > REALTYPE THEN FLAG(102) ; 00699900 END ; 00700000 EMITO(GRTR); 00700100 EMITB(-1, TRUE); 00700200 LADR3 ~ LAX; 00700300 EMITB(-1, FALSE); 00700400 ADJUST; 00700500 DOTEST[DT] ~ (ADR+1) & LAX[TOADDR] & NSEG[TOSEGNO]; 00700600 IF NEXT ! COMMA THEN EMITL(1) ELSE 00700700 BEGIN 00700800 SCAN; 00700900 IF NEXT=SEMI THEN BEGIN FLAG(36); GO TO XIT END ; 00701000 IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 00701100 END; 00701200 EMITV(FX1); 00701300 EMITO(ADD); 00701400 EMITN(FX1); 00701500 EMITO(STN); 00701600 EMITB(LADR2, FALSE); 00701700 FIXB(LADR1); 00701800 FIXB(LADR3); 00701900 END ELSE EMITSTORE(FX1, FX2); 00702000 XIT: 00702100 IF DEBUGTOG THEN FLAGROUTINE(" ASSIG","NMENT ",FALSE ) ; 00702200 END ASSIGNMENT; 00702300 BOOLEAN PROCEDURE RINGCHECK; 00702400 COMMENT THIS PROCEDURE PREVENTS THE POSSIBILITY OF DELINKING A 00702500 HEADER FROM THE HEADER RING; 00702600 BEGIN 00702700 INTEGER I; 00702800 I~A; 00702900 DO 00703000 IF I ~ GETC(I).ADDR = ROOT THEN RINGCHECK ~ TRUE 00703100 UNTIL I = A; 00703200 END RINGCHECK; 00703300 PROCEDURE SETLINK(INFADDR); VALUE INFADDR; INTEGER INFADDR; 00703400 COMMENT THIS PROCEDURE LINKS AN ELEMENT TO ITS PREVIOUS HEADER; 00703500 BEGIN 00703600 INTEGER LAST,I; REAL COML; LABEL XIT; 00703700 XIT: 00703800 LAST ~(GETC(INFADDR).LASTC)-1; 00703900 FOR I ~ INFADDR+2 STEP 1 UNTIL LAST 00704000 DO BEGIN IF GETC(I).CLASS = ENDCOM THEN I~GETC(I).LINK; 00704100 IF FX1 = (COML~GETC(I)).LINK THEN 00704200 IF INFADDR~COML.LASTC=A THEN COM[PWI].LASTC~ROOT 00704300 ELSE GO XIT ; 00704400 END; 00704500 END SETLINK; 00704600 PROCEDURE DIMENSION; 00704700 BEGIN 00704800 LABEL L, LOOP, ERROR ; 00704900 BOOLEAN DOUBLED, SINGLETOG; %109-00705000 IF DEBUGTOG THEN FLAGROUTINE(" DIMEN","SION ",TRUE ) ; 00705100 IF LOGIFTOG THEN FLAG(101); 00705200 LABL ~ BLANKS; 00705300 IF NEXT=STAR THEN IF TYPE!DOUBTYPE THEN 00705400 BEGIN 00705500 SCAN ; 00705600 IF NEXT=SUM AND NUMTYPE=INTYPE THEN 00705700 BEGIN 00705800 IF FNEXT=4 THEN 00705900 BEGIN 00706000 SINGLETOG ~ TRUE; %109-00706100 IF TYPE=COMPTYPE THEN FLAG(176); GO L ; 00706200 END ; 00706300 IF FNEXT=8 THEN 00706400 BEGIN 00706500 IF TYPE=REALTYPE THEN TYPE~DOUBTYPE 00706600 ELSE IF TYPE!COMPTYPE THEN FLAG(177) ; 00706700 GO L ; 00706800 END ; 00706900 END ; 00707000 FLAG(IF TYPE=REALTYPE THEN 178 00707100 ELSE 177-REAL(TYPE=COMPTYPE)) ; 00707200 L: NCR~REAL(NCR.[30:3]!0)+3"677777"+NCR; SCN~1; SCAN ; 00707300 END ; 00707400 LOOP: DOUBLED~FALSE; 00707500 IF NEXT ! ID THEN BEGIN FLOG(105); GO TO ERROR END; 00707600 FX1 ~ IF SINGLETOG THEN -FNEXT ELSE FNEXT; %109-00707700 IF TYPE } DOUBTYPE THEN % FIX ARRAY TYPE OFR 00707800 PUT(FX1,GET(FX1)&TYPE[TOSUBCL]); % BOUNDS ROUTINE 00707900 IF XREF THEN BEGIN INFA ~ 0&GET(FX1)[15:15:9]; 00708000 IF TYPE>0 THEN INFA.SUBCLASS~TYPE; 00708100 END; 00708200 XTA ~ INFB ~ NAME; 00708300 SCAN; 00708400 IF XREF THEN 00708500 BEGIN IF INFA.CLASS = UNKNOWN THEN 00708600 INFA.CLASS~IF NEXT=LPAREN THEN ARRAYID ELSE VARID; 00708700 ENTERX(INFB,INFA); 00708800 END; 00708900 IF NEXT=LPAREN THEN BEGIN SCAN; DOUBLED~BOUNDS(FX1) END ELSE 00709000 IF TYPE = -1 THEN FLOG(103); 00709100 GETALL(FX1, INFA, XTA, INFC); 00709200 IF TYPE > 0 THEN 00709300 IF BOOLEAN(INFA.TYPEFIXED) THEN FLAG(31) ELSE 00709400 BEGIN 00709500 IF TYPE > LOGTYPE THEN 00709600 IF GET(FX1+2) <0 THEN 00709700 BEGIN 00709800 IF NOT DOUBLED AND INFA.CLASS=1 THEN 00709900 BEGIN 00710000 BUMPLOCALS; 00710100 LENGTH~LOCALS + 1536; 00710200 PUT(FX1+2,INFC & LENGTH[TOSIZE]); 00710300 END 00710400 END ELSE IF NOT DOUBLED THEN 00710500 BEGIN IF INFC.SIZE > 16383 THEN FLAG(99); 00710600 PUT(FX1+2,INFC & (2 | INFC.SIZE)[TOSIZE]); 00710700 END; 00710800 PUT (FX1,INFA & 1[TOTYPE] & TYPE[TOSUBCL]); 00710900 END; 00711000 IF INFA < 0 THEN FLAG(39) ELSE 00711100 IF TYPE = -2 THEN 00711200 BEGIN 00711300 BAPC(INFA&FX1[TOLINK]&1[TOCE]&ROOT[TOLASTC]); 00711400 IF BOOLEAN(INFA.CE) THEN FLAG(2); 00711500 IF BOOLEAN(INFA.EQ) THEN 00711600 BEGIN 00711700 COM[NEXTCOM.IR,NEXTCOM.IC].LASTC ~ A ~ INFA.ADDR; 00711800 B~GETC(ROOT).ADDR ; 00711900 SETLINK(A); 00712000 IF NOT RINGCHECK THEN 00712100 BEGIN 00712200 COM[PWROOT].ADDR~GETC(A).ADDR ; 00712300 PUTC(A,GETC(A)&B[TOADDR]&7[TOSUBCL]) ; 00712400 END 00712500 END ELSE 00712600 PUT(FX1, INFA & 1[TOCE] & ROOT[TOADDR]); 00712700 IF BOOLEAN(INFA.FORMAL) THEN FLAG(10); 00712800 END; 00712900 IF ERRORTOG THEN 00713000 ERROR: 00713100 WHILE NEXT ! COMMA AND NEXT ! SEMI AND NEXT ! SLASH DO SCAN; 00713200 IF NEXT = COMMA THEN BEGIN SCAN; GO TO LOOP END; 00713300 IF DEBUGTOG THEN FLAGROUTINE(" DIMEN","SION ",FALSE ); 00713400 END DIMENSION; 00713500 PROCEDURE FORMALPP(PARMSREQ, CLASS); VALUE PARMSREQ, CLASS; 00713600 BOOLEAN PARMSREQ; REAL CLASS; 00713700 BEGIN 00713800 LABEL LOOP, XIT; 00713900 IF DEBUGTOG THEN FLAGROUTINE(" FORM","ALPP ",TRUE ) ; 00714000 PARMS ~ 0; 00714100 SCAN; 00714200 IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 00714300 IF CLASS = FUNID THEN 00714400 IF FUNVAR = 0 THEN 00714500 BEGIN 00714600 IF TYPE > 0 THEN 00714700 IF FUNVAR ~ GLOBALSEARCH(NAME) ! 0 THEN 00714800 IF BOOLEAN((T ~ GET(FUNVAR)).TYPEFIXED) AND TYPE ! T.SUBCLASS 00714900 THEN FLAG(31); 00715000 PUT(FUNVAR ~ FNEXT,GET(FNEXT) & VARID[TOCLASS]); 00715100 END; 00715200 FNEW ~ NEED(NNEW ~ NAME, CLASS); 00715300 ENTERX(NAME,IF CLASS = FUNID THEN 00715400 1&GET(FNEW)[15:15:9] ELSE 1&GET(FNEW)[15:15:5]); 00715500 SCAN; 00715600 IF NEXT ! LPAREN THEN 00715700 IF PARMSREQ THEN FLOG(106) ELSE ELSE 00715800 BEGIN 00715900 LOOP: 00716000 SCAN; 00716100 IF NEXT = ID THEN PARMLINK[PARMS ~ PARMS+1] ~ FNEXT ELSE 00716200 IF NEXT=STAR AND CLASS!FUNID THEN PARMLINK[PARMS~PARMS+1]~0ELSE00716300 FLOG(107); 00716400 IF XREF THEN ENTERX(NAME,IF NEXT = STAR THEN 0 ELSE 00716500 0&GET(FNEXT)[15:15:9]); 00716600 SCAN; 00716700 IF NEXT = COMMA THEN GO TO LOOP; 00716800 IF NEXT ! RPAREN THEN FLOG(108); 00716900 SCAN; 00717000 END; 00717100 IF NOT ERRORTOG THEN DECLAREPARMS(FNEW); 00717200 XIT: 00717300 IF DEBUGTOG THEN FLAGROUTINE(" FORM","ALPP ",FALSE) ; 00717400 END FORMALPP; 00717500 00717600 PROCEDURE ENDS; FORWARD; 00717700 00717800 PROCEDURE FUNCTION ; 00717900 BEGIN 00718000 REAL A,B,C,I; LABEL FOUND ; 00718100 IF SPLINK NEQ 0 THEN BEGIN FLAG(5); ENDS; SEGMENTSTART; END; 00718200 LABL ~ BLANKS; 00718300 FORMALPP(TRUE, FUNID); 00718400 GETALL(FNEW, INFA, INFB, INFC); 00718500 B~NUMINTM1 ; 00718600 WHILE A+1SUPERMAXCOM THEN 00726500 BEGIN ROOT~0; FATAL(124) END 00726600 ELSE ROOT~NEXTCOM ; 00726700 PUTC(ROOT,0&HEADER[TOCLASS]&1[TOCE]&ROOT[TOADDR]) ; 00726800 BAPC(Z); 00726900 END ELSE 00727000 BEGIN 00727100 ROOT ~ T.ADINFO; 00727200 COM[(T~GETC(ROOT).LASTC).IR,T.IC].LINK~NEXTCOM+1 ; 00727300 IF COM[PWROOT]<0 THEN FLAG(2) ; 00727400 END; 00727500 DIMENSION; 00727600 BAPC(0&ENDCOM[TOCLASS]) ; 00727700 COM[PWROOT].LASTC~NEXTCOM ; 00727800 PUT(T~GETC(ROOT+1)+2,GET(T)&ROOT[TOADINFO]) ; 00727900 IF NEXT ! SEMI THEN GO TO LOOP; 00728000 END COMMON; 00728100 PROCEDURE ENDS; 00728200 BEGIN 00728300 IF SPLINK=0 THEN FLAG(184) ELSE %112-00728400 BEGIN %112-00728500 EODS~FALSE ; 00728600 IF LOGIFTOG THEN FLAG(101); 00728700 LABL ~ BLANKS; 00728800 IF SPLINK < 0 THEN EMITO(XIT) ELSE EMITPAIR(0, KOM); 00728900 SEGMENT((ADR+4) DIV 4, NSEG, TRUE, EDOC); 00729000 END; %112-00729100 END ENDS; 00729200 PROCEDURE ENTRY; 00729300 BEGIN 00729400 REAL SP; 00729500 IF SPLINK = 0 THEN FLAG(111) ELSE 00729600 IF SPLINK = 1 THEN BEGIN ELX ~ 0; FLAG(4) END; 00729700 LABL ~ BLANKS; 00729800 ADJUST ; 00729900 SP ~ GET(SPLINK); 00730000 FORMALPP( (T~SP.CLASS) = FUNID, T); 00730100 GETALL(FNEW, INFA, INFB, INFC); 00730200 IF INFA.CLASS = FUNID THEN 00730300 PUT(FNEW, INFA & 1[TOTYPE] & (SP.SUBCLASS)[TOSUBCL]); 00730400 PUT(FNEW+2, INFC & (ADR+1)[TOBASE]); 00730500 END ENTRY; 00730600 PROCEDURE EQUIVALENCE; 00730700 COMMENT THIS PROCEDURE MAKES THE COM ENTRY FOR EQUIV ITEMS AND SETS 00730800 THE EQ BIT IN BOTH THE COM AND INFO TABLES AND LINKS 00730900 THE HEADS OF CHAINS; 00731000 BEGIN 00731100 REAL P, Q, R, S; 00731200 BOOLEAN FIRST,PCOMM; 00731300 LABEL XIT; 00731400 IF LOGIFTOG THEN FLAG(101); 00731500 LABL ~ BLANKS; 00731600 DO 00731700 BEGIN 00731800 FIRST ~ FALSE; 00731900 SCAN; 00732000 IF NEXT ! LPAREN THEN BEGIN FLOG(106); GO TO XIT END; 00732100 IF NEXTCOM~NEXTCOM+1>SUPERMAXCOM THEN 00732200 BEGIN ROOT~0; FATAL(124) END 00732300 ELSE ROOT~NEXTCOM ; 00732400 PUTC(ROOT,0&HEADER[TOCLASS]&ROOT[TOADDR]) ; 00732500 BAPC(0); Q~0 ; 00732600 DO 00732700 BEGIN 00732800 SCAN; 00732900 IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 00733000 IF XREF THEN ENTERX(NAME,0&GET(FNEXT)[15:15:9]); 00733100 FX1 ~ FNEXT; 00733200 LENGTH ~ 0; 00733300 SCAN; 00733400 IF NEXT = LPAREN THEN 00733500 BEGIN 00733600 IF GET(FX1).CLASS ! ARRAYID THEN 00733700 BEGIN XTA ~ GET(FX1+1); FLOG(112) END; 00733800 R ~ 0; P ~ 1; 00733900 S ~ GET(FX1+2).ADINFO; 00734000 DO 00734100 BEGIN 00734200 SCAN; 00734300 IF NEXT ! NUM OR NUMTYPE ! INTYPE THEN FLAG(113); 00734400 LENGTH ~ LENGTH + P|(FNEXT-1); 00734500 P ~ P|EXTRAINFO[(S+R).IR,(S+R).IC] ; 00734600 R ~ R-1; 00734700 SCAN; 00734800 END UNTIL NEXT ! COMMA; 00734900 IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 00735000 IF R!-1 THEN IF R~R+GET(FX1+2).NEXTRA!0 THEN 00735100 BEGIN XTA~GET(FX1+1); FLAG(IF R>0 THEN 23 ELSE 24) END ; 00735200 SCAN; 00735300 END; 00735400 IF (INFA~GET(FX1)) < 0 THEN 735500 BEGIN XTA ~ GET(FX1+1); FLAG(39) END ELSE 735600 BEGIN 735700 IF INFA.SUBCLASS > LOGTYPE THEN LENGTH ~ 2|LENGTH ; 00735800 BAPC(INFA&FX1[TOLINK]&LENGTH[TORELADD]&1[TOEQ]&ROOT[TOLASTC]); 00735900 IF(PCOMM~BOOLEAN(INFA.CE)) OR BOOLEAN(INFA.EQ) THEN 00736000 BEGIN 00736100 IF FIRST AND PCOMM THEN BEGIN XTA~GET(FX1+1); FLAG(2) END 00736200 ELSE IF NOT FIRST THEN FIRST ~ PCOMM; 00736300 PUT(FX1,INFA & 1[TOEQ]); 00736400 COM[NEXTCOM.IR,NEXTCOM.IC].LASTC ~ A ~ INFA.ADDR; 00736500 B~GETC(ROOT).ADDR ; 00736600 SETLINK(A); 00736700 IF NOT RINGCHECK THEN 00736800 BEGIN 00736900 COM[PWROOT].ADDR~GETC(A).ADDR ; 00737000 PUTC(A,GETC(A)&B[TOADDR]&7[TOSUBCL]) ; 00737100 END 00737200 END ELSE 00737300 PUT(FX1,INFA & 1[TOEQ] & ROOT[TOADDR]); 00737400 IF LENGTH > Q THEN Q ~ LENGTH; 00737500 IF BOOLEAN(INFA.FORMAL) THEN 00737600 BEGIN XTA ~ GET(FX1+1); FLAG(11) END; 00737700 END; 00737800 END UNTIL NEXT ! COMMA; 00737900 IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 00738000 SCAN; 00738100 PUTC(ROOT+1,Q); 00738200 BAPC(0&ENDCOM[TOCLASS]) ; 00738300 COM[PWROOT].LASTC~NEXTCOM ; 00738400 END UNTIL NEXT ! COMMA; 00738500 XIT: 00738600 END EQUIVALENCE; 00738700 PROCEDURE EXTERNAL; 00738800 BEGIN 00738900 IF SPLINK < 0 THEN FLAG( 12); 00739000 IF LOGIFTOG THEN FLAG(101); 00739100 LABL ~ BLANKS; 00739200 DO 00739300 BEGIN 00739400 SCAN; 00739500 IF NEXT ! ID THEN FLOG(105) ELSE 00739600 BEGIN T ~ NEED(NAME,EXTID); 00739700 IF XREF THEN ENTERX(NAME,0&GET(T)[15:15:9]); 00739800 SCAN; 00739900 END; 00740000 END UNTIL NEXT ! COMMA; 00740100 END EXTERNAL; 00740200 PROCEDURE CHAIN; 00740300 BEGIN 00740400 LABEL AGN, XIT; 00740500 REAL T1; 00740600 DEFINE FLG(FLG1) = BEGIN FLOG(FLG1); GO TO XIT END#; 00740700 EXECUTABLE; 00740800 SCAN; 00740900 T1 ~ 2; 00741000 IF FALSE THEN 00741100 AGN: IF GLOBALNEXT ! COMMA THEN FLG(28); 00741200 SCAN; 00741300 IF EXPR(TRUE) > REALTYPE THEN FLG(102); 00741400 IF (T1 ~ T1 - 1) ! 0 THEN GO TO AGN; 00741500 IF GLOBALNEXT ! RPAREN THEN FLG(3); 00741600 EMITPAIR(37,KOM); 00741700 SCAN; 00741800 IF GLOBALNEXT ! SEMI THEN FLOG(117); 00741900 XIT: WHILE GLOBALNEXT ! SEMI DO SCAN; 00742000 END CHAIN; 00742100 PROCEDURE GOTOS; 00742200 BEGIN LABEL XIT; 00742300 REAL ASSIGNEDID; 00742400 EODS~TRUE ; 00742500 EXECUTABLE; 00742600 SCAN; 00742700 IF NEXT = NUM THEN 00742800 BEGIN 00742900 LABELBRANCH(NAME, FALSE); 00743000 SCAN; 00743100 GO TO XIT; 00743200 END; 00743300 IF NEXT = ID THEN 00743400 BEGIN 00743500 ASSIGNEDID ~ FNEXT; 00743600 IF XREF THEN ENTERX(XTA,0&GET(FNEXT)[15:15:9]); 00743700 SCAN; 00743800 IF NEXT ! COMMA THEN FLOG(114); 00743900 SCAN; 00744000 IF NEXT ! LPAREN THEN FLOG(106); 00744100 DO 00744200 BEGIN 00744300 SCAN; 00744400 IF NEXT ! NUM THEN FLOG(109); 00744500 EMITV(ASSIGNEDID); 00744600 EMITNUM(FNEXT); 00744700 EMITO(NEQL); 00744800 LABELBRANCH(NAME, TRUE); 00744900 SCAN; 00745000 END UNTIL NEXT ! COMMA; 00745100 IF NEXT ! RPAREN THEN FLOG(108); 00745200 SCAN; 00745300 EMITPAIR(1, SSN); % CAUSE INVALID INDEX TERMINATION 00745400 EMITDESCLIT(10); 00745500 GO TO XIT; 00745600 END; 00745700 IF NEXT ! LPAREN THEN FLOG(106); 00745800 P ~ 0; 00745900 DO 00746000 BEGIN 00746100 SCAN; 00746200 IF NEXT ! NUM THEN BEGIN FLOG(109); GO TO XIT END; 00746300 LSTT[P~P+1] ~ NAME; 00746400 SCAN; 00746500 END UNTIL NEXT ! COMMA; 00746600 IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 00746700 SCAN; 00746800 IF NEXT ! COMMA THEN BEGIN FLOG(114); GO TO XIT END; 00746900 SCAN; 00747000 IT ~ P+1; % DONT LET EXPR WIPE OUT LSTT 00747100 IF EXPR(TRUE) > REALTYPE THEN FLOG(102); 00747200 EMITPAIR(JUNK, ISN); 00747300 EMITPAIR(1,LESS); 00747400 EMITOPDCLIT(JUNK); 00747500 EMITO(LOR); 00747600 EMITOPDCLIT(JUNK); 00747700 EMITL(3); 00747800 EMITO(MUL); 00747900 IF ADR+3|P > 4085 THEN BEGIN ADR~ADR+1; SEGOVF END; 00748000 EMITO(BFC); 00748100 EMITPAIR(1, SSN); 00748200 EMITDESCLIT(10); 00748300 FOR I ~ 1 STEP 1 UNTIL P DO 00748400 BEGIN 00748500 J ~ ADR; LABELBRANCH(LSTT[I], FALSE); 00748600 IF ADR-J = 2 THEN EMITO(NOP); 00748700 END; 00748800 XIT: 00748900 IT ~ 0; 00749000 END GOTOS; 00749100 PROCEDURE IFS; 00749200 BEGIN REAL TYPE, LOGIFADR, SAVELABL; 00749300 EODS~TRUE; 00749400 EXECUTABLE; 00749500 SCAN; 00749600 IF NEXT ! LPAREN THEN FLOG(106); 00749700 SCAN; 00749800 IF TYPE ~ EXPR(TRUE) = COMPTYPE THEN FLAG(89); 00749900 IF NEXT ! RPAREN THEN FLOG(108); 00750000 IF TYPE = LOGTYPE THEN 00750100 BEGIN 00750200 EMITB(-1, TRUE); 00750300 LOGIFADR ~ LAX; 00750400 LOGIFTOG ~ TRUE; EOSTOG ~ TRUE; 00750500 SAVELABL ~ LABL; LABL ~ BLANKS; 00750600 STATEMENT; 00750700 LABL ~ SAVELABL; 00750800 LOGIFTOG ~ FALSE; EOSTOG ~ FALSE; 00750900 FIXB(LOGIFADR); 00751000 END ELSE 00751100 BEGIN 00751200 IF TYPE = DOUBTYPE THEN 00751300 BEGIN EMITO(XCH); EMITO(DEL) END; 00751400 SCAN; 00751500 IF NEXT ! NUM THEN FLOG(109); 00751600 FX1 ~ FNEXT; NX1 ~ NAME; 00751700 SCAN; 00751800 IF NEXT ! COMMA THEN FLOG(114); 00751900 SCAN; 00752000 IF NEXT ! NUM THEN FLOG(109); 00752100 FX2 ~ FNEXT; NX2 ~ NAME; 00752200 SCAN; 00752300 IF NEXT ! COMMA THEN FLOG(114); 00752400 SCAN; 00752500 IF NEXT ! NUM THEN FLOG(109); 00752600 FX3 ~ FNEXT; NX3 ~ NAME; 00752700 SCAN; 00752800 IF FX2 = FX3 THEN 00752900 BEGIN 00753000 EMITPAIR(0,GEQL); 00753100 LABELBRANCH(NX1, TRUE); 00753200 LABELBRANCH(NX3, FALSE); 00753300 IF XREF THEN ENTERX(NX2,0&LABELID[TOCLASS]); 00753400 END ELSE 00753500 IF FX1 = FX3 THEN 00753600 BEGIN 00753700 EMITPAIR(0,NEQL); 00753800 LABELBRANCH(NX2, TRUE); 00753900 LABELBRANCH(NX1, FALSE); 00754000 IF XREF THEN ENTERX(NX3,0&LABELID[TOCLASS]); 00754100 END ELSE 00754200 IF FX1 = FX2 THEN 00754300 BEGIN 00754400 EMITPAIR(0,LEQL); 00754500 LABELBRANCH(NX3, TRUE); 00754600 LABELBRANCH(NX1, FALSE); 00754700 IF XREF THEN ENTERX(NX2,0&LABELID[TOCLASS]); 00754800 END ELSE 00754900 BEGIN 00755000 EMITO(DUP); 00755100 EMITPAIR(0,NEQL); 00755200 EMITB(-1,TRUE); 00755300 EMITPAIR(0,LESS); 00755400 LABELBRANCH(NX3, TRUE); 00755500 LABELBRANCH(NX1, FALSE); 00755600 FIXB(LAX); 00755700 EMITO(DEL); 00755800 LABELBRANCH(NX2, FALSE); 00755900 END; 00756000 END; 00756100 END IFS; 00756200 PROCEDURE NAMEL; 00756300 BEGIN LABEL NIM,XIT,ELMNT,WRAP; 00756400 IF SPLINK < 0 THEN FLAG(12); 00756500 IF LOGIFTOG THEN FLAG(101); 00756600 LABL ~ BLANKS; 00756700 SCAN; IF NEXT ! SLASH THEN FLOG(110); 00756800 NIM: SCAN; IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 00756900 IF J ~ (INFA ~ GET(LADR2 ~ FNEXT)).CLASS = UNKNOWN THEN 00757000 PUT(LADR2,INFA&NAMELIST[TOCLASS]) 00757100 ELSE IF J ! NAMELIST THEN 00757200 BEGIN XTA ~ GET(LADR2 + 1); 00757300 FLAG(20); 00757400 END; 00757500 LSTT[LSTS ~ LADR1 ~ 0] ~ NAME; 00757600 IF XREF THEN ENTERX(NAME,0&NAMELIST[TOCLASS]); 00757700 SCAN; IF NEXT ! SLASH THEN FLOG(110); 00757800 ELMNT: SCAN; IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 00757900 LADR1 ~ LADR1 + 1; 00758000 IF (T ~ GET(FNEW ~ GETSPACE(FNEXT)).CLASS) > VARID THEN FLAG(48); 00758100 GETALL(FNEW,INFA,INFB,INFC); 00758200 IF XREF THEN ENTERX(INFB,0&INFA[15:15:9]); 00758300 IF LSTS ~ LSTS+1 = LSTMAX THEN BEGIN FLOG(78); GO TO XIT END ELSE 00758400 LSTT[LSTS] ~ NAME&INFA.CLASNSUB[2:38:10]&0[8:47:1]; 00758500 IF T = ARRAYID THEN 00758600 BEGIN J ~ INFC.ADINFO; 00758700 I ~ INFC.NEXTRA; 00758800 IF LSTS + I + 1 > LSTMAX THEN 00758900 BEGIN FLOG(78); GO TO XIT END; 00759000 LSTT[LSTS ~ LSTS + 1] ~ 0&I[1:42:6] % # DIMENSIONS 00759100 &INFA.ADDR[7:37:11] % REL ADR 00759200 &INFC.BASE[18:33:15] % BASE 00759300 &INFC.SIZE[33:33:15]; % SIZE 00759400 FOR T ~ J STEP -1 UNTIL J - I + 1 DO 00759500 LSTT[LSTS ~ LSTS + 1] ~ EXTRAINFO[T.IR,T.IC]; 00759600 END ELSE BEGIN LSTT[LSTS~LSTS+1]~0&(INFA.ADDR)[7:37:11]; 00759700 IF BOOLEAN(INFA.CE) THEN LSTT[LSTS]~LSTT[LSTS]&INFC.BASE[18:33:15]00759800 &INFC.SIZE[33:33:15] END; 00759900 SCAN; IF NEXT = COMMA THEN GO TO ELMNT; 00760000 IF NEXT ! SEMI AND NEXT ! SLASH THEN FLOG(115); 00760100 LSTT[LSTS + 1] ~ 0; 00760200 LSTT[0].[2:10] ~ LADR1; 00760300 PRTSAVER(LADR2,LSTS + 2,LSTT); 00760400 IF NEXT ! SEMI THEN GO TO NIM; 00760500 XIT: 00760600 END NAMEL; 00760700 PROCEDURE PAUSE; 00760800 IF DCINPUT THEN BEGIN XTA~"PAUSE "; FLOG(151) END ELSE 00760900 BEGIN 00761000 EODS~TRUE ; 00761100 IF TSSEDITOG THEN TSSED("PAUSE ",2) ; 00761200 EXECUTABLE; 00761300 SCAN; 00761400 IF NEXT = SEMI THEN EMITL(0) ELSE 00761500 IF NEXT = NUM THEN 00761600 BEGIN 00761700 EMITNUM(NAME); 00761800 SCAN; 00761900 END; 00762000 EMITPAIR(33, KOM); 00762100 EMITO(DEL); 00762200 END PAUSE; 00762300 PROCEDURE TYPIT(TYP,TMPNXT); VALUE TYP; REAL TYP,TMPNXT ; 00762400 BEGIN 00762500 TYPE~TYP; SCAN ; 00762600 IF NEXT=16 THEN BEGIN TMPNXT~16; FUNCTION END ELSE DIMENSION ; 00762700 END OF TYPIT ; 00762800 DEFINE COMPLEX =TYPIT(COMPTYPE,TEMPNEXT) #, 00762900 LOGICAL =TYPIT(LOGTYPE ,TEMPNEXT) #, 00763000 DOUBLEPRECISION =TYPIT(DOUBTYPE,TEMPNEXT) #, 00763100 INTEGERS =TYPIT(INTYPE ,TEMPNEXT) #, 00763200 REALS =TYPIT(REALTYPE,TEMPNEXT) #; 00763300 PROCEDURE STOP; 00763400 BEGIN 00763500 RETURNFOUND ~ TRUE; 00763600 EODS~TRUE; 00763700 EXECUTABLE; 00763800 COMMENT INITIAL SCAN ALREADY DONE; 00763900 EMITL(1); 00764000 EMITPAIR(16,STD); 00764100 EMITPAIR(10, KOM); 00764200 EMITPAIR(5, KOM); 00764300 WHILE NEXT ! SEMI DO SCAN; 00764400 END STOP; 00764500 PROCEDURE RETURN; 00764600 BEGIN LABEL EXIT; 00764700 REAL T, XITCODE; 00764800 RETURNFOUND ~ TRUE; 00764900 EODS~TRUE ; 00765000 EXECUTABLE; 00765100 SCAN; 00765200 IF SPLINK=0 OR SPLINK=1 THEN 00765300 BEGIN XTA~"RETURN"; FLOG(153); GO EXIT END ; 00765400 IF NEXT = SEMI THEN 00765500 BEGIN 00765600 IF (T ~ GET(SPLINK)).CLASS = FUNID THEN 00765700 BEGIN 00765800 EMITV(FUNVAR); 00765900 IF T.SUBCLASS > LOGTYPE THEN EMITPAIR(JUNK, STD); 00766000 XITCODE ~ RTN; 00766100 END ELSE XITCODE ~ XIT; 00766200 IF ADR } 4077 THEN 00766300 BEGIN ADR ~ ADR+1; SEGOVF END; 00766400 EMITOPDCLIT(1538); % F+2 00766500 EMITPAIR(3, BFC); 00766600 EMITPAIR(10, KOM); 00766700 EMITO(XITCODE); 00766800 EMITOPDCLIT(16); 00766900 EMITPAIR(1, SUB); 00767000 EMITPAIR(16, STD); 00767100 EMITO(XITCODE); 00767200 GO TO EXIT; 00767300 END; 00767400 IF LABELMOM = 0 THEN FLOG(145); 00767500 IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 00767600 IF EXPRESULT = NUMCLASS THEN 00767700 BEGIN IF XREF THEN ENTERX(EXPVALUE,0&LABELID[TOCLASS]); 00767800 ADR ~ ADR-1;EMITL(EXPVALUE-1) 00767900 END ELSE 00768000 EMITPAIR(1, SUB); 00768100 EMITOPDCLIT(LABELMOM); 00768200 EMITO(MKS); 00768300 EMITL(9); 00768400 EMITOPDCLIT(5); 00768500 EXIT: 00768600 END RETURN; 00768700 PROCEDURE IMPLICIT ; 00768800 BEGIN 00768900 REAL R1,R2,R3,R4 ; 00769000 LABEL R,A,X,L ; 00769100 IF NOT(LASTNEXT=42 OR LASTNEXT=1000 OR LASTNEXT=30 %110-00769200 OR LASTNEXT=16 OR LASTNEXT = 11) %110-00769300 THEN BEGIN FLOG(181); FILETOG~TRUE; GO X END ; 00769400 R: EOSTOG~ERRORTOG~TRUE; FILETOG~FALSE ; 00769500 MOVEW(ACCUM[3],ACCUM[2],0,3); SCAN; ERRORTOG~FALSE; FILETOG~TRUE ; 00769600 IF R1~IF R2~NEXT=18 THEN INTID ELSE IF R3=26 THEN REALID ELSE 0& 00769700 (IF R3=10 THEN DOUBTYPE ELSE IF R3=19 THEN LOGTYPE ELSE IF R3=00769800 6 THEN COMPTYPE ELSE 0)[TOSUBCL]=0 THEN 00769900 BEGIN FLOG(182); GO X END ; 00770000 SCN~2; SCAN ; 00770100 IF NEXT = STAR THEN IF R3!10 THEN 00770200 BEGIN SCAN ; 00770300 IF NEXT=NUM AND NUMTYPE=INTYPE THEN 00770400 BEGIN 00770500 IF FNEXT=4 THEN BEGIN IF R3=6 THEN FLAG(176); GO L END ; 00770600 IF FNEXT=8 THEN 00770700 BEGIN 00770800 IF R3=26 THEN R1~0&DOUBTYPE[TOSUBCL] 00770900 ELSE IF R3!6 THEN FLAG(177) ; 00771000 GO L; 00771100 END ; 00771200 END ; 00771300 FLAG(IF R3=26 THEN 178 ELSE 177-REAL(R3=6)) ; 00771400 L: NCR~REAL(NCR.[30:3]!0)+3"677777"+NCR; SCN~1; SCAN ; 00771500 END ; 00771600 IF NEXT!LPAREN THEN BEGIN FLOG(106); GO X END ; 00771700 A: SCAN; R4~ERRORCT ; 00771800 IF R2~NAME.[12:6]<17 OR (R2>25 AND R2<33) OR (R2>41 AND R2<50) 00771900 OR R2>57 OR NAME.[18:30]!" " THEN FLAG(179) ; 00772000 SCAN ; 00772100 IF NEXT!MINUS THEN 00772200 BEGIN IF ERRORCT=R4 THEN TIPE[IF R2!"0" THEN R2 ELSE 12]~R1 END00772300 ELSE BEGIN 00772400 SCAN ; 00772500 IF R3~NAME.[12:6]<17 OR (R3>25 AND R3<33) OR (R3>41 AND R3<50) 00772600 OR R3>57 OR NAME.[18:30]!" " THEN FLAG(179) ; 00772700 IF R3 LEQ R2 THEN FLAG(180) ; 00772800 IF ERRORCT=R4 THEN FOR R2~R2 STEP 1 UNTIL R3 DO 00772900 BEGIN 00773000 IF R2>25 AND R2<33 THEN R2~33 ELSE IF R2>41 AND R2<50 00773100 THEN R2~50 ; 00773200 TIPE[IF R2!"0" THEN R2 ELSE 12]~R1 ; 00773300 END ; 00773400 SCAN ; 00773500 END ; 00773600 IF NEXT=COMMA THEN GO A ; 00773700 IF NEXT!RPAREN THEN BEGIN FLOG(108); GO X END ; 00773800 SCAN; IF NEXT=COMMA THEN GO R ; 00773900 IF NEXT!SEMI THEN BEGIN FLOG(117); GO X END ; 00774000 IF SPLINK > 1 THEN 00774100 BEGIN 00774200 IF BOOLEAN(TYPE.[2:1]) THEN IF GET(SPLINK).CLASS=FUNID THEN 00774300 BEGIN 00774400 INFO[SPLINK.IR,SPLINK.IC].SUBCLASS~R3~TIPE[IF R3~GET( 00774500 SPLINK+1).[12:6]!"0" THEN R3 ELSE 12].SUBCLASS ; 00774600 INFO[FUNVAR.IR,FUNVAR.IC].SUBCLASS~R3 ; 00774700 END ; 00774800 IF R1~GET(SPLINK+2)<0 THEN 00774900 FOR R2~R1.NEXTRA-1+R1~R1.ADINFO STEP -1 UNTIL R1 DO 00775000 IF R3~PARMLINK[R2-R1+1]!0 THEN 00775100 BEGIN 00775200 EXTRAINFO[R2.IR,R2.IC].SUBCLASS~R4~TIPE[IF R4~ 00775300 GET(R3+1).[12:6]!"0" THEN R4 ELSE 12] 00775400 .SUBCLASS ; 00775500 INFO[R3.IR,R3.IC].SUBCLASS~R4 ; 00775600 END ; 00775700 END ; 00775800 X: WHILE NEXT!SEMI DO SCAN; FILETOG~FALSE ; 00775900 END OF IMPLICIT ; 00776000 00776100 PROCEDURE SUBROUTINE; 00776200 BEGIN 00776300 IF SPLINK NEQ 0 THEN BEGIN FLAG(5); ENDS; SEGMENTSTART; END; 00776400 LABL ~ BLANKS; 00776500 FORMALPP(FALSE, SUBRID); 00776600 SPLINK ~ FNEW; 00776700 END SUBROUTINE; 00776800 PROCEDURE MEMHANDLER(N); VALUE N; REAL N ; 00776900 BEGIN 00777000 REAL A ; 00777100 LABEL L1,L2,L3,XIT ; 00777200 IF DEBUGTOG THEN FLAGROUTINE(" MEMHA","NDLER ",TRUE) ; 00777300 IF N LEQ 2 THEN 00777400 BEGIN % FIXED=1, VARYING=2. 00777500 N~IF N=1 THEN 6 ELSE 0 ; 00777600 L1: SCAN; 00777700 IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 00777800 IF (A~GET(GETSPACE(FNEXT))).CLASS!ARRAYID THEN 00777900 BEGIN FLOG(35); GO XIT END ; 00778000 IF XREF THEN ENTERX(XTA,0&A[15:15:9]) ; 00778100 IF BOOLEAN(A.EQ) OR BOOLEAN(A.FORMAL) THEN FLAG(169) 00778200 ELSE BEGIN 00778300 EMITO(MKS); EMITPAIR(A.ADDR,LOD); EMITL(N) ; 00778400 EMITV(NEED(".MEMHR",INTRFUNID)) ; 00778500 END ; 00778600 SCAN; IF NEXT=COMMA THEN GO L1 ; 00778700 END 00778800 ELSE IF N=3 THEN 00778900 BEGIN % AUXMEMED FUNCTION OR SUBROUTINE. 00779000 SCAN ; 00779100 IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 00779200 IF GET(FNEXT+1)!GET(SPLINK+1) THEN 00779300 BEGIN FLOG(170); GO XIT END ; 00779400 PUT(SPLINK,GET(SPLINK)&1[TOADJ]) ; 00779500 IF XREF THEN ENTERX(XTA,0&GET(FNEXT)[15:15:9]); SCAN ; 00779600 END 00779700 ELSE BEGIN % RELEASE. 00779800 L2: SCAN ; 00779900 IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 00780000 IF (A~GET(GETSPACE(FNEXT))).CLASS=ARRAYID THEN 00780100 BEGIN 00780200 IF BOOLEAN(A.EQ) OR BOOLEAN(A.FORMAL) THEN FLAG(169) 00780300 ELSE BEGIN 00780400 EMITO(MKS); EMITPAIR(A.ADDR,LOD) ; 00780500 EMITPAIR(1,SSN) ; 00780600 EMITV(NEED(".MEMHR",INTRFUNID)) ; 00780700 END ; 00780800 L3: IF XREF THEN ENTERX(XTA,0&A[15:15:9]) ; 00780900 END 00781000 ELSE IF A.CLASS}BLOCKID OR A.CLASS{LABELID THEN 00781100 BEGIN FLOG(171); GO XIT END 00781200 ELSE BEGIN 00781300 EMITPAIR(A.ADDR,LOD); EMITPAIR(38,KOM) ; 00781400 EMITO(DEL); GO L3 ; 00781500 END ; 00781600 SCAN; IF NEXT=COMMA THEN GO L2 ; 00781700 END ; 00781800 XIT:IF DEBUGTOG THEN FLAGROUTINE(" MEMHA","NDLER ",FALSE) ; 00781900 END OF MEMHANDLER ; 00782000 PROCEDURE STATEMENT; 00782100 BEGIN LABEL DOL1, XIT; 00782200 REAL TEMPNEXT ; 00782300 BOOLEAN ENDTOG; %112-00782400 DO SCAN UNTIL NEXT ! SEMI; 00782500 IF NEXT=ID THEN ASSIGNMENT ELSE IF NEXT LEQ RSH1 THEN 00782600 CASE(TEMPNEXT~NEXT) OF 00782700 BEGIN 00782800 FLOG(16); 00782900 ASSIGN; 00783000 IOCOMMAND(4); %BACKSPACE 00783100 BLOCKDATA; 00783200 CALL; 00783300 COMMON; 00783400 COMPLEX; 00783500 BEGIN EXECUTABLE; SCAN END; % CONTINUE 00783600 IOCOMMAND(7); % DATA 00783700 BEGIN SCAN; TYPE ~ -1; DIMENSION END; 00783800 DOUBLEPRECISION; 00783900 BEGIN ENDS; ENDTOG:=TRUE; SCAN END; %112-00784000 FILECONTROL(1); %ENDFILE 00784100 ENTRY; 00784200 EQUIVALENCE; 00784300 EXTERNAL; 00784400 BEGIN TYPE ~ -1; FUNCTION END; 00784500 GOTOS; 00784600 INTEGERS; 00784700 LOGICAL; 00784800 NAMEL; 00784900 PAUSE; 00785000 IOCOMMAND(2); %PRINT 00785100 ; 00785200 IOCOMMAND(3); %PUNCH 00785300 IOCOMMAND(0); %READ 00785400 REALS; 00785500 RETURN; 00785600 FILECONTROL(0); %REWIND 00785700 BEGIN SCAN; STOP END; 00785800 SUBROUTINE; 00785900 IOCOMMAND(1); %WRITE 00786000 FILECONTROL(7); %CLOSE 00786100 FILECONTROL(6); %LOCK 00786200 FILECONTROL(4); %PURGE 00786300 IFS; 00786400 FORMATER; 00786500 CHAIN; 00786600 MEMHANDLER(1) ; %FIXED 00786700 MEMHANDLER(2) ; %VARYING 00786800 MEMHANDLER(3) ; %AUXMEM FOR SUBPROGRAMS 00786900 MEMHANDLER(4) ; %RELEASE 00787000 IMPLICIT ; 00787100 END ELSE IF NEXT=EOF THEN GO XIT ELSE BEGIN NEXT~0; FLOG(16) END ; 00787200 LASTNEXT.[33:15]~TEMPNEXT ; 00787300 IF NOT ENDTOG THEN IF SPLINK=0 THEN SPLINK:=1; %112-00787400 ENDTOG:=FALSE; %112-00787500 IF LABL ! BLANKS THEN 00787600 BEGIN 00787700 IF DT ! 0 THEN 00787800 BEGIN 00787900 DOL1: IF LABL = DOLAB[TEST ~ DT] THEN 00788000 BEGIN 00788100 EMITB(DOTEST[DT], FALSE); 00788200 FIXB(DOTEST[DT].ADDR); 00788300 IF DT ~ DT-1 > 0 THEN GO TO DOL1; 00788400 END ELSE 00788500 WHILE TEST ~ TEST-1 > 0 DO 00788600 IF DOLAB[TEST] = LABL THEN FLAG(14); 00788700 END; 00788800 LABL ~ BLANKS; 00788900 END; 00789000 IF NEXT ! SEMI THEN 00789100 BEGIN 00789200 FLAG(117); 00789300 DO SCAN UNTIL NEXT=SEMI OR NEXT=EOF ; 00789400 END; 00789500 ERRORTOG ~ FALSE; 00789600 EOSTOG ~ TRUE; 00789700 XIT: 00789800 END STATEMENT; 00789900 00790000 BOOLEAN STREAM PROCEDURE FLAGLAST(BUFF,ERR) ; 00790100 BEGIN 00790200 LOCAL A; SI~ERR; 8(IF SC!" " THEN JUMP OUT;SI~SI+1;TALLY~TALLY+1);00790300 A~TALLY; SI~LOC A; SI~SI+7 ; 00790400 IF SC<"8" THEN 00790500 BEGIN TALLY~1; FLAGLAST~TALLY ; 00790600 DI~BUFF;DS~46 LIT"LAST SYNTAX ERROR OCCURRED AT SEQUENCE NUMBER ";00790700 DS~LIT"""; SI~ERR; DS~8 CHR; DS~LIT"""; 00790800 DS~32 LIT " "; %510-00790900 DS~32 LIT " "; %510-00791000 END 00791100 END FLAGLAST ; 00791200 INTEGER PROCEDURE FIELD(X); VALUE X; INTEGER X; 00791300 FIELD~IF X<10 THEN 1 ELSE IF X<100 THEN 2 ELSE IF X<1000 THEN 3 ELSE IF 00791400 X<10000 THEN 4 ELSE IF X<100000 THEN 5 ELSE IF X<1000000 THEN 6 ELSE 7; 00791500 FORMAT EOC1(/ "NUMBER OF SYNTAX ERRORS DETECTED = ",I*,".",X*, 00791600 "NUMBER OF SEQUENCE ERRORS DETECTED = ",I*,"."), 00791700 EOC2("PRT SIZE = ",I*,"; TOTAL SEGMENT SIZE = ",I*, 00791800 " WORDS; DISK SIZE = ",I*," SEGS; NO. PRGM. SEGS = ",I*, 00791900 "."), 00792000 EOC3("ESTIMATED CORE STORAGE REQUIREMENT = ",I*," WORDS;", 00792100 " COMPILATION TIME = ",I*," MIN, ",I*," SECS;", 00792200 " NO. CARDS = ",I*,"."), 00792300 EOC4("ESTIMATED CORE STORAGE REQUIREMENT = ",I*," WORDS;" 00792400 " COMPILATION TIME = ",I*," SECS; NO. CARDS = ",I*,"."), 00792500 EOC5("NUMBER OF TSS WARNINGS DETECTED = ",I*,".") ; 00792600 COMMENT MAIN DRIVER FOR FORTRAN COMPILER BEGINS HERE; 00792700 RTI ~ TIME(1); 00792800 INITIALIZATION; 00792900 DO STATEMENT UNTIL NEXT = EOF; 00793000 IF NOT ENDSEGTOG THEN IF SPLINK NEQ 0 %112-00793100 THEN BEGIN XTA:=BLANKS; FLAG(5); ENDS END; %112-00793200 WRAPUP; 00793300 POSTWRAPUP: 00793400 IF TIMETOG THEN IF FIRSTCALL THEN DATIME; 00793500 IF NOT FIRSTCALL THEN 00793600 BEGIN 00793700 WRITE(RITE,EOC1,FIELD(ERRORCT),ERRORCT,IF SEQERRCT=0 THEN 99 ELSE 00793800 5,FIELD(SEQERRCT-1),SEQERRCT-1) ; 00793900 IF WARNED AND NOT DCINPUT THEN WRITE(RITE,EOC5,FIELD(WARNCOUNT), 00794000 WARNCOUNT) ; 00794100 WRITE(RITE,EOC2,FIELD(PRTS),PRTS,FIELD(TSEGSZ),TSEGSZ,FIELD(DALOC-1),00794200 DALOC-1,FIELD(NXAVIL),NXAVIL) ; 00794300 IF C1~(TIME(1)-RTI)/60 > 59 THEN WRITE(RITE,EOC3,FIELD(64|ESTIMATE), 00794400 64|ESTIMATE,FIELD(C1 DIV 60),C1 DIV 60,FIELD(C1 MOD 60),C1 MOD 60, 00794500 FIELD(CARDCOUNT-1),CARDCOUNT-1) ELSE WRITE(RITE,EOC4,FIELD(ESTIMATE 00794600 |64),ESTIMATE|64,FIELD(C1),C1,FIELD(CARDCOUNT-1),CARDCOUNT-1) ; 00794700 IF ERRORCT>0 THEN IF FLAGLAST(ERRORBUFF,LASTERR) THEN WRITE(RITE,15, 00794800 ERRORBUFF[*]) ; 00794900 END ; 00795000 END INNER BLOCK; 00795100 END. 00795200