diff --git a/SYMBOL/FORTRAN.alg_m b/SYMBOL/FORTRAN.alg_m index c6c4b9c..a21dc35 100644 --- a/SYMBOL/FORTRAN.alg_m +++ b/SYMBOL/FORTRAN.alg_m @@ -52,9 +52,9 @@ COMMENT 00001900 031 IDENTIFIER ALREADY GIVEN TYPE 00034000 032 ILLEGAL FORMAT SYNTAX 00035000 033 INCORRECT USE OF FILE 00036000 -034 INCONSISTENT USE OF IDENTIFIER 00037000 +034 INCONSISTENT USE OF IDENTIFIER 00037000 035 ARRAY IDENTIFIER EXPECTED 00038000 -036 EXPRESSION VALUE REQUIRED 00039000 +036 EXPRESSION VALUE REQUIRED 00039000 037 ILLEGAL FILE CARD SYNTAX 00040000 038 ILLEGAL CONTROL ELEMENT 00041000 039 DECLARATION MUST PRECEDE FIRST REFERENCE 00042000 @@ -108,7 +108,7 @@ COMMENT 00001900 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 +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 @@ -223,27 +223,27 @@ DEFINE NUMINTM1= 00155210 % WHICH IS ADDED, ADD 1 TO THE VALUE ON SEQ# 00155211. 00155213 DEFINE MAXEL=15#; 00156000 REAL ARRAY ENTRYLINK[0:MAXEL]; 00157000 -REAL ELX; 00143065 -ALPHA FNEW, NNEW; 00143066 -REAL LABELMOM; 00143067 -INTEGER LOCALS,PARMS,PRTS,FLAGROUTINECOUNTER ; 00143068 -REAL LIMIT, VOIDTSEQ; 00143069 -REAL IDINFO, TYPE, NSEG; 00143070 -REAL FX1, FX2, FX3, NX1, NX2, NX3; 00143071 -INTEGER LENGTH, LOWERBOUND, GROUPPRT; 00143072 -ALPHA EQVID, INTID, REALID; 00143073 -INTEGER ROOT, ADR; 00143074 -INTEGER LASTMODE ; %%% = 1 FOR $CARD; = 2 FOR $TAPE. 00143075 -BOOLEAN ERRORTOG,%PREVIOUS LISTED RECORD. 00143076 - EOSTOG,%END OF STMT TOGGLE. 00143077 - CODETOG,%LIST CODE GENERATED.. 00143078 - TAPETOG,%MERGE TAPE INPUT. 00143079 - EODS,%END OF DECLRSTMTS, RESET BY ENDS. 00143080 - FILETOG,%PROCESSING FILE CARDS. 00143081 - DEBUGTOG,%TO LIST OUT ENTRING AND EXITING PROCEDURES. 00143082 - DESCREQ,%DESCRIPTOR REQUIRED. 00143083 - XREF,%TO CREATE XREF OF PROGRAM. 00143084 - SAVETOG;%VARIOUS BOOLEANS. 00143085 +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 @@ -281,7 +281,7 @@ DEFINE LIBTAPE = SAVETOG.[47:1]#,%USE TO SAVE NEW WHILE INCLUDE. 00169053 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 169090 + 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 @@ -292,7979 +292,7975 @@ DEFINE LIBTAPE = SAVETOG.[47:1]#,%USE TO SAVE NEW WHILE INCLUDE. 00169053 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 00169101 -ENDSAVTOGDEF=#; 00169102 -ARRAY SSNM[0:18] ; % THESE WORDS ARE USED FOR TEMP STORAGE AND STORING 00169103 - % PERMANENT FLAGGED DATA. 00169104 -DEFINE LASTSEQ=SSNM[0]#, LASTERR=SSNM[1]#, LINKLIST=SSNM[2]# ; 00169105 -DEFINE VOIDSEQ=SSNM[3] # ; 00169106 -ALPHA ARRAY ERRORBUFF,PRINTBUFF[0:14] ; 00169107 -ARRAY INLINEINT[0:35] ; 00169108 -DEFINE XRBUFF = 150#, XRBUFFDIV3=50 #; 00169109 -ARRAY XRRY[0:XRBUFF-1] ; 00169110 -INTEGER SEQBASE,SEQINCR; 00169111 -INTEGER SCN,LABL,NEXTSCN,NEXTCARD; 00169112 -INTEGER SAVECARD; % TO SAVE NEXTCART WHILE IN $ INCLUDE 00169113 -INTEGER RESULT,INSERTDEPTH; 00169114 -REAL INCLUDE; % CONTAINS "INCLUDE" 00169115 -REAL DEBUGADR ; 00169116 -ALPHA ACR0, CHR0, INITIALNCR; 00169117 -ALPHA ACR, NCR ; 00169118 -SAVE ARRAY TIPE[0:63] ; 00169119 -REAL LASTNEXT ; 00169120 -ALPHA NEXTACC, NEXTACC2; 00169121 -ALPHA BLANKS; 00169122 -ALPHA XTA; 00169123 -ALPHA ARRAY EDOC[0:7, 0:127]; COMMENT HOLDS CODE EMITTED; 00169124 -ALPHA ARRAY HOLDID[0:2]; 00169125 -REAL NXAVIL,STRTSEG; 00169126 -ALPHA ARRAY WOP[0:139]; % HOLDS NAME AND CODE OF WORD MODE OPERATORS 00169127 -SAVE ALPHA ARRAY DB,TB,CB[0:9], 00169128 - CRD[0:14]; 00169129 -ALPHA ARRAY XR[0:32]; INTEGER XRI; 00169130 -SAVE ARRAY ACCUM, EXACCUM[0:20] ; 00169131 -REAL ACCUMSTOP, EXACCUMSTOP ; 00169132 -REAL DBLOW; 00169133 -REAL MAX; 00169134 -ALPHA ACR1, CHR1; 00169135 -ALPHA ARRAY PERIODWORD[0:10]; 00169136 -REAL ARRAY MAP[0:7]; 00169137 -REAL F1, F2; 00169138 -INTEGER C1, C2; 00169139 -DEFINE 00169140 - RSP=14 #, RSP1=15 #, RWP=29 #, 00169141 - RSH=41 #, RSH1=42 #, RWS=83 #; 00169142 -ALPHA ARRAY RESERVEDWORDSLP[0:RWP], RESLENGTHLP,LPGLOBAL[0:RSP], 00169143 - RESERVEDWORDS [0:RWS], RESLENGTH [0:RSH] ; 00169144 -SAVE REAL ARRAY PR, OPST [0:25]; % USED IN EXPR ONLY 00169145 -DEFINE PARMLINK = LSTT#; 00169146 -ALPHA BUFF, BUFL, SYMBOL; 00169147 -INTEGER TV, % INDEX INTO INFO FOR PRT OF LIST NAMES 00169148 - SAVESUBS, % MAX NUMBER OF SUBSCRIPTS FOR NAMELIST IDENTIFIERS 00169149 - NAMEIND ; % INDEX INTO NAMLIST IDENTIFIERS ARRAY 00169150 -ARRAY NAMLIST[0:256]; % ARRAY TO STOKE NAMELIST IDENTIFIERS 00169151 -ALPHA LISTID; 00169152 -REAL ARRAY BDPRT[0:20]; REAL BDX; 00169153 -DEFINE MAXSTRING = 49#; 00169154 -ALPHA ARRAY STRINGARRAY[0:MAXSTRING]; 00169155 -REAL STRINGSIZE; % NUMBER OF WORDS IN STRING 00169156 -DEFINE LSTMAX = 256#; 00169157 -REAL ARRAY LSTT, LSTP[0:LSTMAX]; 00169158 -INTEGER LSTI,LSTS,LSTA; 00169159 -DEFINE MAXOPFILES = 63#, BIGGESTFILENB = 99#; 00169160 -ARRAY FILEINFO[0:3,0:MAXOPFILES]; 00169161 -DEFINE % SOME FILE STUFF 00169162 - SLOWV = 2#, 00169163 - FASTV = 1#, 00169164 - SENSPDEUNF= [1:8]#, 00169165 - SENSE= [1:1]#, 00169166 - SPDF = [2:2]#, 00169167 - EUNF = [4:5]#, 00169168 - FPBVERSION= 1#, 00169169 - FPBVERSF = [1:8]#, 00169170 - DKAREASZ = [9:39]#, 00169171 -ENDFILDEF=#; 00169172 -INTEGER MAXFILES; 00169173 -ARRAY TEN[0:137]; 00169174 -DEFINE LBRANCH = 50#; 00169175 -REAL ARRAY BRANCHES[0:LBRANCH]; REAL LAX, BRANCHX; 00169176 -INTEGER INXFIL,FILEARRAYPRT; 00169177 -DEFINE MAXCOM=15 # ; 00169178 -INTEGER SUPERMAXCOM; %%% SUPERMAXCOM = 128|(MAXCOM+1). 00169179 -ALPHA ARRAY COM[0:MAXCOM,0:127] ; 00169180 -REAL NEXTCOM; 00169181 -ALPHA ARRAY INFO[0:31, 0:127]; 00169182 -REAL ARYSZ; 00169183 -ALPHA ARRAY EXTRAINFO[0:31, 0:127]; 00169184 -REAL EXPT1, EXPT2, EXPT3; 00169185 -DEFINE IR = [36:5]#, IC = [41:7]#; 00169186 -REAL INFA,INFB,INFC; 00169187 -INTEGER NEXTINFO, GLOBALNEXTINFO, NEXTEXTRA; 00169188 -INTEGER NEXTSS; 00169189 -DEFINE SHX=189#, GHX=61#; 00169190 -REAL ARRAY STACKHEAD[0:SHX]; 00169191 -REAL ARRAY GLOBALSTACKHEAD[0:GHX]; 00169192 -REAL LA, DT, TEST; 00169193 -ALPHA LADR1,LADR2,LADR3,LADR4,LADR5,LINFA; INTEGER LINDX,LADDR; 00169194 -DEFINE MAXDOS=20#; 00169195 -ALPHA ARRAY DOTEST, DOLAB[0:MAXDOS]; 00169196 -ALPHA LISTART; 00169197 -ALPHA ARRAY INT[0:NUMINTM1+NUMINTM1+2]; 00169198 -ALPHA ARRAY TYPES[0:6], KLASS[0:14]; 00169199 -INTEGER OP, PREC, IP, IT; 00169200 -DEFINE DUMPSIZE=127 #; 00169201 -ARRAY FNNHOLD[0:DUMPSIZE]; 00169202 -INTEGER FNNINDEX,FNNPRT; 00169203 -DEFINE MAXNBHANG = 30#; 00169204 -ARRAY FNNHANG[0:MAXNBHANG]; 00169205 -DEFINE INTCLASS=[6:3]#, INTPARMCLASS=[9:3]#, INTINLINE=[12:6]#, 00169206 - INTPRT =[24:6]#, INTPARMS =[30:6]#, INTNUM =[36:12]#, 00169207 - INAM =[12:36]#, INTX =[2:10]#, INTSEEN =[2:1]# ; 00169208 -DEFINE 00169209 - INSERTMAX = 20 #, % MAX NO OF RECURSIVE CALL ALLOW ON LIB ROUT 00169210 - INSERCOP = INSERTINFO[INSERTDEPTH,4] #, 00169211 - INSERTMID = INSERTINFO[INSERTDEPTH,0] #, 00169212 - INSERTFID = INSERTINFO[INSERTDEPTH,1] #, 00169213 - INSERTINX = INSERTINFO[INSERTDEPTH,2] #, 00169214 - INSERTSEQ = INSERTINFO[INSERTDEPTH,3] #; 00169215 -ARRAY INSERTINFO[0:INSERTMAX,0:4]; 00169216 -DEFINE MSRW=11 #; 00169217 -ALPHA ARRAY MESSAGE[0:MSRW,0:96] ; 00169218 -BOOLEAN ARRAY MSFL[0:MSRW]; 00169219 -ALPHA ARRAY LINEDICT[0:7,0:127]; % LINE DICTIONARY ARRAY 00169220 -ALPHA ARRAY LINESEG [0:11,0:127]; % LINE SEGMENT ARRAY 00169221 -ARRAY TSSMESA[0:15] ; %%% BIT FLAGS PRNTD ERR MESSGS ({748). 00169222 -INTEGER NOLIN; % NUMBER OF ENTRIES IN LINE SEGMENT 00169223 -REAL LASTADDR; %%% STORES LAST ADR. 00169224 -INTEGER WARNCOUNT; %%% COUNTS NUMBER OF TSS WARNINGS. 00169225 -DEFINE CE = [2:1]#, %INFA %996-00169226 - LASTC = [3:12]#, %INFA %996-00169227 - SEGNO = [3:9]#, %INFA %996-00169228 - CLASS = [15:5]#, %INFA %996-00169229 - EQ = [20:1]#, %INFA %996-00169230 - SUBCLASS = [21:3]#, %INFA %996-00169231 - CLASNSUB = [14:10]#, %INFA %996-00169232 - ADJ = [14:1]#, %INFA %996-00169233 - TWOD = [14:1]#, %INFA %996-00169234 - FORMAL = [13:1]#, %INFA %996-00169235 - TYPEFIXED= [12:1]#, %INFA %996-00169236 - ADDR = [24:12]#, %INFA %996-00169237 - LINK = [36:12]#, %INFC %996-00169238 - BASE = [18:15]#, %INFC %996-00169239 - SIZE = [33:15]#, %INFC %996-00169240 - BASENSIZE= [18:30]#, %INFC %996-00169241 - NEXTRA = [2:6]#, %INFC %996-00169242 - ADINFO = [8:10]#, %INFC %996-00169243 - RELADD = [21:15]#, %INFA %996-00169244 - TOCE = 2:47:1#, %INFA %996-00169245 - TOSEGNO = 3:39:9#, %INFA %996-00169246 - TOLASTC = 3:36:12#, %INFA %996-00169247 - TOCLASS = 15:43:5#, %INFA %996-00169248 - TOEQ = 20:47:1#, %INFA %996-00169249 - TOSUBCL = 21:45:3#, %INFA %996-00169250 - TOADJ = 14:47:1#, %INFA %996-00169251 - TOFORMAL = 13:47:1#, %INFA %996-00169252 - TOTYPE = 12:47:1#, %INFA %996-00169253 - TOADDR = 24:36:12#, %INFA %996-00169254 - TOLINK = 36:36:12#, %INFC %996-00169255 - TOBASE = 18:33:15#, %INFC %996-00169256 - TOSIZE = 33:33:15#, %INFC %996-00169257 - TONEXTRA = 2:42:6#, %INFC %996-00169258 - TOADINFO = 8:38:10#, %INFC %996-00169259 - TORELADD = 21:33:15#, %INFA %996-00169260 - %THE FOLLOWING CLASSES APPEAR IN THE 1ST WORD OF EACH 3-WORD ENTRY 00169261 - %OF THE "INFO" ARRAY, AND MAY BE COPIED TO INFA.CLASS. %996-00169262 - UNKNOWN = 0#, 00169263 - ARRAYID = 1#, 00169264 - VARID = 2#, 00169265 - STMTFUNID= 3#, 00169266 - NAMELIST = 4#, 00169267 - FORMATID = 5#, 00169268 - LABELID = 6#, 00169269 - FUNID = 7#, 00169270 - INTRFUNID= 8#, 00169271 - EXTID = 9#, 00169272 - SUBRID = 10#, 00169273 - BLOCKID = 11#, 00169274 - FILEID = 12#, 00169275 - SUBSVAR = 13#, 00169276 - EXPCLASS = 14#, 00169277 - SBVEXP = 15#, 00169278 - LISTSID = 16#, 00169279 - JUNK = 17#, % NOT A GENUINE CLASS %99600169280- - DUMMY = 27#, 00169281 - NUMCLASS = 28#, 00169282 - RESERVED = 29#, 00169283 - HEADER = 30#, 00169284 - ENDCOM = 31#, 00169285 - %THE FOLLOWING SUBCLASSES APPEAR IN THE 1ST WORD OF SOME 3-WORKD%99600169286- - %ENTRIES OF THE "INFO" ARRAY, AND MAY BE COPIED TO INFA.SUBCLASS. 00169287 - INTYPE = 1#, 00169288 - STRINGTYPE=2#, 00169289 - REALTYPE = 3#, 00169290 - LOGTYPE = 4#, 00169291 - DOUBTYPE = 5#, 00169292 - COMPTYPE = 6#; 00169293 -DEFINE EOF= 500#, ID= 501#, NUM= 502#, PLUS= 503#, MINUS= 504#, 00169294 - STAR= 505#, SLASH= 506#, LPAREN= 507#, RPAREN= 508#, 00169295 - EQUAL= 509#, COMMA= 510#, SEMI= 511#, DOLLAR=0#, UPARROW=0# ; 00169296 -DEFINE THRU = STEP 1 UNTIL #; %996-00169297 -DEFINE 00169298 - ADD = 16#, BBC = 22#, BBW = 534#, BFC = 38#, BFW = 550# 00169299 - ,CDC =168#, CHS =134#, COC = 40#, KOM =130#, DEL = 10# 00169300 - ,DUP =261#, EQUL=581#, GBC = 278#, GBW =790#, GEQL= 21# 00169301 - ,GFC =294#, GFW =806#, GRTR= 37#, IDV =384#, INX = 24# 00169302 - ,ISD =532#, ISN =548#, LEQL= 533#, LND = 67#, LNG = 19# 00169303 - ,LOD =260#, LOR = 35#, LQV = 131#, LESS=549#, MDS = 515# 00169304 - ,MKS = 72#, MUL = 64#, NEQL= 69#, NOP = 11#, PRL = 18# 00169305 - ,XRT = 12#, RDV =896#, RTN = 39#,RTS =167#, SND = 132# 00169306 - , SSN = 70#, SSP = 582#, STD = 68#, SUB = 48#, XCH = 133# 00169307 - ,XIT = 71#, ZP1 =322#, DIU =128#, STN =132# 00169308 - ,DIA = 45#, DIB = 49#, TRB = 53#, ISO = 37# 00169309 - ,AD2 =17#, SB2 = 49#, ML2 = 65#, DV2 =129#, FTC = 197# 00169310 - ,SSF =280#, FTF =453#, CTC =709#, CTF = 965# 00169311 - ,TOP=262# 00169312 - ; 00169313 -FORMAT FD(X100,"NEXT = ",I3,X2,2A6) ; 00169314 -FORMAT SEGSTRT(X63, " START OF SEGMENT **********", I4), 00169315 - FLAGROUTINEFORMAT(X41,A6,A2,X1,2A6," (",A1,I*,")"), 00169316 - XHEDM(X40,"CROSS REFERENCE LISTING OF MAIN PROGRAM",X41,/, 00169317 - X40,"----- --------- ------- -- ---- -------",X41), 00169318 - XHEDS(X38, "CROSS REFERENCE LISTING OF SUBROUTINE ",A6,X38,/, 00169319 - X38, "----- --------- ------- -- ---------- ",A6,X38), 00169320 - XHEDF(X35,"CROSS REFERENCE LISTING OF ",A6,A1," FUNCTION ",A6, 00169321 - X35,/,X35,"----- --------- ------- -- ",A6,A1," -------- ",A6, 00169322 - X35), 00169323 - XHEDG(X43,"CROSS REFERENCE LISTING OF GLOBALS",X43,/, 00169324 - X43,"----- --------- ------- -- -------",X43), 00169325 - XHEDB(X34,"CROSS REFERENCE LISTING OF BLOCK DATA SUBPROGRAM",X35,00169326 - /,X34,"----- --------- ------- -- ----- ---- ----------",X35), 00169327 - SEGEND (X70," SEGMENT",I5," IS",I5," LONG"); 00169328 -ARRAY PDPRT [0:31,0:63]; 00169329 -REAL PDINX; % INDEX OF LAST ENTRY IN PDPRT 00169330 -REAL TSEGSZ; % RUNNING COUNT OF TOTAL SEGMENT SIZE; 00169331 - COMMENT FORMAT OF PRT&SEGMENT ENTRIES, IN PDPRT; 00169332 -DEFINE STYPF= [1:2]#, % 0 = PROGRAM SEGMENT-SEGMENT ENTRY ONLY 00169333 - STYPC= 1:46:2#, % 1 = MCP INTRINSIC 00169334 - % 2 = DATA SEGMENT 00169335 - DTYPF= [4:2]#, % 0 = THUNK - PRT ENTRY ONLY 00169336 - DTYPC= 4:46:2 #,% 1 = WORD MODE PROGRAM DESCRIPTOR 00169337 - % 2 = LABEL DESCRIPTOR 00169338 - % 3 = CHARACTER MODE PROGRAM DESCRIPTOR 00169339 - PRTAF= [8:10]#, % ACTUAL PRT ADDRESS - PRT ENTRY 00169340 - PRTAC= 8:38:10#, 00169341 - RELADF = [18:10]#, % ADDRESS WITHIN SEGMENT -PRT ONLY 00169342 - RELADC= 18:38:10#, 00169343 - SGNOF= [28:10]#, % SEGMENT NUMBER - BOTH 00169344 - SGNOC= 28:38:10#, 00169345 - DKAI = [13:15]#, % RELATIVE DISK ADDRESS - SEGMENT ENTRY 00169346 - DKAC = 13:33:15#, 00169347 - SEGSZF =[38:10]#, % SEGMENT SIZE - SEGMENT ENTRY 00169348 - SEGSZC =38:38:10#;% MUST BE 0 IF PRT ENTRY 00169349 -DEFINE % SOME EXTERNAL CONSTANTS 00169350 - BLKCNTRLINT = 5#, 00169351 - FPLUS2 = 1538#, 00169352 -ENDEXTCONDEF=#; 00169353 -DEFINE PDIR = PDINX.[37:5]#, 00169354 - PDIC = PDINX.[42:6]#; 00169355 -DEFINE CIS = CRD[0]#, % CARD 00169356 - TIS = CRD[1]#, % TAPE 00169357 - TOS = CRD[2]#, % NEW TAPE 00169358 - LOS = CRD[3]#; % PRINTER 00169359 -DEFINE PWROOT=ROOT.IR,ROOT.IC #,PWI=I.IR,I.IC # ; 00169360 -DEFINE GLOBALNEXT=NEXT#; 00169361 -BEGIN % SCAN FPB TO SEE IF VARIOUS FILES ARE DISK OR TAPE 00169362 -INTEGER STREAM PROCEDURE GETFPB(Q); VALUE Q; 00169363 - BEGIN 00169364 - SI ~ LOC GETFPB; SI ~ SI - 7; DI ~ LOC Q; DI ~ DI + 5; 00169365 - SKIP 3 DB; 9(IF SB THEN DS ~ SET ELSE DS ~ RESET; 00169366 - SKIP SB); 00169367 - DI ~ LOC Q; SI ~ Q; DS ~ WDS; SI ~ Q; GETFPB ~ SI; 00169368 - END; 00169369 -INTEGER STREAM PROCEDURE GNC(Q); VALUE Q; 00169370 - BEGIN SI ~ Q; SI ~ SI + 7; DI ~ LOC GNC; DI ~ DI +7; DS ~CHR END; 00169371 -INTEGER FPBBASE; 00169372 - FPBBASE ~ GETFPB(3); 00169373 - TIS ~ TOS ~ 50; CIS ~ LOS ~ 0; 00169374 - IF GNC(FPBBASE+3) =12 THEN CIS ~ 150; % CARD 00169375 - IF GNC(FPBBASE+8) =12 THEN LOS ~ 150; % PRINTER 00169376 - IF GNC(FPBBASE+13) = 12 THEN TOS ~ 150; % NEW TAPE; 00169377 - IF GNC(FPBBASE+18) =12 THEN TIS ~ 150; % TAPE 00169378 - END; 00169379 -BEGIN COMMENT INNER BLOCK; 00169380 -% *** DO NOT DECLARE ANY FILES PRIOR TO THIS POINT, DO NOT ALTER 00169381 -% SEQUENCE OF FOLLOWING FILE DECLARATIONS 00169382 -FILE CARD (5,10,CIS); 00169383 -DEFINE LINESIZE = 900 #; 00169384 -SAVE FILE LINE DISK SERIAL [20:LINESIZE] (2,15,LOS,SAVE 10); 00169385 -SAVE FILE NEWTAPE DISK SERIAL [20:LINESIZE] "FORSYM" (2,10,TOS,SAVE 10);00169386 -FILE TAPE "FORSYM" (2,10,TIS); 00169387 -FILE REMOTE 19(2,10) ; 00169388 -DEFINE CHUNK = 180#; 00169389 -DEFINE PTR=LINE#,RITE=LINE#,CR=CARD#,TP=TAPE#; %515-00169390 -FILE CODE DISK RANDOM [20:CHUNK] (4,30,SAVE ABS(SAVETIME)); 00169391 -FILE LIBRARYFIL DISK RANDOM (2,10,150); 00169392 -DEFINE LF = LIBRARYFIL#; 00169393 -FILE XREFF DISK SERIAL[20:1500](2,XRBUFF) ; 00169394 -FILE XREFG DISK SERIAL[20:1500](2,3,XRBUFF); 00169395 -REAL DALOC; % DISK ADDRESS 00169396 -LABEL POSTWRAPUP; 00169397 -PROCEDURE EMITNUM(N); VALUE N; REAL N; FORWARD; 00169398 -REAL PROCEDURE LOOKFORINTRINSIC(L); VALUE L; REAL L; FORWARD ; 00169399 -PROCEDURE SEGOVF; FORWARD; 00169400 -DEFINE BUMPADR= IF (ADR~ADR+1)=4089 THEN SEGOVF#; 00169401 -DEFINE BUMPLOCALS = BEGIN IF LOCALS.LOCALS+1>255 THEN BEGIN FLAG(148); 00169402 - LOCALS~2 END END#; 00169403 -DEFINE BUMPPRT=BEGIN IF PRTS~PRTS+1>1023 THEN BEGIN FLAG(46); 00169404 - PRTS~40 END END#; 00169405 -DEFINE EDOCI = ADR.[36:3], ADR.[39:7]#; 00169406 -DEFINE TWODPRT=IF TWODPRTX=0 THEN(TWODPRTX~PRTS~PRTS+1)ELSE TWODPRTX#; 00169407 -REAL PROCEDURE SEARCH(E); VALUE E; REAL E; FORWARD; 00169408 -PROCEDURE PRINTCARD; FORWARD; 00169409 -INTEGER PROCEDURE FIELD(X); VALUE X; INTEGER X; FORWARD ; 00169410 -ALPHA PROCEDURE NEED(T, C); VALUE T, C; ALPHA T, C; FORWARD; 00169411 -ALPHA PROCEDURE GETSPACE(S); VALUE S; ALPHA S; FORWARD; 00169412 -PROCEDURE EQUIV(R); VALUE R; REAL R; FORWARD; 00169413 -PROCEDURE EXECUTABLE; FORWARD; 00169414 -ALPHA PROCEDURE B2D(B); VALUE B; REAL B; FORWARD; 00169415 -PROCEDURE DEBUGWORD (N); VALUE N; REAL N; FORWARD; 00169416 -PROCEDURE EMITL(N); VALUE N; REAL N; FORWARD; 00169417 -PROCEDURE ADJUST;FORWARD; 00169418 -PROCEDURE DATIME; FORWARD; 00169419 -PROCEDURE EMITB(A,C); VALUE A,C; REAL A; BOOLEAN C; FORWARD; 00169420 -PROCEDURE FIXB(N); VALUE N; REAL N; FORWARD; 00169421 -PROCEDURE EMITO(N); VALUE N; REAL N; FORWARD; 00169422 -PROCEDURE EMITOPDCLIT(N); VALUE N; REAL N; FORWARD; 00169423 -PROCEDURE EMITDESCLIT(N); VALUE N; REAL N; FORWARD; 00169424 -PROCEDURE EMITPAIR(L,OP); VALUE L,OP; INTEGER L,OP; FORWARD; 00169425 -PROCEDURE EMITN(N); VALUE N; REAL N; FORWARD; 00169426 -PROCEDURE ARRAYDEC(I); VALUE I; REAL I; FORWARD; 00169427 -INTEGER PROCEDURE ENTER(W, E); VALUE W, E; ALPHA W, E; FORWARD; 00169428 -REAL PROCEDURE PRGDESCBLDR(A,B,C,D); VALUE A,B,C,D; REAL A,B,C,D; 00169429 - FORWARD; 00169430 -PROCEDURE WRITEDATA(A,B,C); VALUE A,B; REAL A,B; 00169431 - ARRAY C[0]; FORWARD; 00169432 -PROCEDURE SCAN; FORWARD; 00169433 -PROCEDURE SEGMENT(A,B,C,D); VALUE A,B,C; 00169434 - REAL A,B; BOOLEAN C; ARRAY D[0,0]; FORWARD; 00169435 -STREAM PROCEDURE MOVESEQ(OLD,NEW); BEGIN DI~OLD; SI~NEW; DS~WDS END ; 00169436 -PROCEDURE WRITAROW(N,ROW); VALUE N; INTEGER N; REAL ARRAY ROW[0] ; 00169437 -IF SINGLETOG THEN WRITE(LINE,N,ROW[*]) ELSE WRITE(RITE,N,ROW[*]) ; 00169438 -PROCEDURE WRITALIST(FMT,N,L1,L2,L3,L4,L5,L6,L7,L8); 00169439 -VALUE N,L1,L2,L3,L4,L5,L6,L7,L8; INTEGER N; 00169440 -REAL L1,L2,L3,L4,L5,L6,L7,L8; FORMAT FMT; 00169441 - BEGIN 00169442 - PRINTBUFF[1]~L1; 00169443 - L1~1 ; 00169444 - FOR L2~L2,L3,L4,L5,L6,L7,L8 DO PRINTBUFF[L1~L1+1]~L2 ; 00169445 - IF SINGLETOG THEN WRITE(LINE,FMT,FOR L1~1 THRU N DO PRINTBUFF[L1]) 00169446 - ELSE WRITE(RITE,FMT,FOR L1~1 THRU N DO PRINTBUFF[L1]) ; 00169447 - END WRITALIST ; 00169448 -STREAM PROCEDURE BLANKIT(A,N,P); VALUE N,P; 00169449 -BEGIN DI~A; N(DS~8 LIT" "); P(DS~8 LIT"99999999") END ; 00169450 -BOOLEAN STREAM PROCEDURE TSSMES(A,B); VALUE B; 00169451 -BEGIN SI~A; SKIP B SB; IF SB THEN ELSE BEGIN TALLY~1; TSSMES~TALLY ; 00169452 -DI~A; SKIP B DB; DS~SET END END OF TSSMES ; 00169453 -STREAM PROCEDURE TSSEDIT(X,P1,P2,P3,P,N); VALUE P1,P2,P3,N ; 00169454 -BEGIN DI~P;DS~16LIT"TSS WARNING: ";SI~X;SI~SI+2; DS~6CHR; DS~4LIT" ";00169455 -P1(DS~48LIT"A TSS HOL OR QUOTED STRING MUST BE ON 1 LINE ") ; 00169456 -P2(DS~48LIT"THIS CONSTRUCT IS ILLEGAL IN TSS FORTRAN ") ; 00169457 -P3(DS~48LIT"THIS CONSTRUCT IS UNRESERVED IN TSS FORTRAN ") ; 00169458 -DS~26LIT" "; DS~8LIT"*"; DS~LIT" "; SI~LOC N; DS~3DEC END TSSEDIT ; 00169459 -PROCEDURE TSSED(X,N); VALUE X,N; ALPHA X; INTEGER N ; 00169460 -BEGIN IF NOT (LISTOG OR SEQERRORS) THEN PRINTCARD ; UNPRINTED~FALSE ; 00169461 -TSSEDIT(X,N=1,N=2,N=3,PRINTBUFF,WARNCOUNT~WARNCOUNT+1) ; 00169462 -WRITAROW(14,PRINTBUFF) END OF TSSED; 00169463 -PROCEDURE ERRMESS(N); VALUE N; INTEGER N; 00169464 -BEGIN 00169465 -STREAM PROCEDURE PLACE(D,N,X,S,E,L); VALUE N,E ; 00169466 -BEGIN DI ~ D; DS ~ 6 LIT "ERROR "; 00169467 - SI ~ LOC N; DS ~ 3 DEC; DS ~ 5 LIT ": "; 00169468 - SI ~ X; SI ~ SI + 2; DS ~ 6 CHR; DS ~ 4 LIT " "; 00169469 - SI~S; DS~6 WDS; DS~6 LIT" "; SI~L; DS~8 CHR; DS~14 LIT" " ; 00169470 - DS ~ 8 LIT "X"; DS ~ LIT " "; 00169471 - SI ~ LOC E; DS ~ 3 DEC; 00169472 -END PLACE; 00169473 -STREAM PROCEDURE DCPLACE(D,N,X,S,M,P); VALUE N,P; 00169474 - BEGIN DI~D; DS~4LIT"ERR#"; SI~LOC N; DS~3 DEC; DS~3LIT" @ "; 00169475 - SI~S; DS~8CHR; DS~2LIT": "; SI~X; SI~SI+2; DS~6CHR; DS~54LIT" " ; 00169476 - END OF DCPLACE ; 00169477 -ERRORCT~ERRORCT+1; 00169478 -IF NOT MSFL[N DIV 16] THEN 00169479 - BEGIN 00169480 - MSFL[N DIV 16]~TRUE ; 00169481 - CASE(N DIV 16)OF 00169482 -BEGIN 00169483 - FILL MESSAGE[0,*] WITH 00169484 -"SYNTAX E","RROR "," "," "," "," ", %000 00169485 -"MISSING ","OPERATOR"," OR PUNC","TUATION "," "," ", %001 00169486 -"CONFLICT","ING COMM","ON AND/O","R EQUIVA","LENCE AL","LOCATION", %002 00169487 -"MISSING ","RIGHT PA","RENTHESI","S "," "," ", %003 00169488 -"ENTRY ST","MT ILLEG","AL IN MA","IN PGM O","R BLOCK ","DATA ", %004 00169489 -"MISSING ","END STAT","EMENT "," "," "," ", %005 00169490 -"ARITHMET","IC EXPRE","SSION RE","QUIRED "," "," ", %006 00169491 -"LOGICAL ","EXPRESSI","ON REQUI","RED "," "," ", %007 00169492 -"TOO MANY"," LEFT PA","RENTHESE","S "," "," ", %008 00169493 -"TOO MANY"," RIGHT P","ARENTHES","ES "," "," ", %009 00169494 -"FORMAL P","ARAMETER"," ILLEGAL"," IN COMM","ON "," ", %010 00169495 -"FORMAL P","ARAMETER"," ILLEGAL"," IN EQUI","VALENCE "," ", %011 00169496 -"THIS STA","TEMENT I","LLEGAL I","N BLOCK ","DATA SUB","PROGRAM ", %012 00169497 -"INFO ARR","AY OVERF","LOW "," "," "," ", %013 00169498 -"IMPROPER"," DO NEST"," "," "," "," ", %014 00169499 -"DO LABEL"," PREVIOU","SLY DEFI","NED "," "," ", %015 00169500 -0; 00169501 - FILL MESSAGE[1,*] WITH 00169502 -"UNRECOGN","IZED STA","TEMENT T","YPE "," "," ", %016 00169503 -"ILLEGAL ","DO STATE","MENT "," "," "," ", %017 00169504 -"FORMAT S","TATEMENT"," MUST HA","VE LABEL"," "," ", %018 00169505 -"UNDEFINE","D LABEL "," "," "," "," ", %019 00169506 -"MULTIPLE"," DEFINIT","ION "," "," "," ", %020 00169507 -"ILLEGAL ","IDENTIFI","ER CLASS"," IN THIS"," CONTEXT"," ", %021 00169508 -"UNPAIRED"," QUOTES ","IN FORMA","T "," "," ", %022 00169509 -"NOT ENOU","GH SUBSC","RIPTS "," "," "," ", %023 00169510 -"TOO MANY"," SUBSCRI","PTS "," "," "," ", %024 00169511 -"FUNCTION"," OR SUBR","OUTINE P","REVIOUSL","Y DEFINE","D ", %025 00169512 -"FORMAL P","ARAMETER"," MULTIPL","Y DEFINE","D IN HEA","DING ", %026 00169513 -"ILLEGAL ","USE OF N","AMELIST "," "," "," ", %027 00169514 -"NUMBER O","F PARAME","TERS INC","ONSISTEN","T "," ", %028 00169515 -"CANNOT B","RANCH TO"," FORMAT ","STATEMEN","T "," ", %029 00169516 -"SUBROUTI","NE OR FU","NCTION N","OT DEFIN","ED IN PR","OGRAM ", %030 00169517 -"IDENTIFI","ER ALREA","DY GIVEN"," TYPE "," "," ", %031 00169518 -0; 00169519 - 00169520 - FILL MESSAGE[2,*] WITH 00169521 -"ILLEGAL ","FORMAT S","YNTAX "," "," "," ", %032 00169522 -"INCORREC","T USE OF"," FILE "," "," "," ", %033 00169523 -"INCONSIS","TENT USE"," OF IDEN","TIFIER "," "," ", %034 00169524 -"ARRAY ID","ENTIFIER"," EXPECTE","D "," "," ", %035 00169525 -"EXPRESSI","ON VALUE"," REQUIRE","D "," "," ", %036 00169526 -"ILLEGAL ","FILE CAR","D SYNTAX"," "," "," ", %037 00169527 -"ILLEGAL ","CONTROL ","ELEMENT "," "," "," ", %038 00169528 -"DECLARAT","ION MUST"," PRECEDE"," FIRST R","EFERENCE"," ", %039 00169529 -"INCONSIS","TENT USE"," OF LABE","L AS PAR","AMETER "," ", %040 00169530 -"NO. OF P","ARAMS. D","ISAGREES"," WITH PR","EV. REFE","RENCE ", %041 00169531 -"ILLEGAL ","USE OF F","ORMAL PA","RAMETER "," "," ", %042 00169532 -"ERROR IN"," HOLLERI","TH LITER","AL CHARA","CTER COU","NT ", %043 00169533 -"ILLEGAL ","ACTUAL P","ARAMETER"," "," "," ", %044 00169534 -"TOO MANY"," SEGMENT","S IN SOU","RCE PROG","RAM "," ", %045 00169535 -"TOO MANY"," PRT ASS","IGNMENTS"," IN SOUR","CE PROGR","AM ", %046 00169536 -"LAST BLO","CK DECLA","RATION H","AD LESS ","THAN 102","4 WORDS ", %047 00169537 -0; 00169538 - FILL MESSAGE[3,*] WITH 00169539 -"ILLEGAL ","I/O LIST"," ELEMENT"," "," "," ", %048 00169540 -"LEFT SID","E MUST B","E SIMPLE"," OR SUBS","CRIPTED ","VARIABLE", %049 00169541 -"VARIABLE"," EXPECTE","D "," "," "," ", %050 00169542 -"ILLEGAL ","USE OF .","OR. "," "," "," ", %051 00169543 -"ILLEGAL ","USE OF .","AND. "," "," "," ", %052 00169544 -"ILLEGAL ","USE OF .","NOT. "," "," "," ", %053 00169545 -"ILLEGAL ","USE OF R","ELATIONA","L OPERAT","OR "," ", %054 00169546 -"ILLEGAL ","MIXED TY","PES "," "," "," ", %055 00169547 -"ILLEGAL ","EXPRESSI","ON STRUC","TURE "," "," ", %056 00169548 -"ILLEGAL ","PARAMETE","R "," "," "," ", %057 00169549 -"RECORD B","LOCK GRE","ATER THA","N 1023 "," "," ", %058 00169550 -"TOO MANY"," OPTIONA","L FILES "," "," "," ", %059 00169551 -"FILE CAR","DS MUST ","PRECEDE ","SOURCE D","ECK "," ", %060 00169552 -"BINARY W","RITE STA","TEMENT H","AS NO LI","ST "," ", %061 00169553 -"UNDEFINE","D FORMAT"," NUMBER "," "," "," ", %062 00169554 -"ILLEGAL ","EXPONENT"," IN CONS","TANT "," "," ", %063 00169555 -0; 00169556 - FILL MESSAGE[4,*] WITH 00169557 -"ILLEGAL ","CONSTANT"," IN DATA"," STATEME","NT "," ", %064 00169558 -"MAIN PRO","GRAM MIS","SING "," "," "," ", %065 00169559 -"PARAMETE","R MUST B","E ARRAY ","IDENTIFI","ER "," ", %066 00169560 -"PARAMETE","R MUST B","E EXPRES","SION "," "," ", %067 00169561 -"PARAMETE","R MUST B","E LABEL "," "," "," ", %068 00169562 -"PARAMETE","R MUST B","E FUNCTI","ON IDENT","IFIER "," ", %069 00169563 -"PARAMETE","R MUST B","E FUNCTI","ON OR SU","BROUTINE"," ID ", %070 00169564 -"PARAMETE","R MUST B","E SUBROU","TINE IDE","NTIFIER "," ", %071 00169565 -"PARAMETE","R MUST B","E ARRAY ","IDENTIFI","ER OR EX","PRESSION", %072 00169566 -"ARITHMET","IC - LOG","ICAL CON","FLICT ON"," STORE "," ", %073 00169567 -"ARRAYID ","MUST BE ","SUBSCRIP","TED IN T","HIS CONT","EXT ", %074 00169568 -"MORE THA","N ONE MA","IN PROGR","AM "," "," ", %075 00169569 -"ONLY COM","MON ELEM","ENTS PER","MITTED "," "," ", %076 00169570 -"TOO MANY"," FILES "," "," "," "," ", %077 00169571 -"FORMAT O","R NAMELI","ST TOO L","ONG "," "," ", %078 00169572 -"FORMAL P","ARAMETER"," MUST BE"," ARRAY I","DENTIFIE","R ", %079 00169573 -0; 00169574 - FILL MESSAGE[5,*] WITH 00169575 -"FORMAL P","ARAMETER"," MUST BE"," SIMPLE ","VARIABLE"," ", %080 00169576 -"FORMAL P","ARAMETER"," MUST BE"," FUNCTIO","N IDENTI","FIER ", %081 00169577 -"FORMAL P","ARAMETER"," MUST BE"," SUBROUT","INE IDEN","TIFIER ", %082 00169578 -"FORMAL P","ARAMETER"," MUST BE"," FUNCTIO","N OR SUB","ROUTINE ", %083 00169579 -"DO OR IM","PLIED DO"," INDEX M","UST BE I","NTEGER O","R REAL ", %084 00169580 -"ILLEGAL ","COMPLEX ","CONSTANT"," "," "," ", %085 00169581 -"ILLEGAL ","MIXED TY","PE STORE"," "," "," ", %086 00169582 -"CONSTANT"," EXCEEDS"," HARDWAR","E LIMITS"," "," ", %087 00169583 -"PARAMETE","R TYPE C","ONFLICTS"," WITH PR","EVIOUS U","SE ", %088 00169584 -"COMPLEX ","EXPRESSI","ON ILLEG","AL IN IF"," STATEME","NT ", %089 00169585 -"COMPLEX ","EXPRESSI","ON ILLEG","AL IN RE","LATION "," ", %090 00169586 -"TOO MANY"," FORMATS"," REFEREN","CED BUT ","NOT YET ","FOUND ", %091 00169587 -"VARIABLE"," ARRAY B","OUND MUS","T BE FOR","MAL VARI","ABLE ", %092 00169588 -"ARRAY BO","UND MUST"," HAVE IN","TEGER OR"," REAL TY","PE ", %093 00169589 -"COMMA OR"," RIGHT P","ARENTHES","IS EXPEC","TED "," ", %094 00169590 -"ARRAY AL","READY GI","VEN BOUN","DS "," "," ", %095 00169591 -0; 00169592 - FILL MESSAGE[6,*] WITH 00169593 -"ONLY FOR","MAL ARRA","YS MAY B","E GIVEN ","VARIABLE"," BOUNDS ", %096 00169594 -"MISSING ","LEFT PAR","ENTHESIS"," IN IMPL","IED DO "," ", %097 00169595 -"SUBSCRIP","T MUST B","E INTEGE","R OR REA","L "," ", %098 00169596 -"ARRAY SI","ZE CANNO","T EXCEED"," 32767 W","ORDS "," ", %099 00169597 -"COMMON O","R EQUIV ","BLOCK CA","NNOT EXC","EED 3276","7 WORDS ", %100 00169598 -"THIS STA","TEMENT I","LLEGAL I","N LOGICA","L IF "," ", %101 00169599 -"REAL OR ","INTEGER ","TYPE REQ","UIRED "," "," ", %102 00169600 -"ARRAY BO","UND INFO","RMATION ","REQUIRED"," "," ", %103 00169601 -"REPLACEM","ENT OPER","ATOR EXP","ECTED "," "," ", %104 00169602 -"IDENTIFI","ER EXPEC","TED "," "," "," ", %105 00169603 -"LEFT PAR","ENTHESIS"," EXPECTE","D "," "," ", %106 00169604 -"ILLEGAL ","FORMAL P","ARAMETER"," "," "," ", %107 00169605 -"RIGHT PA","RENTHESI","S EXPECT","ED "," "," ", %108 00169606 -"STATEMEN","T NUMBER"," EXPECTE","D "," "," ", %109 00169607 -"SLASH EX","PECTED "," "," "," "," ", %110 00169608 -"ENTRY ST","ATEMENT ","CANNOT B","EGIN PRO","GRAM UNI","T ", %111 00169609 -0; 00169610 - FILL MESSAGE[7,*] WITH 00169611 -"ARRAY MU","ST BE DI","MENSIONE","D PRIOR ","TO EQUIV"," STMT ", %112 00169612 -"INTEGER ","CONSTANT"," EXPECTE","D "," "," ", %113 00169613 -"COMMA EX","PECTED "," "," "," "," ", %114 00169614 -"SLASH OR"," END OF ","STATEMEN","T EXPECT","ED "," ", %115 00169615 -"FORMAT, ","ARRAY OR"," NAMELIS","T EXPECT","ED "," ", %116 00169616 -"END OF S","TATEMENT"," EXPECTE","D "," "," ", %117 00169617 -"IO STATE","MENT WIT","H NAMELI","ST CANNO","T HAVE I","O LIST ", %118 00169618 -"COMMA OR"," END OF ","STATEMEN","T EXPECT","ED "," ", %119 00169619 -"STRING T","OO LONG "," "," "," "," ", %120 00169620 -"MISSING ","QUOTE AT"," END OF ","STRING "," "," ", %121 00169621 -"ILLEGAL ","ARRAY BO","UND "," "," "," ", %122 00169622 -"TOO MANY"," HANGING"," BRANCHE","S "," "," ", %123 00169623 -"TOO MANY"," COMMON ","OR EQUIV","ALENCE E","LEMENTS "," ", %124 00169624 -"ASTERISK"," EXPECTE","D "," "," "," ", %125 00169625 -"COMMA OR"," SLASH E","XPECTED "," "," "," ", %126 00169626 -"DATA SET"," TOO LAR","GE "," "," "," ", %127 00169627 -0; 00169628 - FILL MESSAGE[8,*] WITH 00169629 -"TOO MANY"," ENTRY S","TATEMENT","S IN THI","S SUBPRO","GRAM ", %128 00169630 -"DECIMAL ","WIDTH EX","CEEDS FI","ELD WIDT","H "," ", %129 00169631 -"UNSPECIF","IED FIEL","D WIDTH "," "," "," ", %130 00169632 -"UNSPECIF","IED SCAL","E FACTOR"," "," "," ", %131 00169633 -"ILLEGAL ","FORMAT C","HARACTER"," "," "," ", %132 00169634 -"UNSPECIF","IED DECI","MAL FIEL","D "," "," ", %133 00169635 -"DECIMAL ","FIELD IL","LEGAL FO","R THIS S","PECIFIER"," ", %134 00169636 -"ILLEGAL ","LABEL "," "," "," "," ", %135 00169637 -"UNDEFINE","D NAMELI","ST "," "," "," ", %136 00169638 -"MULTIPLY"," DEFINED"," ACTION ","LABELS "," "," ", %137 00169639 -"TOO MANY"," NESTED ","DO STATE","MENTS "," "," ", %138 00169640 -"STMT FUN","CTION ID"," AND EXP","RESSION ","DISAGREE"," IN TYPE", %139 00169641 -"ILLEGAL ","USE OF S","TATEMENT"," FUNCTIO","N "," ", %140 00169642 -"UNRECOGN","IZED CON","STRUCT "," "," "," ", %141 00169643 -"RETURN, ","STOP OR ","CALL EXI","T REQUIR","ED IN SU","BPROGRAM", %142 00169644 -"FORMAT N","UMBER US","ED PREVI","OUSLY AS"," LABEL "," ", %143 00169645 -0; 00169646 - FILL MESSAGE[9,*] WITH 00169647 -"LABEL US","ED PREVI","OUSLY AS"," FORMAT ","NUMBER "," ", %144 00169648 -"NON-STAN","DARD RET","URN REQU","IRES LAB","EL PARAM","ETERS ", %145 00169649 -"DOUBLE O","R COMPLE","X REQUIR","ES EVEN ","OFFSET "," ", %146 00169650 -"FORMAL P","ARAMETER"," ILLEGAL"," IN DATA"," STATEME","NT ", %147 00169651 -"TOO MANY"," LOCAL V","ARIABLES"," IN SOUR","CE PROGR","AM ", %148 00169652 -"A $FREEF","ORM SOUR","CE LINE ","MUST HAV","E < 67 C","OLS ", %149 00169653 -"A HOL/ST","RING UND","ER $FREE","FORM MUS","T BE ON ","ONE LINE", %150 00169654 -"THIS CON","STRUCT I","S ILLEGA","L IN TSS","FORTRAN "," ", %151 00169655 -"ILLEGAL ","FILE CAR","D PARAME","TER VALU","E "," ", %152 00169656 -"RETURN I","N MAIN P","ROGRAM N","OT ALLOW","ED "," ", %153 00169657 -"NON-POSI","TIVE SUB","SCRIPTS ","ARE ILLE","GAL "," ", %154 00169658 -"NON-IDEN","TIFIER U","SED FOR ","NAME OF ","LIBRARY ","ROUTINE ", %155 00169659 -"HYPHEN E","XPECTED "," "," "," "," ", %156 00169660 -"SEQUENCE"," NUMBER ","EXPECTED"," "," "," ", %157 00169661 -"TOO MANY"," RECURSI","VE CALLS"," ON LIBR","ARY ROUT","INE ", %158 00169662 -"ASTERISK"," NOT ALL","OWED ID ","READ STA","TEMENT "," ", %159 00169663 -0; 00169664 - FILL MESSAGE[10,*] WITH 00169665 -"ASTERISK"," ONLY AL","LOWED IN"," FREE FI","ELD OUTP","UT ", %160 00169666 -"TOO MANY"," *-ED LI","ST ELEME","NTS IN O","UTPUT "," ", %161 00169667 -"HOL OR Q","UOTED ST","RING > 7"," CHARACT","ERS IN E","XPRESSN ", %162 00169668 -"DECIMAL ","FIELD GR","EATER TH","AN FIELD"," WIDTH-5"," ", %163 00169669 -"PLUS NOT"," ALLOWED"," IN THIS"," FORMAT ","PHRASE "," ", %164 00169670 -"K NOT AL","LOWED IN"," THIS FO","RMAT PHR","ASE "," ", %165 00169671 -"$ NOT AL","LOWED IN"," THIS FO","RMAT PHR","ASE "," ", %166 00169672 -"INTRNSCS","-NAMD FU","NCT MUST"," HAV PRE","V EXTRNL"," REFERNC", %167 00169673 -"DATA STM","T COMMON"," ELEM MU","ST BE IN"," BLK DAT","A SUBPRG", %168 00169674 -"VARIABLE"," CANNOT ","BE A FOR","MAL PARA","METER OR"," IN CMMN", %169 00169675 -"CURRENT ","SUBPROGR","AM ID EX","PECTED "," "," ", %170 00169676 -"SUBPROGR","AM, EXTE","RNAL, OR"," ARRAY I","D EXPECT","ED ", %171 00169677 -"REPEAT, ","WIDTH, A","ND DECIM","AL PARTS"," MUST BE"," < 4091 ", %172 00169678 -"REPEAT P","ART MUST"," BE EMPT","Y OR > 0"," AND < 4","091 ", %173 00169679 -"IN SUBPR","GM:VARBL"," IS USED"," PRIOR T","O USE IN"," DATSTMT", %174 00169680 -"SYNTATIC","AL TOKEN"," CONTAIN","S TOO MA","NY CHARA","CTERS. ", %175 00169681 -0; 00169682 - FILL MESSAGE[11,*] WITH 00169683 -"INTEGER ","VALUE OF"," 8 EXPEC","TED "," "," ", %176 00169684 -"INTEGER ","VALUE OF"," 4 EXPEC","TED "," "," ", %177 00169685 -"INTEGER ","VALUE OF"," 4 OR 8 ","EXPECTED"," "," ", %178 00169686 -"AN ALPHA","BETIC LE","TTER (A,","B,C,...,","Z) IS RE","QUIRED ", %179 00169687 -"SECOND R","ANGE LET","TER MUST"," BE GREA","TER THAN"," FIRST ", %180 00169688 -"IMPLICIT"," MUST BE"," FIRST S","TATEMENT"," IN PROG","RAM UNIT", %181 00169689 -"REAL/INT","EGER/LOG","ICAL/COM","PLEX/DOU","BLEPRECI","SION REQ", %182 00169690 - "ILLEGAL ","USE OF A","STERISK ","FOR RUN-","TIME EDI","TING ",%111"00169691 - "NO PROGR","AM UNIT ","FOR THIS"," END STA","TEMENT "," ",%112"00169692 -0; 00169693 - 00169694 -END FILL STATEMENTS; 00169695 - 00169696 - 00169697 - END ; 00169698 -IF DCINPUT THEN 00169699 - BEGIN 00169700 - DCPLACE(ERRORBUFF,N,XTA,LASTSEQ,MESSAGE[N DIV 16,6|(N MOD 16)], 00169701 - IF TSSMESTOG THEN TSSMES(TSSMESA[(N-1)DIV 48], 00169702 - ENTIER((N-1) MOD 48)) ELSE FALSE) ; 00169703 - WRITE(REMOTE,9,ERRORBUFF[*]) ; 00169704 - END ; 00169705 -IF LISTOG OR NOT DCINPUT THEN 00169706 - BEGIN 00169707 - PLACE(ERRORBUFF,N,XTA,MESSAGE[N DIV 16,6|(N MOD 16)],ERRORCT, 00169708 - LASTERR) ; 00169709 - WRITAROW(14,ERRORBUFF) ; 00169710 - END; 00169711 -MOVESEQ(LASTERR,LINKLIST) ; 00169712 -END ERRMESS; 00169713 - 00169714 -PROCEDURE FLAGROUTINE(NAME1,NAME2,ENTERING) ; 00169715 -VALUE NAME1,NAME2,ENTERING ; 00169716 -ALPHA NAME1,NAME2; 00169717 -BOOLEAN ENTERING; 00169718 -IF ENTERING THEN WRITALIST(FLAGROUTINEFORMAT,7,"ENTERI","NG",NAME1, 00169719 -NAME2,"+",FIELD(FLAGROUTINECOUNTER~FLAGROUTINECOUNTER+1), 00169720 -FLAGROUTINECOUNTER,0) ELSE 00169721 - BEGIN 00169722 - WRITALIST(FLAGROUTINEFORMAT,7,"LEAVIN","G ",NAME1,NAME2,"-", 00169723 - FIELD(FLAGROUTINECOUNTER),FLAGROUTINECOUNTER,0) ; 00169724 - FLAGROUTINECOUNTER~FLAGROUTINECOUNTER-1 ; 00169725 - END ; 00169726 -%END OF FLAGROUTINE 00169727 -PROCEDURE FLAG(N); VALUE N; INTEGER N; 00169728 -IF NOT ERRORTOG OR DEBUGTOG THEN 00169729 -BEGIN 00169730 - IF NOT (LISTOG OR SEQERRORS OR DCINPUT) THEN PRINTCARD ; 00169731 - ERRMESS(N); 00169732 - IF ERRORCT } LIMIT THEN GO TO POSTWRAPUP; 00169733 -END; 00169734 -PROCEDURE FLOG(N); VALUE N; INTEGER N; 00169735 -IF NOT ERRORTOG OR DEBUGTOG THEN 00169736 - BEGIN ERRORTOG ~ TRUE; 00169737 - IF NOT (LISTOG OR SEQERRORS OR DCINPUT) THEN PRINTCARD; 00169738 - ERRMESS(N); 00169739 - IF ERRORCT } LIMIT THEN GO TO POSTWRAPUP; 00169740 - END; 00169741 -PROCEDURE FATAL(N); VALUE N; INTEGER N; 00169742 -BEGIN 00169743 - FORMAT FATALERR("XXXXXXXX", X18, 00169744 - "PREVIOUS ERROR IS FATAL - REMAINDER OF SUBPROGRAM IGNORED", 00169745 - X17, "XXXXXXXX"); 00169746 - ERRORTOG ~ FALSE; 00169747 - FLAG(N); 00169748 - WRITALIST(FATALERR,0,0,0,0,0,0,0,0,0) ; 00169749 - WHILE NEXT ! 11 DO % LOOK FOR END STMT 00169750 - BEGIN 00169751 - WHILE NEXT ! SEMI DO SCAN; 00169752 - EOSTOG ~ TRUE; 00169753 - SCAN; 00169754 - END; 00169755 - SEGMENT((ADR+4) DIV 4, NSEG, FALSE, EDOC); 00169756 - SCAN; 00169757 -END FATAL; 00169758 - 00169759 -REAL STREAM PROCEDURE D2B(BCL); BEGIN SI~BCL; DI~LOC D2B; DS~8OCT END;00169760 -REAL PROCEDURE GET(I); VALUE I; INTEGER I ; 00169761 - BEGIN 00169762 - GET ~ INFO[(I~I).IR,I.IC]; 00169763 - END GET; 00169764 -PROCEDURE PUT(I,VLU); VALUE I,VLU; INTEGER I; REAL VLU; 00169765 - BEGIN 00169766 - INFO[(I~I).IR,I.IC] ~ VLU; 00169767 - END PUT; 00169768 -PROCEDURE GETALL(I,INFA,INFB,INFC); 00169769 -VALUE I; INTEGER I; REAL INFA,INFB,INFC; 00169770 - BEGIN 00169771 - INFA ~ INFO[(I~I).IR,I.IC] ; 00169772 - INFB ~ INFO[(I~I+1).IR,I.IC]; 00169773 - INFC ~ INFO[(I~I+1).IR,I.IC]; 00169774 - END; 00169775 -PROCEDURE PUTC(I,V); VALUE I,V; INTEGER I; REAL V; 00169776 -IF I~I>SUPERMAXCOM THEN FATAL(124) ELSE COM[I.IR,I.IC]~V; 00169777 -REAL PROCEDURE GETC(I); VALUE I; INTEGER I ; 00169778 -GETC~COM[(I~I).IR,I.IC]; 00169779 -PROCEDURE BAPC(V); VALUE V; REAL V; 00169780 -IF NEXTCOM~NEXTCOM+1 > SUPERMAXCOM THEN FATAL(124) 00169781 -ELSE COM[NEXTCOM.IR,NEXTCOM.IC]~V ; 00169782 -STREAM PROCEDURE MOVEW(F,T,D,M); VALUE D,M; 00169783 - BEGIN SI ~ F; DI ~ T; D(DS ~32 WDS; DS ~ 32 WDS); DS ~ M WDS; END; 00169784 -PROCEDURE CALLEQUIV(I,B,G); VALUE I,B,G; INTEGER I; REAL G; BOOLEAN B ; 00169785 -BEGIN REAL A,T,R,INFA,INFC; 00169786 - REAL LAST,D; LABEL L; 00169787 -PROCEDURE CORRECTINFO(R,A); VALUE R,A; INTEGER R,A; 00169788 -COMMENT THIS PROCEDURE CORRECTS THE INFO TABLE FOR COMMON AND 00169789 - EQUIVALENCE ELEMENTS. 00169790 - IF ITEMS ARE IN COMMON THE INFA[EQ] BIT IS SET 00169791 - THIS BIT IS USED TO TELL DATA STATEMENTS THAT THIS IS A 00169792 - COMMON ELEMENT AND IF NOT IN BLOCK DATA SUBPROGRAM EMIT 00169793 - SYNTAX ERROR 168. 00169794 - THE INFA[CE] BIT IS SET TO TELL THAT IF THE CLASS IS VARID 00169795 - EMIT CODE AS IF THIS ITEM WERE ARRAYID BUT DO NOT 00169796 - ALLOW SUBSCRIPTING; 00169797 -BEGIN 00169798 - REAL T,I,LAST,L,REL,TWODBIT,INFA,INFB,INFC; 00169799 - REAL CEBIT; 00169800 - DEFINE LB = LOWERBOUND#; 00169801 - TWODBIT ~ REAL(LENGTH > 1023); 00169802 - CEBIT ~ REAL(LENGTH > 1); 00169803 - T ~ R; 00169804 - DO 00169805 - BEGIN 00169806 - LAST~GETC(T).LASTC-1 ; 00169807 - FOR I ~ T+2 STEP 1 UNTIL LAST DO 00169808 - BEGIN 00169809 - IF GETC(I).CLASS = ENDCOM THEN I~GETC(I).LINK ; 00169810 - INFA~GET(L~GETC(I).LINK); INFC~GET(L+2) ; 00169811 - IF INFC > 0 AND LB ! 0 THEN 00169812 - BEGIN 00169813 - IF BOOLEAN(INFA.ADJ) THEN 00169814 - REL ~ -INFC.BASE ELSE REL~INFC.BASE; 00169815 - PUT(L+2,-(INFC&(REL-LB)[TOBASE])); 00169816 - END; 00169817 - PUT(L,INFA&TWODBIT[TOADJ]&CEBIT[TOCE]&A[TOEQ]); 00169818 - END; 00169819 - END UNTIL T~GETC(T).ADDR=R ; 00169820 -END CORRECTINFO; 00169821 - 00169822 - LABEL XIT; 00169823 -IF DEBUGTOG THEN FLAGROUTINE(" CALLE","QUIV ",TRUE ); 00169824 -COMMENT THIS PROCEDURE MAKES THE DETERMINATION IF THIS GROUP 00169825 - IS EQUIVALENCE OR COMMON IF BOTH TREATED AS COMMON; 00169826 - T ~ I; 00169827 - GROUPPRT ~ LENGTH ~ A ~ 0; 00169828 - LOWERBOUND ~ 32000; 00169829 - DO BEGIN IF GETC(T).CE=1 THEN 00169830 - BEGIN IF GROUPPRT ! 0 THEN 00169831 - BEGIN XTA~G; 00169832 - FLAG(2); 00169833 - END; 00169834 - GROUPPRT~GET(A~GETC(T+1)).ADDR; 00169835 - END; 00169836 - IF T > R THEN R ~ T; 00169837 - END UNTIL T~GETC(T).ADDR=I ; 00169838 - IF GROUPPRT = 0 THEN 00169839 - IF B THEN BEGIN BUMPPRT;GROUPPRT~ PRTS END ELSE %OWN 00169840 - BEGIN BUMPLOCALS; GROUPPRT~LOCALS + 1536 END; 00169841 - T ~ R; 00169842 - SWARYCT ~0; 00169843 - SSNM[6]~LOCALS ; SSNM[7]~PARMS ; SSNM[8]~PRTS ; 00169844 - SSNM[9]~LSTS ; SSNM[10]~LSTA ; SSNM[11]~TV ; 00169845 - SSNM[12]~SAVESUBS; SSNM[13]~NAMEIND ; SSNM[14]~LSTI ; 00169846 - SSNM[15]~FX1 ; SSNM[16]~FX2 ; SSNM[17]~FX3 ; 00169847 - SSNM[18]~NX1 ; 00169848 - SEENADOUB~FALSE;% 00169849 - DO IF GETC(T+1) ! 0 THEN BEGIN EQUIV(T); T~R; END 00169850 - ELSE T~GETC(T).ADDR UNTIL T = R; 00169851 - IF GETC(T) > 0 THEN EQUIV(T); 00169852 - LOCALS~SSNM[6]; PARMS~SSNM[7]; PRTS~SSNM[8]; LSTS~SSNM[9] ; 00169853 - LSTA~SSNM[10]; TV~SSNM[11]; SAVESUBS~SSNM[12]; NAMEIND~SSNM[13] ;00169854 - LSTI~SSNM[14]; FX1~SSNM[15]; FX2~SSNM[16]; FX3~SSNM[17]; 00169855 - NX1~SSNM[18] ; 00169856 - LENGTH ~ LENGTH - LOWERBOUND; 00169857 - IF SEENADOUB THEN LENGTH~LENGTH+LENGTH.[47:1];% EVEN UP LENGTH 00169858 - SEENADOUB~FALSE; 00169859 - IF A = 0 THEN 00169860 - BEGIN COMMENT THIS IS AN EQUIVALENCE GROUP; 00169861 - IF SWARYCT } 1 AND LENGTH = 1 THEN LENGTH ~ 2; 00169862 - IF LENGTH > 1 THEN 00169863 - BEGIN 00169864 - A ~ ENTER(-0 & ARRAYID[TOCLASS] & GROUPPRT[TOADDR], 00169865 - EQVID ~ EQVID+1); 00169866 - PUT(A+2,0 & LENGTH[TOSIZE]); 00169867 - END; 00169868 - CORRECTINFO(R,0); 00169869 - GO TO XIT; 00169870 - END; 00169871 - COMMENT THIS IS A COMMON BLOCK; 00169872 - IF T ~ (INFC ~ GET(A+2)).SIZE ! 0 THEN 00169873 - IF T { 1023 AND LENGTH > 1023 THEN 00169874 - BEGIN XTA ~ GET(A+1); FLAG(47) END; 00169875 - IF T < LENGTH THEN PUT(A+2, INFC&LENGTH[TOSIZE]) ELSE LENGTH ~ T; 00169876 - IF LENGTH = 1 THEN LENGTH ~ 2; 00169877 - CORRECTINFO(R,1); 00169878 - XIT: 00169879 - IF LENGTH > 32767 THEN BEGIN XTA ~ GET(A+1); FLAG(100) END; 00169880 -IF DEBUGTOG THEN FLAGROUTINE(" CALLE","QUIV ",FALSE) ; 00169881 -END CALLEQUIV; 00169882 - 00169883 -STREAM PROCEDURE STOSEQ(XR,SEQ,ID); VALUE ID; 00169884 -BEGIN LOCAL T; LABEL L1,L2 ; 00169885 - SI ~ LOC ID; DI ~ XR; DS ~ 7LIT"0"; DS ~ CHR; SI ~ SI+1; 00169886 - IF SC } "0" THEN 00169887 - BEGIN SI~SI+4; DI~DI-2; 00169888 - 5(IF SC= " " THEN SI~SI-1 00169889 - ELSE BEGIN DS~CHR; SI~SI-2; DI~DI-2; END); 00169890 - END ELSE 00169891 - BEGIN DI~DI-6; 00169892 - 6(IF SC=" " THEN BEGIN TALLY~TALLY+1; SI~SI+1 END 00169893 - ELSE DS~CHR); 00169894 - T~TALLY; 00169895 - END; 00169896 - DI~XR; DI~DI+8; SI~SEQ; 00169897 - 8(IF SC=" " THEN SI~SI+1 ELSE JUMP OUT TO L1); DS~8LIT"BLANKSEQ";00169898 - GO L2; L1: SI~SEQ; DS~WDS; L2: 00169899 - DI~DI+4; SI~LOC T; SI~SI+7; DS~CHR; 00169900 -END; 00169901 -PROCEDURE ENTERX(IDENT,ADINFO); VALUE IDENT, ADINFO; 00169902 -REAL IDENT,ADINFO; 00169903 -BEGIN REAL R,S; 00169904 - IF ADINFO.CLASS>LABELID THEN 00169905 - BEGIN 00169906 - XR[2]~ADINFO; STOSEQ(XR,LINKLIST,IDENT); 00169907 - IF ADINFO.CLASS=FUNID THEN XR[2].[26:1]~S~1 ; 00169908 - WRITE(XREFG,3,XR[*]); XGLOBALS~TRUE; 00169909 - END ; 00169910 - IF R~XRI MOD XRBUFFDIV3=0 THEN 00169911 - IF XRI!0 THEN WRITE(XREFF,XRBUFF,XRRY[*]) ; 00169912 - XRRY[(R~R+R+R)+2]~ADINFO&S[26:47:1] ; 00169913 - STOSEQ(XRRY[R],LINKLIST,IDENT) ; 00169914 - IF XRI~XRI+1=1 THEN BEGIN XR[3]~IDENT; XR[4]~XRRY[2] END; 00169915 -END ENTERX; 00169916 - STREAM PROCEDURE TRANSFER(W2,B,K); VALUE K; 00169917 - BEGIN DI~W2; SI~B; SI~SI+8; K(DS~WDS; SI~SI+16) END ; 00169918 -BOOLEAN STREAM PROCEDURE CMPA(F,S); 00169919 -BEGIN SI~F; DI ~ S; IF 8 SC { DC THEN TALLY ~ 1; CMPA~TALLY; END; 00169920 -BOOLEAN PROCEDURE CMP(A,B); ARRAY A,B[0]; 00169921 -BEGIN 00169922 -CMP ~ IF A[0] < B[0] THEN TRUE ELSE IF A[0] = B[0] THEN 00169923 - IF A[2].[26:4] < B[2].[26:4] THEN TRUE ELSE 00169924 - IF A[2].[26:4] = B[2].[26:4] THEN CMPA(A[1],B[1]) ELSE FALSE 00169925 - ELSE FALSE; 00169926 -END; 00169927 -PROCEDURE HV(V); ARRAY V[0]; 00169928 -FILL V[*] WITH OCT777777777777777,OCT777777777777777,OCT777777777777777;00169929 - 00169930 -BOOLEAN PROCEDURE INP(XR); ARRAY XR[0]; 00169931 -BEGIN LABEL EOF; REAL R ; 00169932 -IF EODS THEN READ(XREFG,3,XR[*])[EOF] ELSE 00169933 -IF IT ~ IT+1 > XRI THEN 00169934 - BEGIN EOF: INP~TRUE; IT~XRI~0; END 00169935 -ELSE BEGIN 00169936 - IF R~(IT-1) MOD XRBUFFDIV3=0 THEN READ(XREFF,XRBUFF,XRRY[*]) ; 00169937 - XR[0]~XRRY[R~R+R+R]; XR[2]~XRRY[R+2]; TRANSFER(XR[1],XRRY[R],1) ; 00169938 - END ; 00169939 -END OF INP ; 00169940 - 00169941 -PROCEDURE VARIABLEDIMS(A,C); VALUE A, C; REAL A, C; 00169942 -BEGIN 00169943 - REAL NSUBS, BDLINK, BOUND, I; 00169944 - LABEL XIT; 00169945 -IF DEBUGTOG THEN FLAGROUTINE("VARIAB","LEDIMS",TRUE); 00169946 - IF NSUBS ~ C.NEXTRA = 1 AND A.SUBCLASS < DOUBTYPE THEN GO TO XIT; 00169947 - BDLINK ~ C.ADINFO; 00169948 - FOR I ~ 1 STEP 1 UNTIL NSUBS DO 00169949 - BEGIN 00169950 - IF BOUND ~ EXTRAINFO[BDLINK.IR,BDLINK.IC] < 0 THEN 00169951 - EMITOPDCLIT(BOUND) ELSE EMITNUM(BOUND); 00169952 - BDLINK ~ BDLINK -1; 00169953 - IF I > 1 THEN EMITO(MUL); 00169954 - END; 00169955 - IF A.SUBCLASS } DOUBTYPE THEN EMITPAIR(2, MUL); 00169956 - EMITPAIR( C,SIZE,STD); 00169957 - XIT: 00169958 -IF DEBUGTOG THEN FLAGROUTINE("VARIAB","LEDIMS",FALSE); 00169959 -END VARIABLEDIMS; 00169960 - 00169961 -PROCEDURE EMITD(R,OP); VALUE R,OP; REAL R,OP; FORWARD; 00169962 -STREAM PROCEDURE SETPNT(W1,W2,PNT,CL,SUBC,STAR,POS,F,S,Q) ; 00169963 -VALUE CL,SUBC,STAR,POS,F,S,Q ; 00169964 -BEGIN F(SI~W1; SI~SI+2; DI~PNT ; 00169965 - IF SC}"0" THEN 00169966 - BEGIN DS~5CHR; DS~LIT" "; DI~DI-6; DS~5FILL ; 00169967 - END ELSE BEGIN DS~6LIT" "; DI~PNT; DS~Q CHR END); 00169968 - S(DI~PNT; DI~DI+6; DS~LIT" "; 00169969 - SI ~ LOC SUBC; SI ~ SI+2; DS ~ 6 CHR; DS ~ LIT " "; 00169970 - SI~LOC CL; SI~SI+2; DS~6CHR; DS~LIT" "); 00169971 - DI~PNT; DI~DI+21; 00169972 - POS(DI~DI+11); 00169973 - SI ~ LOC STAR; SI ~ SI+7; DS ~ CHR; 00169974 - SI ~ W2; DS~8CHR ; 00169975 - SI ~ LOC STAR; SI ~ SI+7; DS ~ CHR; 00169976 -END OF SETPNT; 00169977 -PROCEDURE PT(EOF,REC); VALUE EOF; BOOLEAN EOF; ARRAY REC[0]; 00169978 -BEGIN LABEL L6; REAL L; 00169979 - IF EOF THEN WRITE(LINE,15,PRINTBUFF[*]) 00169980 - ELSE 00169981 - IF BOOLEAN(L~REAL(REC[0]~REC[0]&REC[2] [1:26:1]=XTA)) THEN 00169982 - BEGIN 00169983 - IF IT~IT+1=9 THEN 00169984 - BEGIN LASTLINE~FALSE; WRITE(LINE,15,PRINTBUFF[*]) ; 00169985 -L6: BLANKIT(PRINTBUFF,15,IT~0) ; 00169986 - END; 00169987 - SETPNT(REC[0],REC[1],PRINTBUFF,KLASS[REC[2],CLASS],TYPES[REC[2]00169988 - ,SUBCLASS],IF BOOLEAN(REC[2]) THEN "*" ELSE " ",IT,L-1, 00169989 - LASTLINE,6-REC[2],[27:3]) ; 00169990 - END 00169991 - ELSE BEGIN 00169992 - LASTLINE~TRUE; WRITE(RITE,15,PRINTBUFF[*]); XTA~REC[0] ;00169993 - GO L6 ; 00169994 - END ; 00169995 -END OF PT ; 00169996 - 00169997 -PROCEDURE CHECKINFO; 00169998 -BEGIN REAL I, T, A; 00169999 - REAL LASTF; 00170000 - REAL INFB,INFC; 00170001 - LABEL NXT; ALPHA N; 00170002 - FORMAT INFOF( 3(A6, X2), 00170003 - " ADDRESS = ", A2, A4, 00170004 - ", LENGTH = ", I5, 00170005 - ", OFFSET = ", I5), 00170006 - INFOT( / "LOCAL IDENTIFIERS:"), 00170007 - LABF(A6,X10,"LABEL REL-ADR = ",I6,", SEGMNT = ",I5); 00170008 - IF PRTOG THEN 00170009 - WRITALIST(INFOT,0,0,0,0,0,0,0,0,0) ; 00170010 - IF I ~ SEARCH("ERR ") ! 0 THEN 00170011 - IF GET(I).CLASS = UNKNOWN THEN PUT(I+1, "......"); 00170012 - IF I ~ SEARCH("END ") ! 0 THEN 00170013 - IF GET(I).CLASS = UNKNOWN THEN PUT(I+1, "......"); 00170014 - IF NOT DCINPUT THEN IF I~SEARCH("ZIP ") ! 0 THEN 00170015 - IF GET(I).CLASS=UNKNOWN THEN PUT(I+1,"......") ; 00170016 - FOR I ~ 0 STEP 1 UNTIL NEXTCOM DO 00170017 - IF GETC(I).CLASS=HEADER THEN 00170018 - 00170019 - IF GETC(I).CE=1 THEN 00170020 - PUT((T~GETC(I+1).LINK+2),GET(T)&0[TOADINFO]) ; 00170021 - 00170022 - T ~ 2; WHILE T < NEXTINFO DO 00170023 - BEGIN 00170024 - GETALL(T,A,INFB,INFC); 00170025 - IF I ~ A.CLASS > FILEID THEN GO TO NXT; 00170026 - IF N ~ INFB = "......" THEN GO TO NXT; 00170027 - XTA ~ N; 00170028 - IF I = LABELID THEN 00170029 - BEGIN 00170030 - IF A > 0 THEN FLAG(19) ELSE 00170031 - IF PRTOG THEN WRITALIST(LABF,3,N,A.ADDR DIV 4,A.SEGNO,0,0,0,0, 00170032 - 0) ; 00170033 - GO TO NXT; 00170034 - END; 00170035 - IF I = FORMATID THEN 00170036 - IF A > 0 THEN BEGIN FLAG(62); GO TO NXT END ; 00170037 - IF I = NAMELIST THEN 00170038 - IF A > 0 THEN BEGIN FLAG(136); GO TO NXT END; 00170039 - IF I = ARRAYID THEN 00170040 - IF BOOLEAN(A.CE) THEN BEGIN IF A>0 THEN T~GETSPACE(T) END 00170041 - ELSE IF A<0 THEN 00170042 - IF BOOLEAN(A.FORMAL) THEN 00170043 - BEGIN IF SPLINK > 1 AND ELX > 1 THEN 00170044 - BEGIN % THIS IS A FORMAL PARAMETER FOR A SUBROUTINE OR A 00170045 - % FUNCTION THAT HAS ONE OR MORE ENTRY STATEMENT. THIS 00170046 - % PARAMETER WILL BE INITIALIZED TO AN ARRAY DESCRIPTOR00170047 - % TO 0 SO THAT IF THE PARAMETERS ARE NOT SET UP BY THE00170048 - % CALL ANY REFERENCE TO THEM WILL CAUSE AN INVALID 00170049 - % ADDRESS 00170050 - IF LASTF = 0 THEN % FIRST TIME THRU 00170051 - BEGIN LASTF ~ A.ADDR; 00170052 - EMITDESCLIT(2); EMITL(1); 00170053 - EMITD(50,DIA); EMITD(10,DIB); EMITD(10,TRB); 00170054 - END ELSE EMITPAIR(LASTF,LOD); 00170055 - EMITPAIR(A.ADDR,SND); 00170056 - END 00170057 - END 00170058 - ELSE ARRAYDEC(T); 00170059 - IF PRTOG THEN 00170060 - WRITALIST(INFOF,7,INFB, 00170061 - IF BOOLEAN(A.TYPEFIXED) THEN TYPES[A.SUBCLASS] ELSE " ", 00170062 - KLASS[A.CLASS], 00170063 - IF A.ADDR < 1024 AND A < 0 THEN "R+" ELSE " ", 00170064 - IF A < 0 THEN B2D(A.[26:10]) ELSE "NULL", 00170065 - INFC.SIZE, 00170066 - INFC.BASE,0); 00170067 - IF BOOLEAN(A.CE) THEN IF A.SUBCLASS } DOUBTYPE THEN 00170068 - IF BOOLEAN(INFC.BASE) THEN FLAG(146); 00170069 - NXT: 00170070 - T ~ T+3; 00170071 - END; 00170072 -END CHECKINFO; 00170073 - 00170074 -PROCEDURE SEGMENTSTART; 00170075 -BEGIN 00170076 - NSEG ~ NXAVIL ~ NXAVIL + 1; 00170077 - IF LISTOG THEN WRITALIST(SEGSTRT,1,NSEG,0,0,0,0,0,0,0) ; 00170078 - DEBUGADR~ADR~-1; 00170079 - IF NOT SEGOVFLAG THEN 00170080 - BEGIN 00170081 - DATAPRT~DATASTRT~DATALINK~DATASKP~ 00170082 - LABELMOM ~ BRANCHX ~ FUNVAR ~ 00170083 - DT ~ SPLINK ~ NEXTCOM ~ ELX ~ 0; 00170084 - NEXTSS ~ 1022; 00170085 - INITIALSEGNO ~ NSEG; 00170086 - FOR I ~ 0 STEP 1 UNTIL LBRANCH DO BRANCHES[I] ~ I+1; 00170087 - FOR I~0 STEP 1 UNTIL SHX DO STACKHEAD[I] ~ 0; 00170088 - NEXTINFO ~ LOCALS ~ 2; 00170089 - F2TOG ~ FALSE; RETURNFOUND ~ FALSE; 00170090 - END; 00170091 - ENDSEGTOG ~ FALSE; 00170092 - IF SEGSW THEN LINESEG[NOLIN~0,0]~0 & D2B(LASTSEQ)[10:20:28] ; 00170093 -END SEGMENTSTART; 00170094 -PROCEDURE FIXPARAMS(I); VALUE I; INTEGER I; 00170095 -BEGIN 00170096 - REAL FMINUS, NPARMS, ELINK, LABX; 00170097 - REAL PLINKX, PLINK; 00170098 - REAL PTYPEX, PTYPE; 00170099 - REAL CL, INF; 00170100 - LABEL ARRY, LOAD, INDX; 00170101 - REAL EWORD; 00170102 -IF DEBUGTOG THEN FLAGROUTINE(" FIXP","ARMS ",TRUE); 00170103 - EWORD ~ ENTRYLINK[I]; 00170104 - ELINK ~ EWORD.LINK; 00170105 - IF LABX ~ EWORD.CLASS > 0 THEN 00170106 - BEGIN 00170107 - EMITO(MKS); 00170108 - EMITDESCLIT(LABELMOM); 00170109 - EMITL(LABX); 00170110 - EMITL(1); EMITL(1); EMITL(0); 00170111 - EMITOPDCLIT(BLKCNTRLINT); 00170112 - EMITL(1); EMITPAIR(FPLUS2,STD);% F+2~TRUE FOR BLKXIT CALL 00170113 - END; %10600170114- - FMINUS ~ 1920; 00170115 - NPARMS ~ (J~GET(ELINK+2)).NEXTRA; 00170116 - IF NPARMS > 0 THEN %10600170117- - BEGIN 00170118 - PLINKX ~ EWORD.ADDR-NPARMS+1; 00170119 - PTYPEX ~ J.ADINFO + NPARMS-1; 00170120 - FOR J ~ 1 STEP 1 UNTIL NPARMS DO 00170121 - BEGIN 00170122 - PLINK ~ EXTRAINFO[PLINKX.IR,PLINKX.IC]; 00170123 - PTYPE ~ EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS; 00170124 - FMINUS ~ FMINUS+1; 00170125 - IF PLINK = 0 THEN 00170126 - BEGIN 00170127 - EMITOPDCLIT(FMINUS); 00170128 - EMITL(LABX ~ LABX-1); 00170129 - EMITDESCLIT(LABELMOM); 00170130 - EMITO(STD); 00170131 - END ELSE 00170132 - BEGIN 00170133 - IF CL ~ (INF ~ GET(PLINK)).CLASS = UNKNOWN THEN CL ~ VARID; 00170134 - XTA ~ GET(PLINK+1); 00170135 - IF PTYPE = 0 THEN EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS 00170136 - ~ PTYPE ~ CL; 00170137 - CASE PTYPE OF 00170138 - BEGIN ; 00170139 - IF CL ! ARRAYID THEN FLAG(79) ELSE 00170140 - ARRY: 00170141 - BEGIN 00170142 - FMINUS ~ FMINUS+1; 00170143 - IF INF < 0 THEN 00170144 - BEGIN 00170145 - EMITPAIR(FMINUS, LOD); 00170146 - EMITPAIR(T~INF.ADDR, STD); 00170147 - EMITOPDCLIT(FMINUS-1); 00170148 - EMITPAIR(T-1, STD); 00170149 - END; 00170150 - END; 00170151 - IF CL ! VARID THEN FLAG(80) ELSE 00170152 - LOAD: 00170153 - BEGIN 00170154 - IF INF.SUBCLASS}DOUBTYPE AND CL=VARID THEN FMINUS~FMINUS+1; 00170155 - IF INF<0 THEN 00170156 - BEGIN 00170157 - EMITPAIR(FMINUS, LOD); 00170158 - EMITPAIR(T~INF.ADDR,STD); 00170159 - IF INF.SUBCLASS}DOUBTYPE AND CL=VARID THEN %10001701605- - BEGIN EMITOPDCLIT(FMINUS-1); 00170161 - EMITPAIR(T+1,STD); 00170162 - END; 00170163 - END ; 00170164 - END; 00170165 - ; ; ; ; 00170166 - IF CL = FUNID THEN GO TO LOAD ELSE FLAG(81); 00170167 - 00170168 - ; 00170169 - IF CL = FUNID OR CL = SUBRID OR CL = EXTID THEN GO TO LOAD 00170170 - ELSE FLAG(83); 00170171 - IF CL = SUBRID THEN GO TO LOAD ELSE FLAG(82); 00170172 - ; ; 00170173 - BEGIN 00170174 - IF CL = ARRAYID THEN 00170175 - BEGIN 00170176 - EXTRAINFO[PTYPEX.IR,PTYPEX.IC].CLASS ~ CL; 00170177 - GO TO ARRY; 00170178 - END; 00170179 - INDX: 00170180 - IF CL ! VARID THEN FLAG(80); 00170181 - FMINUS ~ FMINUS+1; 00170182 - IF INF < 0 THEN 00170183 - BEGIN 00170184 - EMITOPDCLIT(FMINUS-1); 00170185 - EMITDESCLIT(FMINUS); 00170186 - EMITPAIR(INF.ADDR, STD); 00170187 - END; 00170188 - END; 00170189 - IF CL = VARID THEN GO TO LOAD ELSE FLAG(80); 00170190 - GO TO INDX; 00170191 - END CASE STATEMENT; 00170192 - 00170193 - 00170194 - A ~ INF.SUBCLASS; 00170195 - IF T ~ EXTRAINFO[PTYPEX.IR,PTYPEX.IC].SUBCLASS = 0 OR 00170196 - T = INTYPE AND A = REALTYPE THEN 00170197 - EXTRAINFO[PTYPEX.IR,PTYPEX.IC].SUBCLASS ~ A ELSE 00170198 - IF T ! A THEN 00170199 - BEGIN XTA ~ GET(PLINK+1); FLAG(88) END; 00170200 - END; 00170201 - PLINKX ~ PLINKX+1; 00170202 - PTYPEX ~ PTYPEX-1; 00170203 - END; 00170204 - PLINKX ~ PLINKX-NPARMS; 00170205 - FOR J ~ 1 STEP 1 UNTIL NPARMS DO 00170206 - BEGIN 00170207 - PLINK ~ EXTRAINFO[PLINKX.IR,PLINKX.IC]; 00170208 - IF PLINK ! 0 THEN 00170209 - IF (A~GET(PLINK)).CLASS = ARRAYID THEN 00170210 - IF T~GET(PLINK+2) <0 THEN VARIABLEDIMS(A, T); 00170211 - PLINKX ~ PLINKX+1; 00170212 - END; 00170213 - END; 00170214 - EMITB(GET(ELINK+2).BASE & (GET(ELINK).SEGNO)[TOSEGNO], FALSE); 00170215 -IF DEBUGTOG THEN FLAGROUTINE(" FIXP","ARMS ",FALSE) ; 00170216 -END FIXPARAMS; 00170217 - 00170218 -PROCEDURE XREFCORESORT ; 00170219 - BEGIN 00170220 - REAL F,G,H,J,K,L,T,TT,IJ,M,TN ; 00170221 - SAVE ARRAY A[0:XRI-1], IL,IU[0:8]; 00170222 - ARRAY W2,W3[0:XRI-1] ; 00170223 - LABEL L1,L2,L3,L4,L5,L6,L11,L12,L13,L14 ; 00170224 - DEFINE CMPARGT(A) = A.NAME=TN THEN IF (IF G~W3[H~A.[2:10]].[26:4] 00170225 - =TT~W3[F~T.[2:10]].[26:4] THEN NOT CMPA(W2[H], 00170226 - W2[F]) ELSE G>TT) #, 00170227 - CMPARLS(A) = A.NAME=TN THEN IF (IF G~W3[H~T.[2:10]].[26:4] 00170228 - =TT~W3[F~A.[2:10]].[26:4] THEN NOT CMPA(W2[H], 00170229 - W2[F]) ELSE G>TT) #, 00170230 - NAME = [12:36] # ; 00170231 - J~XRI-1; G~XRI DIV K~XRBUFFDIV3; H~XRBUFF ; 00170232 - FOR L~1 STEP 1 UNTIL G DO 00170233 - BEGIN 00170234 -L11: READ(XREFF,H,XRRY[*]); TRANSFER(W2[T~(L-1)|50,XRRY,K) ; 00170235 - IJ~T+K-1; TN~-3; 00170236 - FOR F~T STEP 1 UNTIL IJ DO 00170237 - BEGIN A[F]~XRRY[TN~TN+3]&F[2:38:10]; W3[F]~XRRY[TN+2] END;00170238 - END; 00170239 - IF H=XRBUFF THEN IF K~XRI MOD K DIV 1!0 THEN BEGIN H~3|X;GO L11 END;00170240 - GO L4 ; 00170241 -L1: IF A[K~I].NAME>TN~(T~A[IJ~((L~J)+I+1).[37:10]]).NAME THEN 00170242 -L12: BEGIN A[IJ]~A[I]; A[I]~T; TN~(T~A[IJ]).NAME END 00170243 - ELSE IF CMPARGT(A[I]) THEN GO L12 ; 00170244 - IF A[J].NAMETN THEN GO L2; IF CMPARGT(A[L]) THEN GO L2; 00170253 -L3: IF A[K~K+1].NAMEJ+I THEN BEGIN IL[M]~I; IU[M]~L; I~K END 00170256 - M~M+1 ; 00170257 -L4: IF I+10TN~(T~A[I]).NAME THEN 00170261 - BEGIN 00170262 -L5: A[K+1]~A[K]; IF A[K~K-1].NAME>TN THEN GO L5 ; 00170263 - IF CMPARGT(A[K]) THEN GO L5 ; 00170264 - A[K+1]~T ; 00170265 - END 00170266 - ELSE IF CMPARGT(A[K]) THEN GO L5 ; 00170267 - IF (M~M-1) GEQ 0 THEN BEGIN I~IL[M]; J~IU[M]; GO L4 END ; 00170268 - G~XRI-1 ; 00170269 - FOR I~ 0 STEP 1 UNTIL G DO 00170270 - IF BOOLEAN(L~REAL(A[I]~A[I].NAME&(TN~W3[J~A[I].[2:10]])[1:26:1]00170271 - =XTA)) THEN 00170272 - BEGIN 00170273 - IF IT~IT+1=9 THEN 00170274 - BEGIN LASTLINE~FALSE; WRITE(LINE,15,PRINTBUFF[*]) ; 00170275 -L6: BLANKIT(PRINTBUFF,15,IT~0) ; 00170276 - END ; 00170277 - SETPNT(A[I],W2[J],PRINTBUFF,KLASS[TN.CLASS],TYPES[TN. 00170278 - SUBCLASS],IF BOOLEAN(TN) THEN "*" ELSE " ",IT,L-1, 00170279 - LASTLINE,6-TN.[27:3]) ; 00170280 - END 00170281 - ELSE BEGIN 00170282 - LASTLINE~TRUE; WRITE(RITE,15,PRINTBUFF[*]); XTA~A[I]; 00170283 - GO L6; 00170284 - END ; 00170285 - WRITE(LINE,15,PRINTBUFF[*]); XRI~0; 00170286 - END OF XREFCORESORT ; 00170287 - 00170288 -PROCEDURE SETUPSTACK ; 00170289 -BEGIN 00170290 - REAL I; 00170291 - EMITOPDCLIT(16); 00170292 - EMITL(1); 00170293 - EMITO(ADD); 00170294 - EMITL(16); 00170295 - EMITO(SND); 00170296 - FOR I ~ 1 STEP 1 UNTIL LOCALS DO EMITL(0); 00170297 - CHECKINFO; 00170298 - IF DATAPRT ! 0 THEN 00170299 - BEGIN ADJUST; EMITOPDCLIT(DATAPRT); EMITO(LNG); EMITB(-1,TRUE);00170300 - DATASKP~LAX; EMITB(DATASTRT,FALSE); FIXB(DATALINK); 00170301 - EMITL(1); EMITPAIR(DATAPRT,STD); FIXB(DATASKP); 00170302 - END; 00170303 - ADJUST; 00170304 -END SETUPSTACK; 00170305 - 00170306 -PROCEDURE BRANCHLIT(X,Y); VALUE X,Y; REAL X; BOOLEAN Y; 00170307 -BEGIN 00170308 - IF ADR } 4075 THEN 00170309 - BEGIN ADR ~ ADR+1; SEGOVF END; 00170310 - ADJUST; 00170311 - IF X.SEGNO!NSEG THEN BEGIN 00170312 - IF(PRTS+1).[37:2]=1 AND Y THEN 00170313 - EMITOPDCLIT(PRGDESCBLDR(2,0,(ADR+5) DIV 4+1,NSEG)) 00170314 - ELSE EMITOPDCLIT(PRGDESCBLDR(2,0,(ADR+5) DIV 4,NSEG)) END 00170315 - ELSE 00170316 - EMITL((ADR+5) DIV 4 - X.LINK DIV 4) ; 00170317 -END BRANCHLIT; 00170318 -PROCEDURE SEGMENT(SZ,CURSEG,SEGTYP,EDOC); % WRITES OUT EDOC AS SEGMENT 00170319 - VALUE SZ,CURSEG,SEGTYP; % UPDATES PDPRT WITH PSUEDO 00170320 - REAL SZ,CURSEG; % UPDATES PDPRT WITH PSUEDO 00170321 - BOOLEAN SEGTYP; % TRUE TO WRAP UP A SUBROUTINE BLOCK 00170322 - % FALSE TO WRAP UP A SPLIT BLOCK 00170323 - ARRAY EDOC[0,0]; % CONTAINS DATA TO WRITE; 00170324 - BEGIN 00170325 - STREAM PROCEDURE M1(F,T); BEGIN DI ~ T; SI ~ F; DS ~ 2 WDS END;00170326 - REAL T; 00170327 - REAL BEGINSUB, ENDSUB, HERE; 00170328 - LABEL WRITEPGM; 00170329 - INTEGER I, CNTR; 00170330 -IF DEBUGTOG THEN FLAGROUTINE(" SEGM","ENT ",TRUE ); 00170331 - IF NOT SEGTYP THEN GO TO WRITEPGM; 00170332 - IF SPLINK > 1 AND NOT RETURNFOUND THEN 00170333 - BEGIN XTA ~ BLANKS; FLAG(142) END; 00170334 - IF SPLINK < 0 THEN 00170335 - BEGIN 00170336 - ADJUST; 00170337 - BDPRT[BDX~BDX+1] ~ PRGDESCBLDR(1, 0, (ADR+1) DIV 4, NSEG); 00170338 - FOR I ~ 1 STEP 1 UNTIL LOCALS DO EMITL(0); 00170339 - CHECKINFO; 00170340 - 00170341 - EMITB(0&INITIALSEGNO[TOSEGNO], FALSE); 00170342 - END 00170343 - ELSE 00170344 - IF SPLINK = 1 THEN % MAIN PROGRAM 00170345 - BEGIN 00170346 - ADJUST; 00170347 - IF STRTSEG ! 0 THEN FLAG(75); 00170348 - STRTSEG ~ NSEG & 00170349 - PRGDESCBLDR(1, 0, (ADR+1) DIV 4, NSEG)[18:33:15]; 00170350 - SETUPSTACK; 00170351 - 00170352 - EMITB(0&INITIALSEGNO[TOSEGNO], FALSE); 00170353 - END 00170354 - ELSE 00170355 - IF ELX { 1 THEN 00170356 - BEGIN 00170357 - ADJUST; 00170358 - T ~ PRGDESCBLDR(1, GET(SPLINK).ADDR, (ADR+1) DIV 4, NSEG); 00170359 - SETUPSTACK; 00170360 - FIXPARAMS(0); 00170361 - INFC[SPLINK.IR, SPLINK.IC].SEGNO ~ NSEG; 00170362 - END 00170363 - ELSE 00170364 - BEGIN 00170365 - ADJUST; 00170366 - BEGINSUB ~ (ADR+1) & NSEG[TOSEGNO]; 00170367 - EMITL(17); EMITO(STD); 00170368 - SETUPSTACK; 00170369 - EMITOPDCLIT(17); EMITO(GFW); 00170370 - ENDSUB ~ ADR & NSEG[TOSEGNO]; 00170371 - FOR I ~ 0 STEP 1 UNTIL ELX-1 DO 00170372 - BEGIN 00170373 - ADJUST; 00170374 - HERE ~ (ADR+1) DIV 4; 00170375 - T ~ ENTRYLINK[I].LINK; 00170376 -%VOID 00170377 - T ~ PRGDESCBLDR(1, GET(T).ADDR, HERE, NSEG); 00170378 - BRANCHLIT(ENDSUB,FALSE); 00170379 - EMITB(BEGINSUB, FALSE); 00170380 - ADJUST; 00170381 - FIXPARAMS(I); 00170382 - INFC[(ENTRYLINK[I].LINK).IR,(ENTRYLINK[I].LINK).IC].SEGNO~NSEG;00170383 - END; 00170384 - END; 00170385 - SZ ~ (ADR+4) DIV 4; 00170386 - CNTR ~ 0; 00170387 - CURSEG ~ NSEG; 00170388 - WRITEPGM: 00170389 - NSEG ~ ((T ~ SZ) + 29) DIV 30; 00170390 - IF DALOC DIV CHUNK < I ~ (DALOC+NSEG) DIV CHUNK 00170391 - THEN DALOC ~ CHUNK | I; % INSURE SEGMENT DONT BREAK 00170392 - % ACROSS ROW 00170393 - IF LISTOG THEN WRITALIST(SEGEND,2,CURSEG,T,0,0,0,0,0,0) ; 00170394 - PDPRT[PDIR,PDIC] ~ % PDPRT ENTRY FOR SEGMENT 00170395 - SZ&DALOC[DKAC] 00170396 - & GET(SPLINK)[12:41:1] 00170397 - &CURSEG[SGNOC]; 00170398 - IF ERRORCT = 0 THEN 00170399 - DO BEGIN 00170400 - FOR I~0 STEP 2 WHILE I < 30 AND CNTR < SZ DO 00170401 - BEGIN M1(EDOC[CNTR.[38:3],CNTR.[41:7]],CODE(I)); 00170402 - CNTR ~ CNTR + 2; 00170403 - END; 00170404 - WRITE(CODE[DALOC]); 00170405 - DALOC ~ DALOC +1; 00170406 - END UNTIL CNTR } SZ; 00170407 - PDINX ~ PDINX +1; 00170408 - IF NOT SEGOVFLAG THEN 00170409 - IF PXREF THEN 00170410 - IF(EODS~(NEXT=EOF))AND NOT XGLOBALS THEN ELSE 00170411 - BEGIN KLASS[6]~ "LABEL "; 00170412 - WRITE(XREFF,XRBUFF,XRRY[*]) ; 00170413 - IF FIRSTCALL THEN DATIME ELSE WRITE(PTR[PAGE]); 00170414 - IF SPLINK<0 THEN 00170415 - BEGIN WRITE(PTR,XHEDB);REWIND(XREFF);END 00170416 - ELSE 00170417 - IF EODS THEN BEGIN WRITE(PTR,XHEDG); REWIND(XREFG) END 00170418 - ELSE BEGIN REWIND(XREFF); C2~(XR[4].SUBCLASS|2+5); 00170419 - IF TT~XR[4].CLASS=FUNID THEN WRITE(PTR,XHEDF, 00170420 - XR[C2],XR[C2+1],XR[3],XR[C2+12], 00170421 - XR[C2+13],"------") 00170422 - ELSE IF IT=SUBRID THEN WRITE(PTR,XHEDS,XR[3], 00170423 - "------") ELSE WRITE(PTR,XHEDM); 00170424 - END; 00170425 - IT~XTA~0; 00170426 - LASTLINE ~ FALSE; 00170427 - BLANKIT(PRINTBUFF,15,0); 00170428 - IF XRI>1023 OR EODS THEN SORT(PT,INP,0,HV,CMP,3,4000) 00170429 - ELSE XREFCORESORT ; 00170430 - REWIND(XREFF); 00170431 - PXREF~IF XREF THEN TRUE ELSE FALSE; 00170432 - KLASS[6] ~ "ERROR "; 00170433 - IF (NOT SEGTYP AND EODS) OR (SEGTYP AND LISTOG AND 00170434 - NOT SEGPTOG) THEN WRITE (PTR[PAGE]); 00170435 - END; 00170436 - IF LISTOG AND SEGTYP AND SEGPTOG THEN WRITE(PTR[PAGE]); 00170437 - IF SEGTYP THEN 00170438 - BEGIN 00170439 - FOR I~12,17 STEP 1 UNTIL 24,39 STEP 1 UNTIL 41, 00170440 - 50 STEP 1 UNTIL 57 DO TIPE[I]~REALID ; 00170441 - FOR I~25,33 STEP 1 UNTIL 37 DO TIPE[I]~INTID ; 00170442 - LASTNEXT ~ 1000; 00170443 - END; 00170444 - ENDSEGTOG ~ TRUE; 00170445 - TSEGSZ ~ TSEGSZ + SZ; 00170446 - COMMENT IF SEGSW THEN LETS ALSO WRITE OUT THE LINE SEGMENTS 00170447 - THAT WE VE GONE TO SUCH TROUBLE BUILDING. LINESEG 00170448 - CONTAINS A CARD SEQUENCE NUMBER(BINARY) IN [10:28] 00170449 - AND THE WORD BOUNDARY ADDRESS OF THE FIRST CODE 00170450 - SYLLABLE IN [38:10]; 00170451 - IF SEGSW THEN 00170452 - IF NOLIN > 0 THEN 00170453 - BEGIN 00170454 - LINEDICT[CURSEG.IR,CURSEG.IC] ~ % UPDATE LINE DICTIONARY 00170455 - 0 & NOLIN[18:33:15] & DALOC[33:33:15];%FOR THIS SEGMENT 00170456 - CNTR ~ 0; DO BEGIN 00170457 - FOR I ~ 0 STEP 2 WHILE I<30 AND CNTR 30 THEN 30 ELSE (SZ-I)); 00170494 - WRITE(CODE[DALOC]); 00170495 - DALOC ~ DALOC +1; 00170496 - END; 00170497 - IF LISTOG THEN WRITALIST(SEGEND,2,SEG,T,0,0,0,0,0,0) ; 00170498 - TSEGSZ ~ TSEGSZ + SZ; 00170499 - END WRITEDATA; 00170500 - 00170501 -REAL PROCEDURE PRGDESCBLDR(DT,PRT,RELADR,SGNO); 00170502 - VALUE DT,PRT,RELADR,SGNO; 00170503 - REAL DT,PRT,RELADR,SGNO; 00170504 - BEGIN 00170505 - FORMAT FMT("PRT=",A4,", REL-ADR=",A4,", SEG=",I4,", TYPE=",A2); 00170506 - IF PRT=0 THEN BEGIN BUMPPRT; PRT~PRTS END; 00170507 - PDPRT[PDIR,PDIC] ~ 00170508 - 0&DT[DTYPC] 00170509 - &PRT[PRTAC] 00170510 - &RELADR[RELADC] 00170511 - &SGNO[SGNOC]; 00170512 - PDINX ~ PDINX +1; 00170513 - IF CODETOG THEN WRITALIST(FMT,4,B2D(PRT),B2D(RELADR),SGNO, 00170514 - IF DT=0 THEN "AE" ELSE IF DT=1 THEN "PD" ELSE "LD",0,0,0,0) ; 00170515 - PRGDESCBLDR ~ PRT; 00170516 - END PRGDESCBLDR; 00170517 - 00170518 -PROCEDURE EQUIV(R); VALUE R; REAL R; 00170519 -COMMENT THIS PROCEDURE FIXES UP THE INFO TABLE FOR THE EQUIV OR 00170520 - COMMON RING. THE FIRST ELEMENT PAST HAS AN OFFSET (DO NOT 00170521 - ALTER THIS) THE TYPE IS FIXED. THE OFFSET IS DETERMINED 00170522 - FROM THE FIRST. CORRECTINFO ADJUST THE OFFSET IF THERE 00170523 - IS A NEGATIVE OFFSET ON ANY ELEMENT. THE INFA[ADJ] BIT IS 00170524 - SET IF THE ELEMENT HAS A NEGATIVE OFFSET. IF THE ELEMENT 00170525 - APPEARED IN MORE THAN ONE EQUIVALENCE STATEMENT OR AN 00170526 - EQUIVALENCE STATEMENT AND A COMMON STATEMENT THE ELEMENTS 00170527 - ARE LINKED BY COM[LASTC] WHICH POINTS TO THE HEADER 00170528 - OF THAT STATEMENT; 00170529 -BEGIN 00170530 - DEFINE BASS = LOCALS #, % THESE DEFINES ARE USED TO REDUCE THE00170531 - REL = PARMS #, % STACKSIZE OF EQUIV FOR RECURSION 00170532 - I = PRTS #, 00170533 - T = LSTS #, 00170534 - Q = LSTA #, 00170535 - LAST = TV #, 00170536 - B = SAVESUBS #, 00170537 - P = NAMEIND #, 00170538 - PRTX = LSTI #, 00170539 - C = FX1 #, 00170540 - INFA = FX2 #, 00170541 - INFB = FX3 #, 00170542 - INFC = NX1 #; 00170543 - LABEL XIT, CHECK; 00170544 -IF DEBUGTOG THEN FLAGROUTINE(" EQU","IV ",TRUE) ; 00170545 - IF GETC(R) <0 THEN GO TO XIT; 00170546 - PUTC(R,-GETC(R)) ; 00170547 - PRTX ~ GROUPPRT; 00170548 - C~REAL(GETC(R).CE=1) ; 00170549 - LAST~GETC(R).LASTC-1 ; 00170550 - BASS~GETC(R+1); P~0 ; 00170551 - FOR I ~ R+2 STEP 1 UNTIL LAST DO 00170552 - BEGIN IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; 00170553 - GETALL(T~GETC(I).LINK,INFA,INFB,INFC) ; 00170554 - IF Q~INFC.SIZE=0 THEN % A SIMPLE VARIABLE 00170555 - INFC.SIZE ~ Q ~ IF INFA.SUBCLASS { LOGTYPE THEN 1 ELSE 2; 00170556 - PUT(T+2,INFC); 00170557 - IF INFA.SUBCLASS>LOGTYPE THEN SEENADOUB~TRUE; 00170558 - IF BOOLEAN(C) THEN 00170559 - BEGIN COM[PWI].RELADD~REL~P ; 00170560 - P ~ P + Q; 00170561 - END ELSE COM[PWI].RELADD~REL~BASS-GETC(I).RELADD ; 00170562 - IF INFA < 0 THEN IF INFA .ADJ = 1 THEN 00170563 - B ~ -INFC.BASE - REL ELSE B ~ INFC.BASE - REL; 00170564 - END; 00170565 - FOR I ~ R+2 STEP 1 UNTIL LAST DO 00170566 - BEGIN IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; 00170567 - GETALL(T~GETC(I).LINK,INFA,INFB,INFC) ; 00170568 - IF INFA.CLASS = 1 THEN SWARYCT ~ 1; 00170569 - P~B+GETC(I).RELADD ; 00170570 - Q ~ INFC .SIZE; 00170571 - IF INFA < 0 THEN 00170572 - BEGIN IF INFA .ADJ = 1 THEN BASS ~ -INFC .BASE ELSE 00170573 - BASS ~ INFC.BASE; 00170574 - IF P ! BASS THEN 00170575 - BEGIN XTA ~ INFB ; FLAG(2) END; 00170576 - GO TO CHECK; 00170577 - END; 00170578 - INFA ~ -INFA & PRTX[TOADDR]; 00170579 - IF INFA .CLASS = UNKNOWN THEN INFA .CLASS ~ VARID; 00170580 - INFA .TYPEFIXED ~ 1; 00170581 - INFC.BASE ~ P; 00170582 - PUT(T+2,INFC); 00170583 - IF P < 0 THEN INFA .ADJ ~ 1; 00170584 - PUT(T,INFA); 00170585 - CHECK: 00170586 - IF P+Q > LENGTH THEN LENGTH ~ P+Q; 00170587 - IF P < LOWERBOUND THEN LOWERBOUND ~ P; 00170588 - END; 00170589 - FOR I ~ R+2 STEP 1 UNTIL LAST DO 00170590 - BEGIN 00170591 - IF GETC(I).CLASS=ENDCOM THEN I~GETC(I).LINK ; 00170592 - IF T~GETC(I).LASTC!R THEN 00170593 - IF GETC(T)}0 THEN 00170594 - BEGIN R~R&LAST[3:33:15]&[18:33:15] ; 00170595 - EQUIV(T); LAST~R.[3:15]; I~R.[18:15]; R~R.[33.15] ; 00170596 - END; 00170597 - END; 00170598 - XIT: 00170599 -IF DEBUGTOG THEN FLAGROUTINE(" EQU","IV ",FALSE) ; 00170600 -END EQUIV; 00170601 -ALPHA PROCEDURE GETSPACE(S); VALUE S; ALPHA S; 00170602 -BEGIN LABEL RPLUS, FMINUS, XIT; 00170603 - LABEL DONE; 00170604 - REAL A; 00170605 - BOOLEAN OWNID; 00170606 - IF OWNID ~ S < 0 THEN S~ -S; % IN DATA STMT, THUS OWN 00170607 - IF A ~ GET(GETSPACE~S) < 0 THEN GO TO DONE; 00170608 - IF A.CLASS GEQ 13 THEN FLAG(34) ELSE 00170609 -CASE A.CLASS OF 00170610 -BEGIN 00170611 -BEGIN 00170612 - PUT(S,A~A&VARID[TOCLASS]); 00170613 - PUT(S+2,(GET(S+2) &(IF A.SUBCLASS { LOGTYPE 00170614 - THEN 1 ELSE 2 )[TOSIZE])); 00170615 -END; 00170616 - IF BOOLEAN(A.FORMAL) THEN BUMPLOCALS; 00170617 -; 00170618 -BEGIN A.TYPEFIXED ~ 1; GO TO RPLUS END; 00170619 -GO TO RPLUS; 00170620 -GO TO RPLUS; 00170621 -GO TO DONE; 00170622 -BEGIN A.TYPEFIXED ~ 1; IF BOOLEAN(A.FORMAL) THEN GO TO FMINUS 00170623 - ELSE GO TO RPLUS; 00170624 -END; 00170625 -BEGIN A.TYPEFIXED ~ 1; GO TO RPLUS END; 00170626 -IF BOOLEAN(A.FORMAL) THEN GO TO FMINUS ELSE GO TO RPLUS; 00170627 -IF BOOLEAN(A.FORMAL) THEN GO TO FMINUS ELSE GO TO RPLUS; 00170628 -GO TO RPLUS; 00170629 -GO TO RPLUS; 00170630 -END OF CASE STATEMENT; 00170631 - 00170632 - 00170633 -A.TYPEFIXED ~ 1; 00170634 -IF BOOLEAN(A.FORMAL) THEN 00170635 - GO TO FMINUS; 00170636 -IF BOOLEAN(A.CE) OR BOOLEAN(A.EQ) THEN 00170637 -BEGIN 00170638 - PUT(S,A); 00170639 - CALLEQUIV(A.ADDR,OWNID,GET(S+1)) ; 00170640 - GO TO DONE; 00170641 -END; 00170642 - A.TWOD ~ REAL(GET(S+2).SIZE > 1023); 00170643 -FMINUS: 00170644 - IF OWNID THEN BEGIN BUMPPRT; A.ADDR~PRTS END ELSE 00170645 - BEGIN BUMPLOCALS; A.ADDR ~ LOCALS +1536 END; 00170646 - IF A.CLASS = VARID THEN IF A.SUBCLASS } DOUBTYPE THEN 00170647 - IF OWNID THEN BUMPPRT ELSE 00170648 - BUMPLOCALS; 00170649 - GO TO XIT; 00170650 -RPLUS: 00170651 - BUMPPRT; A.ADDR~PRTS; 00170652 -XIT: 00170653 - PUT(S, -A); 00170654 -DONE: 00170655 -END GETSPACE; 00170656 -INTEGER STREAM PROCEDURE LBLSHFT(S); VALUE S; 00170657 - BEGIN 00170658 - LOCAL T; 00170659 - LABEL L; 00170660 - DI ~ LOC LBLSHFT; DS ~ 8 LIT "00 "; 00170661 - DI ~ DI - 6; SI ~LOC S; SI ~ SI + 2; 00170662 - TALLY ~ 1; T ~ TALLY; 00170663 - 5(T(IF SC="0" THEN BEGIN SI~SI+1; JUMP OUT 1 TO L END 00170664 - ELSE TALLY~0; T~TALLY); 00170665 - IF SC}"0" THEN DS~CHR ELSE IF SC=" " THEN SI~SI+1 00170666 - ELSE JUMP OUT; L: ) ; 00170667 - IF SC ! " " THEN BEGIN DI ~ LOC LBLSHFT; DS ~ LIT "+" END; 00170668 - END LBLSHFT; 00170669 - COMMENT EMITTERS AND CODE CONTROL; 00170670 -ALPHA PROCEDURE B2D(B); VALUE B; REAL B; 00170671 - B2D ~ 0&B[45:45:3]&B[39:42:3]&B[33:39:3]&B[27:36:3]; 00170672 -PROCEDURE DEBUG(S); % PRINTS OUT DEBUG CODE 00170673 - VALUE S; REAL S; % IF S<0 THEN S IS FIELD TYPE OPERATOR 00170674 - BEGIN 00170675 - FORMAT FF(X35,*(33(".")),A4,":",A1,2(X2,A4),X4,A4) ; 00170676 - ALPHA CODE,MNM,SYL; 00170677 - REAL T; 00170678 -PROCEDURE SEARCH(CODE,S); VALUE S; REAL S,CODE; 00170679 - BEGIN % SEARCHS WOP TO FIND CODE FOR S 00170680 - REAL N,I; 00170681 - LABEL L; 00170682 - N ~ 64; 00170683 - FOR I ~ 66 STEP IF WOP[I] < S THEN N ELSE -N 00170684 - WHILE N ~ N DIV 2 } 1 DO 00170685 - IF WOP[I] =S THEN GO TO L; 00170686 - I ~ 0; % NOT FOUND 00170687 - L: CODE ~ WOP[I+1]; 00170688 - END SEARCH; 00170689 - 00170690 - IF S < 0 THEN 00170691 - BEGIN % FIELD TYPE OPERATOR 00170692 - SYL ~ S; 00170693 - MNM ~ B2D(S.[36:6]); 00170694 - IF (S ~ S.[42:6]) = 37 THEN CODE ~ "ISO " ELSE 00170695 - IF S = 45 THEN CODE ~ "DIA " ELSE 00170696 - IF S = 49 THEN CODE ~ "DIB " ELSE 00170697 - IF S = 53 THEN CODE ~ "TRB "; 00170698 - END 00170699 - ELSE 00170700 - BEGIN 00170701 - IF (T ~ S.[46:2]) ! 1 THEN 00170702 - BEGIN 00170703 - SYL ~ S; 00170704 - MNM ~ B2D(S.[36:10]); 00170705 - IF T = 0 THEN CODE ~ "LITC" 00170706 - ELSE IF T =2 THEN CODE ~ "OPDC" 00170707 - ELSE CODE ~ "DESC"; 00170708 - END 00170709 - ELSE 00170710 - BEGIN % SEARCH WOP FOR OPERATOR NAME 00170711 - SYL ~ S; 00170712 - MNM ~ " "; 00170713 - SEARCH(CODE,S.[36:10]); 00170714 - END; 00170715 - END; 00170716 - WRITALIST(FF,6,IF ADR{DEBUGADR THEN 1 ELSE -1,B2D(ADR.[36:10]),00170717 - B2D(ADR.[46:2]),CODE,MNM,B2D(SYL),0,0) ; 00170718 - IF DEBUGADR0 THEN S~GET(GETSPACE(P)); 00170769 - IF S.CLASS = VARID THEN IF BOOLEAN(S.CE) THEN 00170770 - IF BOOLEAN(S.TWOD) THEN 00170771 - BEGIN 00170772 - EMITL( (T~GET(P+2).BASE).[33:7]); 00170773 - EMITDESCLIT(S.ADDR); 00170774 - EMITO(LOD); 00170775 - EMITL(T.[40:8]); 00170776 - EMITO(CDC); 00170777 - GO TO XIT; 00170778 - END ELSE 00170779 - EMITNUM(GET(P+2).BASE) 00170780 - ELSE 00170781 - IF NOT BOOLEAN(S.FORMAL) THEN IF NOT DESCREQ THEN 00170782 - BEGIN 00170783 - EMITL(S~S.ADDR); 00170784 - IF S.[37:2]=1 THEN %REFERENCING 2ND HALF OF PRT; 00170785 - BEGIN 00170786 - IF ADR } 4087 THEN 00170787 - BEGIN ADR ~ ADR+1; SEGOVF END; 00170788 - EMITO(XRT); 00170789 - END; 00170790 - GO TO XIT; 00170791 - END; 00170792 - EMITDESCLIT(S.ADDR); 00170793 - XIT: 00170794 -END EMITN; 00170795 - 00170796 -PROCEDURE EMITV(P); VALUE P; ALPHA P; 00170797 - BEGIN 00170798 - ALPHA S; 00170799 - IF S~ GET(P) > 0 THEN S ~ GET(GETSPACE(P)); 00170800 - IF S.CLASS = VARID THEN 00170801 - IF BOOLEAN(S.CE) THEN 00170802 - IF BOOLEAN(S.TWOD) THEN 00170803 - BEGIN 00170804 - EMITL( (T~GET(P+2).BASE).[33:7]); 00170805 - EMITDESCLIT(S.ADDR); 00170806 - EMITO(LOD); 00170807 - IF S.SUBCLASS } DOUBTYPE THEN 00170808 - BEGIN 00170809 - EMITO(DUP); 00170810 - EMITPAIR(T.[40:8]+1, COC); 00170811 - EMITO(XCH); 00170812 - EMITPAIR(T.[40:8], COC); 00170813 - END ELSE EMITPAIR(T.[40:8], COC); 00170814 - END 00170815 - ELSE 00170816 - IF S.SUBCLASS } DOUBTYPE THEN 00170817 - BEGIN 00170818 - EMITNUM( (T~GET(P+2).BASE)+1); 00170819 - EMITOPDCLIT(S.ADDR); 00170820 - EMITNUM(T); 00170821 - EMITOPDCLIT(S.ADDR); 00170822 - END ELSE 00170823 - BEGIN 00170824 - EMITNUM(GET(P+2).BASE); 00170825 - EMITOPDCLIT(S.ADDR); 00170826 - END 00170827 - ELSE 00170828 - IF S.SUBCLASS } DOUBTYPE THEN 00170829 - IF BOOLEAN(S.FORMAL) THEN 00170830 - BEGIN 00170831 - EMITDESCLIT(S.ADDR); 00170832 - EMITO(DUP); 00170833 - EMITPAIR(1, XCH); 00170834 - EMITO(INX); 00170835 - EMITO(LOD); 00170836 - EMITO(XCH); 00170837 - EMITO(LOD); 00170838 - END ELSE 00170839 - BEGIN 00170840 - EMITOPDCLIT(S.ADDR+1); 00170841 - EMITOPDCLIT(S.ADDR); 00170842 - END 00170843 - ELSE EMITOPDCLIT(S.ADDR) 00170844 - ELSE EMITOPDCLIT(S.ADDR); 00170845 -END EMITV; 00170846 - 00170847 -PROCEDURE EMITL(N); VALUE N; REAL N; 00170848 - BEGIN 00170849 - BUMPADR; 00170850 - PACK(EDOC[EDOCI],(N~0&N[36:38:10]),ADR.[46:2]); 00170851 - IF CODETOG THEN DEBUG(N); 00170852 -END EMITL; 00170853 -PROCEDURE EMITD(R, OP); VALUE R, OP; REAL R, OP; 00170854 -BEGIN 00170855 - BUMPADR; 00170856 - PACK(EDOC[EDOCI], (R ~ OP & R[36:42:6]), ADR.[46:2]); 00170857 - IF CODETOG THEN DEBUG(-R); 00170858 -END EMITD; 00170859 -PROCEDURE EMITDDT(B,A,X); VALUE B,A,X; INTEGER B,A,X ; 00170860 - BEGIN % DOES DIB B, DIA A, TRB X; HANDLES [B:A:X]. 00170861 - EMITD(B~B MOD 6+B DIV 6|8,DIB); EMITD(A~A MOD 6+A DIV 6|8,DIA) ; 00170862 - EMITD(X~X,TRB); 00170863 - END OF EMITDDT ; 00170864 -PROCEDURE EMITPAIR(L, OP); VALUE L, OP; INTEGER L, OP; 00170865 -BEGIN 00170866 - EMITL(L); 00170867 - IF L.[37:2] = 1 THEN 00170868 - BEGIN 00170869 - IF ADR } 4087 THEN 00170870 - BEGIN ADR ~ ADR+1; SEGOVF END; 00170871 - EMITO(XRT); 00170872 - END; 00170873 - EMITO(OP); 00170874 -END EMITPAIR; 00170875 -PROCEDURE ADJUST; 00170876 - WHILE ADR.[46:2] ! 3 DO EMITO(NOP); 00170877 -PROCEDURE EMITNUM(N); VALUE N; REAL N; 00170878 - BEGIN 00170879 - DEFINE CPLUS = 1792#; 00170880 - IF N.[3:6] =0 AND ABS(N) < 1024 THEN 00170881 - BEGIN 00170882 - EMITL(N); 00170883 - IF N < 0 THEN EMITO(SSN); 00170884 - END ELSE 00170885 - BEGIN 00170886 - IF ADR } 4079 THEN 00170887 - BEGIN ADR ~ ADR+1; SEGOVF END; 00170888 - EMITOPDCLIT(CPLUS + (ADR+1).[46:1] + 1); 00170889 - EMITL(2); 00170890 - EMITO(GFW); 00170891 - ADJUST; 00170892 - BUMPADR; 00170893 - PACK(EDOC[EDOCI],N.[1:11],ADR.[46:2]); 00170894 - BUMPADR; 00170895 - PACK(EDOC[EDOCI],N.[12:12],ADR.[46:2]); 00170896 - BUMPADR; 00170897 - PACK(EDOC[EDOCI],N.[24:12],ADR.[46:2]); 00170898 - BUMPADR; 00170899 - PACK(EDOC[EDOCI],N.[36:12],ADR.[46:2]); 00170900 - IF N.[36:12]=49 THEN %%% IF C-REL CONSTANT LOOKS LIKE AN XRT 00170901 - EMITO(NOP); %%% THEN INSURE AGAINST P-BIT INTERRUPT. 00170902 - IF CODETOG THEN DEBUGWORD(N); 00170903 - END; 00170904 -END EMITNUM; 00170905 - 00170906 -PROCEDURE EMITNUM2(HI,LO);VALUE HI,LP; REAL HI,LO; 00170907 - BEGIN 00170908 - BOOLEAN B; REAL I,N; 00170909 - LABEL Z,X; 00170910 - DEFINE CPLUS = 1792#; 00170911 - IF HI=0 OR LO=0 THEN BEGIN EMITNUM(LO); EMITNUM(HI); GO Z END; 00170912 - ADJUST; 00170913 - IF ADR } 4077 THEN 00170914 - BEGIN ADR~ADR+1; SEGOVF; ADR~-1 END; 00170915 - EMITOPDCLIT(CPLUS + 2); EMITOPDCLIT(CPLUS + 1); 00170916 - EMITPAIR(3,GFW); 00170917 - X: FOR I ~ 0 STEP 1 UNTIL 3 DO 00170918 - BEGIN 00170919 - CASE I OF BEGIN 00170920 - N ~ HI.[ 1:11]; 00170921 - N ~ HI.[12:12]; 00170922 - N ~ HI.[24:12]; 00170923 - N ~ HI.[36:12]; 00170924 - END CASE; 00170925 - BUMPADR; PACK(EDOC[EDOCI],N,ADR.[46:2]); 00170926 - END; 00170927 - IF CODETOG THEN DEBUGWORD(HI); 00170928 - IF NOT B THEN BEGIN B~TRUE; HI~LO; GO TO X; END; 00170929 - IF N=49 THEN %%% IF C-REL CONSTANT LOOKS LIKE AN XRT 00170930 - EMITO(NOP) ; %%% THEN INSURE AGAINST P-BIT INTERRUPT. 00170931 -Z: 00170932 - END EMITNUM2; 00170933 - 00170934 -PROCEDURE EMITLINK(N); VALUE N; REAL N; % EMITS LINKS 00170935 - BEGIN 00170936 - FORMAT FF(X35,*(33(".")),A4,":",A1," LINK",X10,A4,"******") ; 00170937 - BUMPADR; 00170938 - PACK(EDOC[EDOCI],N,ADR.[46:2]); 00170939 - IF CODETOG THEN 00170940 - WRITALIST(FF,4,IF ADR{DEBUGADR THEN 1 ELSE -1,B2D(ADR.[36:10]),00170941 - B2D(ADR.[46:2]),B2D(N),0,0,0,0) ; 00170942 - IF DEBUGADRLBRANCH THEN FATAL(123); 00171040 - BRANCHX ~ BRANCHES[LAX~BRANCHX]; 00171041 - BRANCHES[LAX] ~ -(ADR+1); 00171042 - EMITLINK(0); 00171043 - EMITO(IF C THEN BFC ELSE BFW); 00171044 - EMITO(NOP); 00171045 - END ELSE 00171046 - BEGIN 00171047 - SEG ~ A.SEGNO; 00171048 - A ~ A.LINK; 00171049 - BEOREF ~ ADR > A; 00171050 - IF A.[46:2] =0 THEN 00171051 - BEGIN 00171052 - IF SEG > 0 AND SEG ! NSEG THEN 00171053 - EMITOPDCLIT(PRGDESCBLDR(2, 0, A.[36:10], SEG)) 00171054 - ELSE 00171055 - EMITL(ABS((ADR+2).[36:10] - A.[36:10])); 00171056 - IF BEOREF THEN 00171057 - EMITO( IF C THEN GBC ELSE GBW) ELSE 00171058 - EMITO( IF C THEN GFC ELSE GFW); 00171059 - END ELSE 00171060 - BEGIN 00171061 - EMITL(ABS(ADR + 3 - A)); 00171062 - IF BEOREF THEN 00171063 - EMITO(IF C THEN BBC ELSE BBW) ELSE 00171064 - EMITO(IF C THEN BFC ELSE BFW); 00171065 - END; 00171066 - END; 00171067 -END EMITB; 00171068 - 00171069 -PROCEDURE EMITDESCLIT(N); VALUE N; REAL N; 00171070 - BEGIN 00171071 - IF N.[37:2] = 1 THEN 00171072 - BEGIN 00171073 - IF ADR } 4087 THEN 00171074 - BEGIN ADR ~ ADR+1; SEGOVF END; 00171075 - EMITO(XRT); 00171076 - END; 00171077 - BUMPADR; 00171078 - PACK(EDOC[EDOCI],(N~3&N[36:38:10]),ADR.[46:2]); 00171079 - IF CODETOG THEN DEBUG(N); 00171080 -END EMITDESCLIT; 00171081 -PROCEDURE EMITOPDCLIT(N); VALUE N; REAL N; 00171082 - BEGIN 00171083 - IF N.[37:2] = 1 THEN 00171084 - BEGIN 00171085 - IF ADR } 4087 THEN 00171086 - BEGIN ADR ~ ADR+1; SEGOVF END; 00171087 - EMITO(XRT); 00171088 - END; 00171089 - BUMPADR; 00171090 - PACK(EDOC[EDOCI],(N~2&N[36:38:10]),ADR.[46:2]); 00171091 - IF CODETOG THEN DEBUG(N); 00171092 -END EMITOPDCLIT; 00171093 -PROCEDURE EMITLABELDESC(N); VALUE N; ALPHA N; 00171094 -BEGIN 00171095 - LABEL XIT; 00171096 - REAL T,B,C,D ; 00171097 - IF N ~ LBLSHFT(XTA~N) = 0 OR N = BLANKS THEN 00171098 - BEGIN FLAG(135); GO TO XIT END; 00171099 - IF T ~ SEARCH(N) = 0 THEN 00171100 - T ~ ENTER(0 & LABELID[TOCLASS], N) ELSE 00171101 - IF GET(T).CLASS ! LABELID THEN 00171102 - BEGIN FLAG(144); GO TO XIT END; 00171103 - IF XREF THEN ENTERX(N,0&LABELID[TOCLASS]); 00171104 - IF B ~(C~GET(T+2)).BASE =0 THEN 00171105 - IF (D~GET(T)).SEGNO!0 THEN C.BASE~B~PRGDESCBLDR(2,0,D.ADDR DIV 4, 00171106 - D.SEGNO) ELSE 00171107 - BEGIN BUMPPRT; C.BASE~B~PRTS END; PUT(T+2,C); 00171108 - EMITL(B); EMITO(MKS); 00171109 - EMITDESCLIT(1536); % F+0 00171110 - EMITOPDCLIT(1537); % F+1 00171111 - EMITV(NEED(".LABEL", INTRFUNID)); 00171112 - XIT: 00171113 -END EMITLABELDESC; 00171114 - 00171115 -COMMENT TRACEBACK, OFLOWHANGERS, AND PRTSAVER ARE 00171116 -PROCEDURES USED TO ACCUMULATE FORMAT AND NAMELIST ARRAYS; 00171117 -PROCEDURE TRACEBACK(M,DEX,PRT); VALUE M,DEX,PRT; INTEGER M,DEX,PRT; 00171118 -BEGIN INTEGER I,J; REAL C; 00171119 - IF (C~GET(M+2)).BASE ! 0 THEN 00171120 - BEGIN I ~ ADR; ADR ~ C.BASE; 00171121 - DO BEGIN J ~ GIT(ADR); 00171122 - ADR ~ ADR - 1; 00171123 - EMITL(DEX); 00171124 - EMITPAIR(PRT,LOD); 00171125 - END UNTIL ADR ~ J = 0; 00171126 - ADR ~ I; 00171127 - END; 00171128 -INFC[M.IR,M.IC].ADDR ~ PRT; PUT(M+2,0&DEX[TOBASE]); 00171129 -END TRACEBACK; 00171130 - 00171131 -PROCEDURE OFLOWHANGERS(I); VALUE I; INTEGER I; 00171132 -BEGIN INTEGER J; LABEL XIT; 00171133 -FOR J ~ 1 STEP 1 UNTIL MAXNBHANG DO 00171134 -IF FNNHANG[J] = 0 THEN % MAKE AN ENTRY 00171135 -BEGIN FNNHANG[J] ~ I; 00171136 - PUT(I+2,J); 00171137 - GO TO XIT; 00171138 -END; 00171139 -XTA ~ MAXNBHANG; % IF WE REACH HERE WERE HURTIN 00171140 -FLAG(91); 00171141 -XIT: 00171142 -END OFLOWHANGERS; 00171143 - 00171144 -PROCEDURE PRTSAVER(M,SZ,ARY); VALUE M,SZ; 00171145 -INTEGER M,SZ; ARRAY ARY[0]; 00171146 -BEGIN INTEGER I; REAL INFA; 00171147 -LABEL SHOW,XIT; 00171148 -IF (INFA~GET(M)) < 0 THEN % PREVIOUSLY DEFINED 00171149 -BEGIN XTA ~ GET(M+1); 00171150 - FLAG(20); GO TO XIT; 00171151 -END; 00171152 -IF I ~ INFA .ADDR ! 0 THEN % PRT ASSIGNED AT OFLOW TIME 00171153 -SHOW: 00171154 -BEGIN I ~ PRGDESCBLDR(1,I,0,NXAVIL ~ NXAVIL + 1); 00171155 - WRITEDATA(SZ,NXAVIL,ARY); 00171156 - FNNHANG[GET(M+2).SIZE] ~ 0; 00171157 -END ELSE % ADD THIS ARRAY TO HOLD 00171158 -BEGIN IF FNNPRT=0 THEN BEGIN BUMPPRT; FNNPRT~PRTS END; 00171159 - IF FNNINDEX + SZ > DUMPSIZE THEN % ARRAY WONT FIT 00171160 - BEGIN BUMPPRT;FNNHANG[GET(M+2).SIZE]~0; TRACEBACK(M,0,I~PRTS); 00171161 - GO TO SHOW; 00171162 - END ELSE % DUMP OUT CURRENT HOLDINGS 00171163 - BEGIN FNNPRT ~ PRGDESCBLDR(1,FNNPRT,0,NXAVIL ~ NXAVIL + 1); 00171164 - WRITEDATA(FNNINDEX,NXAVIL,FNNHOLD); 00171165 - FNNINDEX ~ 0; BUMPPRT; FNNPRT ~PRTS; 00171166 - END; 00171167 - FNNHANG[GET(M + 2).SIZE] ~0; 00171168 - TRACEBACK(M,FNNINDEX,FNNPRT); 00171169 - MOVEW(ARY,FNNHOLD[FNNINDEX],SZ.[36:6],SZ); 00171170 - FNNINDEX ~ FNNINDEX + SZ; 00171171 -END; 00171172 -PUT(M,-GET(M)); % ID NOW ASSIGNED 00171173 -XIT: 00171174 -END PRTSAVER; 00171175 - 00171176 -PROCEDURE SEGOVF; 00171177 - BEGIN 00171178 - REAL I, T, A, J, SADR, INFC, LABPRT; 00171179 - REAL SAVINS; 00171180 - FOR T ~ 1 STEP 1 UNTIL MAXNBHANG DO 00171181 -IF J~FNNHANG[T]!0 THEN BEGIN BUMPPRT;TRACEBACK(J,FNNHANG[T]~0,PRTS) END;00171182 - SEGOVFLAG ~ TRUE; 00171183 -BUMPPRT; 00171184 - IF PRTS.[37:2]=1 THEN BEGIN 00171185 - PACK(EDOC[EDOCI],(T~1&XRT[36:38:10]),ADR.[46:2]); 00171186 - IF CODETOG THEN DEBUG(T); ADR~ADR+1 END; 00171187 - PACK(EDOC[EDOCI], (T~2&PRTS[36:38:10]), ADR.[46:2]); 00171188 - IF CODETOG THEN DEBUG(T); 00171189 - ADR ~ ADR+1; 00171190 - PACK(EDOC[EDOCI], (T~1&BFW [36:38:10]), ADR.[46:2]); 00171191 - IF CODETOG THEN DEBUG(T); 00171192 - SADR ~ ADR; 00171193 - T ~ PRGDESCBLDR(2, PRTS, 0, NXAVIL+1); 00171194 - FOR I ~ 0 STEP 1 UNTIL SHX DO 00171195 - BEGIN T ~ STACKHEAD[I]; 00171196 - WHILE T ! 0 DO 00171197 - BEGIN IF (A~ GET(T)).CLASS = LABELID THEN 00171198 - IF A > 0 THEN 00171199 - BEGIN 00171200 - ADR ~ A.ADDR; 00171201 - IF LABPRT ~ (INFC~GET(T+2)).BASE = 0 THEN 00171202 - BEGIN 00171203 - BUMPPRT; LABPRT~PRTS; 00171204 - PUT(T+2, INFC & PRTS[TOBASE]); 00171205 - END; 00171206 - WHILE ADR ! 0 DO 00171207 - BEGIN J ~ GIT(ADR); ADR ~ ADR-1; 00171208 - SAVINS~GIT(ADR+2).[36:10]; 00171209 - EMITOPDCLIT(LABPRT); 00171210 - EMITO(SAVINS); 00171211 - ADR ~ J; 00171212 - END; 00171213 - INFC[T.IR,T.IC].ADDR ~ 0; 00171214 - END; 00171215 - T ~ A.LINK; 00171216 - END; 00171217 - END; 00171218 - FOR I ~ 0 STEP 1 UNTIL LBRANCH DO 00171219 - IF T ~ - BRANCHES[I] > 0 AND T < 4096 THEN 00171220 - BEGIN 00171221 - ADR ~ T-1; 00171222 - SAVINS~GIT(ADR+2).[36:10]; 00171223 - BUMPPRT; EMITOPDCLIT(PRTS); 00171224 - EMITO(SAVINS); 00171225 - BRANCHES[I] ~ - (PRTS+4096); 00171226 - END; 00171227 - SEGMENT((SADR+4) DIV 4,NSEG,FALSE,EDOC); 00171228 - SEGMENTSTART; 00171229 - EMITO(NOP); EMITO(NOP); 00171230 - SEGOVFLAG ~ FALSE; 00171231 -END SEGOVF; 00171232 - 00171233 -PROCEDURE ARRAYDEC(I); VALUE I; REAL I; 00171234 - BEGIN % DECLARES ARRAYS WHOSE INFO INDEX IS I 00171235 - REAL PRT,LNK,J; 00171236 - LABEL XIT; 00171237 - BOOLEAN OWNID; REAL X; 00171238 -IF DEBUGTOG THEN FLAGROUTINE(" ARRA","YDEC ",TRUE ); 00171239 - PRT ~ GET(I).ADDR; 00171240 - IF LNK ~ GET(I+2).SIZE = 0 THEN GO TO XIT ; 00171241 - IF (OWNID ~ PRT < 1536 AND DATAPRT ! 0) THEN 00171242 - BEGIN 00171243 - EMITOPDCLIT(DATAPRT); EMITO(LNG); 00171244 - EMITB(-1, TRUE); X ~ LAX; 00171245 - END; 00171246 - EMITO(MKS); 00171247 - EMITDESCLIT(PRT); % STACK OR PRT ADDRESS 00171248 - IF LNK { 1023 THEN 00171249 - BEGIN 00171250 - IF OWNID THEN EMITL(0); % LOWER BOUND 00171251 - EMITL(LNK); % ARRAY SIZE 00171252 - EMITL(1); % ONE DIMENSION 00171253 - END 00171254 - ELSE 00171255 - BEGIN 00171256 - J ~ (LNK + 255) DIV 256; 00171257 - LNK ~ 256; %INCLUDE ENTIRE ARRAY SIZE IN ESTIMATE %512- 00171258 - IF OWNID THEN EMITL(0); % FIRST LOWER BOUND 00171259 - EMITL(J); % NUMBER OF ROWS 00171260 - IF OWNID THEN EMITL(0); % SECOND LOWER BOUND 00171261 - EMITL(256); % SIZE OF EACH ROW 00171262 - EMITL(2); % TWO DIMENSIONS 00171263 - END; 00171264 - EMITL(1); % ONE ARRAY 00171265 - EMITL(IF OWNID THEN 2 ELSE 0); %OWN OR LOCAL 00171266 - EMITOPDCLIT(5); % CALL BLOCK 00171267 - ARYSZ ~ ARYSZ + J + LNK; 00171268 - IF NOT(F2TOG OR OWNID) THEN 00171269 - BEGIN 00171270 - F2TOG ~ TRUE; 00171271 - EMITL(1); 00171272 - EMITPAIR(FPLUS2,STD);% F+2~TRUE 00171273 - END; 00171274 - IF OWNID THEN FIXB(X); 00171275 - XIT: 00171276 -IF DEBUGTOG THEN FLAGROUTINE(" ARRA","YDEC ",FALSE) ; 00171277 - END ARRAYDEC; 00171278 - 00171279 -REAL PROCEDURE SEARCH(E); VALUE E; REAL E; 00171280 -BEGIN REAL T; LABEL XIT; 00171281 - T ~ STACKHEAD[E MOD SHX]; 00171282 - WHILE T ! 0 DO 00171283 - IF INFC[(T+1).IR,(T+1).IC] = E THEN GO TO XIT 00171284 - ELSE T ~ INFC[T.IR,T.IC].LINK; 00171285 - XIT: SEARCH ~ T; 00171286 -END SEARCH; 00171287 - 00171288 -INTEGER PROCEDURE GLOBALSEARCH(E); VALUE E; REAL E; 00171289 -BEGIN REAL T; LABEL XIT; 00171290 - T ~ GLOBALSTACKHEAD[E MOD GHX]; 00171291 - WHILE T ! 0 DO 00171292 - IF INFC[(T+1).IR,(T+1).IC] = E THEN GO TO XIT 00171293 - ELSE T ~ INFC[T.IR,T.IC].LINK; 00171294 - XIT: GLOBALSEARCH ~ T; 00171295 -END GLOBALSEARCH; 00171296 - 00171297 -PROCEDURE PURGEINFO; 00171298 -BEGIN REAL J; 00171299 - FLAG(13); 00171300 - FOR J ~ 0 STEP 1 UNTIL SHX DO STACKHEAD[J] ~ 0; 00171301 - NEXTINFO ~ 2; 00171302 - NEXTCOM ~ 0; 00171303 - END; 00171304 - 00171305 -INTEGER PROCEDURE ENTER(W, E); VALUE W, E; ALPHA W, E; 00171306 -BEGIN REAL J; 00171307 - IF GLOBALNEXTINFO { NEXTINFO THEN PURGEINFO; 00171308 - W.LINK ~ STACKHEAD[J ~ E MOD SHX]; 00171309 - STACKHEAD[J] ~ ENTER ~ J ~ NEXTINFO; 00171310 - INFC[J.IR,J.IC] ~ W; 00171311 - INFC[(J~J+1).IR,J.IC] ~ E; 00171312 - INFC[(J~J+1).IR,J.IC] ~ 0; 00171313 - NEXTINFO ~ NEXTINFO + 3; 00171314 -END ENTER; 00171315 - 00171316 -INTEGER PROCEDURE GLOBALENTER(W, E); VALUE W, E; ALPHA W, E; 00171317 -BEGIN REAL J; 00171318 - IF GLOBALNEXTINFO { NEXTINFO THEN PURGEINFO; 00171319 - W.LINK ~ GLOBALSTACKHEAD[J ~ E MOD GHX]; 00171320 - GLOBALSTACKHEAD[J] ~ GLOBALENTER ~ J ~ GLOBALNEXTINFO; 00171321 - INFC[J.IR,J.IC] ~ W; 00171322 - INFC[(J~J+1).IR,J.IC] ~ E; 00171323 - INFC[(J~J+1).IR,J.IC] ~ 0; 00171324 - GLOBALNEXTINFO ~ GLOBALNEXTINFO - 3; 00171325 -END GLOBALENTER; 00171326 - 00171327 -PROCEDURE LABELBRANCH(K, C); VALUE K, C; REAL K; BOOLEAN C; 00171328 -BEGIN REAL TS,T,I,X; 00171329 -DEFINE LABL = K#; 00171330 -COMMENT LABELBRANCH GENERATES A "LITC ..." AND "BRANCH" FROM THE 00171331 -CURRENT ADDRESS TO LABEL K. IF THE BOOLEAN C IS TRUE 00171332 -THE BRANCH IS CONDITIONAL. IF THE LABEL HAS NOT BEEN ENCOUNTERED 00171333 -THEN THE APPROPRIATE LINKAGE IS MADE; 00171334 - LABEL XIT; 00171335 - IF ADR } 4086 THEN 00171336 - BEGIN ADR ~ ADR+1; SEGOVF END; 00171337 - IF LABL ~ LBLSHFT(XTA~LABL) { 0 OR LABL = BLANKS THEN 00171338 - BEGIN FLAG(135); GO TO XIT END; 00171339 - IF T ~ SEARCH(LABL) ! 0 THEN 00171340 - BEGIN TS ~ (I ~ GET(T)).ADDR; 00171341 - IF I.CLASS ! LABELID THEN BEGIN FLAG(144); GO TO XIT END; 00171342 - IF I > 0 THEN 00171343 - BEGIN EMITLINK(TS); 00171344 - EMITO(IF C THEN BFC ELSE BFW); 00171345 - PUT(T,I&(ADR-1)[TOADDR]); 00171346 - EMITO(NOP); 00171347 - END ELSE 00171348 - IF I.SEGNO = NSEG THEN EMITB(TS, C) ELSE 00171349 - BEGIN IF TS~(X~GET(T+2)).BASE = 0 THEN 00171350 - X.BASE ~ TS ~ PRGDESCBLDR(2,0,(I.ADDR).[36:10],I.SEGNO); 00171351 - PUT(T+2,X); 00171352 - EMITOPDCLIT(TS); 00171353 - EMITO(IF C THEN BFC ELSE BFW); 00171354 - END; 00171355 -END ELSE 00171356 - BEGIN 00171357 - IF ADR < 0 THEN EMITO(NOP); 00171358 - EMITLINK(0); 00171359 - EMITO( IF C THEN BFC ELSE BFW); 00171360 - T ~ ENTER(0 & LABELID[TOCLASS] & (ADR-1)[TOADDR], LABL); 00171361 - EMITO(NOP); 00171362 - END; 00171363 - IF XREF THEN ENTERX(LABL,0&LABELID[TOCLASS]); 00171364 - XIT: 00171365 -END LABELBRANCH; 00171366 - 00171367 -PROCEDURE DATASET; % SCANS CONSTANTS IN BLOCK DATA 00171368 - BEGIN 00171369 - REAL LST,CUR,LTYP,CTYP,SIZ,RPT; 00171370 - REAL CUD; 00171371 - BOOLEAN SGN; 00171372 - DEFINE TYP = GLOBALNEXT#, 00171373 - TYPC = 18:33:15#; 00171374 - LABEL XIT,ERROR,DPP,SPP,CPP,COMM,S; 00171375 -IF DEBUGTOG THEN FLAGROUTINE(" DATA","SET ",TRUE) ; 00171376 - DATATOG ~ TRUE; FILETOG ~ TRUE; 00171377 - SCAN; 00171378 - LSTS ~ -1; LTYP ~77; 00171379 - S: IF TYP = PLUS OR (SGN ~ TYP = MINUS ) THEN SCAN; 00171380 - IF TYP = NUM THEN 00171381 - BEGIN 00171382 - IF NUMTYPE = STRINGTYPE AND STRINGSIZE > 1 THEN 00171383 - BEGIN 00171384 - IF LTYP ! 77 THEN 00171385 - BEGIN % NOT FIRST ENTRY-PUSH DOWN PRIOR NUMBER 00171386 - IF LSTS+2 > LSTMAX THEN 00171387 - BEGIN FLAG(127); GO TO ERROR END; 00171388 - LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 00171389 - LSTT[LSTS~LSTS+1] ~ LST; 00171390 - LTYP ~ 77; 00171391 - END; 00171392 - 00171393 - IF LSTS + STRINGSIZE > LSTMAX THEN 00171394 - BEGIN FLAG(127); GO TO ERROR END; 00171395 - LSTT[LSTS~LSTS+1] ~ STRINGSIZE & STRINGTYPE[TYPC] 00171396 - & SIZ[3:33:15]; 00171397 - MOVEW(STRINGARRAY,LSTT[LSTS~LSTS+1], 00171398 - STRINGSIZE.[36:6],STRINGSIZE); 00171399 - LSTS ~ LSTS + STRINGSIZE -1; 00171400 - SCAN; 00171401 - GO TO COMM; 00171402 - END; 00171403 - % GOT NUMBER 00171404 - IF NUMTYPE = STRINGTYPE THEN 00171405 - BEGIN 00171406 - FNEXT ~ STRINGARRAY[0]; 00171407 - NUMTYPE ~ INTYPE; 00171408 - IF SIZ = 0 THEN SIZ ~ 1; 00171409 - END; 00171410 - CUR ~ IF SGN THEN -FNEXT ELSE FNEXT; 00171411 - CTYP ~ NUMTYPE; CUD ~ DBLOW; 00171412 - 00171413 - SCAN; 00171414 - IF TYP = COMMA OR TYP = SLASH THEN 00171415 - BEGIN 00171416 - IF SIZ = 0 THEN SIZ ~ 1; 00171417 - IF CTYP = DOUBTYPE THEN 00171418 - BEGIN 00171419 - DPP: IF LTYP ! 77 THEN 00171420 - BEGIN 00171421 - IF LSTS+2 > LSTMAX THEN 00171422 - BEGIN FLAG(127); GO TO ERROR END; 00171423 - LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 00171424 - LSTT[LSTS~LSTS+1] ~ LST; 00171425 - LTYP ~ 77; 00171426 - END; 00171427 - IF LSTS+3 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END; 00171428 - LSTT[LSTS~LSTS+1] ~ SIZ&DOUBTYPE[TYPC]; 00171429 - LSTT[LSTS~LSTS+1] ~ CUR; 00171430 - LSTT[LSTS~LSTS+1] ~ CUD; 00171431 - GO TO COMM; 00171432 - END; 00171433 - % SINGLE PRECISION 00171434 - SPP: 00171435 - IF LTYP = 77 THEN 00171436 - BEGIN 00171437 - LST ~ CUR; 00171438 - LTYP ~ CTYP; 00171439 - RPT ~ SIZ; 00171440 - GO TO COMM; 00171441 - END; 00171442 - IF LTYP = CTYP THEN 00171443 - IF REAL(BOOLEAN(CUR) EQV BOOLEAN(LST)) = REAL(NOT FALSE) THEN 00171444 - BEGIN 00171445 - RPT ~ RPT + SIZ; 00171446 - GO TO COMM; 00171447 - END; 00171448 - IF LSTS+2 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END; 00171449 - LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 00171450 - LSTT[LSTS~LSTS+1] ~ LST; 00171451 - RPT ~ SIZ; 00171452 - LST ~ CUR; LTYP ~ CTYP; 00171453 - GO TO COMM; 00171454 - END; 00171455 - % TYP ! COMMA - CHECK FOR * 00171456 - IF TYP ! STAR THEN BEGIN FLAG(125); GO TO ERROR END; 00171457 - IF CTYP ! INTYPE THEN BEGIN FLAG(113); GO TO ERROR END; 00171458 - IF SIZ ! 0 OR SIZ ~ CUR { 0 THEN 00171459 - BEGIN FLAG(64); GO TO ERROR END; 00171460 - SCAN; GO TO S; 00171461 - END; 00171462 - % TYP ! NUM AT LABEL S 00171463 - IF SIZ = 0 THEN SIZ ~ 1; 00171464 - IF NAME = "T " OR NAME = "F " THEN 00171465 - BEGIN 00171466 - CUR ~ REAL(NAME = "T "); 00171467 - CTYP ~ LOGTYPE; 00171468 - SCAN; GO TO SPP; 00171469 - END; 00171470 - IF TYP ! LPAREN THEN BEGIN FLAG(64); GO TO ERROR END; 00171471 - CPP: % COMPLEX 00171472 - IF LTYP ! 77 THEN 00171473 - BEGIN 00171474 - IF LSTS+2 > LSTMAX THEN 00171475 - BEGIN FLAG(127); GO TO ERROR END; 00171476 - LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 00171477 - LSTT[LSTS~LSTS+1] ~ LST; 00171478 - LTYP ~ 77; 00171479 - END; 00171480 - SCAN; 00171481 - IF TYP = PLUS OR (SGN~TYP=MINUS) THEN SCAN; 00171482 - IF TYP ! NUM OR NUMTYPE > REALTYPE THEN 00171483 - BEGIN FLAG(64); GO TO ERROR END; 00171484 - IF LSTS+2 > LSTMAX THEN BEGIN FLAG(127); GO TO ERROR END;00171485 - LSTT[LSTS~LSTS+1] ~ SIZ&COMPTYPE[TYPC]; 00171486 - LSTT[LSTS~LSTS+1] ~ IF SGN THEN -FNEXT ELSE FNEXT; 00171487 - SCAN; 00171488 - IF TYP ! COMMA THEN BEGIN FLAG(114); GO TO ERROR END; 00171489 - SCAN; 00171490 - IF TYP = PLUS OR (SGN ~ TYP = MINUS) THEN SCAN; 00171491 - IF TYP ! NUM OR NUMTYPE > REALTYPE THEN 00171492 - BEGIN FLAG(64); GO TO ERROR END; 00171493 - LSTT[LSTS~LSTS+1]~IF SGN THEN - FNEXT ELSE FNEXT ; 00171494 - SCAN; 00171495 - IF TYP ! RPAREN THEN BEGIN FLAG(108); GO TO ERROR END; 00171496 - SCAN; 00171497 - COMM: 00171498 - SIZ ~ 0; 00171499 - IF TYP = COMMA THEN BEGIN SCAN; GO TO S; END; 00171500 - IF TYP = SLASH THEN GO TO XIT; 00171501 - FLAG(126); 00171502 - ERROR: 00171503 - LSTS ~ 0; 00171504 - WHILE TYP ! COMMA AND TYP ! SLASH AND TYP ! SEMI DO SCAN;00171505 - IF TYP = COMMA THEN GO TO COMM; 00171506 - XIT: 00171507 - IF LTYP ! 77 THEN 00171508 - BEGIN 00171509 - IF LSTS+2>LSTMAX THEN BEGIN FLAG(127); LSTS~0 END;00171510 - LSTT[LSTS~LSTS+1] ~ RPT<YP[TYPC]; 00171511 - LSTT[LSTS~LSTS+1] ~ LST; 00171512 - END; 00171513 - IF LSTS+1 > LSTMAX THEN BEGIN FLAG(127); LSTS~0 END; 00171514 - LSTT[LSTS~LSTS+1]~0; 00171515 -IF DEBUGTOG THEN FLAGROUTINE(" DATA","SET ",FALSE); 00171516 - DATATOG ~ FALSE; FILETOG ~ FALSE; 00171517 -END DATASET; 00171518 - 00171519 -ALPHA PROCEDURE CHECKDO; 00171520 -BEGIN ALPHA X, T; INTEGER N; 00171521 -STREAM PROCEDURE CKDO(A, ID, LAB); 00171522 -BEGIN 00171523 - SI ~ A; SI ~ SI+4; DI ~ LAB; DI ~ DI+2; 00171524 - 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); 00171525 - DI ~ ID; DI ~ DI+2; 00171526 - 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); 00171527 -END CKDO; 00171528 - IF (XTA~HOLDID[0]).[12:24] = "FILE" THEN FLOG(37) ELSE 00171529 - IF XTA.[12:12] ! "DO" THEN FLOG(17) ELSE 00171530 - BEGIN 00171531 - X ~ T ~ BLANKS; 00171532 - CKDO(HOLDID[0], X, T); 00171533 - IF X=BLANKS THEN FLOG(105); 00171534 - IF T ~ LBLSHFT(T) < 0 OR T = BLANKS THEN FLOG(17) ELSE 00171535 - TEST ~ NEED(T, LABELID); 00171536 - DOLAB[DT]~ T; 00171537 - IF XREF THEN ENTERX(T,0&LABELID[TOCLASS]); 00171538 - IF GET(TEST) < 0 THEN % TEST FOR PREV DEFINITION 00171539 - BEGIN 00171540 - XTA ~ GET(TEST+1); 00171541 - FLAG(15); 00171542 - DT ~ DT-1; 00171543 - END; 00171544 - IF N ~ SEARCH(X) = 0 THEN 00171545 - N~ENTER(TIPE[IF T~X.[12:6]!"0" THEN T ELSE 12],X); 00171546 - CHECKDO ~ GETSPACE(N); 00171547 - IF XREF THEN ENTERX(X,1&GET(N) [15:15:9]); 00171548 - IF (X~GET(N)).SUBCLASS > REALTYPE OR X.CLASS ! VARID THEN 00171549 - BEGIN XTA ~ GET(N+1); FLAG(84) END; 00171550 - IF GET(FX1).CLASS = UNKNOWN THEN PUT(FX1+1, "......"); 00171551 - END; 00171552 -END CHECKDO; 00171553 - 00171554 -PROCEDURE FIXB(N); VALUE N; REAL N; 00171555 -BEGIN 00171556 - REAL T, U, FROM; 00171557 - LABEL XIT, BIGJ; 00171558 -IF DEBUGTOG THEN FLAGROUTINE(" FI","XB ",TRUE); 00171559 - IF N } 10000 THEN FROM ~ N-10000 ELSE 00171560 - IF FROM ~ - BRANCHES[N] > 4095 THEN 00171561 - BEGIN 00171562 - ADJUST; 00171563 - T ~ PRGDESCBLDR(2, FROM.LINK, (ADR+1).[36:10], NSEG); 00171564 - GO TO XIT; 00171565 - END; 00171566 -T ~ ADR; ADR ~ FROM - 1; 00171567 -IF (T + 1).[46:2] = 0 THEN GO TO BIGJ; 00171568 -IF (U ~ T - 2 - ADR) { 1023 THEN EMITL(U) ELSE 00171569 -BEGIN ADR ~ T; ADJUST; T ~ ADR; ADR ~ FROM - 1; 00171570 -BIGJ: EMITL((T+1).[36:10] - (ADR+2).[36:10]); 00171571 - EMITO(IF BOOLEAN(GIT(FROM + 1).[36:1]) THEN GFW ELSE GFC); 00171572 -END; 00171573 -ADR ~ T; 00171574 - XIT: 00171575 - IF N < 10000 THEN BEGIN 00171576 - BRANCHES[N] ~ BRANCHX; 00171577 - BRANCHX ~ N; 00171578 - END; 00171579 -IF DEBUGTOG THEN FLAGROUTINE(" FI","XB ",FALSE); 00171580 -END FIXB; 00171581 - 00171582 -PROCEDURE DATIME; % PRODUCES HEADING LINE FOR LISTING. 00171583 - BEGIN 00171584 - INTEGER D; 00171585 - 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 ",00171586 -"XVI.0" 00171587 - ,",",A2,",",AB,"DAY, ",2(A2,"/"),A2,",",A2,":",A2," H,"/); 00171588 - WRITALIST(T,7, 00171589 - "16" %999-00171590 - ,TIME(6),(D~TIME(5)).[12:12],D.[24:12],D.[36:12], 00171591 - D~(D~RTI DIV 216000) MOD 10+D DIV 10|64, 00171592 - D~(D~RTI DIV 3600 MOD 60) MOD 10+D DIV 10|64,0) ; 00171593 - IF D~LINE.TYPE=10 OR D=12 OR D=13 THEN 00171594 - BEGIN 00171595 - LOCK(LINE); LINE.AREAS~0; LINE.AREASIZE~0 ; 00171596 - ID D ! 12 THEN LINE.TYPE~12; SPACE(LINE,2) ; 00171597 - END; 00171598 - FIRSTCALL~FALSE ; 00171599 - END DATIME; 00171600 - 00171601 -PROCEDURE PRINTCARD; 00171602 -BEGIN 00171603 - STREAM PROCEDURE MOVE(P, Q, A); VALUE A, Q; 00171604 - BEGIN 00171605 - SI ~ Q; DI ~ P; 00171606 - DS ~ CHR; 00171607 - DI ~ DI+11; SI ~ LOC A; 00171608 - DS ~ 4 DEC; 00171609 - END MOVE; 00171610 - STREAM PROCEDURE MOVEBACK(P); 00171611 - BEGIN DI ~ P; DS ~ LIT "]" END; 00171612 - MOVE (CRD[9],BUFL,(ADR+1).[36:10]); 00171613 - IF FIRSTCALL THEN DATIME; 00171614 - IF UNPRINTED THEN WRITAROW(15,CRD) ; 00171615 - MOVEBACK(CRD[9]); 00171616 - IF SEQERRORS THEN WRITAROW(14,ERRORBUFF) ; 00171617 -END PRINTCARD; 00171618 - 00171619 -BOOLEAN PROCEDURE READACARD; FORWARD; 00171620 -PROCEDURE FILEOPTION; FORWARD; 00171621 -BOOLEAN PROCEDURE LABELR; 00171622 -BEGIN 00171623 -LABEL XIT, LOOP; 00171624 -BOOLEAN STREAM PROCEDURE CHECK(CD, LAB); 00171625 -BEGIN LABEL XIT; LOCAL T1; 00171626 - SI ~ CD; 00171627 - IF SC ! " " THEN IF SC < "0" THEN 00171628 - BEGIN DI ~ LAB; DI ~ DI + 2; 00171629 - DS ~ 6 CHR; GO TO XIT; 00171630 - END; 00171631 - DI ~LOC T1; DS ~ 6 LIT " "; DI ~ DI -6; 00171632 - 5(IF SC } "0" THEN DS ~ CHR ELSE SI ~ SI+1); 00171633 - DI ~LAB; DI ~DI + 2; SI ~ LOC T1; 00171634 - 5(IF SC ! "0" THEN JUMP OUT; SI ~ SI + 1); 00171635 - 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); 00171636 - TALLY ~ 1; 00171637 - XIT: CHECK ~ TALLY; 00171638 -END CHECK; 00171639 -BOOLEAN STREAM PROCEDURE BLANKCARD(CD); 00171640 -BEGIN LABEL XIT; 00171641 - SI ~ CD; 00171642 - 2(36( IF SC ! " " THEN JUMP OUT 2 TO XIT ELSE SI ~ SI + 1)); 00171643 - TALLY ~ 1; 00171644 - XIT: BLANKCARD ~ TALLY; 00171645 -END BLANKCARD; 00171646 - LOOP: 00171647 - LABL ~ BLANKS; 00171648 - IF LABELR ~ NOT READACARD THEN GO TO XIT; 00171649 - IF NOT CHECK(CRD[0],LABL) THEN 00171650 - BEGIN IF LABL = "FILE " THEN FILEOPTION ELSE 00171651 - BEGIN IF LISTOG THEN PRINTCARD; 00171652 - IF (XTA ~ LABL).[12:6] ! "C" THEN FLAG(135); 00171653 - END; 00171654 - GO TO LOOP; 00171655 - END; 00171656 - IF ENDSEGTOG THEN IF BLANKCARD(CRD) THEN 00171657 - BEGIN IF LISTOG THEN PRINTCARD; GO TO LOOP END ELSE 00171658 - BEGIN SEGMENTSTART; 00171659 - IF LISTOG THEN PRINTCARD; 00171660 - IF LABL = BLANKS THEN GO TO XIT; 00171661 - END ELSE 00171662 - BEGIN 00171663 - IF LABL = BLANKS THEN 00171664 - BEGIN IF LISTOG THEN PRINTCARD; GO TO XIT END; 00171665 - IF ADR > 0 THEN ADJUST; 00171666 - IF LISTOG THEN PRINTCARD; 00171667 - END; 00171668 - XIT: 00171669 -END LABELR; 00171670 - 00171671 -PROCEDURE FILEOPTION; 00171672 -BEGIN COMMENT THIS PROCEDURE PROCESSES THE OPTIONAL FILE CONTROL CARD. 00171673 -THE WORD "FILE" APPEARS IN COL. 1 - 4. COL. 5 AND 6 ARE BLANK. 00171674 -#1 BELOW IS REQUIRED, OTHER ENTRIES MAY BE AS SPARSE AS DESIRED. 00171675 -1. FILE = / 00171676 - OR 00171677 - FILE = 00171678 - THE FOLLOWING "/" IS A DOCUMMENTARY OR. 00171679 - THE SEQUENCE OF RESERVED WORDS MUST BE MAINTAINED. 00171680 -2. UNIT=PRINT/READER/PUNCH/DISK/TAPE7/TAPE9/REMOTE (UNIT DESIGNATE). 00171681 -3. UNLABELED (FOR UNLABELED TAPES) 00171682 -4. ALPHA (FOR ALPHA RECORDING MODE) 00171683 -5. BCL (IGNORED, FOR 3500 USE) 00171684 -6. FIXED (IGNORED, FOR 3500 USE) 00171685 -7. SAVE = (SAVE FACTOR IN DAYS) 00171686 -8. LOCK (LOCK FILE AT EOJ) 00171687 -9. RANDOM/SERIAL/UPDATE (DISK USE) 00171688 -10. AREA = (DISK RECORDS/ROW) 00171689 -11. BLOCKING = (RECORD PER BLOCK) 00171690 -12. RECORD = (RECORD SIZE) 00171691 -13. BUFFER = (# OF BUFFERS) 00171692 -14. WORKAREA (IGNORED, FOR 3500) ; 00171693 -ALPHA P,KEEP; BOOLEAN TOG,CA,TS; LABEL XIT; 00171694 -COMMENT INXFIL = INFC.ADINFO, MULTI FILE ID = FILEINFO[1,INXFIL], 00171695 - FILE ID = FILEINFO[2,INXFIL], DISK RECORDS = FILEINFO[3,INXFIL],00171696 - FILEINFO[0,INXFIL] FROM RIGHT TO LEFT IS; 00171697 -INTEGER % NAME USE BITS 00171698 - BUFF, % # BUFFERS 6 00171699 - RECORD, % RECORD SIZE 12 00171700 - BLOCK, % BLOCK SIZE 12 00171701 - SAVER, % SAVE FACTOR 12 00171702 - SPIN, % REW & LOCK @ EOJ 2 00171703 - ALPH; % RECORDING MODE 1 00171704 -PROCEDURE FETCH; 00171705 -BEGIN SCAN; XTA ~ SYMBOL; 00171706 - IF NEXT=COMMA OR NEXT=MINUS THEN 00171707 - BEGIN SCAN; XTA ~ SYMBOL; 00171708 - IF NEXT ! ID THEN FLOG(37); 00171709 - END; 00171710 -END FETCH; 00171711 -INTEGER STREAM PROCEDURE MAKEINT(XTA); 00171712 -BEGIN LABEL LOOP; LOCAL T; 00171713 -SI ~ XTA; SI ~ SI + 2; 00171714 -LOOP: IF SC } "0" THEN 00171715 - BEGIN TALLY ~ TALLY + 1; SI ~ SI + 1; GO TO LOOP END; 00171716 -T ~ TALLY; SI ~ XTA; SI ~ SI + 2; DI ~ LOC MAKEINT; DS ~ T OCT; 00171717 -END MAKEINT; 00171718 -INTEGER PROCEDURE REPLACEMENT; 00171719 -BEGIN 00171720 -FETCH; IF NEXT = EQUAL THEN 00171721 -BEGIN FETCH; IF XTA.[12:6] { 11 THEN BEGIN REPLACEMENT ~ MAKEINT(XTA); 00171722 - FETCH END ELSE FLOG(37); 00171723 -END ELSE FLOG(37); 00171724 -END REPLACEMENT; 00171725 -INTEGER STREAM PROCEDURE SRI7(S); 00171726 -BEGIN SI ~ S; DI ~ LOC SRI7; 00171727 - SI ~ SI + 2; DI ~ DI + 1; DS ~ 7 CHR; 00171728 -END SRI7; 00171729 -COMMENT * * * * * START OF CODE * * * * ; 00171730 -IF DEBUGTOG THEN FLAGROUTINE(" FILEO","PTION ", TRUE); 00171731 -ERRORTOG ~ FALSE; 00171732 -IF LISTOG THEN PRINTCARD; 00171733 -XTA ~ "FILE "; 00171734 -IF NSEG ! 0 THEN FLAG(60); 00171735 -IF INXFIL ~ INXFIL + 1 > MAXOPFILES THEN 00171736 -BEGIN FLAG(59); GO TO XIT END; 00171737 -BUMPPRT; 00171738 -MAXFILES ~ MAXFILES + 1; 00171739 -FILETOG ~ TRUE; SCN ~ 1; % START SCAN MAINTAINENCE 00171740 -FETCH; IF XTA.[12:6] > 11 THEN BEGIN FLAG(37); GO TO XIT END; 00171741 - IF XTA.[12:6] = 0 THEN BEGIN FLOG(037); GO TO XIT END; 00171742 -IF T ~ GLOBALSEARCH(P ~ 0&"."[12:42:6]&XTA[18:12:30]) ! 0 THEN FLAG(20) 00171743 -ELSE BEGIN P~ GLOBALENTER(-0&PRTS[TOADDR]&FILEID[TOCLASS],P); 00171744 - PUT(P+2,GET(P+2)&INXFIL[TOADINFO]); 00171745 - IF XREF THEN ENTERX(XTA &1[TOCE],1&FILEID[TOCLASS]); 00171746 - END; 00171747 -INFC ~ GET(P + 2); 00171748 -FETCH; IF NEXT = EQUAL THEN FETCH ELSE 00171749 - BEGIN FLOG(37); GO TO XIT; END; 00171750 -IF NEXT = SEMI THEN 00171751 -BEGIN FLAG(37); GO TO XIT END 00171752 - ELSE FILEINFO[2,INXFIL] ~ SRI7(ACCUM[1]); 00171753 -FETCH; IF NEXT = SLASH THEN 00171754 - BEGIN FILEINFO[1,INXFIL] ~ FILEINFO[2,INXFIL]; % MULTI FILE ID 00171755 - FETCH; 00171756 - IF NEXT = SEMI THEN BEGIN FLAG(37); GO TO XIT; END 00171757 - ELSE FILEINFO[2,INXFIL] ~ SRI7(ACCUM[1]); 00171758 - FETCH; 00171759 - END; 00171760 -IF XTA = "UNIT " THEN 00171761 -BEGIN 00171762 - FETCH; 00171763 - IF NEXT = EQUAL THEN FETCH ELSE FLOG(37); 00171764 - INFC.LINK ~ KEEP ~ (IF TOG ~ XTA = "PRINT " 00171765 - OR XTA = "PRINTE" THEN 16 ELSE 00171766 - IF CA ~ TOG ~ XTA = "READ " 00171767 - OR XTA = "READER" THEN 2 ELSE 00171768 - IF CA ~ TOG ~ XTA = "PUNCH " THEN 0 ELSE 00171769 - IF TOG ~ XTA = "DISK " THEN 12 ELSE 00171770 - IF TOG ~ XTA = "TAPE " 00171771 - OR XTA = "TAPE7 " THEN 2 ELSE 00171772 - IF TOG ~ XTA = "PAPER " THEN 6 ELSE 00171773 - IF CA ~TOG~XTA= "REMOTE" THEN 19 ELSE 00171774 - IF TOG ~ XTA = "TAPE9 " THEN 2 ELSE 2); 00171775 - IF TOG THEN FETCH ELSE FLOG(37) 00171776 -END ELSE INFC.LINK~KEEP~IF DCINPUT THEN 12 ELSE 2 ; 00171777 -TS~KEEP=12 ; 00171778 -IF XTA="BACKUP" THEN 00171779 - BEGIN 00171780 - FETCH; IF KEEP!0 AND KEEP!18 THEN FLAG(37); 00171781 - IF TOG~XTA="DISK " THEN KEEP~IF KEEP=0 THEN 22 ELSE 15 00171782 - ELSE IF TOG~XTA="TAPE " THEN KEEP~IF KEEP=0 THEN 20 ELSE 6 00171783 - ELSE BEGIN 00171784 - TOG~XTA="ALTERN"; KEEP~IF KEEP=0 THEN 25 ELSE 16 ; 00171785 - END; 00171786 - IF TOG THEN FETCH; INFC.LINK~KEEP ; 00171787 - END ; 00171788 -IF XTA = "UNLABE" THEN % FOR UNLABELED TAPES 00171789 - BEGIN IF KEEP = 2 THEN INFC .LINK ~ 9; FETCH; END; 00171790 -IF XTA = "ALPHA " THEN FETCH ELSE IF KEEP = 2 THEN ALPH ~ 1; % MODE 00171791 -IF XTA = "BCL " THEN FETCH; % FOR B3500 00171792 -IF XTA = "FIXED " THEN FETCH; % FOR B3500 00171793 -IF XTA = "SAVE " THEN SAVER ~ REPLACEMENT; 00171794 -IF XTA = "LOCK " THEN BEGIN SPIN ~ 2; FETCH END; % REW & LOCK AT EOJ 00171795 - IF TOG ~ XTA = "RANDOM" THEN T ~ 10 ELSE 00171796 - IF TOG ~ XTA = "SERIAL" THEN T ~ 12 ELSE 00171797 - IF TOG ~ XTA = "UPDATE" THEN T ~ 13; 00171798 -IF TOG THEN 00171799 - BEGIN IF KEEP=12 THEN INFC.LINK~T ELSE FLAG(37); FETCH END; 00171800 -IF XTA="AREA " THEN 00171801 - BEGIN 00171802 - IF KEEP!12 THEN FLAG(37); 00171803 - T~REPLACEMENT; 00171804 - IF XTA="EU " THEN 00171805 - IF I~REPLACEMENT>19 THEN FLAG(37) 00171806 - ELSE T.EUNF~I+1;% 0 MEANS EU NOT SPECIFIED 00171807 - IF XTA="SPEED " THEN 00171808 - BEGIN 00171809 - FETCH; 00171810 - IF NEXT=EQUAL THEN 00171811 - BEGIN 00171812 - FETCH; 00171813 - IF XTA.[12:6]{SLOWV THEN 00171814 - IF I~MAKEINT(XTA)>SLOWV THEN FLAG(37) 00171815 - ELSE 00171816 - ELSE IF XTA="FAST " THEN T.SPDF~FASTV 00171817 - ELSE IF XTA="SLOW " THEN T.SPDF~SLOWV 00171818 - ELSE FLOG(37); 00171819 - FETCH; 00171820 - END 00171821 - ELSE FLOG(37); 00171822 - END; 00171823 - IF XTA="SENSIT" THEN 00171824 - BEGIN 00171825 - T.SENSE~1; 00171826 - FETCH; 00171827 - END; 00171828 - FILEINFO[3,INXFIL]~T; 00171829 - END; 00171830 -IF XTA = "BLOCKI" THEN BLOCK ~ REPLACEMENT & 1[2:47:1]; 00171831 -RECORD ~ IF XTA="RECORD" THEN REPLACEMENT ELSE IF CA THEN 10 ELSE IF TS 00171832 - AND NOT (BOOLEAN(BLOCK.[2:1])) THEN 10 & 1[2:47:1] ELSE 17; 00171833 -BUFF ~ IF XTA = "BUFFER" THEN REPLACEMENT ELSE 2; 00171834 -IF XTA = "WORKAR" THEN FETCH; % IGNORED, FOR 3500 00171835 -IF BUFF<1 OR BUFF>32 THEN BEGIN XTA~"BUFFER"; FLAG(152) END ; 00171836 -IF RECORD<1 THEN BEGIN XTA~"RECORD"; FLAG(152)END ; 00171837 -IF SAVER>999 THEN BEGIN XTA~"SAVE "; FLAG(152) END ; 00171838 -IF T~INFC.LINK=10 OR T=12 OR T=13 THEN %%% ARE IN DISK FILE 00171839 - BEGIN 00171840 - IF BOOLEAN(RECORD.[2:1])THEN BLOCK ~ 300 00171841 - ELSE 00171842 - IF BLOCK~BLOCK|RECORD>1890 OR RECORD>1023 THEN 00171843 - BEGIN XTA~"BK/REC"; FLAG(152) END 00171844 - END 00171845 -ELSE IF BLOCK~BLOCK|RECORD>1023 OR RECORD>1023 THEN IF KEEP ! 2 THEN 00171846 - BEGIN XTA~"BK/REC"; FLAG(58 ) END ELSE BEGIN RECORD~257; BLOCK~0END;00171847 -FILEINFO[0,INXFIL] ~ 0&BUFF[42:42:6]&RECORD[30:36:12]&BLOCK[18:36:12] 00171848 - &SAVER[6:36:12]&SPIN[4:46:2]&ALPH[3:47:1]; 00171849 -XIT: IF NEXT ! SEMI THEN 00171850 - BEGIN FLOG(37); DO SCAN UNTIL NEXT = SEMI; END; 00171851 - FILETOG ~ FALSE; % END SCAN MAINTAINENCE 00171852 - PUT(P+2,INFC); 00171853 -IF DEBUGTOG THEN FLAGROUTINE(" FILEO","PTION ",FALSE) ; 00171854 -END FILEOPTION; 00171855 - 00171856 -PROCEDURE DOLOPT; 00171857 -BEGIN 00171858 -REAL STREAM PROCEDURE SCAN(BUF,ID); VALUE BUF; 00171859 - BEGIN LABEL LP,LA,LE,XIT; 00171860 - SI ~ BUF; DI ~ ID; DS ~ 2 LIT "0"; 00171861 - LP: IF SC = " " THEN BEGIN SI~SI+1; GO TO LP; END; 00171862 - IF SC = "," THEN BEGIN SI~SI+1; GO TO LP; END; 00171863 - IF SC = "+" THEN BEGIN DS~CHR; GO TO XIT; END; 00171864 - IF SC = "-" THEN BEGIN DS~CHR; GO TO XIT; END; 00171865 - IF SC < "A" THEN BEGIN DI ~ ID; DS ~ 8 LIT "+0000001"; 00171866 -LE: SI~SI+1; 00171867 - GO TO XIT; 00171868 - END; 00171869 - IF SC="|" THEN GO TO LE;% THIS IS > "A" 00171870 - IF SC="!" THEN GO TO LE;% THIS IS > "A" 00171871 - 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); 00171872 - LA: IF SC = ALPHA THEN BEGIN SI~SI+1; GO TO LA; END; 00171873 - XIT: 00171874 - SCAN ~ SI; 00171875 - END SCAN; 00171876 -REAL STREAM PROCEDURE GETVOID(BUF,VOIDSEQ,FR); VALUE BUF,FR; 00171877 - BEGIN LABEL L,LC,LD,LE,XIT; LOCAL TA; 00171878 - SI ~ BUF; DI~VOIDSEQ; DS~8LIT" "; DI~VOIDSEQ; 00171879 - L: IF SC = " " THEN BEGIN SI~SI+1; GO TO L; END; 00171880 - TA ~ SI; 00171881 - IF SC = """ THEN 00171882 - BEGIN 9(SI~SI+1; 00171883 - IF SC = """ THEN BEGIN SI~SI+1; JUMP OUT TO LC; END 00171884 - ELSE TALLY ~ TALLY + 1); 00171885 - TALLY~TALLY+63; SI~TA; SI~SI+1; GO TO LE; 00171886 - END; 00171887 - IF SC < "0" THEN GO TO LD; 00171888 - DS~8LIT"0"; %115- 00171889 - 8(SI~SI+1; DI~DI-1; TALLY~TALLY+1; %115- 00171890 - IF SC LSS "0" THEN JUMP OUT); %115-00171891 - LC: SI ~ TA; 00171892 - LE: TA~TALLY; DS~TA CHR; GETVOID~SI; GO TO XIT; 00171893 - LD: GETVOID~SI; 00171894 - FR(DS~8LIT"9"); 00171895 - XIT: 00171896 - END GETVOID; 00171897 -REAL STREAM PROCEDURE SEQNUM(BUF,VLU); VALUE BUF; 00171898 - BEGIN LABEL L,LA,LC; LOCAL TA,TB; 00171899 - SI ~ BUF; 00171900 - L: IF SC = " " THEN BEGIN SI~SI+1; GO TO L; END; 00171901 - IF SC = "," THEN BEGIN SI~SI+1; GO TO L; END; 00171902 - TA ~ SI; 00171903 - IF SC = "+" THEN 00171904 - BEGIN SI~SI+1; 00171905 - LA: IF SC = " " THEN BEGIN SI~SI+1; GO TO LA;END; 00171906 - TB ~ SI; 00171907 - IF SC < "0" THEN BEGIN SI~TA; GO TO LC; END; 00171908 - DI~TB;TA~DI; 00171909 - END; 00171910 - 8(IF SC < "0" THEN JUMP OUT TO LC; 00171911 - TALLY~TALLY+1; SI~SI+1;); 00171912 - LC: TB ~ TALLY; SEQNUM ~ SI; 00171913 - SI ~ TA; DI ~ VLU; DS ~ TB OCT; 00171914 - END SEQNUM; 00171915 -REAL STREAM PROCEDURE MKABS(S); 00171916 - BEGIN SI ~ S; SI~SI+1; MKABS ~ SI; 00171917 - DI ~ S; 9(DI ~ DI + 8); DS ~ LIT "["; 00171918 - END MKABS; 00171919 -STREAM PROCEDURE MOVEW(P,Q); VALUE Q; 00171920 -BEGIN SI~P; DI ~ Q; DS~CHR; END ; 00171921 - REAL BUF,ID; 00171922 - BOOLEAN VAL, SAVELISTOG; %511-00171923 - LABEL LP,SET,RESET; 00171924 - FORMAT WARN(X18,A6," ILLEGAL CONSTRUCT ON DALLAR CARD XXXX",X39, 00171925 - "WARNING"); 00171926 - DEFINE GETID = BEGIN ID~ " "; BUF ~ SCAN(BUF,ID) END#; 00171927 - SAVELISTOG ~ LISTOG; %511- 00171928 - MOVEW(CRD[9],BUFL); 00171929 - BUF ~ MKABS(CRD[0]); 00171930 - GETID; 00171931 - IF ID = "VOID " THEN 00171932 - BEGIN BUF ~ GETVOID(BUF, VOIDSEQ,0); VOIDTOG ~ TRUE 00171933 - END ELSE 00171934 - IF ID = "VOIDT " THEN 00171935 - BEGIN BUF ~ GETVOID(BUF, VOIDTSEQ,0); VOIDTTOG ~ TRUE 00171936 - END ELSE 00171937 - BEGIN 00171938 - TAPETOG.[47:1] ~ LASTMODE = 2; %517- 00171939 - IF ID = "SET " OR ID = "+ " THEN 00171940 -SET: BEGIN GETID; VAL~ TRUE END 00171941 - ELSE 00171942 - IF ID = "RESET " OR ID = "- " THEN 00171943 -RESET: BEGIN GETID; VAL ~ FALSE END 00171944 - ELSE 00171945 - BEGIN 00171946 - TSSMESTOG ~ VAL; TSSEDITOG ~ VAL; CHECKTOG ~ VAL %501- 00171947 - SINGLETOG~NOT VAL; HOLTOG~VAL; %501- 00171948 - LISTOG~VAL; CODETOG ~ DEBUGTOG ~ VAL; NEWTPTOG ~ VAL; 00171949 - PRTOG~VAL; DOLIST~VAL; LIBTAPE~VAL; SEGPTOG~VAL; %501- 00171950 - LISTPTOG ~ VAL; FREEFTOG ~ XREF ~ VAL ; 00171951 - VAL ~ TRUE; 00171952 - END; 00171953 -LP: IF ID > 0 THEN 00171954 - BEGIN 00171955 - IF ID = "TRACE " THEN 00171956 - BEGIN PRTOG~VAL; LISTOG~VAL; CODETOG~DEBUGTOG~VAL; 00171957 - END ELSE 00171958 - IF ID = "CARD " THEN 00171959 - BEGIN TAPETOG.[47:1]~NOT VAL; LASTMODE~2-REAL(VAL) END ELSE 00171960 - IF ID = "TAPE " THEN 00171961 - BEGIN TAPETOG.[47:1] ~ VAL; LASTMODE ~ REAL(VAL)+1; END ELSE00171962 - IF ID = "NOSEQ " THEN SEQTOG ~ FALSE ELSE 00171963 - IF ID = "SET " OR ID = "+ " THEN GO TO SET ELSE 00171964 - IF ID = "RESET " OR ID = "- " THEN GO TO RESET ELSE 00171965 - IF ID = "ONSITE" AND NOT REMFIXED THEN REMOTETOG ~ FALSE ELSE 00171966 - IF ID = "REMOTE" AND NOT REMFIXED THEN REMOTETOG ~ VAL ELSE 00171967 - IF ID = "FREEFO" THEN FREEFTOG ~ VAL ELSE 00171968 - IF ID = "SINGLE" OR ID = "SGL " THEN 00171969 - BEGIN SINGLETOG ~ VAL; LISTOG ~ TRUE; END ELSE 00171970 - IF ID = "NEW " OR ID = "NEWTAP" THEN 00171971 - BEGIN LIBTAPE~VAL; NEWTPTOG~VAL; NTAPTOG~TRUE; %501- 00171972 - IF ID = "NEW " THEN %501-00171973 - BEGIN %501-00171974 - GETID; %501-00171975 - IF ID ! "TAPE " THEN %501-00171976 - GO TO LP; %501-00171977 - END; %501-00171978 - END ELSE %501-00171979 - IF ID = "LIST " THEN LISTOG ~ VAL ELSE 00171980 - IF ID = "SEQXEQ" AND NOT SEGSWFIXED THEN SEGSW ~ VAL ELSE 00171981 - IF ID = "PRT " THEN PRTOG ~ VAL ELSE 00171982 - IF ID = "DEBUGN" THEN 00171983 - BEGIN LISTOG~VAL; CODETOG~VAL; PRTOG ~ VAL END ELSE 00171984 - IF ID = "TIME " THEN TIMETOG ~ VAL ELSE 00171985 - IF ID = "ERRMES" THEN TSSMESTOG ~ VAL ELSE 00171986 - IF ID = "TSSEDI" THEN TSSEDITOG ~ VAL ELSE 00171987 - IF ID = "LISTLI" THEN LISTLIBTOG ~ VAL ELSE 00171988 - IF(ID = "SEGMEN" OR ID = "SEG ") AND VAL THEN 00171989 - BEGIN ADR~ADR+1; SEGOVF; END ELSE 00171990 - IF ID = "PAGE " AND VAL THEN WRITE(LINE[PAGE]) ELSE 00171991 - IF ID = "VOID " THEN 00171992 - BEGIN VOIDTOG ~ VAL; 00171993 - IF VAL THEN BUF ~ GETVOID(BUF,VOIDSEQ,1); 00171994 - END ELSE 00171995 - IF ID = "VOIDT " THEN 00171996 - BEGIN VOIDTTOG ~ VAL; 00171997 - IF VAL THEN BUF ~ GETVOID(BUF,VOIDTSEQ,1); 00171998 - END ELSE 00171999 - IF ID = "LIMIT " THEN 00172000 - BEGIN LIMIT ~ IF VAL THEN 0 ELSE @60; 00172001 - BUF ~ SEQNUM(BUF,LIMIT); 00172002 - IF LIMIT LEQ ERRORCT THEN GO TO POSTWRAPUP; 00172003 - END ELSE 00172004 - IF ID = "XREF " THEN 00172005 - BEGIN 00172006 - PXREF ~ TRUE; XREF ~ VAL; 00172007 - END ELSE 00172008 - IF ID = "SEQ " THEN 00172009 - BEGIN SEQTOG ~ VAL; 00172010 - IF VAL THEN 00172011 - BEGIN SEQBASE ~ SEQINCR ~ 0; 00172012 - BUF ~ SEQNUM(BUF,SEQBASE); 00172013 - BUF ~ SEQNUM(BUF,SEQINCR); 00172014 - IF SEQINCR { 0 THEN SEQINCR ~ 1000; 00172015 - END END ELSE 00172016 - IF ID = "LISTDO" THEN DOLIST ~ VAL ELSE 00172017 - IF ID = "HOL " THEN HOLTOG ~ VAL ELSE 00172018 - IF ID = "CHECK " THEN CHECKTOG ~ VAL ELSE 00172019 - IF ID = "NEWPAG" THEN SEGPTOG ~ VAL ELSE %501-00172020 - IF ID = "LISTP " THEN LISTPTOG ~ VAL ELSE 00172021 - BEGIN IF FIRSTCALL THEN DATIME; 00172022 - IF UNPRINTED THEN BEGIN PRINTCARD; UNPRINTED~FALSE END; 00172023 - IF SINGLETOG THEN WRITE(LINE,WARN,ID) 00172024 - ELSE WRITE(RITE,WARN,ID); 00172025 - END 00172026 - ; 00172027 - GETID; 00172028 - GO TO LP; 00172029 - END; 00172030 - END; 00172031 - IF DOLIST OR LISTOG OR SAVELISTOG THEN %511-00172032 - IF UNPRINTED THEN PRINTCARD; %517-00172033 - UNPRINTED ~ TRUE; 00172034 -END DOLOPT; 00172035 - 00172036 -STREAM PROCEDURE NEWSEQ(A,B); VALUE B; 00172037 - BEGIN 00172038 - SI ~ LOC B; DI ~ A; DS ~ 8 DEC; 00172039 - END NEWSEQ; 00172040 -INTEGER STREAM PROCEDURE SEQCHK(T,C); 00172041 - BEGIN 00172042 - SI ~ T; DI ~ C; 00172043 - IF 8 SC < DC THEN TALLY ~ 4 ELSE 00172044 - BEGIN 00172045 - SI ~ SI - 8; DI ~ DI - 8; 00172046 - IF 8 SC =DC THEN TALLY ~ 2 00172047 - ELSE TALLY ~ 3; 00172048 - END; 00172049 - SEQCHK ~ TALLY; 00172050 - END SEQCHK; 00172051 -BOOLEAN PROCEDURE READACARD; 00172052 -BEGIN 00172053 -DEFINE FLAGI(FLAGI1) = BEGIN FLAG(FLAGI1); GO TO E4A;END #; 00172054 -REAL STREAM PROCEDURE SCANINC(BUF,ID,RESULT,N,M); 00172055 - VALUE BUF,M,N; 00172056 - BEGIN 00172057 - LOCAL TA; 00172058 - LABEL LP,LQ,XIT; 00172059 - DI := RESULT; DI := DI +7; 00172060 - SI := BUF; 00172061 - LP: IF SC = " " THEN BEGIN SI := SI + 1; GO TO LP; END; 00172062 - IF SC = ALPHA THEN ELSE BEGIN DS:=LIT "1"; DI:=ID; DS~2LIT"0"; 00172063 - DS := CHR; DS := 5LIT" ";GO TO XIT; END; 00172064 - IF SC LSS "0" THEN DS:=LIT "2" ELSE DS:=LIT "3"; %400-00172065 - N (DI:=ID; DS:=8 LIT "0 "; DI:=DI-7; %400-00172066 - 7(IF SC=ALPHA THEN DS~CHR ELSE JUMP OUT 2 TO XIT); 00172067 - JUMP OUT TO XIT); 00172068 - M ( 8 ( IF SC LSS "0" THEN JUMP OUT 2 TO LQ; %400-00172069 - IF SC GTR "9" THEN JUMP OUT 2 TO LQ; %400-00172070 - SI:=SI+1; TALLY:=TALLY+1)); %400-00172071 - LQ: TA := TALLY; 00172072 - SI := SI - TA; 00172073 - DI := ID; 00172074 - DS := TA OCT; 00172075 - XIT: SCANINC := SI; 00172076 - END SCANINC; 00172077 -REAL STREAM PROCEDURE MKABS(S); 00172078 - BEGIN SI := S; SI := SI + 1; MKABS := SI; END; 00172079 -STREAM PROCEDURE MOVE(P, Q); VALUE Q; 00172080 -BEGIN SI ~ P; DI ~ Q; DS ~ CHR; 00172081 - DI ~ P; DS ~ LIT "]"; 00172082 -END MOVE; 00172083 -STREAM PROCEDURE MOVEC(C,B); VALUE B; 00172084 -BEGIN SI~B; DI~C; DS~CHR; END; 00172085 -BOOLEAN STREAM PROCEDURE GETCOL1(BUF); 00172086 - BEGIN 00172087 - SI ~ BUF; IF SC = "$" THEN TALLY ~ 1; 00172088 - GETCOL1 ~ TALLY; 00172089 - END; 00172090 -STREAM PROCEDURE TSSEDITS(C,P); BEGIN SI~C; DI~P; DS~10WDS; SI~C ; 00172091 -IF SC="C" THEN BEGIN DI~P; DI~DI+1; DS~LIT"-" END ELSE 00172092 -IF SC!"$" THEN BEGIN SI~SI+5; IF SC!" " THEN IF SC!"0" THEN BEGIN DI~P;00172093 -DS~6LIT"- " END END END OF TSSEDITS ; 00172094 -STREAM PROCEDURE MOVEW(F,T,B,R); VALUE B, R; 00172095 - BEGIN 00172096 - LABEL XIT; 00172097 - SI ~ F; DI ~ T; 00172098 - B( 00172099 - 2(40( IF SC = ALPHA THEN DS ~ CHR ELSE 00172100 - IF SC = " " THEN DS ~ CHR ELSE 00172101 - IF SC = "%" THEN BEGIN DS ~ LIT "("; SI ~ SI+1 END ELSE 00172102 - IF SC = "[" THEN BEGIN DS ~ LIT ")"; SI ~ SI+1 END ELSE 00172103 - IF SC = "#" THEN BEGIN DS ~ LIT "="; SI ~ SI+1 END ELSE 00172104 - IF SC = "&" THEN BEGIN DS ~ LIT "+"; SI ~ SI+1 END ELSE 00172105 - IF SC = "@" THEN BEGIN DS ~ LIT """; SI ~ SI+1 END ELSE 00172106 - IF SC = ":" THEN BEGIN DS ~ LIT """; SI ~ SI+1 END ELSE 00172107 - IF SC = "<" THEN BEGIN DS ~ LIT "+"; SI ~ SI+1 END ELSE 00172108 - IF SC = ">" THEN BEGIN DS ~ LIT "="; SI ~ SI+1 END ELSE 00172109 - DS ~ CHR )); JUMP OUT TO XIT); 00172110 - XIT: 00172111 - SI~LOC R; SI~SI+7; DI~DI+1 ; 00172112 - DS~CHR ; 00172113 - END MOVEW; 00172114 -ALPHA STREAM PROCEDURE DCMOVEW(F,T,B,FIL,R); VALUE B,FIL,R; 00172115 - BEGIN LOCAL C; LABEL L1,L2,L3,L4 ; 00172116 - SI~F; DI~T; 2(SI~SI+36; DS~36LIT" "); C~SI; DS~8CHR ; 00172117 - SI~LOC R; SI~SI+6; DS~2CHR; DI~C; DS~8LIT"]";TALLY~33;SI~F; 00172118 - IF SC = " " THEN %%% IT MIGHT BE A FILES CARD. 00172119 - BEGIN SI~SI+1; IF SC="F" THEN 00172120 - BEGIN DI~LOC FIL; DI~DI+2; IF 5SC=DC THEN 00172121 - BEGIN DI~F; SI~LOC FIL; SI~SI+2; DS~6CHR ; GO TO L1; END 00172122 - ELSE SI~F END ELSE SI~F END 00172123 - ELSE IF SC = "F" THEN BEGIN DI~LOC FIL;DI~DI+2;IF 6SC=DC THEN GO L1 00172124 - ELSE SI~F;END 00172125 - ELSE IF SC="-" THEN 00172126 - BEGIN %%% IT IS A CONTINUATION CARD. 00172127 - SI~SI+1; DI~T; DS~6LIT" *" ; 00172128 - 5(IF SC=" " THEN SI~SI+1 ELSE JUMP OUT); GO TO L2 ; 00172129 - END 00172130 - ELSE IF SC="C" THEN 00172131 - BEGIN %%% IT MIGHT BE A COMMENT CARD. 00172132 - SI~SI+1; IF SC="-" THEN GO TO L1 ELSE SI~F ; 00172133 - END ; 00172134 - IF SC!"$" THEN %%% IT IS NOT A COMMENT CARD, NOR IS IT A $ CARD, 00172135 - BEGIN %%% NOR A CONTINUATION CARD, NOR A FILES CARD. 00172136 - 2(33(IF SC=" " THEN SI~SI+1 ELSE JUMP OUT 2 TO L3)); L3: DI~T;00172137 - 5(IF SC=" " THEN SI~SI+1 ELSE IF SC}"0" THEN IF SC{"9" 00172138 - THEN DS~CHR ELSE JUMP OUT ELSE JUMP OUT) ; 00172139 - DI~T; DI~DI+6; IF SC=" " THEN SI~SI+1 ; 00172140 - END 00172141 - ELSE 00172142 - BEGIN 00172143 - L1: SI~F; DI~T; TALLY~36 ; 00172144 - END ; 00172145 - L2: C~TALLY ; 00172146 - B(2(C(IF SC>">" THEN DS~CHR ELSE IF SC<"[" THEN DS~CHR ELSE 00172147 - IF SC="%" THEN BEGIN DS~LIT"("; SI~SI+1 END ELSE 00172148 - IF SC="#" THEN BEGIN DS~LIT"="; SI~SI+1 END ELSE 00172149 - IF SC="&" THEN BEGIN DS~LIT"+"; SI~SI+1 END ELSE 00172150 - IF SC="@" THEN BEGIN DS~LIT"""; SI~SI+1 END ELSE 00172151 - IF SC=":" THEN BEGIN DS~LIT"""; SI~SI+1 END ELSE 00172152 - IF SC="<" THEN BEGIN DS~LIT"+"; SI~SI+1 END ELSE 00172153 - IF SC=">" THEN BEGIN DS~LIT"="; SI~SI+1 END ELSE 00172154 - IF SC="[" THEN BEGIN DS~LIT")"; SI~SI+1 END ELSE 00172155 - IF SC="]" THEN JUMP OUT 3 TO L4 ELSE DS~CHR));JUMP OUT TO L4);00172156 - 2(C(IF SC="]" THEN JUMP OUT 2 TO L4 ELSE DS~CHR)) ; 00172157 - L4: DI~LOC DCMOVEW; DS~8LIT"00 "; DI~DI-6 ; 00172158 - 6(IF SC="]" THEN JUMP OUT ELSE DS~CHR) ; 00172159 - END OF DCMOVEW ; 00172160 -STREAM PROCEDURE SEQERR(BUFF, NEW, OLD); 00172161 -BEGIN 00172162 - DI ~ BUFF; DS ~ 18 LIT "SEQUENCE ERROR "; 00172163 - SI ~ NEW; DS ~ LIT"""; 00172164 - DS ~ 8 CHR; DS ~ LIT """; 00172165 - DS ~ 3 LIT " < "; 00172166 - SI ~ OLD; DS ~ LIT """; 00172167 - DS ~ 8 CHR; DS ~ LIT """; 00172168 - DS ~ 59 LIT " "; 00172169 - DS ~ 8 LIT "X"; DS ~ 4 LIT " "; 00172170 -END SEQERR; 00172171 -STREAM PROCEDURE DCMOVE(E,C,A,N); VALUE A,N; 00172172 -BEGIN SI~C; DI~E; DS~10WDS; DS~4CHR; SI~LOC A; DS~4DEC; 00172173 - N(DS~8LIT" PATCH"); END; 00172174 - REAL BUF,ID; 00172175 - BOOLEAN NOWRI; LABEL ENDPB, E4B; 00172176 - LABEL LIBADD, ENDPA, E4A, E4, STRTA; 00172177 - LABEL E1,E2,E3,STRT,ENDP,XIT; 00172178 - UNPRINTED~TRUE; 00172179 - GO TO STRT; 00172180 -LIBADD: 00172181 - XTA := BLANKS; 00172182 - IF INSERTDEPTH = -1 THEN SAVECARD ~ NEXTCARD; 00172183 - MOVE (CRD[9],BUFL); 00172184 - 00172185 - IF (INSERTDEPTH ~ INSERTDEPTH + 1) GTR INSERTMAX THEN 00172186 - FLAG(158); 00172187 - NEWPTOG ~ FALSE; 00172188 - INSERTINX ~ -1; 00172189 - INSERTCOP ~ 0; 00172190 - BLANKIT(SSNM[5],1,0); 00172191 - BUF ~ SCANINC(BUF,INSERTMID,RESULT,1,0); 00172192 - IF RESULT = 1 AND INSERTMID = "+ "THEN 00172193 - BEGIN BUF~SCANINC(BUF,ID,RESULT,1,0); 00172194 - IF ID = "COPY " THEN INSERTCOP ~ 1 00172195 - ELSE FLAG(155); 00172196 - BUF~SCANINC(BUF,INSERTMID,RESULT,1,0); 00172197 - END; 00172198 - IF RESULT NEQ 2 THEN FLAGI (155); 00172199 - BUF := SCANINC(BUF,ID,RESULT,0,1); %107-00172200 - IF RESULT = 1 THEN IF ID = "/ " THEN 00172201 - BEGIN BUF := SCANINC(BUF,INSERTFID,RESULT,1,0); 00172202 - IF RESULT NEQ 2 THEN FLAGI(155); 00172203 - BUF := SCANINC(BUF,ID,RESULT,0,1); 00172204 - END ELSE INSERTFID := TIME(-1) ELSE INSERTFID := TIME(-1); 00172205 - IF RESULT = 3 THEN 00172206 - BEGIN NEWSEQ(SSNM[5],ID); 00172207 - BUF := SCANINC(BUF,ID,RESULT,0,1); 00172208 - IF RESULT NEQ 1 THEN FLAGI(156); 00172209 - IF ID = "] " THEN NEWSEQ (INSERTSEQ,99999999) %400-00172210 - ELSE BEGIN %400-00172211 - BUF ~ SCANINC(BUF,ID,RESULT,0,1); 00172212 - IF RESULT NEQ 3 THEN FLAGI(157); 00172213 - NEWSEQ (INSERTSEQ,ID); 00172214 - END %400-00172215 - END ELSE IF ID = "] " THEN NEWSEQ(INSERTSEQ,999999999) 00172216 - ELSE FLAGI(157); 00172217 - IF INSERTDEPTH > 0 THEN CLOSE (LF,RELEASE); 00172218 - FILL LF WITH INSERTMID,INSERTFID; 00172219 - DO BEGIN 00172220 - READ (LF[INSERTINX ~ INSERTINX+1],10,DB[*])[E4]; 00172221 - END UNTIL SEQCHK(SSNM[5],DB[9]) NEQ 3; 00172222 - NEWPTOG ~ BOOLEAN(INSERTCOP); 00172223 - IF NOT NEWTPTOG THEN 00172224 - BEGIN 00172225 - IF SEQTOG THEN 00172226 - BEGIN NEWSEQ(CRD[9],SEQBASE); MOVE(CRD[9],BUFL); 00172227 - SEQBASE~SEQBASE+SEQINCR; 00172228 - END; MOVEC(CRD[9],BUFL); 00172229 - IF LIBTAPE AND(INSERTDEPTH = 0 ) THEN WRITE(NEWTAPE,10,CRD[*]); 00172230 - END; %511- 00172231 - IF LISTOG OR DOLIST THEN PRINTCARD; %511- 00172232 - NEXTCARD~7; 00172233 - GO TO STRT; 00172234 - E1: IF NEXTCARD=1 THEN IF TAPETOG THEN 00172235 - BEGIN 00172236 - NEXTCARD~5; READ(TP,10,TB[*])[E2]; GO TO STRT ; 00172237 - END 00172238 - ELSE 00172239 - BEGIN 00172240 - NEXTCARD:=6; 00172241 - IF GETCOL1(CRD[0]) THEN BEGIN BUF := MKABS(CRD[0]); 00172242 - BUF:=SCANINC(BUF,ID,RESULT,1,0); IF ID NEQ INCLUDE 00172243 - THEN BLANKIT(CRD,9,1); END; 00172244 - GO TO ENDP ; 00172245 - END ; 00172246 - NEXTCARD ~ 5; GO TO ENDP; 00172247 - E2: IF NEXTCARD = 5 THEN 00172248 - BEGIN 00172249 - NEXTCARD:=6; 00172250 - IF GETCOL1(CRD[0]) THEN BEGIN BUF := MKABS(CRD[0]); 00172251 - BUF:=SCANINC(BUF,ID,RESULT,1,0); IF ID NEQ INCLUDE 00172252 - THEN BLANKIT(CRD,9,1); END; 00172253 - END 00172254 - ELSE IF NEXTCARD!2 THEN NEXTCARD~1 ELSE 00172255 - BEGIN 00172256 - NEXTCARD~1; TAPETOG~BOOLEAN(2); READ(CR,10,CB[*])[E1] ; 00172257 - END ; 00172258 - IF VOIDTTOG THEN IF SEQCHK(CRD[0],VOIDTSEQ) < 4 %11001722594- - THEN VOIDTTOG~FALSE %11001722604- - ELSE BEGIN VOIDTTOG~FALSE; GO TO STRT; END; %11001722614- - GO TO ENDP ; 00172262 - E4B: NOWRI ~TRUE; 00172263 - IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); 00172264 - IF NEWTPTOG THEN IF TSSEDITOG THEN 00172265 - BEGIN TSSEDITS(CRD,PRINTBUFF); WRITE(NEWTAPE,10,PRINTBUFF[*]); 00172266 - END ELSE WRITE(NEWTAPE,10,CRD[*]); 00172267 - E4: CLOSE (LF,RELEASE); 00172268 - NEWTPTOG~ SAVETOG; 00172269 - IF (INSERTDEPTH := INSERTDEPTH - 1) = -1 THEN 00172270 - BEGIN NEXTCARD ~ SAVECARD; GO TO ENDPA; END 00172271 - ELSE NEWTPTOG ~ BOOLEAN(INSERTCOP); 00172272 - FILL LF WITH INSERTMID,INSERTFID; 00172273 - READ(LF[INSERTINX := INSERTINX + 1],10,DB[*])[E4]; 00172274 - IF SEQCHK(INSERTSEQ,DB[9]) = 4 THEN GO TO E4; 00172275 - GO TO ENDP; 00172276 - E4A: 00172277 - NEWTPTOG~SAVETOG; 00172278 - IF (INSERTDEPTH ~ INSERTDEPTH-1) = -1 THEN NEXTCARD~SAVECARD 00172279 - ELSE NEWTPTOG ~ BOOLEAN(INSERTCOP); 00172280 - STRT: 00172281 - STRTA: 00172282 - IF NEXTCARD=6 THEN GO XIT ; 00172283 - CARDCOUNT ~ CARDCOUNT+1; 00172284 - IF NEXTCARD = 1 THEN 00172285 - BEGIN % CARD ONLY 00172286 - IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG 00172287 - THEN MOVEW(CB,CRD,HOLTOG,IF DCINPUT THEN "D" ELSE "R") 00172288 - ELSE IF SNNM[4]~DCMOVEW(CB,CRD,HOLTOG,"FILE ",IF FREEFTOG 00172289 - THEN " R" ELSE " D") ! " " THEN 00172290 - BEGIN XTA~SSNM[4] ; 00172291 - MOVESEQ(SSNM[4],LASTSEQ); MOVESEQ(LASTSEQ,CRD[9]) ; 00172292 - IF LISTOG THEN 00172293 - BEGIN IF FIRSTCALL THEN DATIME ; 00172294 - DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],0); 00172295 - WRITAROW(11,PRINTBUFF); UNPRINTED~FALSE ; 00172296 - END ; 00172297 - FLOG(149); MOVESEQ(LASTSEQ,SSNM[4]) ; 00172298 - END ; 00172299 - IF GETCOL1(CRD[0]) THEN 00172300 - BEGIN 00172301 - BUF := MKABS(CRD[0]); 00172302 - BUF := SCANINC(BUF,ID,RESULT,1,0); 00172303 - IF ID NEQ INCLUDE THEN 00172304 - BEGIN 00172305 - DOLOPT; 00172306 - IF REAL(TAPETOG)=3 THEN READ(TP) ; 00172307 - READ(CR,10,CB[*])[E1]; 00172308 - IF NOT TAPETOG THEN GO TO STRT; 00172309 - READ(TP,10,TB[*])[E2]; 00172310 - NEXTCARD ~ SEQCHK(TB[9], CB[9]); 00172311 - GO TO STRT; 00172312 - END; 00172313 - END; 00172314 - IF LISTPTOG THEN 00172315 - BEGIN IF FIRSTCALL THEN DATIME; 00172316 - IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); 00172317 - DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],1); 00172318 - WRITAROW (12,PRINTBUFF); UNPRINTED ~ FALSE; 00172319 - END; 00172320 - READ(CR,10,CB[*])[E1]; 00172321 - GO TO ENDP; 00172322 - END; 00172323 - IF NEXTCARD = 5 THEN 00172324 - BEGIN 00172325 - MOVEW(TB,CRD,HOLTOG,"T") ; 00172326 - READ(TP, 10, TB[*])[E2]; 00172327 - IF VOIDTTOG THEN IF SEQCHK(CRD[9],VOIDTSEQ) < 4 THEN 00172328 - VOIDTTOG ~ FALSE ELSE GO TO STRT; 00172329 - GO TO ENDP; 00172330 - END; 00172331 - IF NEXTCARD { 3 THEN 00172332 - BEGIN % CARD OVER TAPE 00172333 - IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG 00172334 - THEN MOVEW(CB,CRD,HOLTOG,IF DCINPUT THEN "D" ELSE "R") 00172335 - ELSE IF SSNM[4]~DCMOVEW(CB,CRD,HOLTOG,"FILE ",IF FREEFTOG 00172336 - THEN " R" ELSE " D") ! " " THEN 00172337 - BEGIN XTA~SSNM[4] ; 00172338 - MOVESEQ(SSNM[4],LASTSEQ); MOVESEQ(LASTSEQ,CRD[9] ); 00172339 - IF LISTOG THEN 00172340 - BEGIN IF FIRSTCALL THEN DATIME; 00172341 - DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],0); 00172342 - WRITAROW(11,PRINTBUFF); UNPRINTED~FALSE ; 00172343 - END; 00172344 - FLOG(149); MOVESEQ(LASTSEQ,SSNM[4]) ; 00172345 - END; 00172346 - IF NEXTCARD =2 THEN READ(TP,10,TB[*])[E2]; 00172347 - IF GETCOL1(CRD) THEN 00172348 - BEGIN 00172349 - BUF ~ MKABS(CRD[0]); 00172350 - BUF ~ SCANINC(BUF,ID,RESULT,1,0); 00172351 - IF ID NEQ INCLUDE THEN 00172352 - BEGIN 00172353 - DOLOPT; 00172354 - READ(CR,10,CB[*])[E3]; 00172355 - NEXTCARD ~ SEQCHK(TB[9], CB[9]); 00172356 - GO TO STRT; 00172357 - E3: NEXTCARD~5; GO TO STRT; 00172358 - END; 00172359 - END; 00172360 - IF LISTPTOG THEN 00172361 - BEGIN IF FIRSTCALL THEN DATIME; 00172362 - IF SEQTOG THEN NEWSEQ(CRD[9],SEQBASE); 00172363 - DCMOVE(PRINTBUFF,CRD,(ADR+1).[36:10],1); 00172364 - WRITAROW (12,PRINTBUFF); UNPRINTED ~ FALSE; 00172365 - END; 00172366 - READ(CR,10,CB[*])[E1]; 00172367 - NEXTCARD ~ SEQCHK(TB[9], CB[9]); 00172368 - GO TO ENDP; 00172369 - END; 00172370 - % TAPE BEFORE CARD 00172371 - IF NEXTCARD = 7 THEN 00172372 - BEGIN 00172373 - IF(NOT DCINPUT OR TSSEDITOG)AND NOT FREEFTOG 00172374 - THEN MOVEW(DB,CRD,HOLTOG,"L") ELSE IF XTA~DCMOVEW(DB,CRD, 00172375 - HOLTOG,"FILE ",IF FREETOG THEN " R" ELSE " D") 00172376 - ! " " THEN FLOG(149); 00172377 - IF GETCOL1(CRD[0]) THEN 00172378 - BEGIN 00172379 - BUF ~ MKABS(CRD[0]); 00172380 - BUF ~ SCANINC(BUF,ID,RESULT,1,0); 00172381 - IF ID = INCLUDE THEN GO TO LIBADD; 00172382 - END; 00172383 - READ(LF[INSERTINX~INSERTINX+1],10,DB[*])[E4B]; 00172384 - IF SEQCHK(INSERTSEQ,DB[9]) = 4 THEN GO TO E4B; 00172385 - IF GETCOL1(CRD[0]) THEN BEGIN DOLOPT; GO TO STRT; END; 00172386 - GO TO ENDP; 00172387 - END; 00172388 - MOVEW(TB,CRD,HOLTOG,"T") ; 00172389 - READ(TP,10,TB[*])[E2]; 00172390 - IF VOIDTTOG THEN IF SEQCHK(CRD[9],VOIDTSEQ) < 4 THEN 00172391 - VOIDTTOG~FALSE ELSE BEGIN NEXTCARD~SEQCHK(TB[9],CB[9]); 00172392 - GO TO STRT; END; %114-00172393 - NEXTCARD ~ SEQCHK(TB[9], CB[9]); 00172394 - ENDP: 00172395 - IF NEXTCARD NEQ 7 THEN 00172396 - IF VOIDTOG THEN IF SEQCHK(CRD[9],VOIDSEQ) < 4 THEN 00172397 - VOIDTOG ~ FALSE ELSE GO TO STRT; 00172398 - IF GETCOL1(CRD[0]) THEN 00172399 - BEGIN 00172400 - BUF ~ MKABS(CRD[0]); 00172401 - BUF ~ SCANINC(BUF,ID,RESULT,1,0); 00172402 - IF ID = INCLUDE THEN GO TO LIBADD ELSE GO TO STRT; 00172403 - END; 00172404 - SEQERRORS ~ FALSE; 00172405 - IF NEXTCARD = 7 THEN 00172406 - BEGIN MOVESEQ(LASTSEQ,CRD[9]); GO TO ENDPA; END; 00172407 - IF CHECKTOG AND SEQERRCT=0 THEN SEQERRCT~1 ; 00172408 - IF CHECKTOG THEN IF SEQCHK(LASTSEQ,CRD[9])=3 THEN 00172409 - BEGIN 00172410 - SEQERR(ERRORBUFF,CRD[9],LASTSEQ) ; 00172411 - MOVESEQ(LASTSEQ,CRD[9]) ; 00172412 - IF SEQTOG THEN 00172413 - BEGIN NEWSEQ(CRD[9],SEQBASE);SEQBASE~SEQBASE+SEQINCR END;00172414 - MOVESEQ(LINKLIST,CRD[9]); 00172415 - MOVE(CRD[9],BUFL) ; 00172416 - SEQERRCT~SEQERRCT+1 ; 00172417 - SEQERRORS~TRUE ; 00172418 - IF NOT LISTOG THEN PRINTCARD ; 00172419 - END 00172420 - ELSE MOVESEQ(LASTSEQ,CRD[9]) ELSE MOVESEQ(LASTSEQ,CRD[9]) ; 00172421 - 00172422 - 00172423 - 00172424 - 00172425 - 00172426 - 00172427 - 00172428 - 00172429 -ENDPA: 00172430 - IF SEQTOG THEN 00172431 - BEGIN 00172432 - NEWSEQ(CRD[9],SEQBASE); 00172433 - SEQBASE ~ SEQBASE + SEQINCR; 00172434 - END; 00172435 - IF NOWRI THEN GO TO ENDPB; 00172436 - IF NEWTPTOG THEN IF TSSEDITOG THEN BEGIN TSSEDITS(CRD,PRINTBUFF) ; 00172437 - WRITE(NEWTAPE,10,PRINTBUFF[*]) END ELSE WRITE(NEWTAPE,10,CRD[*]) ; 00172438 -ENDPB: 00172439 - IF NOT SEQERRORS THEN 00172440 - BEGIN 00172441 - MOVESEQ(LINKLIST,CRD[9]) ; 00172442 - MOVE(CRD[9],BUFL) ; 00172443 - END ; 00172444 - NCR ~ INITIALNCR; 00172445 - READACARD ~ TRUE; 00172446 -XIT: 00172447 - SEGSWFIXED ~ TRUE ; 00172448 - REMFIXED~TRUE ; 00172449 - IF TSSEDITOG THEN WARNED~TRUE ; 00172450 - IF LISTOG AND FIRSTCALL THEN DATIME; 00172451 - IF SEGSW THEN %%% ENTER SEQ# AND ADR TO LINESEG ARRAY. 00172452 - BEGIN IF LASTADDR!ADR THEN BEGIN NOLIN~NOLIN+1; LASTADDR~ADR END;00172453 - LINESEG[NOLIN.IR,NOLIN.IC]~0 & D2B(LASTSEQ)[10:20:28] & (ADR+3) 00172454 - [38:36:10] ; 00172455 - END ; 00172456 -END READACARD; 00172457 - 00172458 -INTEGER STREAM PROCEDURE CONVERT(NUB,SIZE,P,CHAR); VALUE P; 00172459 - BEGIN 00172460 - LOCAL T; 00172461 - SI ~ P; 00172462 - 8(IF SC < "0" THEN JUMP OUT; 00172463 - SI ~ SI + 1; TALLY ~ TALLY + 1); 00172464 - CONVERT ~ SI; 00172465 - DI ~ CHAR; DS ~ 7 LIT "0"; DS ~ CHR; 00172466 - T ~ TALLY; 00172467 - SI ~ P; DI ~ NUB; DS ~ T OCT; 00172468 - DI ~ SIZE ; SI ~ LOC T; DS ~ WDS; 00172469 - END CONVERT; 00172470 -PROCEDURE SCAN; 00172471 -BEGIN 00172472 -BOOLEAN STREAM PROCEDURE ADVANCE(NCR, ACR, CHAR, NCRV, ACRV); 00172473 -VALUE NCRV, ACRV, CHAR; 00172474 -BEGIN LABEL LOOP; 00172475 - LABEL DIG, ALPH, BK1, BK2, SPEC; 00172476 - DI ~ ACRV; 00172477 - SI ~ CHAR; SI ~ SI+8; 00172478 - IF SC ! " " THEN 00172479 - IF SC } "0" THEN BEGIN SI ~ NCRV; GO TO BK1 END ELSE 00172480 - BEGIN SI ~ NCRV; GO TO BK2 END; 00172481 - SI ~ NCRV; 00172482 - LOOP: 00172483 - IF SC = " " THEN BEGIN SI~SI+1; GO TO LOOP END; 00172484 - IF SC } "0" THEN 00172485 - BEGIN 00172486 - DIG: DS ~ CHR; 00172487 - BK1: IF SC = " " THEN BEGIN SI ~ SI+1; GO TO BK1 END; 00172488 - IF SC } "0" THEN GO TO DIG; 00172489 - GO TO SPEC; 00172490 - END; 00172491 - IF SC = ALPHA THEN 00172492 - BEGIN 00172493 - ALPH: DS ~ CHR; 00172494 - BK2: IF SC = " " THEN BEGIN SI ~ SI+1; GO TO BK2 END; 00172495 - IF SC = ALPHA THEN GO TO ALPH; 00172496 - END; 00172497 - SPEC: 00172498 - ACRV ~ DI; 00172499 - DS ~ 6 LIT " "; 00172500 - IF SC = "]" THEN 00172501 - BEGIN TALLY ~ 1; SI ~ LOC ACRV; 00172502 - DI ~ ACR; DS ~ WDS; 00172503 - DI ~ CHAR; DS ~ LIT ";"; 00172504 - END ELSE 00172505 - BEGIN DI ~ CHAR; DS ~ CHR; 00172506 - ACRV ~ SI; SI ~ LOC ACRV; 00172507 - DI ~ NCR; DS ~ WDS; 00172508 - END; 00172509 - ADVANCE ~ TALLY; 00172510 -END ADVANCE; 00172511 -BOOLEAN PROCEDURE CONTINUE; 00172512 -BEGIN 00172513 -LABEL LOOP; 00172514 - 00172515 -BOOLEAN STREAM PROCEDURE CONTIN(CD); 00172516 -BEGIN SI~CD; IF SC!"C" THEN IF SC!"$" THEN BEGIN SI~SI+5; IF SC!" " 00172517 -THEN IF SC!"0" THEN BEGIN TALLY~1; CONTIN~TALLY END END END OF CONTIN ;00172518 -BOOLEAN STREAM PROCEDURE COMNT(CD,T); VALUE T; 00172519 -BEGIN LABEL L ; 00172520 - SI ~ CD; IF SC = "C" THEN BEGIN T(SI~SI+1; IF SC="-" THEN TALLY~1 00172521 - ELSE JUMP OUT TO L); TALLY~1; L: END; COMNT~TALLY ; 00172522 -END COMNT; 00172523 -BOOLEAN STREAM PROCEDURE DCCONTIN(CD); 00172524 -BEGIN 00172525 - SI ~ CD; IF SC = "-" THEN TALLY ~ 1; 00172526 - DCCONTIN ~ TALLY; 00172527 -END DCCONTIN; 00172528 -LOOP: IF NOT(CONTINUE ~ 00172529 - IF(DCINPUT AND NOT TSSEDITOG)OR FREEFTOG THEN 00172530 - IF NEXTCARD < 4 THEN DCCONTIN(CB) 00172531 - ELSE IF NEXTCARD = 7 THEN DCCONTIN(DB)ELSE CONTIN(TB) 00172532 - ELSE IF NEXTCARD = 7 THEN CONTIN(DB) 00172533 - ELSE IF NEXTCARD < 4 THEN CONTIN(DB) ELSE 00172534 - CONTIN(TB)) THEN 00172535 - IF(IF NEXTCARD < 4 THEN 00172536 - COMNT(CB,(DCINPUT AND NOT TSSEDITOG) OR FREEFTOG) 00172537 - ELSE IF NEXTCARD = 7 THEN 00172538 - COMNT(CB,(DCINPUT AND NOT TSSEDITOG) OR FREEFTOG) 00172539 - ELSE COMNT(TB,0) AND NEXTCARD ! 6) THEN 00172540 - BEGIN 00172541 - IF READACARD THEN IF LISTOG THEN PRINTCARD; 00172542 - GO TO LOOP; 00172543 - END; 00172544 -END CONTINUE; 00172545 - 00172546 -PROCEDURE SCANX(EOF1, EOF2, EOS1, EOS2, OK1, OK2); 00172547 - VALUE EOF1, EOF2, EOS1, EOS2, OK1, OK2; 00172548 - INTEGER EOF1, EOF2, EOS1, EOS2, OK1, OK2; 00172549 -BEGIN LABEL LOOP, LOOP0 ; 00172550 - LOOP0: 00172551 - EXACCUM[1] ~ BLANKS; 00172552 - ACR ~ ACR1; 00172553 - LOOP: 00172554 - IF ADVANCE(NCR, ACR, CHR1, NCR, ACR) THEN 00172555 - IF CONTINUE THEN 00172556 - IF READACARD THEN 00172557 - BEGIN 00172558 - IF LISTOG THEN PRINTCARD ; 00172559 - IF ACR.[33:15]}EXACCUMSTOP THEN 00172560 - BEGIN XTA~BLANKS; FLOG(175); GO LOOP0 END ; 00172561 - GO LOOP ; 00172562 - END 00172563 - END SCN ~ IF EXACCUM[1] = BLANKS THEN EOF1 ELSE EOF2 00172564 - ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN EOS1 ELSE EOS2 00172565 - ELSE SCN ~ IF EXACCUM[1] = BLANKS THEN OK1 ELSE OK2; 00172566 -END SCANX; 00172567 - 00172568 -DEFINE CHAR = ACCUM[0]#; 00172569 -DEFINE T=SYMBOL#; 00172570 -INTEGER N; 00172571 -BOOLEAN STREAM PROCEDURE CHECKEXP(NCR, NCRV, A); VALUE NCRV; 00172572 -BEGIN 00172573 - SI ~ NCRV; 00172574 - IF SC = "*" THEN 00172575 - BEGIN DI ~ A; DI ~ DI+2; DS ~ 2 LIT "*"; SI ~ SI+1; NCRV ~ SI; 00172576 - TALLY ~ 1; CHECKEXP ~ TALLY; 00172577 - SI ~ LOC NCRV; DI ~ NCR; DS ~ WDS END; 00172578 -END CHECKEXP; 00172579 -PROCEDURE CHECKRESERVED; 00172580 -BEGIN LABEL RESWD, XIT, FOUND1, FOUND2, DONE; 00172581 -BOOLEAN STREAM PROCEDURE COMPLETECHECK(A,B,N); VALUE N ; 00172582 - BEGIN LABEL L ; 00172583 - SI~A; SI~SI-2; DI~B; N(IF SC!DC THEN JUMP OUT TO L); TALLY~1; 00172584 - L: COMPLETECHECK~TALLY ; 00172585 - END OF COMPLETECHECK; 00172586 -STREAM PROCEDURE XFER(FROM, T1, T2, N, M); VALUE FROM, N, M; 00172587 -BEGIN SI ~ FROM; DI ~ T1; DI ~ DI+2; 00172588 - DS ~ M CHR; 00172589 - SI ~ FROM; SI ~ SI+N; 00172590 - DI ~ T2; DI ~ DI+2; 00172591 - DS ~ 6 CHR; 00172592 -END XFER; 00172593 -STREAM PROCEDURE XFERA(FROM, NEXT1, NEXT2); 00172594 - VALUE FROM; 00172595 -BEGIN SI ~ FROM; SI ~ SI+6; 00172596 - DI ~ NEXT1; DI ~ DI+2; 00172597 - 5(IF SC } "0" THEN DS ~ CHR ELSE JUMP OUT); 00172598 - SI ~ SI+2; 00172599 - DI ~ NEXT2; DI ~ DI+2; 00172600 - 6(IF SC = ALPHA THEN DS ~ CHR ELSE JUMP OUT); 00172601 -END XFERA; 00172602 -BOOLEAN STREAM PROCEDURE CHECKFUN(FROM, TOO, N); VALUE FROM, N; 00172603 -BEGIN SI ~ FROM; SI ~ SI +N; 00172604 - IF SC = "O" THEN 00172605 - BEGIN SI ~ SI+1; 00172606 - IF SC = "N" THEN 00172607 - BEGIN SI ~ SI+1; TALLY ~ 1; 00172608 - DI ~ TOO; DI ~ DI+2; 00172609 - DS ~ 6 CHR; 00172610 - END; 00172611 - END; 00172612 - CHECKFUN ~ TALLY; 00172613 -END CHECKFUN; 00172614 -BOOLEAN STREAM PROCEDURE MORETHAN6(P); 00172615 -BEGIN SI ~ P; 00172616 - IF SC ! " " THEN TALLY ~ 1; 00172617 - MORETHAN6 ~ TALLY; 00172618 -END MORETHAN6; 00172619 -INTEGER I; ALPHA ID; 00172620 -INTEGER STOR ; 00172621 - IF ACCUM[1] = " " THEN 00172622 - BEGIN XTA ~ CHAR; FLOG(16); GO TO XIT END; 00172623 - IF CHAR = "= " OR CHAR = "# " THEN GO TO XIT; 00172624 - IF CHAR = "~ " THEN GO TO XIT; 00172625 - IF CHAR ! "( " AND CHAR ! "% " THEN GO TO RESWD; 00172626 - IF MORETHAN6(ACCUM[2]) THEN GO TO RESWD; 00172627 - COMMENT AT THIS POINT WE HAVE ( . 00172628 - THIS MUST BE ONE OF THE FOLLOWING: 00172629 - ASSIGNEMNT STATEMENT WITH SUBSCRIPTED VARIABLE AT THE LEFT. 00172630 - STATEMENT FUNCTION DECLARATION. 00172631 -CALL, REAL, ENTRY, GO TO, READ, WRITE, FORMAT, IF, DATA, CHAIN, PRINT OR00172632 - PUNCH; 00172633 - IF I ~ SEARCH(T) > 0 THEN 00172634 - IF GET(I).CLASS = ARRAYID THEN GO TO XIT; 00172635 - ID ~ T; ID.[36:12] ~ " "; 00172636 - FOR I~0 THRU RSP DO IF RESERVEDWORDSLP[I]=ID THEN IF (IF STOR 00172637 - ~RESLENGTHLP[I]-4<1 THEN TRUE ELSE COMPLETECHECK(ACCUM[2], 00172638 - RESERVEDWORDSLP[I+RSP1],STOR)) THEN GO FOUND1 ; 00172639 - GO TO XIT; 00172640 - FOUND1: 00172641 - NEXT ~ LPGLOBAL[I]; 00172642 - T ~ " "; 00172643 - XFER(ACR0, T, NEXTACC, I~RESLENGTHLP[I], IF I> 6 THEN 6 ELSE I); 00172644 - GO TO DONE; 00172645 - RESWD: 00172646 - COMMENT AT THIS POINT WE KNOW THE MUST BE A SPECIAL WORD 00172647 - TO IDENTIFY THE STATEMENT TYPE; 00172648 - ID ~ T; ID.[36:12] ~ " "; 00172649 - IF T = "ASSIGN" THEN 00172650 - BEGIN 00172651 - NEXTSCN ~ SCN; SCN ~ 14; 00172652 - NEXTACC ~ NEXTACC2 ~ " "; 00172653 - XFERA(ACR0, NEXTACC, NEXTACC2); 00172654 - NEXT ~ 1; 00172655 - GO TO XIT; 00172656 - END; 00172657 - FOR I~1 THRU RSH DO IF RESERVEDWORDS[I]=ID THEN IF (IF STOR~ 00172658 - RESLENGTH[I]-4<1 THEN TRUE ELSE COMPLETECHECK(ACCUM[2],RESERVEDWORDS00172659 - [I+RSH1],IF STOR>8 THEN 8 ELSE STOR)) THEN GO FOUND2 ; 00172660 - XTA ~ T; FLOG(16); GO TO XIT; 00172661 - FOUND2: 00172662 - NEXT ~ I+1; 00172663 - T ~ " "; 00172664 - XFER(ACR0, T, NEXTACC, I~RESLENGTH [I], IF I> 6 THEN 6 ELSE I); 00172665 - DONE: NEXTSCN ~ SCN; 00172666 - SCN ~ 6; 00172667 - IF NEXTACC = "FUNCTI" THEN 00172668 - IF CHECKFUN(ACR0, NEXTACC, I+6) THEN SCN ~ 13; 00172669 - XIT: 00172670 - EOSTOG~FALSE; 00172671 -END CHECKRESERVED; 00172672 - 00172673 -BOOLEAN PROCEDURE CHECKOCTAL; 00172674 -BEGIN 00172675 - INTEGER S, T; LABEL XIT; 00172676 -INTEGER STREAM PROCEDURE COUNT(ACRV,T); VALUE ACRV,T ; 00172677 - BEGIN 00172678 - LOCAL A,B; SI~LOC T; SI~SI+7 ; 00172679 - IF SC="1" THEN BEGIN SI~ACRV;IF SC="O" THEN SI~SI+1 END ELSE SI~ACRV;00172680 - IF SC!" " THEN 00172681 - BEGIN A~SI; 00172682 - 17(IF SC>"7" THEN BEGIN TALLY~17; JUMP OUT END ELSE IF SC < "0" THEN00172683 - BEGIN IF SC!" " THEN TALLY~17; JUMP OUT END; SI~SI+1; 00172684 - TALLY~TALLY+1) ; 00172685 - B~TALLY; SI~LOC B; SI~SI+7 ; 00172686 - IF SC="+" THEN BEGIN SI~A; IF SC>"3" THEN TALLY~17 END; 00172687 - END ; 00172688 - COUNT~TALLY ; 00172689 - END OF COUNT ; 00172690 -ALPHA STREAM PROCEDURE CONV(ACRV, S, T); VALUE ACRV, S, T; 00172691 -BEGIN SI ~ ACRV; IF SC = "O" THEN SI ~ SI+1; 00172692 - DI ~ LOC CONV; SKIP S DB; 00172693 - T(SKIP 3 SB; 3(IF SB THEN DS ~ SET ELSE DS ~ RESET; SKIP 1 SB)); 00172694 -END CONV; 00172695 - IF T~COUNT(ACR0,1) = 0 THEN 00172696 - BEGIN S ~ 1; 00172697 - IF T ~ CHAR ! "+ " AND T ! "& " THEN 00172698 - IF T = "- " THEN S ~ -1 ELSE GO TO XIT; 00172699 - SCANX(4, 4, 3, 3, 10, 10); 00172700 - IF SCN ! 10 THEN GO TO XIT; 00172701 - IF T~COUNT(ACR1,2) = 0 OR T > 16 THEN GO TO XIT ; 00172702 - FNEXT ~ CONV(ACR1, (16-T)|3, T); 00172703 - IF S < 0 THEN FNEXT ~ -FNEXT; 00172704 - END ELSE IF T < 17 THEN FNEXT~CONV(ACR0,(16-T)|3,T) ELSE GO TO XIT ; 00172705 - CHECKOCTAL ~ TRUE; 00172706 - NEXT ~ NUM; 00172707 - NUMTYPE ~ REALTYPE; 00172708 - XIT: 00172709 -END CHECKOCTAL; 00172710 - 00172711 -PROCEDURE HOLLERITH; 00172712 -BEGIN 00172713 - REAL T, COL1, T2, ENDP; 00172714 - LABEL XIT; 00172715 - INTEGER STREAM PROCEDURE STRCNT(S,D,SZ); VALUE S,SZ; 00172716 - BEGIN 00172717 - SI ~ S; DI ~ D;DS ~ 8 LIT "00 "; DI ~ D; 00172718 - DI ~ D; DI ~ DI + 2; DS ~SZ CHR; STRCNT ~ SI; 00172719 - END STRCNT; 00172720 - INTEGER STREAM PROCEDURE RSTORE(S,D,SKP,SZ); 00172721 - VALUE S, SKP, SZ; 00172722 - BEGIN 00172723 - DI ~ D; 00172724 - SI ~ S; DI ~DI + SKP; DS ~ SZ CHR; RSTORE ~ SI; 00172725 - END RSTORE; 00172726 - F1 ~ FNEXT; 00172727 - NUMTYPE ~ STRINGTYPE; 00172728 - T ~ 0 & NCR[30:33:15] & NCR[45:30:3]; 00172729 - COL1 ~ 0 & INITIALNCR[30:33:15]; 00172730 - ENDP ~ COL1 + 72; 00172731 - STRINGSIZE ~ 0; 00172732 - WHILE F1 >0 DO 00172733 - BEGIN 00172734 - T2 ~ IF F1 > 6 THEN 6 ELSE F1; 00172735 - IF STRINGSIZE > MAXSTRING THEN 00172736 - BEGIN FLAG(120); STRINGSIZE ~ 0 END; 00172737 - IF T+T2> ENDP THEN IF DCINPUT OR FREEFTOG THEN 00172738 - BEGIN XTA~BLANKS; FLOG(150); GO TO XIT END 00172739 - ELSE BEGIN 00172740 - IF TSSEDITOG THEN IF NOT DCINPUT THEN TSSED(BLANKS,1) ; 00172741 - NCR ~ STRCNT(NCR, STRINGARRAY[STRINGSIZE], ENDP-T); 00172742 - IF NOT CONTINUE THEN 00172743 - BEGIN FLOG(43); GO TO XIT END; 00172744 - IF READACARD THEN; 00172745 - IF LISTOG THEN PRINTCARD; 00172746 - NCR ~ RSTORE(NCR,STRINGARRAY[STRINGSIZE],ENDP-T+2,T2-(ENDP-T)); 00172747 - STRINGSIZE ~ STRINGSIZE+1; 00172748 - F1 ~ F1 - T2; 00172749 - T ~ COL1 + 6 + T2 - (ENDP - T); 00172750 - END ELSE 00172751 - BEGIN 00172752 - NCR ~ STRCNT(NCR, STRINGARRAY[STRINGSIZE], T2); 00172753 - STRINGSIZE ~ STRINGSIZE +1; 00172754 - T ~ T +T2; 00172755 - F1 ~ F1 - T2; 00172756 - END; 00172757 - END; 00172758 - NUMTYPE ~ STRINGTYPE; 00172759 - SCN ~ 1; 00172760 - XIT: 00172761 -END HOLLERITH; 00172762 -PROCEDURE QUOTESTRING; 00172763 -BEGIN 00172764 - REAL C; 00172765 - LABEL XIT; 00172766 - ALPHA STREAM PROCEDURE STRINGWORD(S,D,SKP,SZ,C); 00172767 - VALUE S,SKP,SZ; 00172768 - BEGIN 00172769 - LABEL QT, XIT; 00172770 - DI ~ D; SI ~ S; 00172771 - DI ~ DI+SKP; DI ~ DI+2; 00172772 - TALLY ~ SKP; 00172773 - SZ( IF SC = """ THEN JUMP OUT TO QT; 00172774 - IF SC = ":" THEN JUMP OUT TO QT; 00172775 - IF SC = "@" THEN JUMP OUT TO QT; 00172776 - IF SC = "]" THEN JUMP OUT TO XIT; 00172777 - DS ~ CHR; TALLY ~ TALLY+1); 00172778 - GO TO XIT; 00172779 - QT: TALLY ~ TALLY+7; SI ~ SI+1; 00172780 - XIT: STRINGWORD ~ SI; S ~ TALLY; 00172781 - SI ~ LOC S; DI ~ C; DS ~ WDS; 00172782 - END STRINGWORD; 00172783 - STRINGSIZE ~ 0; 00172784 - DO 00172785 - BEGIN 00172786 - IF STRINGSIZE > MAXSTRING THEN 00172787 - BEGIN FLAG(120); STRINGSIZE ~ 0 END; 00172788 - STRINGARRAY[STRINGSIZE] ~ BLANKS; 00172789 - NCR ~ STRINGWORD(NCR, STRINGARRAY[STRINGSIZE], 0, 6, C); 00172790 - IF C<6 THEN IF DCINPUT OF FREEFTOG 00172791 - THEN BEGIN XTA~BLANKS; FLOG(150); GO TO XIT END 00172792 - ELSE BEGIN 00172793 - IF TSSEDITOG THEN IF NOT DCINPUT THEN TSSED(BLANKS,1) ; 00172794 - IF NOT CONTINUE THEN 00172795 - BEGIN FLOG(121); GO TO XIT END; 00172796 - IF READACARD THEN; 00172797 - IF LISTOG THEN PRINTCARD; 00172798 - NCR ~ STRINGWORD(NCR, STRINGARRAY[STRINGSIZE ],C,6-C,C); 00172799 - END; 00172800 - STRINGSIZE ~ STRINGSIZE + 1; 00172801 - END UNTIL C } 7; 00172802 - IF C = 7 THEN STRINGSIZE ~ STRINGSIZE-1; 00172803 - FNEXT ~ STRINGSIZE; 00172804 - NEXT ~ NUM; 00172805 - SYMBOL ~ NAME ~ STRINGARRAY[0]; 00172806 - NUMTYPE ~ STRINGTYPE; 00172807 - SCN ~ 1; 00172808 - XIT: 00172809 -END QUOTESTRING; 00172810 - 00172811 -PROCEDURE CHECKPERIOD; 00172812 -BEGIN 00172813 -LABEL FRACTION, XIT, EXPONENT, EXPONENTSIGN; 00172814 -LABEL NUMFINI, FPLP, CHKEXP; 00172815 -ALPHA S, T, I, TS; 00172816 - INTEGER C2; 00172817 -BOOLEAN CON; 00172818 - IF T ~ CHAR ! ". " THEN GO TO CHKEXP; 00172819 -SCANX(4, 9, 3, 8, 10, 11); 00172820 -IF T ~ EXACCUM[1] = " " THEN 00172821 - BEGIN IF NUMTYPE ! DOUBTYPE THEN NUMTYPE ~ REALTYPE; GO TO XIT END; 00172822 -IF T = "E " OR T = "D " THEN GO TO EXPONENTSIGN; 00172823 -IF T.[12:6] { 9 THEN GO TO FRACTION; 00172824 -IF T.[18:6] { 9 THEN 00172825 -BEGIN 00172826 - IF S ~ T.[12:6] ! "E" AND S ! "D" THEN 00172827 - BEGIN XTA ~ T; FLOG(63); GO TO XIT END; 00172828 - EXACCUM[1].[12:6] ~ 0; 00172829 - I ~ 1; GO TO EXPONENT; 00172830 -END; 00172831 -IF EXACCUM[0] ! ". " THEN GO TO XIT; 00172832 -FOR I ~ 0 STEP 1 UNTIL 10 DO 00172833 - IF T = PERIODWORD[I] THEN 00172834 - BEGIN EXACCUM[2] ~ I; SCN ~ 12; GO TO XIT END; 00172835 -GO TO XIT; 00172836 -FRACTION: NEXT ~ NUM; 00172837 -IF NUMTYPE !DOUBTYPE THEN NUMTYPE ~ REALTYPE; XTA ~ ACR1; 00172838 -FPLP: 00172839 -F1 ~ 0; 00172840 -XTA ~ CONVERT(F1,C1,XTA ,TS); 00172841 -C2 ~ C2 + C1; 00172842 -IF (F2 ~ FNEXT|TEN[C1]+F1) { MAX 00172843 - THEN FNEXT ~ F2 00172844 - ELSE BEGIN 00172845 - NUMTYPE ~ DOUBTYPE; 00172846 - CON ~ TRUE; 00172847 - DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|, 00172848 - F1,0,+,~,FNEXT,DBLOW); 00172849 - END; 00172850 -IF TS { 9 THEN GO TO FPLP; 00172851 -F1 ~ 0; 00172852 -IF T ~ EXACCUM[0] ! "E " AND T ! "D " THEN 00172853 -BEGIN IF SCN = 8 THEN SCN ~ 3 ELSE SCN ~ 10; 00172854 - GO TO NUMFINI; 00172855 -END; 00172856 -CHKEXP: FNEXT ~ FNEXT | 1.0; 00172857 -F1 ~ 0; 00172858 -I ~ 1; 00172859 -SCANX(4, 4, 3, 3, 20, 10); 00172860 -IF SCN = 20 THEN 00172861 -EXPONENTSIGN: 00172862 -BEGIN IF S ~ EXACCUM[0] ! "+ " AND S ! "& " THEN 00172863 - IF S = "- " THEN I ~ -1 ELSE 00172864 - BEGIN XTA ~ S; FLOG(63); SCN ~ 10; GO TO XIT END; 00172865 - SCANX(4, 4, 3, 3, 10, 10); 00172866 - END; 00172867 - IF (S ~ EXACCUM[1]).[12:6] > 9 THEN 00172868 - BEGIN XTA ~ IF S ! BLANKS THEN S ELSE T; FLOG(63); GO TO XIT END; 00172869 - EXPONENT: 00172870 - IF NUMTYPE ! DOUBTYPE THEN NUMTYPE ~ REALTYPE; 00172871 -IF T.[12:6] = "D" THEN NUMTYPE ~ DOUBTYPE; 00172872 - IF SCN = 8 THEN SCN ~ 3 ELSE IF SCN = 11 THEN SCN ~ 10; 00172873 - XTA ~ ACR1; 00172874 - XTA ~ CONVERT(F1,C1,XTA ,TS); 00172875 - IF I < 0 THEN F1 ~ -F1; 00172876 - NUMFINI: 00172877 - C1 ~ F1 - C2; 00172878 - IF I ~ (ABS(C1+(FNEXT.[3:6]&FNEXT[1:2:1]))) > 63 OR((ABS(C1) = I OR 00172879 - FNEXT } 5) AND ABS(F1) } 69) 00172880 - THEN BEGIN XTA ~ T; FLOG(87); GO TO XIT; END; 00172881 - IF NUMTYPE ! DOUBTYPE THEN 00172882 - BEGIN 00172883 - IF C1} 0 THEN FNEXT ~ FNEXT | TEN[C1] 00172884 - ELSE FNEXT ~ FNEXT / TEN[-C1]; 00172885 - END ELSE 00172886 - BEGIN 00172887 - IF C1 } 0 00172888 - THEN DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|,~,FNEXT,DBLOW) 00172889 - ELSE DOUBLE(FNEXT,DBLOW,TEN[-C1],TEN[69-C1],/,~,FNEXT,DBLOW); 00172890 - IF CON THEN IF DBLOW.[9:33] = MAX.[9:33] THEN 00172891 - IF FNEXT.[3:6] LSS 14 00172892 - THEN IF BOOLEAN(FNEXT.[2;1]) THEN 00172893 - BEGIN DBLOW ~ 0; FNEXT ~ FNEXT + 1&FNEXT[2:2:7]; END; 00172894 - END; 00172895 - XIT: 00172896 -END CHECKPERIOD; 00172897 - 00172898 -LABEL LOOP0, NUMBER ; 00172899 -LABEL L,XIT; 00172900 -LABEL L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15,L16,L17, 00172901 - L18,L19,L20,L21,BK ; 00172902 -SWITCH CASEL~L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,L13,L14,L15, 00172903 - L16,L17,L18,L19,L20,L21 ; 00172904 -LABEL LOOP, CASESTMT; %994-00172905 -LABEL CASE0,CASE1,CASE2,CASE3,CASE4,CASE5,CASE6,CASE7; %994-00172906 -LABEL CASE8,CASE9,CASE10,CASE11,CASE12,CASE13,CASE14; %994-00172907 -PREC~NEXT~FNEXT~REAL(SCANENTER~FALSE) ; 00172908 -CASESTMT: 00172909 -CASE SCN OF 00172910 -BEGIN 00172911 -CASE0: %994-00172912 -GO TO IF LABELR THEN CASE5 ELSE CASE1; 00172913 -CASE1: 00172914 -BEGIN 00172915 - LOOP0: 00172916 - ACR ~ ACR0; 00172917 - ACCUM[1] ~ BLANKS; 00172918 - LOOP: 00172919 - IF ADVANCE(NCR, ACR, CHR0, NCR, ACR) THEN 00172920 - IF CONTINUE THEN 00172921 - IF READACARD THEN 00172922 - BEGIN 00172923 - IF LISTOG THEN PRINTCARD ; 00172924 - IF ACR.[33:15]}ACCUMSTOP THEN 00172925 - BEGIN XTA~BLANKS; FLOG(175); GO LOOP0 END ; 00172926 - GO LOOP ; 00172927 - END 00172928 - ELSE IF T ~ ACCUM[1] = " " THEN GO TO CASE5 ELSE SCN ~ 4 00172929 - ELSE IF T ~ ACCUM[1] = " " THEN 00172930 - GO TO CASE3 ELSE SCN ~ 3 00172931 - ELSE IF T ~ ACCUM[1] = " " THEN GO TO CASE2 ELSE SCN ~ 2; 00172932 -END; 00172933 -CASE2: 00172934 -BEGIN T ~ CHAR; SCN ~ 1 END; 00172935 -CASE3: 00172936 -BEGIN T ~ "; "; NEXT ~ SEMI; SCN ~ 0; 00172937 - IF EOSTOG THEN IF LOGIFTOG THEN BEGIN LOGIFTOG ~ FALSE; XTA ~ T; 00172938 - FLAG(101); END; 00172939 - GO TO XIT; 00172940 -END; 00172941 -CASE4: %994-00172942 -BEGIN T ~ "; "; NEXT ~ SEMI; SCN ~ 5; GO TO XIT END; 00172943 -CASE5: 00172944 -BEGIN T ~ " "; NEXT ~ EOF; EOSTOG ~ FALSE; GO TO XIT END; 00172945 -CASE6: %994-00172946 -BEGIN T ~ ACCUM[1] ~ NEXTACC; SCN ~ NEXTSCN; 00172947 - IF T = " " THEN GO TO CASESTMT; 00172948 -END; 00172949 -CASE7: %994-00172950 -BEGIN EOSTOG ~ TRUE; 00172951 - IF LABELR THEN GO TO CASE5 ELSE GO TO CASE1; 00172952 -END; 00172953 -CASE8: %994-00172954 -BEGIN T ~ EXACCUM[1]; SCN ~ 3 END; 00172955 -CASE9: %994-00172956 -BEGIN T ~ EXACCUM[1]; SCN ~ 4 END; 00172957 -CASE10: %994-00172958 -BEGIN T ~ CHAR ~ EXACCUM[0]; SCN ~ 1 END; 00172959 -CASE11: %994-00172960 -BEGIN T ~ EXACCUM[1]; SCN ~ 10 END; 00172961 -CASE12: %994-00172962 -BEGIN T ~ EXACCUM[1]; SCN ~ 1; 00172963 - IF N ~ EXACCUM[2] { 1 THEN 00172964 - BEGIN NEXT ~ NUM; FNEXT ~ N; GO TO XIT END; 00172965 - NEXT ~ 0; 00172966 - OP ~ N-1; 00172967 - PREC ~ IF N { 4 THEN N-1 ELSE 4; 00172968 - GO TO XIT; 00172969 -END; 00172970 -CASE13: %994-00172971 -BEGIN T ~ "FUNCTI"; NEXT ~ 16; SCN ~ 6; GO TO XIT END; 00172972 -CASE14: %994-00172973 -BEGIN T ~ ACCUM[1] ~ NEXTACC; 00172974 - NEXTACC ~ NEXTACC2; SCN ~ 6; 00172975 -END; 00172976 -END OF CASE STATEMENT; 00172977 -IF NOT FILETOG THEN 00172978 - IF EOSTOG THEN 00172979 - BEGIN 00172980 - NEXT ~ 0; 00172981 - IF T = "; " THEN GO TO CASESTMT; 00172982 - CHECKRESERVED; 00172983 - IF NEXT > 0 THEN GO TO XIT; 00172984 - END; 00172985 -IF (IDINFO~TIPE[T.[12:6]])>0 THEN 00172986 - BEGIN 00172987 -BK: NEXT~ID ; 00172988 - IF NOT FILETOG THEN 00172989 - IF SCANENTER~((FNEXT~SEARCH(T))=0) THEN FNEXT~ENTER(IDINFO,T) 00172990 - ELSE IF GET(FNEXT).CLASS=DUMMY THEN FNEXT~GET(FNEXT+2).BASE ; 00172991 - GO XIT ; 00172992 - END ; 00172993 -GO CASEL[-IDINFO]; % SEE INITIALIZATION OF "TIP". LINE 03433100%993- 00172994 -L1: %DIGITS %993- 00172995 -BEGIN NUMTYPE ~ INTYPE; NEXT ~ NUM; XTA ~ ACR0; 00172996 - FNEXT ~ DBLOW ~ C1 ~ 0; 00172997 - XTA ~ CONVERT(FNEXT,C1,XTA ,TS); 00172998 - WHILE TS { 9 DO 00172999 - BEGIN 00173000 - XTA ~ CONVERT(F1,C1,XTA ,TS); 00173001 - IF (F2 ~ FNEXT|TEN[C1]+F1) { MAX 00173002 - THEN FNEXT ~ F2 00173003 - ELSE BEGIN 00173004 - NUMTYPE ~ DOUBTYPE; 00173005 - DOUBLE(FNEXT,DBLOW,TEN[C1],TEN[69+C1],|, 00173006 - F1,0,+,~,FNEXT,DBLOW); 00173007 - END; 00173008 - END; 00173009 - IF CHAR = ". " OR CHAR = "E " OR CHAR = "D " THEN 00173010 - CHECKPERIOD 00173011 - ELSE IF CHAR = "H " THEN HOLLERITH; 00173012 - GO TO XIT; 00173013 -END; 00173014 -L2: % > %993- 00173015 -BEGIN PREC ~ 4; OP ~ 7; GO TO XIT END; 00173016 -L3: % } %993- 00173017 -BEGIN PREC ~ 4; OP ~ 8; GO TO XIT END; 00173018 -L4: % & OR + %993- 00173019 -BEGIN PREC ~ 5; OP ~ 10; NEXT ~ PLUS; GO TO XIT END; 00173020 -L5: % . 00173021 -BEGIN 00173022 - FNEXT ~ DBLOW ~ C1 ~ 0; NUMTYPE ~ REALTYPE; 00173023 - CHECKPERIOD; 00173024 - T ~ EXACCUM[1]; 00173025 - IF SCN = 12 THEN 00173026 - BEGIN SCN ~ 1; 00173027 - IF N ~ EXACCUM[2] { 1 THEN 00173028 - BEGIN 00173029 - NEXT ~ NUM; FNEXT ~ N; 00173030 - NUMTYPE ~ LOGTYPE; GO TO XIT; 00173031 - END; 00173032 - NEXT ~ 0; 00173033 - OP ~ N-1; 00173034 - PREC ~ IF N { 4 THEN N-1 ELSE 4; 00173035 - GO TO XIT; 00173036 -END; 00173037 - IF NEXT ! NUM THEN BEGIN NEXT ~ NUM; XTA ~ T; FLOG(141) END; 00173038 - GO TO XIT; 00173039 -END; 00173040 -L6: % % OR ( %993-00173041 -BEGIN NEXT ~ LPAREN; GO TO XIT END; 00173042 -L7: % < %993-00173043 -BEGIN PREC ~ OP ~ 4; GO TO XIT END; 00173044 -L8: % LETTER 0 %993-00173045 -BEGIN IF DATATOG THEN IF CHECKOCTAL THEN GO TO XIT; 00173046 - IDINFO~TIPE[12]; GO BK ; 00173047 -END; 00173048 -L9: % $ %993-00173049 -BEGIN NEXT ~ DOLLAR; GO TO XIT END; 00173050 -L10: % * %993-00173051 -IF CHECKEXP(NCR, NCR, T) THEN 00173052 -BEGIN PREC ~ 9; OP ~ 15; NEXT ~ UPARROW; GO TO XIT END ELSE 00173053 -L11: 00173054 -BEGIN PREC ~ 7; OP ~ 13; NEXT ~ STAR; GO TO XIT END; 00173055 -L12: % - %993-00173056 -BEGIN PREC ~ 5; OP ~ 11; NEXT ~ MINUS; GO TO XIT END; 00173057 -L13: % ) OR [ %993-00173058 -BEGIN NEXT ~ RPAREN; GO TO XIT END; 00173059 -L14: % ; %993-00173060 -BEGIN NEXT ~ SEMI; GO TO XIT END; 00173061 -L15: % { %993-00173062 -BEGIN PREC ~ 4; OP ~ 5; GO TO XIT END; 00173063 -L16: % / %993-00173064 -BEGIN PREC ~ 7; OP ~ 14; NEXT ~ SLASH; GO TO XIT END; 00173065 -L17: % , %993-00173066 -BEGIN NEXT ~ COMMA; GO TO XIT END; 00173067 -L18: % ! %993-00173068 -BEGIN PREC ~ 4; OP ~ 9; GO TO XIT END; 00173069 -L19: % = OR ~ OR # %993- 00173070 -BEGIN NEXT ~ EQUAL; GO TO XIT END; 00173071 -L20: % ] %993-00173072 -BEGIN XTA ~ T; FLAG(0); GO TO CASESTMT END; 00173073 -L21: % " OR : OR @ %993-00173074 -BEGIN QUOTESTRING; GO TO XIT END; 00173075 -XIT: 00173076 -IF DEBUGTOG THEN WRITALIST(FD,3,NEXT,T," ",0,0,0,0,0) ; 00173077 - XTA ~ NAME ~ T; 00173078 -END SCAN; 00173079 - 00173080 -PROCEDURE WRAPUP; 00173081 - COMMENT WRAPUP OF COMPILIATION; 00173082 - BEGIN 00173083 -ARRAY PRT[0:7,0:127], 00173084 - SEGDICT[0:7,0:127], 00173085 - SEG0[0:29]; 00173086 -ARRAY FILES[0:BIGGESTFILENB]; 00173087 -INTEGER THEBIGGEST; 00173088 -SAVE ARRAY FPB[0:1022]; % FILE PARAMETER BLOCK 00173089 -REAL FPS,FPE; % START AND END OF FPB 00173090 -REAL GSEG,PRI,FID,MFID,IDNM,FILTYP,FPBI; 00173091 -BOOLEAN ALF; 00173092 -REAL PRTADR, SEGMNT, LNK, TSEGSZ, T1, I, FPBSZ; 00173093 - DEFINE 00173094 - SPDEUN= FPBSZ#, 00173095 - ENDDEF=#; 00173096 -ARRAY INTLOC[0:150]; 00173097 -REAL J; 00173098 -FORMAT SEGUS(A6, " IS SEGMENT ", I4, 00173099 - ", PRT IS ", A4, "."); 00173100 -LIST SEGLS(IDNM,NXAVIL,T1); 00173101 -LABEL LA, ENDWRAPUP; 00173102 - LABEL QQQDISKDEFAULT; %503-00173103 - COMMENT FORMAT OF SEGMENT DICTIONARY -RUN TIME ; 00173104 -DEFINE SGTYPF= [1:2]#, %0 = PROGRAM SEGMENTS 00173105 - SGTYPC= 1:46:2#,%1 = MCP INTRINSIC 00173106 - %2 = DATA SEGMENT 00173107 - PRTLINKF= [8:10]#, % LINK TO FIRT PRT ENTRY 00173108 - PRTLINKC= 8:38:10#, 00173109 - SGLCF = [18:15]#, % SEGMENT SIZE 00173110 - SGLCC = 23:38:10#, 00173111 - DKADRF = [33:15]#, % RELATIVE DISK ADDRESS OF SEGMENT 00173112 - % OR MCP INTRINSIC NUMBER 00173113 - DKADRC = 33:13:15#; 00173114 - COMMENT FORMAT OF FIRST SEGMENT OF CODE FILE- RUN TIME; 00173115 -COMMENT SEGO[0:29] 00173116 - WORD CONTENTS 00173117 - 0 LOCATION OF SEGMENT DICTIONARY 00173118 - 1 SIZE OF SEGMENT DICTIONARY 00173119 - 2 LOCATION OF PRT 00173120 - 3 SIZE OF PRT 00173121 - 4 LOCATION OF FILE PARAMETER BLOCK 00173122 - 5 SIZE OF FILE PARAMETER BLOCK 00173123 - 6 STARTING SEGMENT NUMBER 00173124 - 7-[2:1] IND FORTRAN FAULT DEC 00173125 - 7-[18:15] NUMBER OF FILES 00173126 - 7-[33:15] CORE REQUIRED/64 00173127 - ; 00173128 - COMMENT FORMAT OF PRT; 00173129 - % FLGF = [0:4] = 1101 = SET BY STREAM 00173130 -DEFINE MODEF =[4:2]#, % 0 = THUNK 00173131 - MODEC=4:46:2#, % 1 = WORD MODE PROGRAM DESCRIPTOR 00173132 - % 2 = LABEL DESCRIPTOR 00173133 - % 3 = CHARACTER MODE PROGRAM DESCRIPTOR 00173134 - STOPF =[6:1]#, % STOPPER = 1 FOR LAST DESCRIPTOR IN 00173135 - STOPC=6:47:1#, % CHAIN OF SAME SEGMENT DESCRIPTORS 00173136 - LINKF =[7:11]#, % IF STOP = 0 THEN PRTLINK 00173137 - LINKC=7:37:11#, % ELSE LINK TO SEGDICT 00173138 - FFF =[18:15]#,% INDEX INTO SEGMENT DICTIONARY 00173139 - FFC =18:33:15#, 01173139 - SINX = [33:15]#;% RELATIVE ADDRESS INTO SEGMENT 00173140 -DEFINE PDR = [37:5]#, 00173141 - PDC = [42:6]#; 00173142 -REAL STREAM PROCEDURE MKABS(F); 00173143 - BEGIN 00173144 - SI ~ F; MKABS ~ SI; 00173145 - END MKABS; 00173146 -REAL STREAM PROCEDURE BUILDFPB(DEST,FILNUM,FILTYP,MFID,FID,IDSZ, 00173147 - IDNM,SPDEUN); 00173148 - VALUE DEST,IDSZ,SPDEUN; 00173149 - BEGIN 00173150 - DI ~ DEST; 00173151 - SI ~ FILNUM; SI ~ SI + 6; DS ~ 2 CHR; 00173152 - SI ~ FILTYP; SI ~ SI + 7; DS ~ CHR; 00173153 - SI ~ MFID; SI ~ SI + 1; DS ~ 7 CHR; 00173154 - SI ~ FID; SI ~ SI + 1; DS ~ 7 CHR; 00173155 - SI ~ LOC IDSZ; SI ~ SI + 1; DS ~ IDSZ CHR; 00173156 - SI~LOC SPDEUN;SI~SI+6;DS~2 CHR;% DISK SPEED & EU NUMBER+1 00173157 - BUILDFPB ~ DI; 00173158 - DS ~ 2 LIT "0"; 00173159 - END BUILDFPB; 00173160 -REAL STREAM PROCEDURE GITSZ(F); 00173161 - BEGIN 00173162 - SI ~ F; SI ~SI + 7; TALLY ~ 7; 00173163 - 3(IF SC ! " " THEN JUMP OUT; 00173164 - SI ~SI - 1; TALLY ~ TALLY + 63;); 00173165 - GITSZ ~ TALLY; 00173166 - END GITSZ; 00173167 -STREAM PROCEDURE MOVE(F,T,SZ); VALUE SZ; 00173168 - BEGIN 00173169 - SI ~ F; DI ~T; DS ~ SZ WDS; 00173170 - END MOVE; 00173171 -INTEGER PROCEDURE MOVEANDBLOCK(FROM,SIZE); VALUE SIZE; 00173172 - ARRAY FROM[0,0]; INTEGER SIZE; 00173173 - BEGIN 00173174 - REAL T,NSEGS,J,I; 00173175 - STREAM PROCEDURE M2(F,T); BEGIN SI~F; DI~T; DS ~ 2 WDS; END M2; 00173176 - NSEGS ~ (SIZE+29) DIV 30; 00173177 - IF DALOC DIV CHUNK < T ~ (DALOC + NSEGS) DIV CHUNK 00173178 - THEN DALOC ~ CHUNK | T; 00173179 - MOVEANDBLOCK ~ DALOC; 00173180 - DO BEGIN FOR J ~ 0 STEP 2 WHILE J < 30 AND I 0 THEN 00173214 - BEGIN T1 ~ GET(T ~ GLOBALSEARCH(".SUBAR")+2); 00173215 - PUT(T,T1~T1&SAVESUBS[TOSIZE]); 00173216 - END; 00173217 - T1~PRGDESCBLDR(1,23,0,NSEG~NXAVIL~NXAVIL+1) ; % BUILD TPAR 00173218 - FILL LSTT[*] WITH 21(0),8(" ") ; % R+23 00173219 - WRITEDATA(29,NXAVIL,LSTT) ; 00173220 - PDPRT[(PDINX-1).[37:5],(PDINX-1).[42:6]].[6:1]~1 ; % SAVE BIT 00173221 - T1 ~ PRGDESCBLDR(1,22,0,NSEG ~ NXAVIL ~ NXAVIL + 1); 00173222 - WRITEDATA (138,NXAVIL,TEN); % POWERS OF TEN TABLE 00173223 - IF LSTI > 0 THEN 00173224 - BEGIN 00173225 - WRITEDATA(LSTI, NXAVIL ~ NXAVIL+1, LSTP); 00173226 - LSTA ~ PRGDESCBLDR(1, LSTA, 0, NXAVIL); 00173227 - END; 00173228 - IF TWODPRTX ! 0 THEN 00173229 - BEGIN 00173230 - FILL LSTT[*] WITH 00173231 - OCT0000000421410010, 00173232 - OCT0301001301412025, 00173233 - OCT2021010442215055, 00173234 - OCT2245400320211025, 00173235 - OCT0106177404310415, 00173236 - OCT1025042112350000; 00173237 - T ~ PRGDESCBLDR(0, TWODPRTX, 0, NXAVIL ~ NXAVIL+1); 00173238 - WRITEDATA(-6, NXAVIL, LSTT); 00173239 - END: 00173240 - COMMENT DECLARE GLOBAL FILES AND ARRAYS; 00173241 - FPS ~ FPE ~ MKABS(FPB); 00173242 - SEGMENTSTART; 00173243 - F2TOG ~ TRUE; 00173244 - GSEG ~ NSEG; 00173245 - FPBI ~ 0; 00173246 - EMITL(0); EMITL(2); EMITO(SSF); 00173247 - EMITL(1); % SET BLOCK COUNTER TO 1 00173248 - EMITL(16); EMITO(STD); 00173249 - EMITL(0); EMITOPDCLIT(23); EMITO(DEL); 00173250 - EMITL(REAL(HOLTOG)); EMITPAIR(21,STD); 00173251 - I ~ GLOBALNEXTINFO; WHILE I < 4093 DO 00173252 - BEGIN 00173253 - I ~ I+3; 00173254 - GETALL(I,INFA,INFB,INFC); 00173255 - IF INFA.CLASS = FILEID THEN %SEE COMMENTS ON LINE 02118000 %992-00173256 - BEGIN 00173257 - FPBI ~ FPBI + 1; 00173258 - PRI ~ INFA .ADDR; 00173259 - IF (XTA ~ INFB ).[18:6] < 10 THEN 00173260 - BEGIN 00173261 - IF XTA ~ MAKEINT(XTA) > BIGGESTFILENB THEN FLAG(77) ELSE 00173262 - FILES[XTA] ~ PRI; 00173263 - IF XTA > THEBIGGEST THEN THEBIGGEST ~ XTA; 00173264 - END; 00173265 - EMITO(MKS); 00173266 - IF J ~ INFC .ADINFO ! 0 THEN % OPTION FILE 00173267 - BEGIN FILTYP ~ INFC .LINK; 00173268 - IDNM ~ " "&"FILE"[6:24:24]&INFB[30:18:18]; 00173269 - T1 ~ GITSZ(IDNM); 00173270 - FID ~ FILEINFO[2,J]; 00173271 - MFID ~ FILEINFO[1,J]; 00173272 - IF FILTYP}10 AND (T~FILEINFO[3,J].DKAREASZ)!0 THEN 00173273 - BEGIN %%% SET UP ; 00173274 - SPDEUN~FILEINFO[3,J].SENSPDEUNF; 00173275 - B~IF (B~((J~FILEINFO[0,J]).[18:12])/(IF A~J.[30:12]{0 THEN00173276 - 1 ELSE A)){0 THEN 1 ELSE B ; 00173277 - %%% B=ORIGINAL "BLOCKING" SIZE = # LOGRECS/PHYSREC. 00173278 - A~ENTIER(B|ENTIER(T/(20|B)+.999999999)+.5) ; 00173279 - %%% T="AREA" SIZE = # LOGRECS IN TOTAL FILE. 00173280 - %%% A=# LOGRECS PER ROW. 00173281 - B~ENTIER(T/A+.999999999) ; 00173282 - %%% B = # ROWS IN FILE. 00173283 - %%% EQUIVALENT ALGOL FILE DESCRIPTION = [B:A]. 00173284 - %%% THE ABOVE LOGIC YIELDS: SHORTEST ROW CONTAINING 00173285 - %%% AN INTEGER NUMBER OF PHYSICAL RECORDS AND WHICH 00173286 - %%% REQUIRES 20 OR FEWER ROWS FOR THE TOTAL AREA, T.00173287 - EMITNUM(B); EMITNUM(A) ; 00173288 - END ELSE 00173289 - BEGIN EMITL(0); EMITL(0); 00173290 - J ~ FILEINFO[0,J]; % THIS ONE HAS ALL THE GOODIES 00173291 - END; 00173292 - QQQDISKDEFAULT: %503-00173293 - ESTIMATE~ESTIMATE+(J.[42:6])|(IF A~J.[18:12]=0 THEN J.[30:12] 00173294 - ELSE A) ; 00173295 - EMITL(J.[4:2]); % LOCK 00173296 - EMITL(FPBI); % FILE PARAM INDEX 00173297 - EMITDESCLIT(PRI); % PRT OF FILE 00173298 - EMITL(J.[42:6]); % # BUFFERS 00173299 - EMITL(J.[3:1]); % RECORDING MODE 00173300 - EMITNUM(J.[30:12]) ; % RECORD SIZE 00173301 - EMITNUM(J.[18:12]) ; % BLOCK SIZE 00173302 - EMITNUM(J.[ 6:12]) ; % SAVE FACTOR 00173303 - END ELSE 00173304 - BEGIN 00173305 - ALF ~TRUE; 00173306 - IF(FILTYP~INFC.LINK=2 OR FILTYP=12) AND INFB.[18:6]{9 THEN 00173307 - IDNM ~ 0&"FILE"[6:24:24]&INFB[30:18:18] 00173308 - ELSE 00173309 - BEGIN 00173310 - ALF ~ FALSE; 00173311 - IF (IDNM ~ " "&INFB[6:18:30]) = "READR " THEN 00173312 - IDNM ~ "READER "; 00173313 - END; 00173314 -IF IDNM="READER " OR IDNM="FILE5 " THEN IDNM~"CARD " ELSE %503-00173315 -IF IDNM="FILE6 " THEN BEGIN IDNM~"PRINTER";FILTYP~18;END ELSE %503-00173316 - BEGIN %503-00173317 - EMITL(20); EMITL(600); FILTYP~12; %20 | 600 REC DISK %503-00173318 - J~0&2[42:42:6]&10[30:36:12]&300[18:36:12]; %503-00173319 - FID~IDNM; MFID~"FORTEMP"; T1~GITSZ(IDNM); %503-00173320 - GO TO QQQDISKDEFAULT; %503-00173321 - END; %503-00173322 - T1 ~ GITSZ(IDNM); 00173323 - FID ~ IDNM; 00173324 - MFID ~ 0; 00173325 - IF DCINPUT AND ALF THEN BEGIN 00173326 - EMITL(20); % DISK ROWS 00173327 - EMITL(100); % DISK RECORD PER ROW 00173328 - EMITL(2); % REWIND AND LOCK 00173329 - EMITL(FPBI); % FILE NUMBER 00173330 - EMITDESCLIT(PRI); % PRT OF FILE 00173331 - EMITL(2); % NUMBER OF BUFFERS 00173332 - EMITL(1); % RECORDING MODE 00173333 - EMITL(10); % RECORD SIZE 00173334 - EMITL(30); % BLOCK SIZE 00173335 - EMITL(1); % SAVE FACTOR 00173336 - END ELSE 00173337 - BEGIN 00173338 - EMITL(0); % DISK ROWS 00173339 - EMITL(0); % DISK RECORDS PER ROW 00173340 - EMITL(0); % REWIND & RELEASE 00173341 - EMITL(FPBI); % FILE NUMBER 00173342 - EMITDESCLIT(PRI); % PRT OF FILE 00173343 - EMITL(2); % 2 BUFFERS 00173344 - EMITL(REAL(ALF)); 00173345 - EMITL(IF FILTYP = 0 THEN 10 ELSE 17); 00173346 - EMITL(0); % 15 WORD BUFFERS 00173347 - EMITL(0); % SAVE FACTOR (SCRATCH BY DEFAULT) 00173348 - END; 00173349 - END; 00173350 - EMITL(11); % INPUT OR OUTPUT 00173351 - EMITL(8); % SWITCH CODE FOR BLOCK 00173352 - EMITOPDCLIT(5); % CALL BLOCK 00173353 - FPE~BUILDFPB(FPE,FPBI,FILTYP,MFID,FID,T1,IDNM,SPDEUN); 00173354 - IF PRTOG THEN WRITALIST(FILEF,3,IDNM.[6:6],IDNM,B2D(PRI), 00173355 - 0,0,0,0,0) ; 00173356 - END 00173357 - ELSE 00173358 - IF INFA.CLASS = BLOCKID THEN 00173359 - BEGIN 00173360 - IF PRTOG THEN WRITALIST(BLOKF,3,INFB,B2D(INFA.ADDR), 00173361 - INFC.SIZE,0,0,0,0,0) ; 00173362 - IF INFA < 0 THEN ARRAYDEC(I); 00173363 - END; 00173364 - IF (T1 ~ INFA .CLASS) } FUNID 00173365 - AND T1 { SUBRID THEN 00173366 - BEGIN 00173367 - PRI ~ 0; 00173368 - IF INFA .SEGNO = 0 THEN 00173369 - BEGIN 00173370 - A~0; B~NUMINTM1 ; 00173371 - WHILE A+1 < B DO 00173372 - BEGIN 00173373 - PRI ~ REAL(BOOLEAN(A+B) AND BOOLEAN(1022)); 00173374 - IF IDNM ~ INT[PRI] = INFB THEN GO TO FOUND; 00173375 - IF INFB < IDNM THEN B ~ PRI.[36:11] ELSE A ~ PRI.[36:11]; 00173376 - END; 00173377 - IF IDNM ~ INT[PRI~(A+B)|2-PRI] = INFB THEN GO TO FOUND; 00173378 - XTA ~ INFB; FLAG(30); 00173379 - GO TO LA; 00173380 - FOUND: 00173381 - IF (T1~INT[PRI+1].INTPARMS)!0 00173382 - AND INFC < 0 00173383 - THEN IF T1 ! INFC.NEXTRA THEN 00173384 - BEGIN XTA ~ INFB ; FLAG(28); END; 00173385 - IF (FID~INTLOC[MFID~INT[PRI+1].INTNUM])=0 THEN 00173386 - BEGIN 00173387 - PDPRT[PDIR,PDIC] ~ 00173388 - 0&1[STYPC] 00173389 - &(FID ~ INTLOC[MFID] ~ NXAVIL ~ NXAVIL + 1)[SGNOC] 00173390 - &1[SEGSZC]; 00173391 - PDINX ~ PDINX + 1; 00173392 - END; 00173393 - T1 ~ PRGDESCBLDR(1,INFA .ADDR,0,FID); 00173394 - IF PRTOG THEN WRITALIST(SEGUS,3,IDNM,FID,B2D(T1),0,0,0,0,0) ; 00173395 - IF INT[PRI+1] < 0 THEN 00173396 - BEGIN 00173397 - T1 ~ PRGDESCBLDR(1,INT[PRI+1].INTPRT,0,FID); 00173398 - INT[PRI+1] ~ ABS(INT[PRI + 1]); 00173399 - END; 00173400 - END 00173401 - ELSE IF PRTOG THEN WRITALIST(SEGUS,3,INFB, 00173402 - INFA.SEGNO,B2D(INFA.ADDR),0,0,0,0,0) ; 00173403 - END; 00173404 - LA: 00173405 - END; 00173406 -COMMENT MUST FOLLOW THE FOR STATEMENT; 00173407 -IF FILEARRAYPRT ! 0 THEN 00173408 -BEGIN % BUILDING OBJECT TIME FILE SEARCH ARRAY 00173409 - J ~ PRGDESCBLDR(1,FILEARRAYPRT,0,NXAVIL ~ NXAVIL + 1); 00173410 - WRITEDATA(THEBIGGEST + 1,NXAVIL,FILES); 00173411 -END; 00173412 - XTA ~ BLANKS; 00173413 - IF NXAVIL > 1023 THEN FLAG(45); 00173414 - IF PRTS > 1023 THEN FLAG(46); 00173415 - IF STRTSEG = 0 THEN FLAG(65); 00173416 - PRI ~ 0; 00173417 - WHILE (IDNM ~ INT[PRI]) ! 0 DO 00173418 - IF INT[PRI+1] } 0 THEN PRI ~ PRI + 2 ELSE 00173419 - BEGIN 00173420 - IF (FID~INTLOC[MFID~INT[PRI+1].INTNUM])=0 THEN 00173421 - BEGIN 00173422 - PDPRT[PDIR,PDIC] ~ 00173423 - 0&1[STYPC] 00173424 - &MFID[DKAC] 00173425 - &(FID ~ INTLOC[MFID] ~ NXAVIL ~ NXAVIL + 1)[SGNOC] 00173426 - &1[SEGSZC]; 00173427 - PDINX ~ PDINX + 1; 00173428 - END; 00173429 - T1 ~ PRGDESCBLDR(1,INT[PRI + 1].INTPRT,0,FID); 00173430 - PRI ~ PRI+2; 00173431 - END; 00173432 - FOR I ~ 1 STEP 1 UNTIL BDX DO 00173433 - BEGIN EMITO(MKS); EMITOPDCLIT(BDPRT[I]) END; 00173434 - EMITO(MKS); 00173435 - EMITOPDCLIT(STRTSEG.[18:15]); 00173436 - T ~ PRGDESCBLDR(1,0,0,NSEG); 00173437 - SEGMENT((ADR+4) DIV 4,NSEG,FALSE,EDOC); 00173438 - IF ERRORCT ! 0 THEN GO TO ENDWRAPUP; 00173439 - FILL SEG0[*] WITH 00173440 - OCT020005, % BLOCK 00173441 - OCT220014, % WRITE 00173442 - OCT230015, % READ 00173443 - OCT240016; % FILE CONTROL 00173444 - COMMENT INTRINSIC FUNCTIONS; 00173445 - FOR I ~ 0 STEP 1 UNTIL 3 DO 00173446 - BEGIN 00173447 - T1 ~ PRGDESCBLDR(1,SEG0[I].[36:12],0, 00173448 - NSEG ~ NXAVIL ~ NXAVIL + 1); 00173449 - PDPRT[PDIR,PDIC] ~ 00173450 - 0&1[STYPC] 00173451 - &(SEG0[I].[30:6])[DKAC] 00173452 - &NXAVIL[SGNOC] 00173453 - &1[SEGSZC]; 00173454 - PDINX ~ PDINX + 1; 00173455 - END; 00173456 - COMMENT GENERATE PRT AND SEGMENT DICTIONARY; 00173457 - PRT[0,41] ~ PDPRT[0,0] & 63[10:42:6]; % USED FOR FAULT OPTN 00173458 - FOR I ~ 1 STEP 1 UNTIL PDINX-1 DO 00173459 - IF (T1~PDPRT[I.PDR,I.PDC]).SEGSZF = 0 THEN 00173460 - BEGIN % PRT ENTRY 00173461 - PRTADR ~T1.PRTAF; 00173462 - SEGMNT ~T1.SGNOF; 00173463 - LNK ~ SEGDICT[SEGMNT.[36:5], SEGMNT.[41:7]].PRTAF; 00173464 - MDESC(T1.RELADF&SEGMNT[FFC] 00173465 - &(REAL(LNK=0))[STOPC] 00173466 - &(IF LNK=0 THEN SEGMNT ELSE LNK)[LINKC] 00173467 - &(T1.DTYPF)[MODEC] 00173468 - &5[1:45:3], 00173469 - PRT[PRTADR.[36:5],PRTADR.[41:7]]); 00173470 - SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]].PRTLINKF ~ PRTADR; 00173471 - END 00173472 - ELSE 00173473 - BEGIN % SEGMENT DICTIONARY ENTRY 00173474 - SEGMNT ~ T1.SGNOF; 00173475 - SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]]~ 00173476 - SEGDICT[SEGMNT.[36:5],SEGMNT.[41:7]] 00173477 - &T1[SGLCC] 00173478 - &T1[DKADRC] 00173479 - & T1[4:12:1] 00173480 - &T1[6:6:1] 00173481 - &T1[1:1:2]; 00173482 - TSEGSZ ~ TSEGSZ + T1.SEGSZF; 00173483 - END; 00173484 - COMMENT WRITE OUT FILE PARAMETER BLOCK; 00173485 - FPBSZ ~ ((FPE.[33:15] - FPS) | 8 + FPE.[30:3] + 9) DIV 8; 00173486 - I ~ (FPBSZ + 29) DIV 30; 00173487 - IF DALOC DIV CHUNK < T1 ~ (DALOC +I) DIV CHUNK 00173488 - THEN DALOC ~ CHUNK | T1; 00173489 - SEG0[4] ~ DALOC; 00173490 - SEG0[5] ~ FPBSZ; 00173491 - SEG0[5].FPBVERSF~FPBVERSION; 00173492 - FOR I ~ 0 STEP 30 WHILEI < FPBSZ DO 00173493 - BEGIN 00173494 - MOVE(FPB[I],CODE(0),IF (FPBSZ-I) } 30 00173495 - THEN 30 ELSE (FPBSZ-I)); 00173496 - WRITE(CODE[DALOC]); 00173497 - DALOC ~ DALOC + 1; 00173498 - END; 00173499 - SEG0[2] ~ MOVEANDBLOCK(PRT,PRTS+1); % WRITES OUT PRT 00173500 - % SAVES ADDRESS OF PRT 00173501 - SEG0[3] ~ PRTS + 1; % SIZE OF PRT 00173502 - SEG0[0] ~ MOVEANDBLOCK(SEGDICT,NXAVIL + 1); % WRITE SEG DICT 00173503 - SEG0[1] ~ NXAVIL + 1; % SIZE OF SEGMENT DICTIONARY 00173504 - SEG0[6] ~ -GSEG; % FIRST SEGMENT TO EXECUTE 00173505 - SEG0[7].[33:15] ~ FPBI; % NUMBER OF FILES 00173506 - SEG0[7].[18:15] ~ ESTIMATE ~ IF % CORE ESTIMATE 00173507 - ( I ~ 00173508 - ESTIMATE+60+ %%% OPTION FILE BUFF SIZES + DEFAULT BUFF SIZES.00173509 - PRTS + 512 % PRT AND STACK SIZE 00173510 - +TSEGSZ % TOTAL SIZE OF CODE 00173511 - + 1022 % FOR INTRINSICS 00173512 - +ARYSZ % TOTAL ARRAY SIZE 00173513 - + (MAXFILES | 28) % SIZE OF ALL FIBS 00173514 - +FPBSZ % SIZE OF FILE PARAMETER BLOCK 00173515 - + (IF ESTIMATE = 0 THEN 0 ELSE (ESTIMATE + 1000)) 00173516 - + (NXAVIL + 1) % SIZE OF SEGMENT DICTIONARY 00173517 - ) > 32768 THEN 510 ELSE (I DIV 64); 00173518 - COMMENT IF SEGSW THEN UPDATE LINDICT, SEG0[0] & WRITE IT ; 00173519 - SEG0[7].[2:1] ~ 1; % USED FOR FORTRAN FAULT DEC; 00173520 - IF SEGSW THEN 00173521 - BEGIN 00173522 - FOR I ~ NXAVIL + 1 STEP -1 UNTIL 1 DO 00173523 - IF LINEDICT[I.IR,I.IC] = 0 THEN % INDICATE NO LINE SEGMENT 00173524 - LINEDICT[I.IR,I.IC] ~ -1; % FOR THIS SEGMENT 00173525 - SEG0[0] ~ SEG0[0] & (MOVEANDBLOCK(LINEDICT,NXAVIL+1))[TOBASE]; 00173526 - END; 00173527 - WRITE(CODE[0],30,SEG0[*]); 00173528 - IF ERRORCT = 0 AND SAVETIME } 0 THEN LOCK(CODE); 00173529 - ENDWRAPUP: 00173530 - LOCK(TAPE); %RW/L TAPE FILE OR LOCK DISK %502-00173531 - IF NTAPTOG THEN LOCK(NEWTAPE,*); %RW/L TAPE OR CRUNCH DISK%502-00173532 - END WRAPUP; 00173533 -PROCEDURE INITIALIZATION; 00173534 -BEGIN COMMENT INITIALIZATION; 00173535 -ALPHA STREAM PROCEDURE MKABS(P); 00173536 -BEGIN SI ~ P; MKABS ~ SI END; 00173537 -STREAM PROCEDURE BLANKOUT(CRD, N); VALUE N; 00173538 -BEGIN DI ~ CRD; N(DS ~ LIT " ") END; 00173539 -BLANKOUT(CRD[10], 40); 00173540 -BLANKOUT(LASTSEQ, 8); 00173541 -BLANKOUT(LASTERR, 8); 00173542 -INITIALNCR ~ MKABS(CRD[0])&6[30:45:3]; 00173543 -CHR0 ~ MKABS(ACCUM[0])& 2[30:45:3]; 00173544 -ACR0 ~ CHR0+1; 00173545 -ACR1 ~ (CHR1~MKABS(EXACCUM[0]) & 2[30:45:4]) +1; 00173546 -ACCUMSTOP~MKABS(ACCUM[11]); EXACCUMSTOP~MKABS(EXACCUM[11]) ; 00173547 -BUFL ~ MKABS(BUFF) & 2[30:45:3]; 00173548 -NEXTCARD ~ 1; 00173549 -GLOBALNEXTINFO ~ 4093; 00173550 -PDINX ~ 1; 00173551 -LASTNEXT~1000 ; 00173552 -PRTS ~ 41; % CURRENTLY . . . . . LAST USED PRT 00173553 -READ(CR, 10, CB[*]); 00173554 -LISTOG~TRUE; SINGLETOG~TRUE; CHECKTOG ~ FALSE; %DEFAULT %501- 00173555 -FIRSTCALL ~ TRUE; 00173556 -IF BOOLEAN(ERRORCT.[46:1]) THEN LISTOG ~ FALSE; 00173557 -IF BOOLEAN(ERRORCT.[47:1]) THEN DCINPUT ~ TRUE; 00173558 -ERRORCT ~ 0; 00173559 -IF DCINPUT THEN SEGSW ~ TRUE; 00173560 -IF DCINPUT THEN REMOTETOG ~ TRUE; 00173561 -LIMIT~IF DCINPUT THEN 20 ELSE 100 ; 00173562 -IF SEGSW THEN SEGSWFIXED ~ TRUE; 00173563 -EXTRAINFO[0,0] ~ 0 & EXPCLASS[TOCLASS]; 00173564 -NEXTEXTRA ~ 1; 00173565 -LASTMODE ~ 1; 00173566 -DALOC ~ 1; 00173567 -TYPE ~ -1; 00173568 - MAP[0] ~ MAP[2] ~ MAP[4] ~ MAP[7] ~ -10; 00173569 - MAP[5] ~ 1; MAP[6] ~ 2; 00173570 -FILL XR[*] WITH 0,0,0,0,0,0,0, 00173571 - "INTEGE","R R"," "," "," REAL "," ", 00173572 - "LOGICA","L L","DOUBLE"," ","COMPLE","X X", 00173573 - "------","- -"," "," "," ---- "," ", 00173574 - "------","- -","------"," ","------","- -"; 00173575 -FILL TYPES[*] WITH " ","INTGER"," ","REAL ", 00173576 - "LOGCAL", "DOUBLE", "COMPLX"; 00173577 -FILL KLASS[*] WITH 00173578 - "NULL ", "ARRAY ", "VARBLE", "STFUN ", 00173579 - "NAMLST", "FORMAT", "ERROR ", "FUNCTN", 00173580 - "INTRSC", "EXTRNL", "SUBRTN", "COMBLK", 00173581 - "FILE "; 00173582 -FILL RESERVEDWORDSLP[*] WITH 00173583 - "CALL ","ENTR ","FORM ","GOTO ","IF ","READ ", 00173584 - "REAL ","WRIT ","DATA ","CLOS ","LOCK ","PURG ","CHAI ", 00173585 - "PRIN ","PUNC ", 00173586 - 0,"Y ","AT ",0,0,0,0,"E ",0,"E ",0,"E ",00173587 - "N ","T ","H "; 00173588 -FILL RESERVEDWORDS[*] WITH 00173589 - "ASSI ","BACK ","BLOC ","CALL ","COMM ","COMP ","CONT ", 00173590 - "DATA ","DIME ","DOUB ","END ","ENDF ","ENTR ","EQUI ", 00173591 - "EXTE ","FUNC ","GOTO ","INTE ","LOGI ","NAME ","PAUS ", 00173592 - "PRIN ","PROG ","PUNC ","READ ","REAL ","RETU ","REWI ", 00173593 - "STOP ","SUBR ","WRIT ", 00173594 - "CLOS ","LOCK ","PURG ", 00173595 - 0,0,0, 00173596 - "FIXF ","VARY ","AUXM ","RELE ", 00173597 - "IMPL ", 00173598 - "GN ","SPACE ","KDATA ",0,"ON ","LEX ","INUE ", 00173599 - "0,"NSION ","LEPRECIS",0,"ILE ","Y ","VALENCE ","RNAL "00173600 - ,"TION ",0,"GER ","CAL ","LIST ","E ","T ",00173601 - "RAM ","H ",0,0,"RN ","ND ",0,"OUTINE ", 00173602 - "E ","E ",0,"E ",0,0,0,"D ","ING ", 00173603 - "EM ","ASE " 00173604 - ,"ICIT " 00173605 - ; 00173606 -FILL RESLENGTHLP[*] WITH 00173607 - 4,5,6,4,2,4,4,5,4,5,4,5,5,5,5; 00173608 -FILL LPGLOBAL[*] WITH 00173609 - 4, 13, 36, 17, 35, 25, 00173610 - 26, 31, 8, 32, 33, 34, 37, 22, 24; 00173611 -FILL RESLENGTH[*] WITH 00173612 - 0, 9, 9, 4, 6, 00173613 - 7, 8, 4, 9, 15, 00173614 - 3, 7, 5, 11, 8, 00173615 - 8, 4, 7, 7, 8, 00173616 - 5, 5, 7, 5, 4, 00173617 - 4, 6, 6, 4, 10, 5, 00173618 - 5, 4, 5, 0, 0, 0, 5, 7, 6, 7 00173619 - ,8 00173620 - ; 00173621 - FILL WOP[*] WITH 00173622 - "LITC"," ", 00173623 - "OPDC","DESC", 00173624 - 10,"DEL ", 11,"NOP ", 12,"XRT ", 16,"ADD ", 17,"AD2 ", 18,"PRL ", 00173625 - 19,"LNG ", 21,"GEQ ", 22,"BBC ", 24,"INX ", 35,"LOR ", 37,"GTR ", 00173626 - 38,"BFC ", 39,"RTN ", 40,"COC ", 48,"SUB ", 49,"SB2 ", 64,"MUL ", 00173627 - 65,"ML2 ", 67,"LND ", 68,"STD ", 69,"NEQ ", 70,"SSN ", 71,"XIT ", 00173628 - 72,"MKS ", 00173629 - 128,"DIV ",129,"DV2 ",130,"COM ",131,"LQV ",132,"SND ",133,"XCH ", 00173630 - 134,"CHS ",167,"RTS ",168,"CDC ",197,"FTC ",260,"LOD ",261,"DUP ", 00173631 - 278,"GBC ",280,"SSF ",294,"GFC ",322,"ZP1 ",384,"IDV ",453,"FTF ", 00173632 - 515,"MDS ",532,"ISD ",533,"LEQ ",534,"BBW ",548,"ISN ",549,"LSS ", 00173633 - 550,"BFW ",581,"EQL ",582,"SSP ",584,"ECM ",709,"CTC ",790,"GBW ", 00173634 - 806,"GFW ",896,"RDV ",965,"CTF ", 00173635 - 1023,1023,1023,1023,1023,1023,1023,1023,1023,1023,1023, 1023; 00173636 -FILL TIPE[*] WITH 10(-1),-19,-21,OCT300000000,-21,-2,-3,-4, 00173637 - 8(OCT300000000),OCT100000000,-5,-13,-4,-6,-7,-19,-11, 00173638 - 5(OCT100000000),-8,3(OCT300000000),-9,-10,-12,-13,-14,00173639 - -15,-100,-16,8(OCT300000000),-17,-6,-18,-19,-20,-21 ; 00173640 -FILL PERIODWORD[*] WITH 00173641 - "FALSE ", "TRUE ", "OR ", "AND ", "NOT ", 00173642 - "LT ", "LE ", "EQ ", "GT ", "GE ", "NE "; 00173643 -ACCUM[0] ~ EXACCUM[0] ~ "; "; 00173644 -INCLUDE ~ "NCLUDE" & "I"[6:42:6]; 00173645 -INSERTDEPTH ~ -1; 00173646 -FILL TEN[*] WITH % POWERS OF TEN TO PRT 22 00173647 - OCT1141000000000000, OCT1131200000000000, OCT1121440000000000,00173648 - OCT1111750000000000, OCT1102342000000000, OCT1073032400000000,00173649 - OCT1063641100000000, OCT1054611320000000, OCT1045753604000000,00173650 - OCT1037346545000000, OCT1011124027620000, OCT0001351035564000,00173651 - OCT0011643245121000, OCT0022214116345200, OCT0032657142036440,00173652 - OCT0043432772446150, OCT0054341571157602, OCT0065432127413542,00173653 - OCT0076740555316473, OCT0111053071060221, OCT0121265707274265,00173654 - OCT0131543271153342, OCT0142074147406233, OCT0152513201307702,00173655 - OCT0163236041571663, OCT0174105452130240, OCT0205126764556310,00173656 - OCT0216354561711772, OCT0231004771627437, OCT0241206170175346,00173657 - OCT0251447626234640, OCT0261761573704010, OCT0272356132665012,00173658 - OCT0303051561442215, OCT0313664115752660, OCT0324641141345435,00173659 - OCT0336011371636744, OCT0347413670206535, OCT0361131664625026,00173660 - OCT0371360241772234, OCT0401654312370703, OCT0412227375067064,00173661 - OCT0422675274304701, OCT0433454553366061, OCT0444367706263475,00173662 - OCT0455465667740415, OCT0467003245730520, OCT0501060411731664,00173663 - OCT0511274514320241, OCT0521553637404312, OCT0532106607305374,00173664 - OCT0542530351166673, OCT0553256443424452, OCT0564132154331565,00173665 - OCT0575160607420123, OCT0606414751324147, OCT0621012014361120,00173666 - OCT0631214417455344, OCT0641457523370635, OCT0651773450267004,00173667 - OCT0662372362344605, OCT0673071057035747, OCT0703707272645341,00173668 - OCT0714671151416631, OCT0726047403722377, OCT0737461304707077,00173669 - OCT0751137556607071, OCT0761367512350710, OCT0771665435043072,00173670 - OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,00173671 - OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,00173672 - OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,00173673 - OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,00173674 - OCT0000000000000000, OCT0000000000000000, OCT0000000000000000,00173675 - OCT0000000000000000, OCT0000000000000000, OCT0004000000000000,00173676 - OCT0001000000000000, OCT0001720000000000, OCT0004304000000000,00173677 - OCT0007365000000000, OCT0005262200000000, OCT0004536640000000,00173678 - OCT0001666410000000, OCT0000244112000000, OCT0000315134400000,00173679 - OCT0000400363500000, OCT0000450046042000, OCT0006562057452400,00173680 - OCT0004316473365100, OCT0005402212262320, OCT0006702654737004,00173681 - OCT0004463430126605, OCT0007600336154346, OCT0001540425607437,00173682 - OCT0004070533151347, OCT0005106662003641, OCT0005033043640461,00173683 - OCT0002241654610575, OCT0002712227752734, OCT0001474675745524,00173684 - OCT0002014055337051, OCT0004417070626663, OCT0007522706774440,01173684 - OCT0003447470573550, OCT0006361406732502, OCT0005005571052122,00173685 - OCT0006207127264547, OCT0001650755141700, OCT0006223150372260,00173686 - OCT0007670002470733, OCT0007646003207120, OCT0005617404050743,00173687 - OCT0001163305063137, OCT0007420166277771, OCT0001732422375777,00173688 - OCT0002321127075377, OCT0003005354714677, OCT0005606650100057,00173689 - OCT0007150422120072, OCT0003002526544103, OCT0001603254275130,00173690 - OCT0004144127354356, OCT0007175155247451, OCT0007034410521363,00173691 - OCT0007664351264566, OCT0003641443541723, OCT0004611754472310;00173692 -FILL INLINEINT[*] WITH % FILLS MUST BE IN ASCENDING ORDER FOR 00173693 - % BINARY SEARCH IN FUNCTION AND DOITINLINE. 00173694 - % INLINEINT[I].[1:1] = 1 ONCE CODE FOR INTRINSIC 00173695 - % HAS BEEN EMITTED INLINE.00173696 - % INLINEINT[I].[2:10]=INDEX INTO 2-ND WORD OF THE00173697 - % CORR ENTRY IN INT. 00173698 - % INLINEINT[I].[12:36]=NAME OF INTRINSIC. 00173699 -%********FIRST FILL MUST BE NUMBER OF INTRINSICS ****************** 00173700 -34, 00173701 -"00ABS ", 00173702 -"00AIMAG ", 00173703 -"00AINT ", 00173704 -"00AMAX0 ", 00173705 -"00AMAX1 ", 00173706 -"00AMIN0 ", 00173707 -"00AMIN1 ", 00173708 -"00AMOD ", 00173709 -"00AND ", 00173710 -"00CMPLX ", 00173711 -"00COMPL ", 00173712 -"00CONJG ", 00173713 -"00DABS ", 00173714 -"00DBLE ", 00173715 -"00DIM ", 00173716 -"00DSIGN ", 00173717 -"00EQUIV ", 00173718 -"00FLOAT ", 00173719 -"00IABS ", 00173720 -"00IDIM ", 00173721 -"00IDINT ", 00173722 -"00IFIX ", 00173723 -"00INT ", 00173724 -"00ISIGN ", 00173725 -"00MAX0 ", 00173726 -"00MAX1 ", 00173727 -"00MIN0 ", 00173728 -"00MIN1 ", 00173729 -"00MOD ", 00173730 -"00OR ", 00173731 -"00REAL ", 00173732 -"00SIGN ", 00173733 -"00SNGL ", 00173734 -"00TIME ", 00173735 - 0 ; 00173736 - FILL INT [*] WITH 00173737 -COMMENT THESE NAMES (1-ST WORD OF EACH TWO-WORD ENTRY) MUST BE IN 00173738 - ASCENDING ORDER FOR BINARY LOOKUPS. 00173739 - THE SECOND WORD HAS THE FOLLOWING FORMAT: 00173740 - .[1:1] = 0 IF THE INTRINSIC DOES NOT HAVE A PERMANENT PRT 00173741 - LOCATION, OTHERWISE = 1. MAY BE RESET BY 00173742 - WRAPUP. SEE .[18:6] BELOW. 00173743 - .[2:1] = .INTSEEN = 1 IFF INTRINSICS FUNCTION HAS BEEN SEEN. 00173744 - .[6:3] = .INTCLASS = CLASS OF THE INTRINSIC. 00173745 - .[9:3] = .INTPARMCLASS = CLASS OF PARAMETERS. 00173746 - .[12:6] = .INTINLINE = INDEX FOR DOITINLINE IF !0, OTHERWISE 00173747 - DO IT VIA INTRINSIC CALL. 00173748 - .[24:6] = .INTPRT = FIXED PRT LOCATION. SEE .[1:1] ABOVE. 00173749 - .[30:6] = .INTPARMS = NUMBER OF PARAMETERS REQUIRED BY THE INT.00173750 - .[36:12] = .INTNUM = INTRINSICS NUMBER. 00173751 - THE FIELDS .[3:3] AND .[18:6] ARE SO FAR UNUSED. 00173752 -; 00173753 -% 00173754 -%***********************************************************************00173755 -%********* IF YOU ADD AN INTRINSIC, BE SURE TO CHANGE NUMINTM1 *******00173756 -%********* AT SEQUENCE NUMBER 00155211.......THANK YOU. *******00173757 -%***********************************************************************00173758 -% 00173759 -"ABS ", OCT0033010000010007, 00173760 -"AIMAG ", OCT0036020000010074, 00173761 -"AINT ", OCT0033030000010054, 00173762 -"ALGAMA", OCT0033000000010127, 00173763 -"ALOG10", OCT0033000000010103, 00173764 -"ALOG ", OCT2033000035010017, 00173765 -"AMAX0 ", OCT0031250000000031, 00173766 -"AMAX1 ", OCT0033250000000031, 00173767 -"AMIN0 ", OCT0031250000000032, 00173768 -"AMIN1 ", OCT0033250000000032, 00173769 -"AMOD ", OCT0033040000020063, 00173770 -"AND ", OCT0033050000020130, 00173771 -"ARCOS ", OCT0033000000010117, 00173772 -"ARSIN ", OCT2033000032010116, 00173773 -"ATAN2 ", OCT2033000044020114, 00173774 -"ATAN ", OCT2033000037010016, 00173775 -"CABS ", OCT2036000045010053, 00173776 -"CCOS ", OCT0066000000010110, 00173777 -"CEXP ", OCT0066000000010100, 00173778 -"CLOG ", OCT0066000000010102, 00173779 -"CMPLX ", OCT0063060000020075, 00173780 -"COMPL ", OCT0033070000010132, 00173781 -"CONCAT", OCT0033000000050140, 00173782 -"CONJG ", OCT0066110000010076, 00173783 -"COSH ", OCT0033000000010121, 00173784 -"COS ", OCT0033000000010015, 00173785 -"COTAN ", OCT0033000000010112, 00173786 -"CSIN ", OCT0066000000010106, 00173787 -"CSQRT ", OCT0066000000010124, 00173788 -"DABS ", OCT0055010000010052, 00173789 -"DATAN2", OCT0055000000020115, 00173790 -"DATAN ", OCT2055000041010113, 00173791 -"DBLE ", OCT0053120000010062, 00173792 -"DCOS ", OCT0055000000010107, 00173793 -"DEXP ", OCT2055000047010077, 00173794 -"DIM ", OCT0033100000020072, 00173795 -"DLOG10", OCT0055000000010104, 00173796 -"DLOG ", OCT2055000042010101, 00173797 -"DMAX1 ", OCT0055000000000066, 00173798 -"DMIN1 ", OCT0055000000000067, 00173799 -"DMOD ", OCT2055000046020065, 00173800 -"DSIGN ", OCT0055130000020071, 00173801 -"DSIN ", OCT2055000043010105, 00173802 -"DSQRT ", OCT2055000050010123, 00173803 -"EQUIV ", OCT0033140000020133, 00173804 -"ERF ", OCT0033000000010125, 00173805 -"EXP ", OCT2033000033010020, 00173806 -"FLOAT ", OCT0031150000010060, 00173807 -"GAMMA ", OCT2033000040010126, 00173808 -"IABS ", OCT0011010000010007, 00173809 -"IDIM ", OCT0011100000020072, 00173810 -"IDINT ", OCT0015240000010057, 00173811 -"IFIX ", OCT0013030000010054, 00173812 -"INT ", OCT0013030000010054, 00173813 -"ISIGN ", OCT0011160000020070, 00173814 -".ERR. ", OCT2000000030000134, 00173815 -".FBINB", OCT0000000000000160, 00173816 -".FINAM", OCT0000000000000154, 00173817 -".FONAM", OCT0000000000000155, 00173818 -".FREFR", OCT0000000000000146, 00173819 -".FREWR", OCT0000000000000153, 00173820 -".FTINT", OCT0000000000000050, 00173821 -".FTNIN", OCT0000000000000156, 00173822 -".FTNOU", OCT0000000000000157, 00173823 -".FTOUT", OCT0000000000000051, 00173824 -".LABEL", OCT0000000000000021, 00173825 -".MATH ", OCT0000000000000055, 00173826 -".MEMHR", OCT0000000000000164, 00173827 -".XTOI ", OCT0000000000000056, 00173828 -"MAX0 ", OCT0011250000000135, 00173829 -"MAX1 ", OCT0013250000000135, 00173830 -"MIN0 ", OCT0011250000000136, 00173831 -"MIN1 ", OCT0013250000000136, 00173832 -"MOD ", OCT0011170000020137, 00173833 -"OR ", OCT0033200000020131, 00173834 -"REAL ", OCT0036210000010073, 00173835 -"SIGN ", OCT0033160000020070, 00173836 -"SINH ", OCT0033000000010120, 00173837 -"SIN ", OCT2033000034010014, 00173838 -"SNGL ", OCT0035230000010061, 00173839 -"SQRT ", OCT2033000031010013, 00173840 -"TANH ", OCT0033000000010122, 00173841 -"TAN ", OCT2033000036010111, 00173842 -"TIME ", OCT0031220000010064, 00173843 - 0; 00173844 -BLANKS~INLINEINT[MAX~0] ; 00173845 -FOR SCN~1 STEP 1 UNTIL BLANKS DO 00173846 - BEGIN 00173847 - EQVID~INLINEINT[SCN]; WHILE INT[MAX]!EQVID DO MAX~MAX+2 ; 00173848 - INLINEINT[SCN].INTX~MAX+1 ; 00173849 - END ; 00173850 -INTID.SUBCLASS ~ INTYPE; 00173851 -REALID.SUBCLASS ~ REALTYPE; 00173852 -EQVID ~ ".EQ000"; 00173853 -LISTID ~ ".LI000"; 00173854 -BLANKS ~ " "; 00173855 -ENDSEGTOG ~ TRUE; 00173856 -SCN ~ 7; 00173857 -MAX ~ REAL(NOT FALSE).[9:39]; 00173858 -SUPERMAXCOM~128|(MAXCOM+1) ; 00173859 -SEGPTOG ~ FALSE; %INHIBIT PAGE SKIP AFTER SUBROUTINES %501- 00173860 -END INITIALIZATION; 00173861 - 00173862 -ALPHA PROCEDURE NEED(T, C); VALUE T, C; ALPHA T, C; 00173863 -BEGIN INTEGER N; REAL ELBAT; 00173864 - REAL X; 00173865 - LABEL XIT, CHECK; 00173866 - ALPHA INFA, INFB, INFC; 00173867 -COMMENT NEED RETURNS THE ELBAT WORD FOR THE IDENTIFIER T. 00173868 -IF THIS IS THE FIRST OCCURRENCE OF T THEN AN INFO WORD IS BUILT AND 00173869 -GIVEN THEN CLASS C; 00173870 - ELBAT.CLASS ~ C; 00173871 - XTA ~ T; 00173872 - IF C { LABELID THEN 00173873 - BEGIN 00173874 - IF N ~ SEARCH(T) = 0 THEN N ~ ENTER(ELBAT, T) ELSE 00173875 - IF ELBAT ~ GET(N).CLASS = UNKNOWN 00173876 - THEN PUT(N,GET(N)&C[TOCLASS]) 00173877 - ELSE IF ELBAT ! C THEN FLOG(21); 00173878 - GO TO XIT; 00173879 - END; 00173880 - IF N ~ SEARCH(T) = 0 THEN 00173881 - BEGIN 00173882 - IF N ~ GLOBALSEARCH(T) ! 0 THEN GO TO CHECK; 00173883 - N ~ GLOBALENTER(ELBAT, T); 00173884 - GO TO XIT; 00173885 - END; 00173886 - GETALL(N,INFA,INFB,INFC); 00173887 - IF INFA.CLASS = DUMMY THEN BEGIN N ~ INFC.BASE; GO TO CHECK END; 00173888 - IF BOOLEAN(INFA. FORMAL) THEN GO TO CHECK; 00173889 - IF INFA.CLASS ! UNKNOWN THEN 00173890 - BEGIN 00173891 - IF N ~ GLOBALSEARCH(T) ! 0 THEN GO TO CHECK; 00173892 - ELBAT.SUBCLASS ~ INFA.SUBCLASS; 00173893 - N ~ GLOBALENTER(ELBAT, T); 00173894 - GO TO XIT; 00173895 - END; 00173896 - PUT(N, INFA & DUMMY[TOCLASS]); 00173897 - ELBAT.SUBCLASS ~ INFA .SUBCLASS; 00173898 - IF X ~ GLOBALSEARCH(T) = 0 THEN X ~ GLOBALENTER(ELBAT, T); 00173899 - PUT(N+2, INFC & X[TOBASE]); N ~ X; 00173900 - CHECK: 00173901 - INFA ~ GET(N); 00173902 - IF ELBAT ~ INFA .CLASS = UNKNOWN THEN 00173903 - BEGIN INFO[N.IR,N.IC].CLASS ~ C; GO TO XIT END; 00173904 - IF ELBAT ! C THEN 00173905 - IF ELBAT = EXTID AND 00173906 - (C = SUBRID OR C = FUNID) THEN 00173907 - INFO[N.IR,N.IC].CLASS ~ C 00173908 - ELSE IF (ELBAT=SUBRID OR ELBAT= FUNID) AND C = EXTID THEN 00173909 - ELSE FLOG(21); 00173910 - XIT: NEED ~ GETSPACE(N); 00173911 - XTA ~ NAME; % RESTORE XTA FOR DIAGNOSTIC PURPOSES 00173912 -END NEED; 00173913 - 00173914 -INTEGER PROCEDURE EXPR(B); VALUE B; BOOLEAN B; FORWARD; 00173915 - 00173916 -PROCEDURE SPLIT(A); VALUE A; REAL A; 00173917 -BEGIN 00173918 - EMITPAIR(JUNK, ISN); 00173919 - EMITD(40, DIA); 00173920 - EMITD(18, ISO); 00173921 - EMITDESCLIT(A); 00173922 - EMITO(LOD); 00173923 - EMITOPDCLIT(JUNK); 00173924 - EMITPAIR(255,CHS); 00173925 - EMITO(LND); 00173926 -END SPLIT; 00173927 -BOOLEAN PROCEDURE SUBSCRIPTS(LINK,FROM); VALUE LINK,FROM; 00173928 -INTEGER LINK, FROM; 00173929 -BEGIN INTEGER I, NSUBS, BDLINK; 00173930 - LABEL CONSTRUCT, XIT; 00173931 -REAL SUM, PROD, BOUND; 00173932 -REAL INFA,INFB,INFC; 00173933 -REAL SAVENSEG,SAVEADR ; 00173934 -INTEGER INDX; 00173935 -REAL INFD; 00173936 -BOOLEAN TOG, VARF; 00173937 -REAL SAVIT; 00173938 -DEFINE SS = LSTT#; 00173939 -IF DEBUGTOG THEN FLAGROUTINE(" SUBSC","RIPTS ",TRUE ) ; 00173940 - SAVIT ~ IT; 00173941 - LINK ~ GETSPACE(LINK); 00173942 -GETALL(LINK,INFA,INFB,INFC); 00173943 - IF INFA.CLASS ! ARRAYID THEN 00173944 - BEGIN XTA ~ INFB; FLOG(35); GO TO XIT END; 00173945 - NSUBS ~ INFC.NEXTRA; 00173946 - IF FROM = 4 THEN 00173947 - BEGIN IF NSUBS GTR SAVESUBS THEN SAVESUBS ~ NSUBS; 00173948 - IF NSUBS GTR NAMLIST[0] THEN NAMLIST[0] ~ NSUBS; 00173949 - NAMLIST[NAMEIND].[1:8] ~ NSUBS; 00173950 - INFD ~ GET(NEED(".SUBAR",BLOCKID)).ADDR; 00173951 - END; 00173952 - BDLINK ~ INFC.ADINFO-NSUBS+1; 00173953 - VARF ~ INFC < 0; 00173954 - FOR I ~ 1 STEP 1 UNTIL NSUBS DO 00173955 - BEGIN 00173956 - IT~IT+1; SAVENSEG~NSEG; SAVEADR~ADR ; 00173957 - IF EXPR(TRUE) > REALTYPE THEN FLAG(98); 00173958 - IF ADR=SAVEADR THEN FLAG(36) ; 00173959 - IF VARF THEN 00173960 - IF EXPRESULT=NUMCLASS AND NSEG=SAVENSEG THEN 00173961 - BEGIN 00173962 - ADR~SAVEADR ; 00173963 - EMITNUM(EXPVALUE-1); 00173964 - END ELSE EMITPAIR(1, SUB) 00173965 - ELSE 00173966 - IF EXPRESULT=NUMCLASS AND NSEG = SAVENSEG AND FROM NEQ 4 THEN 00173967 - BEGIN 00173968 - ADR~SAVEADR; IF SS[IT]~EXPVALUE{0 THEN FLAG(154) ; 00173969 - END 00173970 - ELSE SS[IT] ~ @9; 00173971 - IF FROM = 4 THEN 00173972 - BEGIN IF VARF THEN BEGIN EMITO(DUP); EMITPAIR(1,ADD); END; 00173973 - EMITL(INDX); INDX ~ INDX+1; 00173974 - EMITDESCLIT(INFD); 00173975 - EMITO(IF VARF THEN STD ELSE STN); 00173976 - END; 00173977 - IF I < NSUBS THEN 00173978 - BEGIN 00173979 - IF GLOBALNEXT ! COMMA THEN 00173980 - BEGIN XTA ~ INFB; FLOG(23) END; 00173981 - SCAN; 00173982 - END; 00173983 - END; 00173984 - IF GLOBALNEXT ! RPAREN THEN BEGIN XTA ~ INFB; FLOG(24); END 00173985 - ELSE IF FROM < 2 THEN 00173986 - BEGIN SCAN; IF PREC > 0 THEN FROM ~ 1; END; 00173987 - SUM ~ 0; 00173988 - TOG ~ VARF; 00173989 - IF VARF THEN 00173990 - FOR I ~ NSUBS-1 STEP -1 UNTIL 1 DO 00173991 - BEGIN 00173992 - IF BOUND ~ EXTRAINFO[(BDLINK~BDLINK+1).IR,BDLINK.IC] < 0 THEN 00173993 - EMITOPDCLIT(BOUND) ELSE EMITNUM(BOUND); 00173994 - EMITO(MUL); 00173995 - EMITO(ADD); 00173996 - END 00173997 - ELSE 00173998 - FOR I ~ NSUBS STEP -1 UNTIL 1 DO 00173999 - BEGIN 00174000 - IF I = 1 THEN BOUND ~ 1 ELSE 00174001 - BOUND ~ EXTRAINFO[(BDLINK~BDLINK+1).IR,BDLINK.IC]; 00174002 - IF T ~ SS[SAVIT+I] < @9 THEN 00174003 - BEGIN 00174004 - SUM ~ (SUM+T-1)|BOUND; 00174005 - IF TOG THEN PROD ~ PROD|BOUND; 00174006 - END 00174007 - ELSE 00174008 - BEGIN 00174009 - IF TOG THEN BEGIN EMITNUM(PROD); EMITO(MUL); EMITO(ADD) END 00174010 - ELSE TOG ~ TRUE; 00174011 - PROD ~ BOUND; 00174012 - SUM ~ (SUM-1)|BOUND; 00174013 - END; 00174014 - END; 00174015 - IF VARF THEN T ~ @9; 00174016 - IF INFA.SUBCLASS } DOUBTYPE THEN 00174017 - BEGIN 00174018 - IF TOG THEN 00174019 - BEGIN 00174020 - IF T < @9 THEN EMITNUM(2|PROD) ELSE EMITL(2); 00174021 - EMITO(MUL); 00174022 - END; 00174023 - SUM ~ SUM|2; 00174024 - END ELSE 00174025 - IF T < @9 AND TOG THEN BEGIN EMITNUM(PROD); EMITO(MUL) END; 00174026 - IF BOOLEAN(INFA.CE) THEN 00174027 - SUM ~ SUM + INFC.BASE ELSE 00174028 - IF BOOLEAN(INFA.FORMAL) THEN 00174029 - BEGIN EMITOPDCLIT(INFA.ADDR-1); 00174030 - IF TOG THEN EMITO(ADD) ELSE TOG ~ TRUE; 00174031 - END; 00174032 - IF BOOLEAN(INFA.TWOD) AND FROM > 0 THEN 00174033 - BEGIN 00174034 - IF SUM = 0 THEN 00174035 - IF TOG THEN ELSE 00174036 - BEGIN 00174037 - EMITL(0); 00174038 - EMITDESCLIT(INFA.ADDR); 00174039 - EMITO(LOD); 00174040 - EMITL(0); 00174041 - GO TO CONSTRUCT; 00174042 - END 00174043 - ELSE 00174044 - IF TOG THEN 00174045 - BEGIN 00174046 - EMITNUM(ABS(SUM)); 00174047 - IF SUM < 0 THEN EMITO(SUB) ELSE EMITO(ADD); 00174048 - END ELSE 00174049 - BEGIN 00174050 - EMITL(SUM.[33:7]); 00174051 - EMITDESCLIT(INFA.ADDR); 00174052 - EMITO(LOD); 00174053 - EMITL(SUM.[40:8]); 00174054 - GO TO CONSTRUCT; 00174055 - END; 00174056 - SPLIT(INFA.ADDR); 00174057 - CONSTRUCT: 00174058 - IF BOOLEAN(FROM) THEN 00174059 - BEGIN 00174060 - IF INFA.SUBCLASS } DOUBTYPE THEN 00174061 - BEGIN 00174062 - EMITO(CDC); 00174063 - EMITO(DUP); 00174064 - EMITPAIR(1, XCH); 00174065 - EMITO(INX); 00174066 - EMITO(LOD); 00174067 - EMITO(XCH); 00174068 - EMITO(LOD); 00174069 - END ELSE EMITO(COC); 00174070 - END ELSE 00174071 - BEGIN 00174072 - IF SUM = 0 THEN IF NOT TOG THEN EMITL(0) ELSE 00174073 - ELSE 00174074 - BEGIN 00174075 - IF TOG THEN 00174076 - BEGIN 00174077 - EMITNUM(ABS(SUM)); 00174078 - IF SUM < 0 THEN EMITO(SUB) ELSE EMITO(ADD); 00174079 - END 00174080 - ELSE EMITNUM(SUM); 00174081 - END; 00174082 - IF FROM > 0 THEN 00174083 - IF BOOLEAN (FROM) THEN 00174084 - IF INFA.SUBCLASS } DOUBTYPE THEN 00174085 - BEGIN 00174086 - EMITDESCLIT(INFA.ADDR); 00174087 - EMITO(DUP); 00174088 - EMITPAIR(1,XCH); 00174089 - EMITO(INX); 00174090 - EMITO(LOD); 00174091 - EMITO(XCH); 00174092 - EMITO(LOD); 00174093 - END ELSE EMITV(LINK) ELSE 00174094 - BEGIN DESCREQ ~ TRUE; EMITN(LINK); DESCREQ ~ FALSE END; 00174095 - END; 00174096 - XIT: 00174097 - IT ~ SAVIT; 00174098 - SUBSCRIPTS ~ BOOLEAN(FROM); 00174099 - IF DEBUGTOG THEN FLAGROUTINE(" SUBSC","RIPTS ",FALSE) ; 00174100 - END SUBSCRIPTS; 00174101 - 00174102 -BOOLEAN PROCEDURE BOUNDS(LINK); VALUE LINK; REAL LINK; 00174103 -BEGIN 00174104 - COMMENT CALLED TO PROCESS ARRAY BOUNDS; 00174105 - BOOLEAN VARF, SINGLETOG; %109-00174106 - DEFINE FNEW = LINK#; 00174107 - REAL T, NSUBS, INFA, INFB, INFC, FIRSTSS; 00174108 - LABEL LOOP; 00174109 -IF DEBUGTOG THEN FLAGROUTINE(" BOU","NDS ",TRUE ); 00174110 - GETALL(FNEW, INFA, INFB, INFC); 00174111 - FIRSTSS ~ NEXTSS; 00174112 - IF LINK < 0 THEN BEGIN SINGLETOG ~ TRUE; LINK ~ ABS(LINK) END; %109-00174113 - LOOP: 00174114 - IF NEXT = ID THEN 00174115 - BEGIN 00174116 - T ~ GET(FNEXT ~ GETSPACE(FNEXT)); 00174117 - IF T.CLASS ! VARID OR NOT BOOLEAN(T.FORMAL) THEN FLAG(92) ELSE 00174118 - IF T.SUBCLASS > REALTYPE THEN FLAG(93); 00174119 - T ~ -T.ADDR; 00174120 - VARF ~ TRUE; 00174121 - END ELSE 00174122 - IF NEXT = NUM THEN 00174123 - BEGIN 00174124 - IF NUMTYPE!INTYPE THEN FLAG(113); 00174125 - IF T~FNEXT=0 THEN FLAG(122) ; 00174126 - IF NOT VARF THEN IF NSUBS = 0 THEN LENGTH ~ FNEXT ELSE 00174127 - LENGTH ~ LENGTH|FNEXT; 00174128 - END ELSE FLOG(122); 00174129 - EXTRAINFO[NEXTSS.IR,NEXTSS.IC] ~ T; 00174130 - NEXTSS ~ NEXTSS-1; 00174131 - NSUBS ~ NSUBS+1; 00174132 - SCAN; 00174133 - IF NEXT = COMMA THEN BEGIN SCAN; GO TO LOOP END; 00174134 - IF NEXT ! RPAREN THEN FLOG(94); 00174135 - XTA ~ INFB; 00174136 - IF INFA.CLASS = ARRAYID THEN FLAG(95); 00174137 - INFA.CLASS ~ ARRAYID; 00174138 - IF VARF THEN 00174139 - BEGIN 00174140 - IF NOT BOOLEAN(INFA.FORMAL) THEN FLAG(96); 00174141 - IF NSUBS > 1 OR INFA .SUBCLASS } DOUBTYPE THEN 00174142 - BEGIN BUMPLOCALS;LENGTH~LOCALS + 1536;BOUNDS~TRUE END ELSE 00174143 - LENGTH ~-EXTRAINFO[FIRSTSS.IR,FIRSTSS.IC]; 00174144 - END ELSE 00174145 - IF NOT SINGLETOG AND INFA.SUBCLASS > LOGTYPE THEN %109-00174146 - BEGIN LENGTH ~ 2 | LENGTH; BOUNDS ~ TRUE END; %109-00174147 - IF LENGTH > 32767 THEN FLAG(99); 00174148 - INFC ~ LENGTH & NSUBS[TONEXTRA] & FIRSTSS[TOADINFO]; 00174149 - IF VARF THEN INFC ~ -INFC; 00174150 - PUT(FNEW, INFA); PUT(FNEW+2, INFC); 00174151 - SCAN; 00174152 -IF DEBUGTOG THEN FLAGROUTINE(" BOU","NDS ",FALSE) ; 00174153 -END BOUNDS; 00174154 - 00174155 -PROCEDURE PARAMETERS(LINK); VALUE LINK; REAL LINK; 00174156 -BEGIN 00174157 - LABEL LOOP; 00174158 - REAL NPARMS, EX, INFC, PTYPE; 00174159 - ALPHA EXPNAME; 00174160 - BOOLEAN CHECK, INTFID; 00174161 - BOOLEAN NOTZEROP; 00174162 - REAL SAVIT; 00174163 - DEFINE PARMTYPE = LSTT#; 00174164 - SAVIT ~ IT ~ IT+1; 00174165 -IF DEBUGTOG THEN FLAGROUTINE(" PARAM","ETERS ",TRUE ) ; 00174166 - INFC ~ GET(LINK+2); 00174167 - IF CHECK ~ BOOLEAN(INFC.[1:1]) THEN 00174168 - BEGIN 00174169 - EX ~ INFC.ADINFO; 00174170 - NOTZEROP ~ INFC.NEXTRA ! 0; 00174171 - INTFID ~ INFC.[36:12] = 1; 00174172 - END; 00174173 - LOOP: 00174174 - BEGIN SCAN; 00174175 - EXPNAME ~ NAME; 00174176 - IF GLOBALNEXT = 0 AND NAME = "$ " THEN 00174177 - BEGIN EXPRESULT ~ LABELID; SCAN; 00174178 - IF GLOBALNEXT ! NUM THEN FLAG(44); 00174179 - EMITLABELDESC(NAME); 00174180 - PTYPE ~ 0; 00174181 - SCAN; 00174182 - END 00174183 - ELSE PTYPE ~ EXPR(CHECK AND EXTRAINFO[EX.IR,EX.IC].CLASS 00174184 - = EXPCLASS AND INTFID); 00174185 - IF EXPRESULT = NUMCLASS THEN 00174186 - IF PTYPE = STRINGTYPE THEN 00174187 - BEGIN 00174188 - ADR ~ ADR - 1; 00174189 - PTYPE ~ INTYPE; 00174190 - EXPRESULT ~ SUBSVAR; 00174191 - IF STRINGSIZE = 1 AND 00174192 - (T ~ EXTRAINFO[EX.IR,EX.IC].CLASS = VARID OR 00174193 - T = EXPCLASS) THEN 00174194 - BEGIN 00174195 - EXPRESULT ~ EXPCLASS; 00174196 - EMITNUM(STRINGARRAY[0]); 00174197 - END ELSE 00174198 - BEGIN 00174199 - EXPRESULT~ARRAYID; 00174200 - EMITPAIR(PRGDESCBLDR(1,0,0,NXAVIL~NXAVIL+1), LOD); 00174201 - EMITL(0); 00174202 - WRITEDATA(STRINGSIZE, NXAVIL, STRINGARRAY); 00174203 - END; 00174204 - END ELSE EXPRESULT ~ EXPCLASS; 00174205 - PARMTYPE[IT] ~ 0 & EXPRESULT[TOCLASS] & PTYPE[TOSUBCL]; 00174206 - XTA ~ EXPNAME; 00174207 - IF TSSEDITOG THEN IF (EXPRESULT=FUNID OR EXPRESULT=SUBRID OR 00174208 - EXPRESULT=EXTID) AND NOT DCINPUT THEN TSSED(XTA,2); 00174209 - IF DCINPUT THEN IF EXPRESULT=FUNID OR EXPRESULT=SUBRID 00174210 - OR EXPRESULT=EXTID THEN FLAG(151) ; 00174211 - IF CHECK THEN 00174212 - BEGIN 00174213 - IF T ~ EXTRAINFO[EX.IR,EX.IC].CLASS ! EXPRESULT THEN 00174214 - CASE T OF 00174215 - BEGIN 00174216 - EXTRAINFO[EX.IR,EX.IC] ~ 0 & EXPRESULT[TOCLASS] 00174217 - & PTYPE[TOSUBCL]; 00174218 - IF EXPRESULT ! SUBSVAR THEN FLAG(66); 00174219 - IF EXPRESULT = SUBSVAR THEN 00174220 - BEGIN EMITO(CDC); 00174221 - IF PTYPE } DOUBTYPE THEN EMITL(0); 00174222 - END ELSE 00174223 - ELSE 00174224 - IF EXPRESULT = EXPCLASS THEN 00174225 - BEGIN IF PTYPE } DOUBTYPE THEN EMITO(XCH); 00174226 - EXTRAINFO[EX.IR,EX.IC].CLASS ~ EXPCLASS 00174227 - END ELSE FLAG(67); 00174228 - ; ; ; 00174229 - FLAG(68); 00174230 - IF EXPRESULT = EXTID THEN 00174231 - PUT(EXPLINK,GET(EXPLINK)&FUNID[TOCLASS]) ELSE 00174232 - FLAG(69); 00174233 - ; 00174234 - IF EXPRESULT = FUNID OR EXPRESULT = SUBRID THEN 00174235 - EXTRAINFO[EX.IR,EX.IC] ~ EXPRESULT ELSE FLAG(70); 00174236 - IF EXPRESULT = EXTID THEN 00174237 - PUT(EXPLINK.GET(EXPLINK)&SUBRID[TOCLASS]) ELSE 00174238 - FLAG(71); 00174239 - ; ; 00174240 - IF EXPRESULT = ARRAYID THEN EXTRAINFO[EX.IR,EX.IC].CLASS 00174241 - ~ ARRAYID ELSE 00174242 - IF EXPRESULT = VARID THEN 00174243 - BEGIN 00174244 - EXTRAINFO[EX.IR,EX.IC].CLASS ~ SBVEXP; 00174245 - EMITL(0) 00174246 - END ELSE 00174247 - IF EXPRESULT = EXPCLASS THEN 00174248 - BEGIN 00174249 - EXTRAINFO[EX.IR,EX.IC].CLASS ~ SBVEXP; 00174250 - IF PTYPE } DOUBTYPE THEN EMITO(XCH) ELSE EMITL(0); 00174251 - END ELSE FLAG(72); 00174252 - IF EXPRESULT = SUBSVAR THEN 00174253 - IF NOT INTFID THEN 00174254 - BEGIN EMITO(CDC); 00174255 - IF PTYPE } DOUBTYPE THEN EMITL(0) 00174256 - END 00174257 - ELSE 00174258 - ELSE IF EXPRESULT = VARID THEN 00174259 - IF NOT INTFID THEN 00174260 - IF PTYPE } DOUBTYPE THEN EMITL(0) ELSE ELSE 00174261 - ELSE FLAG(67); 00174262 - IF EXPRESULT = VARID THEN 00174263 - EMITL(0) ELSE 00174264 - IF EXPRESULT = EXPCLASS THEN 00174265 - IF PTYPE } DOUBTYPE THEN EMITO(XCH) ELSE EMITL(0) 00174266 - ELSE IF EXPRESULT ! SUBSVAR THEN FLAG(67); 00174267 - END OF CASE STATEMENT 00174268 - ELSE IF PTYPE } DOUBTYPE THEN 00174269 - IF EXPRESULT = VARID THEN EMITL(0) 00174270 - ELSE IF EXPRESULT = EXPCLASS AND NOT INTFID 00174271 - THEN EMITO(XCH); 00174272 - IF T ~ EXTRAINFO[EX.IR,EX.IC].SUBCLASS = 0 OR 00174273 - (T = INTYPE AND PTYPE = REALTYPE AND 00174274 - GET(LINK).SEGNO = 0) THEN 00174275 - EXTRAINFO[EX.IR,EX.IC].SUBCLASS ~ PTYPE ELSE 00174276 - IF NOT(T = PTYPE OR T = REALTYPE AND PTYPE = INTYPE ) THEN 00174277 - FLAG(88); 00174278 - END OF CHECK 00174279 - ELSE IF PTYPE } DOUBTYPE THEN 00174280 - IF EXPRESULT = VARID THEN EMITL(0) 00174281 - ELSE IF EXPRESULT = EXPCLASS THEN EMITO(XCH); 00174282 - IF NOTZEROP THEN EX ~ EX+1; 00174283 - IT ~ IT+1; 00174284 - END; 00174285 - IF GLOBALNEXT = COMMA THEN GO TO LOOP; 00174286 - NPARMS ~ IT - SAVIT; 00174287 - IF GLOBALNEXT ! RPAREN THEN FLOG(108); 00174288 - IF NOT CHECK THEN 00174289 - BEGIN 00174290 - INFC ~ GET(LINK+2); 00174291 - INFC ~ -(INFC & NPARMS[TONEXTRA] 00174292 - & NEXTEXTRA[TOADINFO]); 00174293 - PUT(LINK+2,INFC); 00174294 - FOR I ~ SAVIT STEP 1 UNTIL IT-1 DO 00174295 - BEGIN 00174296 - EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ PARMTYPE[I]; 00174297 - NEXTEXTRA ~ NEXTEXTRA+1; 00174298 - END; 00174299 - END 00174300 - ELSE 00174301 - IF T ~ GET(LINK+2).NEXTRA > 0 AND T ! NPARMS OR 00174302 - T=0 AND INTFID AND NPARMS < 2 OR 00174303 - T = 0 AND NOT INTFID THEN 00174304 - BEGIN XTA ~ GET(LINK+1); FLAG(28) END; 00174305 -IF DEBUGTOG THEN FLAGROUTINE(" PARAM","ETERS ",FALSE) ; 00174306 - IT ~ SAVIT-1; 00174307 -END PARAMETERS; 00174308 - 00174309 -PROCEDURE STMTFUNREF(LINK); VALUE LINK; REAL LINK; 00174310 -BEGIN 00174311 - REAL I, PARMLINK, NPARMS, SEG; 00174312 -IF DEBUGTOG THEN FLAGROUTINE(" STMTF","UNREF ",TRUE); 00174313 - PARMLINK ~ GET(LINK+2).[36:12]; 00174314 - DO 00174315 - BEGIN 00174316 - SCAN; 00174317 - IF A~EXPR(TRUE) ! B~GET(PARMLINK).SUBCLASS THEN 00174318 - IF A > REALTYPE OR B > REALTYPE THEN %108-00174319 - BEGIN XTA ~ NNEW; FLAG(88) END; 00174320 - PARMLINK ~ PARMLINK-3; 00174321 - NPARMS ~ NPARMS+1; 00174322 - END UNTIL NEXT ! COMMA; 00174323 - IF NEXT ! RPAREN THEN FLAG(108); 00174324 - SCAN; 00174325 - GETALL(LINK, INFA, XTA, INFC); 00174326 - IF NPARMS ! INFC.NEXTRA THEN FLAG(28); 00174327 - SEG ~ INFA.SEGNO; 00174328 - BRANCHLIT(INFC.BASE&SEG[TOSEGNO],FALSE); 00174329 - EMITB(INFA.ADDR & SEG[TOSEGNO], FALSE); 00174330 - ADJUST; 00174331 - IF DEBUTOG THEN FLAGROUTINE(" STMTF","UNREF ",FALSE); 00174332 - END STMTFUNREF; 00174333 - 00174334 - BOOLEAN PROCEDURE DOITINLINE(LNK); VALUE LNK; REAL LNK ; 00174335 - BEGIN 00174336 - REAL C,I,C1,C2,C3,C4,C5 ; 00174337 - LABEL HUNT,FOUND,XIT,AIMAG,AINT,CMPLX,LOOP,DDT111,SNGL ; 00174338 - DEFINE OPTYPE=LSTT#, E0=EMITO#, EP=EMITPAIR#, EOL=EMITOPDCLIT# ;00174339 - IF DEBUGTOG THEN FLAGROUTINE("DOITIN","LINE ",TRUE); 00174340 - C1~1; C2~INLINEINT[0]; C3~GET(ABS(LNK)+1) ; 00174341 - HUNT: 00174342 - IF (C~INLINEINT[I~(C1+C2).[36:11]].INAM)C3 THEN C2~I-1 ELSE GO FOUND ; 00174344 - IF C10 THEN INLINEINT[I]~-C4; I~0 ; 00174371 - IF XREF THEN ENTERX(C3,0&FUNID[TOCLASS]&C[21:6:3]); 00174372 - IF GLOBALNEXT!LPAREN THEN BEGIN FLOG(106); GO XIT END ; 00174373 - LOOP: SCAN; C5~XTA ; 00174374 - IF I=0 THEN 00174375 - IF LNK=10 THEN EMITL(0) ELSE IF LNK=21 THEN EMITDESCLIT(2) ; 00174376 - IF (C4~EXPR(TRUE))!C1 AND (C1!REALTYPE OR C4!INTYPE) THEN 00174377 - BEGIN XTA~C5; FLAG(88); C2~-2 END ; 00174378 - I~I+1; IF GLOBALNEXT=COMMA THEN GO LOOP ; 00174379 - IF GLOBALNEXT!RPAREN THEN BEGIN FLOG(108); C2~-2 END; SCAN ; 00174380 - IF I!C.INTPARMS THEN IF C.INTPARMS!0 OR I<2 THEN 00174381 - BEGIN XTA~C3; FLAG(28); C2~-2 END ; 00174382 - OPTYPE[IT]~C.INTCLASS; IF C2<0 THEN GO XIT ; 00174383 - CASE (LNK-1) OF 00174384 - BEGIN 00174385 - E0(SSP) ; % @1: ABS, DABS, IABS. 00174386 - AIMAG: E0(DEL) ; % @2: AIMAG. 00174387 - AINT: EP(1,IDV) ; % @3: AINT, IFIX, INT. 00174388 - E0(RDV) ; % @4: AMOD. 00174389 - E0(LND) ; % @5: LOGICAL AND. 00174390 - CMPLX: E0(XCH) ; % @6: CMPLX. 00174391 - E0(LNG) ; % @7: LOGICAL COMPLIMENT (NEGATION). 00174392 - BEGIN % @10: DIM, IDIM. 00174393 - E0(SUB); E0(DUP); EP(0,LESS) ; 00174394 - IF ADR>4082 THEN BEGIN ADR~ADR+1; SEGOVF END ; 00174395 - EP(2,BFC); E0(DEL); EMITL(0) ; 00174396 - END ; 00174397 - BEGIN E0(XCH); E0(CHS); GO CMPLX END ; % @11: CONJG. 00174398 - ; % @12: DBLE (SOME CODE ALREADY EMITTED ABOVE). 00174399 - BEGIN E0(XCH); E0(DEL) ; % @13: DSIGN. 00174400 - DDT111: EMITDDT(1,1,1) ; 00174401 - END; 00174402 - E0(LQV) ; % @14: LOGICAL EQUIVALENCE. 00174403 - ; % @15: FLOAT. 00174404 - GO DDT111 ; % @16: ISIGN, SIGN. 00174405 - BEGIN E0(RDV); GO AINT END ; % @17: MOD. 00174406 - E0(LOR) ; % @20: LOGICAL OR. 00174407 - BEGIN E0(XCH); GO AIMAG END ; % @21: REAL. 00174408 - EP(1,KOM) ; % @22: TIME. 00174409 - BEGIN % @23: SNGL. 00174410 - SNGL: EP(9,SND); E0(XCH); EMITDDT(47,9,1); EMITL(0) ; 00174411 - EMITDDT(9,9,38); EOL(9); EMITO(ADD); IF LNK=20 THEN GO AINT ; 00174412 - END ; 00174413 - GO SNGL ; % @24: IDINT. 00174414 - 00174415 - BEGIN % @25: AMAX0,AMAX1,AMIN0,AMIN1,MAX0,MAX1,MIN0,MIN1. 00174416 - % SOME CODE ALREADY EMITTED ABOVE. 00174417 - IF ADR>4068 THEN BEGIN ADR~ADR+1; SEGOVF END ; 00174418 - EP(9,STD); E0(DUP); EOL(9) ; 00174419 - E0(IF C3.[24:6]="A" OR C3.[24:6]="X" THEN LESS ELSE GRTR) ; 00174420 - EP(2,BFC); E0(DEL); EOL(9); E0(XCH); E0(TOP); E0(LNG) ; 00174421 - EP(14,BBC); E0(DEL); IF C3="MIN1 " OR C3="MAX1 " THEN GO AINT00174422 - END ; 00174423 - 00174424 - END OF CASE STATEMENT ; 00174425 - XIT: 00174426 - IF DEBUGTOG THEN FLAGROUTINE("DOITIN","LINE ",FALSE) ; 00174427 - END OF DOITINLINE ; 00174428 - 00174429 -REAL PROCEDURE LOOKFORINTRINSIC(L); VALUE L; REAL L; 00174430 -BEGIN 00174431 - ALPHA ID, I, X, NPARMS; 00174432 - REAL T; 00174433 - LABEL FOUND, XIT; 00174434 -IF DEBUGTOG THEN FLAGROUTINE("LOOKFO","RINTRN",TRUE); 00174435 - LOOKFORINTRINSIC ~ L ~ NEED(ID ~ GET(L+1),FUNID); 00174436 - IF GET(L+2) < 0 THEN GO TO XIT; % PARAMETER INFO KNOWN 00174437 - COMMENT B MUST BE SET TO K/2, WHERE K IS THE INDEX OF THE LAST 00174438 - INTRINSIC NAME IN THE ARRAY INT; 00174439 - A~0; B~NUMINTM1 ; 00174440 - WHILE A+1 < B DO 00174441 - BEGIN 00174442 - I ~ REAL(BOOLEAN(A+B) AND BOOLEAN(1022)); 00174443 - IF Z ~ INT[I] = ID THEN GO TO FOUND; 00174444 - IF ID < Z THEN B ~ I.[36:11] ELSE A ~ I.[36:11]; 00174445 - END; 00174446 - IF ID = INT[I~(A+B)|2-I] THEN GO TO FOUND; 00174447 - GO TO XIT; 00174448 - FOUND: 00174449 - NPARMS~(X~INT[I+1]).INTPARMS; INT[I+1].INTSEEN~1 ; 00174450 - INFO[L.IR,L.IC].SUBCLASS~X.INTCLASS ; 00174451 - PUT(L+2,-(1&NEXTEXTRA[TOADINFO]&NPARMS[TONEXTRA])); 00174452 - IF NPARMS = 0 THEN NPARMS ~ 1; 00174453 - T~X.INTPARMCLASS ; 00174454 - FOR I ~ 1 STEP 1 UNTIL NPARMS DO 00174455 - BEGIN 00174456 - EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ 00174457 - 0 & EXPCLASS[TOCLASS] & T[TOSUBCL]; 00174458 - NEXTEXTRA ~ NEXTEXTRA + 1; 00174459 - END; 00174460 - XIT: 00174461 -IF DEBUGTOG THEN FLAGROUTINE("LOOKFO","RINTRN",FALSE ) ; 00174462 -END LOOKFORINTRINSIC; 00174463 -INTEGER PROCEDURE EXPR(VALREQ); VALUE VALREQ; BOOLEAN VALREQ; 00174464 -BEGIN LABEL LOOP, STACK, XIT, NOSCAN; REAL T; 00174465 - 00174466 - LABEL ARRY; 00174467 -LABEL HERE ; 00174468 - REAL SAVIT, SAVIP; 00174469 - BOOLEAN CNSTSEENLAST; %FOR HANDLING CONSTANT %113-00174470 - REAL SAVEADR; %EXPONENTS %113-00174471 - DEFINE OPTYPE = LSTT#; 00174472 -REAL EXPRESLT,EXPLNK; 00174473 - REAL EXPV; 00174474 - REAL TM ; 00174475 - DEFINE E0=EMITO#, EP=EMITPAIR#, EOL=EMITOPDCLIT#, 00174476 - ES1(OP)=BEGIN E0(XCH); EP(9,STD); E0(OP) END #, 00174477 - ES2=BEGIN EP(9,STD); E0(XCH); EP(17,SND); E0(MUL) END # ; 00174478 - LABEL CTYP, DTYP, RLESSC, DLESSC, CLESSD, CLESSC, RPLUSD, DTIMESC, 00174479 - CTIMESR, CDIVBYD, CTIMESR1, CTIMESR2, DLESSC1 ; 00174480 - LABEL SPECCHAR, RELATION; 00174481 - REAL LINK; 00174482 - DEFINE T1 = EXPT1#, T2 = EXPT2#, CODE = EXPT3#; 00174483 -COMMENT THE FOLLOWING TABLE GIVES THE PRECEDENCE (PREC) AND 00174484 -OPERATOR NUMBER (OP) OF THE ARITHMETIC AND LOGICAL OPERATORS. 00174485 - OPERATOR PREC OP 00174486 - ** 9 15 00174487 - UNARY - 8 12 00174488 - / 7 14 00174489 - * 7 13 00174490 - - 5 11 00174491 - + 5 10 00174492 - .NE. 4 9 00174493 - .GE. 4 8 00174494 - .GT. 4 7 00174495 - .EQ. 4 6 00174496 - .LE. 4 5 00174497 - .LT. 4 4 00174498 - .NOT. 3 3 00174499 - .AND. 2 2 00174500 - .OR. 1 1 00174501 - THE UNARY PLUS IS IGNORED; 00174502 -PROCEDURE MATH(D, C, T); VALUE D, C, T; REAL D, C, T; 00174503 -BEGIN 00174504 - EMITO(MKS); 00174505 - EMITL(C); 00174506 - EMITV(NEED(".MATH ", INTRFUNID)); 00174507 - EMITO(DFL); 00174508 - IF D = 2 THEN EMITO(DEL); 00174509 - OPTYPE[IT~IT-1] ~ T; 00174510 -END MATH; 00174511 - NNEW ~ NAME; 00174512 -IF DEBUGTOG THEN FLAGROUTINE(" EXPRE","SSION ",TRUE ) ; 00174513 - OPTYPE[SAVIT ~IT ~ IT+1] ~ 00174514 - PR[SAVIP~IP~IP+1] ~ OPST[IP] ~ 0; 00174515 - IF GLOBALNEXT = PLUS THEN GO TO LOOP; 00174516 - IF GLOBALNEXT = MINUS THEN 00174517 - BEGIN PREC ~ 8; OP ~ 12; GO TO STACK END; 00174518 - IF PREC > 0 THEN GO TO STACK; 00174519 - LINK~(EXPLNK~FNEXT)&REAL(SCANENTER)[2:47:1] ; 00174520 - GO TO NOSCAN; 00174521 - LOOP: SCAN; 00174522 - LINK ~ FNEXT; 00174523 - NOSCAN: 00174524 - CNSTSEENLAST~FALSE; %113- 00174525 - IF GLOBALNEXT = ID THEN 00174526 - BEGIN 00174527 - IF IP ! SAVIP THEN EXPRESLT ~ EXPCLASS; 00174528 - OPTYPE[IT~IT+1] ~ (A~GET(LINK)).SUBCLASS; 00174529 - SCAN; 00174530 - IF NOT RANDOMTOG THEN 00174531 - IF NEXT=EQUAL THEN BEGIN NEXT~0; OP~6; PREC~4 END ; 00174532 - IF GLOBALNEXT = ID OR GLOBALNEXT = NUM THEN 00174533 - BEGIN FLOG(1); GO TO XIT END; 00174534 - IF NOT VALREQ AND PREC > 0 THEN VALREQ ~ TRUE; 00174535 - IF GLOBALNEXT ! LPAREN THEN 00174536 - BEGIN 00174537 - LINK ~ GETSPACE(LINK); 00174538 - T ~ (A~GET(LINK)).CLASS; 00174539 - IF XREF THEN ENTERX(GET(LINK+1),0&A[15:15:9]); 00174540 - IF EXPRESLT = 0 THEN EXPRESLT ~ T; 00174541 - IF VALREQ THEN 00174542 - IF T = VARID THEN EMITV(LINK) ELSE 00174543 - BEGIN XTA ~ GET(LINK+1); FLAG(50) END 00174544 - ELSE 00174545 - BEGIN 00174546 - IF T = VARID THEN 00174547 - IF GLOBALNEXT > SLASH AND EXPRESLT = VARID THEN 00174548 - BEGIN 00174549 - DESCREQ~TRUE; EMITN(LINK); DESCREQ ~ FALSE; 00174550 - GO TO XIT; 00174551 - END ELSE EMITV(LINK) 00174552 - ELSE 00174553 - BEGIN 00174554 - IF T = ARRAYID THEN 00174555 - BEGIN 00174556 - IF BOOLEAN(A.CE) THEN 00174557 - EMITNUM(GET(LINK+2).BASE) ELSE 00174558 - IF BOOLEAN(A.FORMAL) THEN 00174559 - EMITOPDCLIT(A.ADDR-1) ELSE 00174560 - EMITL(0); 00174561 - GO TO ARRY; 00174562 - END ELSE EMITPAIR(A.ADDR,LOD); 00174563 - GO TO XIT; 00174564 - END; 00174565 - END; 00174566 - GO TO SPECCHAR; 00174567 - END; 00174568 - IF A.CLASS ! ARRAYID THEN 00174569 - BEGIN COMMENT FUNCTION REFERENCE; 00174570 - EXPRESLT ~ EXPCLASS; 00174571 - IF A.CLASS = STMTFUNID THEN 00174572 - BEGIN 00174573 - IF XREF THEN ENTERX(GET(LINK+1),0&A[15:15:9]); 00174574 - STMTFUNREF(LINK) ; 00174575 - IF NEXT=EQUAL THEN IF NOT RANDOMTOG THEN 00174576 - BEGIN NEXT~0; OP~6; PREC~4 END ; 00174577 - GO TO SPECCHAR ; 00174578 - END ; 00174579 - IF A.CLASS=EXTID OR GET(TM~GLOBALSEARCH(GET(LINK+1))).CLASS=00174580 - EXTID THEN LINK~REAL(DOITINLINE(-LINK)) ELSE 00174581 - IF A.CLASS SLASH AND EXPRESLT = SUBSVAR THEN 00174606 - BEGIN 00174607 - ARRY: 00174608 - IF BOOLEAN((A~GET(LINK)).TWOD) THEN 00174609 - BEGIN 00174610 - EMITPAIR(TWODPRT, LOD); 00174611 - T ~ A.ADDR; 00174612 - IF T { 1023 THEN 00174613 - BEGIN 00174614 - EMITL(T.[38:10]); 00174615 - EMITDESCLIT(10); 00174616 - END ELSE 00174617 - BEGIN 00174618 - EMITL(T.[40:8]); 00174619 - EMITDESCLIT(1536); 00174620 - EMITO(INX); 00174621 - END; 00174622 - EMITO(CTF); 00174623 - END ELSE EMITPAIR(A.ADDR,LOD); 00174624 - EMITO(XCH); 00174625 - GO TO XIT; 00174626 - END; 00174627 - IF BOOLEAN((A~GET(LINK)).TWOD) THEN 00174628 - BEGIN 00174629 - SPLIT(A.ADDR); 00174630 - IF A.SUBCLASS } DOUBTYPE THEN 00174631 - BEGIN 00174632 - EMITO(CDC); 00174633 - EMITO(DUP); 00174634 - EMITPAIR(1, XCH); 00174635 - EMITO(INX); 00174636 - EMITO(LOD); 00174637 - EMITO(XCH); 00174638 - EMITO(LOD); 00174639 - END ELSE EMITO(COC); 00174640 - END ELSE 00174641 - EMITV(LINK); 00174642 - END; 00174643 - END ARRAY REFERENCE; 00174644 - GO TO SPECCHAR; 00174645 - END; 00174646 - IF GLOBALNEXT = NUM THEN 00174647 - BEGIN 00174648 - IF NUMTYPE = STRINGTYPE THEN 00174649 - IF VALREQ THEN 00174650 - BEGIN 00174651 - NUMTYPE~INTYPE ; 00174652 - IF STRINGSIZE=1 THEN FNEXT~STRINGARRAY[0] 00174653 - ELSE BEGIN 00174654 - IF STRINGSIZE>2 OR STRINGARRAY[1].[18:30]!" " THEN 00174655 - FLAG(162) ; 00174656 - IF (FNEXT~STRINGARRAY[1].[12:6]&STRINGARRAY[0][6:12:36]) 00174657 - .[6:6]>7 THEN NUMTYPE~REALTYPE ; 00174658 - END ; 00174659 - END; 00174660 - SAVEADR~ADR; CNSTSEENLAST~TRUE; %113-00174661 - IF NUMTYPE = DOUBTYPE THEN 00174662 - EMITNUM2(FNEXT,DBLOW) ELSE EMITNUM (FNEXT); 00174663 - OPTYPE[IT~IT+1] ~ NUMTYPE; 00174664 - IF EXPRESLT = 0 THEN 00174665 - BEGIN EXPRESLT ~ NUMCLASS; EXPV ~ FNEXT END; 00174666 - SCAN; 00174667 - IF NOT RANDOMTOG THEN 00174668 - IF NEXT=EQUAL THEN BEGIN NEXT~0; OP~6; PREC~4 END; 00174669 - IF NOT VALREQ AND PREC > 0 THEN VALREQ ~ TRUE; 00174670 - IF GLOBALNEXT = ID OR GLOBALNEXT = NUM THEN 00174671 - BEGIN FLOG(1); GO TO XIT END; 00174672 - END; 00174673 - SPECCHAR: 00174674 - IF GLOBALNEXT = LPAREN THEN 00174675 - BEGIN 00174676 - SCAN; 00174677 - OPTYPE[IT~IT+1] ~ EXPR(TRUE); 00174678 - IF GLOBALNEXT = COMMA AND EXPRESULT = NUMCLASS THEN 00174679 - BEGIN 00174680 - IF OPTYPE[IT] > REALTYPE THEN FLAG(85); 00174681 - SCAN; 00174682 - IF EXPR(TRUE) > REALTYPE 00174683 - OR EXPRESULT ! NUMCLASS THEN FLAG(85); 00174684 - EMITO(XCH); 00174685 - OPTYPE[IT] ~ COMPTYPE; 00174686 - IF EXPRESLT = 0 THEN EXPRESLT ~ NUMCLASS; 00174687 - END ELSE EXPRESLT ~ EXPCLASS; 00174688 - IF GLOBALNEXT ! RPAREN THEN 00174689 - BEGIN FLOG(108); GO TO XIT END; 00174690 - GO TO LOOP; 00174691 - END; 00174692 - WHILE PR[IP] } PREC DO 00174693 - BEGIN 00174694 - IF IT { SAVIT THEN GO TO XIT; 00174695 - CODE ~ MAP[T1~OPTYPE[IT-1]]|3 + MAP[T2~OPTYPE[IT]]; 00174696 - CASE OPST[IP] OF 00174697 - BEGIN 00174698 - GO TO XIT; 00174699 - BEGIN 00174700 - IF T1 = LOGTYPE AND T2 = LOGTYPE THEN EMITO(LOR) 00174701 - ELSE FLAG(51); 00174702 - IT ~ IT-1; 00174703 - END; 00174704 - BEGIN 00174705 - IF T1 = LOGTYPE AND T2 = LOGTYPE THEN EMITO(LND) 00174706 - ELSE FLAG(52); 00174707 - IT ~ IT-1; 00174708 - END; 00174709 - IF T2 = LOGTYPE THEN EMITO(LNG) ELSE FLAG(53); 00174710 - BEGIN T ~ LESS; GO TO RELATION END; 00174711 - BEGIN T ~ LEQL; GO TO RELATION END; 00174712 - BEGIN T ~ EQUL; GO TO RELATION END; 00174713 - BEGIN T ~ GRTR; GO TO RELATION END; 00174714 - BEGIN T ~ GEQL; GO TO RELATION END; 00174715 - BEGIN T ~ NEQL; 00174716 - RELATION: 00174717 - IF CODE < 0 THEN FLAG(54) ELSE 00174718 - CASE CODE OF 00174719 - BEGIN ; 00174720 - BEGIN 00174721 - E0(CHS); EP(9,STD); E0(XCH); EOL(9); E0(XCH); EP(0,XCH) ;00174722 - E0(AD2) ; 00174723 - END; 00174724 - FLAG(90); 00174725 - BEGIN EMITPAIR(0, XCH); EMITO(SB2) END; 00174726 - EMITO(SB2); 00174727 - FLAG(90); 00174728 - FLAG(90); 00174729 - FLAG(90; 00174730 - IF T! EQUL AND T! NEQL THEN FLAG(54) %103-00174731 - ELSE %103-00174732 - BEGIN %103-00174733 - EP(9,STD); E0(XCH); EOL(9); E0(T); %103-00174734 - T~(IF T=EQUL THEN LND ELSE LOR); CODE~0; %103-00174735 - END; %103-00174736 - END RELATION CASE STATEMENT; 00174737 - IF CODE > 0 THEN 00174738 - BEGIN EMITO(XCH); EMITO(DFL); EMITL(0) END; 00174739 - EMITO(T); 00174740 - OPTYPE[IT~IT-1] ~ LOGTYPE; 00174741 - END; 00174742 - IF CODE < 0 THEN BEGIN FLAG(53); IT ~ IT-1 END ELSE 00174743 - CASE CODE OF 00174744 - BEGIN 00174745 - BEGIN 00174746 - EMITO(ADD); 00174747 - IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 00174748 - OPTYPE[IT~IT-1] ~ REALTYPE; 00174749 - END; 00174750 - BEGIN TM~AD2 ; 00174751 - RPLUSD: EP(9,STD); E0(XCH); EOL(9); E0(XCH); EP(0,XCH); E0(TM) ; 00174752 - DTYP: OPTYPE[IT~IT-1]~DOUBTYPE ; 00174753 - END ; 00174754 - BEGIN TM~ADD; GO RLESSC END ; 00174755 - BEGIN 00174756 - EMITPAIR(0, XCH); 00174757 - EMITO(AD2); 00174758 - IT ~ IT-1; 00174759 - END; 00174760 - BEGIN EMITO(AD2); IT ~ IT-1 END; 00174761 - BEGIN TM~ADD; GO DLESSC END ; 00174762 - BEGIN EMITO(ADD); IT ~ IT-1 END; 00174763 - BEGIN TM~ADD; GO CLESSD END ; 00174764 - BEGIN TM~ADD; GO CLESSC END ; 00174765 - END ADD CASE STATEMENT; 00174766 - IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 00174767 - CASE CODE OF 00174768 - BEGIN 00174769 - BEGIN 00174770 - EMITO(SUB); 00174771 - IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 00174772 - OPTYPE[IT~IT-1] ~ REALTYPE; 00174773 - END; 00174774 - BEGIN E0(CHS); TM~AD2; GO RPLUSD END; 00174775 - BEGIN TM~SUB ; 00174776 - RLESSC: ES1(TM); GO DLESSC1 ; 00174777 - END ; 00174778 - BEGIN 00174779 - EMITPAIR(0, XCH); 00174780 - EMITO(SB2); 00174781 - IT ~ IT-1; 00174782 - END; 00174783 - BEGIN EMITO(SB2); IT ~ IT-1 END; 00174784 - BEGIN TM~SUB ; 00174785 - DLESSC: ES1(TM); E0(XCH); E0(DEL) ; 00174786 - DLESSC1: EOL(9); IF TM=SUB THEN E0(CHS); GO CTIMESR2 ; 00174787 - END ; 00174788 - BEGIN EMITO(SUB); IT ~ IT-1 END; 00174789 - BEGIN TM~SUB ; 00174790 - CLESSD: E0(XCH); E0(DEL); E0(TM) ; 00174791 - CTYP: OPTYPE[IT~IT-1]~COMPTYPE ; 00174792 - END ; 00174793 - BEGIN TM~SUB ; 00174794 - CLESSC: ES1(TM); GO CTIMESR1 ; 00174795 - END ; 00174796 - END SUBTRACT CASE STATEMENT; 00174797 - BEGIN % HANDLE NEGATIVE NUMBERS CASE STATEMENT. 00174798 - EXPV~-EXPV ; 00174799 - IF T2 { REALTYPE THEN EMITO(CHS) ELSE 00174800 - IF T2 = LOGTYPE THEN FLAG(55) ELSE 00174801 - IF T2 = DOUBTYPE THEN EMITO(CHS) ELSE 00174802 - IF T2 = COMPTYPE THEN 00174803 - BEGIN 00174804 - EMITO(CHS); EMITO(XCH); 00174805 - EMITO(CHS); EMITO(XCH); 00174806 - END ELSE FLAG(55); 00174807 - END OF NEG NUMBERS CASE STATEMNT ; 00174808 - IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 00174809 - CASE CODE OF 00174810 - BEGIN 00174811 - BEGIN 00174812 - EMITO(MUL); 00174813 - IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 00174814 - OPTYPE[IT~IT-1] ~ REALTYPE; 00174815 - END; 00174816 - BEGIN TM~ML2; GO RPLUSD END ; 00174817 - BEGIN ES2; GO DTIMESC END ; 00174818 - BEGIN 00174819 - EMITPAIR(0, XCH); 00174820 - EMITO(ML2); 00174821 - IT ~ IT-1; 00174822 - END; 00174823 - BEGIN EMITO(ML2); IT ~ IT-1 END; 00174824 - BEGIN ES2; E0(XCH); E0(DEL) ; 00174825 - DTIMESC: EOL(9); EOL(17); E0(MUL); GO CTYP ; 00174826 - END ; 00174827 - BEGIN TM~MUL ; 00174828 - CTIMESR: EP(9,SND); E0(TM) ; 00174829 - CTIMESR1:E0(XCH); EOL(9); E0(TM) ; 00174830 - CTIMESR2:E0(XCH); GO CTYP ; 00174831 - END ; 00174832 - BEGIN TM~MUL; GO CDIVBYD END ; 00174833 - MATH(2, 26, COMPTYPE); 00174834 - END MULTIPLY CASE STATEMENT; 00174835 - 00174836 - IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 00174837 - CASE CODE OF 00174838 - BEGIN 00174839 - IF T1 = INTYPE AND T2 = INTYPE THEN 00174840 - BEGIN EMITO(IDV); IT ~ IT-1 END ELSE 00174841 - BEGIN EMITO(DIU); OPTYPE[IT~IT-1] ~ REALTYPE END; 00174842 - BEGIN 00174843 - EP(9,STD); EP(17,STD); EP0(0,XCH); EOL(17); EOL(9); E0(DV2) ; 00174844 - GO DTYP ; 00174845 - END ; 00174846 - MATH(1, 29, COMPTYPE); 00174847 - BEGIN 00174848 - EMITPAIR(0, XCH); 00174849 - EMITO(DV2); 00174850 - IT ~ IT-1; 00174851 - END; 00174852 - BEGIN EMITO(DV2); IT ~ IT-1 END; 00174853 - MATH(2, 32, COMPTYPE); 00174854 - BEGIN TM~DIU; GO CTIMESR END ; 00174855 - BEGIN TM~DIU ; 00174856 - CDIVBYD: E0(XCH); E0(DEL); GO CTIMESR ; 00174857 - END ; 00174858 - MATH(2, 35, COMPTYPE); 00174859 - END OF DIVIDE CASE STATEMENT; 00174860 - IF CODE < 0 THEN BEGIN FLAG(55); IT ~ IT-1 END ELSE 00174861 - BEGIN 00174862 - IF CODE = 0 AND T2 = INTYPE AND 00174863 - CNSTSEENLAST THEN %113-00174864 - BEGIN 00174865 - IF T1 = INTYPE AND T2 = INTYPE THEN IT ~ IT-1 ELSE 00174866 - OPTYPE[IT~IT-1] ~ REALTYPE; 00174867 - EXPV~LINK; %113- 00174868 - A~1; ADR~SAVEADR; %113- 00174869 - WHILE EXPV DIV 2 ! 0 DO 00174870 - BEGIN 00174871 - EMITO(DUP); 00174872 - IF BOOLEAN(EXPV) THEN BEGIN A~A+1; EMITO(DUP) END; 00174873 - EMITO(MUL); 00174874 - EXPV ~ EXPV DIV 2; 00174875 - END; 00174876 - IF EXPV = 0 THEN BEGIN EMITO(DEL); EMITL(1) END ELSE 00174877 - WHILE A ~ A-1 ! 0 DO EMITO(MUL); 00174878 - END ELSE 00174879 - BEGIN 00174880 - EMITO(MKS); 00174881 - EMITL(CODE); 00174882 - EMITV(NEED(".XTOI ", INTRFUNID)); 00174883 - CASE CODE OF 00174884 - BEGIN 00174885 - BEGIN EMITO(DEL); OPTYPE[IT~IT-1]~IF (T1=INTYPE AND T2=INTYPE)00174886 - THEN INTYPE ELSE REALTYPE END; 00174887 - BEGIN EMITO(DEL); OPTYPE[IT~IT-1] ~ DOUBTYPE END; 00174888 - BEGIN EMITO(DEL); OPTYPE[IT~IT-1]~COMPTYPE END ; 00174889 - BEGIN EMITO(DEL); IT ~ IT-1 END; 00174890 - BEGIN EMITO(DEL); EMITO(DEL); IT ~ IT-1 END; 00174891 - BEGIN EMITO(DEL); EMITO(DEL); OPTYPE[IT~IT-1]~COMPTYPE END ; 00174892 - BEGIN EMITO(DEL); IT ~ IT-1 END; 00174893 - BEGIN EMITO(DEL); EMITO(DEL); IT ~ IT-1 END; 00174894 - BEGIN EMITO(DEL); EMITO(DEL); IT~IT-1 END ; 00174895 - END OF POWER CASE STATEMENT; 00174896 - END; 00174897 - END; 00174898 - END; 00174899 - IP ~ IP-1; 00174900 - END; 00174901 - EXPRESLT ~ EXPCLASS; 00174902 - STACK: 00174903 - PR[IP~IP+1] ~ PREC; 00174904 - OPST[IP] ~ OP; 00174905 - IF PREC > 0 AND PREC { 4 THEN 00174906 - BEGIN 00174907 - SCAN; LINK ~ FNEXT; 00174908 - IF NEXT = PLUS THEN GO TO LOOP; 00174909 - IF NEXT ! MINUS THEN GO TO NOSCAN; 00174910 - PREC ~ 8; OP ~ 12; 00174911 - GO TO STACK; 00174912 - END; 00174913 - GO TO LOOP; 00174914 - XIT: IF IP ! SAVIP THEN FLOG(56); 00174915 - IP ~ SAVIP-1; 00174916 - EXPR ~ OPTYPE[IT]; 00174917 - IF OPTYPE[IT-1] ! 0 THEN FLOG(56); 00174918 - IT ~ SAVIT-1; 00174919 - EXPRESULT ~ EXPRESLT; 00174920 - EXPVALUE ~ EXPV; 00174921 - EXPLINK ~ EXPLNK; 00174922 - IF DEBUGTOG THEN FLAGROUTINE(" EXPRE","SSION ",FALSE) ; 00174923 - END EXPR; 00174924 - 00174925 -PROCEDURE FAULT (X); 00174926 - VALUE X; 00174927 - REAL X; 00174928 - BEGIN REAL LINK; LABEL XIT; 00174929 - SCAN; IF GLOBALNEXT ! LPAREN THEN BEGIN FLAG(106); GO XIT END; 00174930 - SCAN; IF GLOBALNEXT ! ID THEN BEGIN FLAG(66); GO TO XIT END; 00174931 - IF X = 1 THEN PDPRT[0,0] ~ PDPRT[0,0] & 1[44:47:1] ELSE 00174932 - PDPRT[0,0] ~ PDPRT [0,0] & 1[43 :47:1]; 00174933 - EMITOPDCLIT(41); EMITO(DUP); 00174934 - IF X = 1 THEN BEGIN EMITL(2); EMITO(XCH); EMITL(1) END 00174935 - ELSE EMITL(6); 00174936 - EMITO(LND); 00174937 - IF X = 2 THEN EMITL(3); 00174938 - EMITO(SUB); 00174939 - IF X = 2 THEN 00174940 - BEGIN EMITO(DUP); EMITL(3); EMITO(SSN) ;EMITO(EQUL); EMITL(2)00174941 - ;EMITO(BFC) ; EMITO(DEL);EMITL(2); 00174942 - END; 00174943 - LINK ~ GET(GETSPACE(FNEXT)); EMITPAIR(LINK.ADDR,ISD); 00174944 - IF X = 1 THEN EMITL(30) ELSE EMITL(25); 00174945 - EMITO(LND); EMITL(41);EMITO(STD); 00174946 - SCAN; IF GLOBALNEXT ! RPAREN THEN FLAG(108); 00174947 - SCAN; 00174948 - XIT: 00174949 - END FAULT; 00174950 -PROCEDURE SUBREF; 00174951 -BEGIN REAL LINK,INFC; 00174952 - REAL ACCIDENT; 00174953 - LABEL XIT; 00174954 -IF DEBUGTOG THEN FLAGROUTINE(" SUB","REF ",TRUE ) ; 00174955 -IF TSSEDITOG THEN IF NAME="ZIP " AND NOT DCINPUT THEN TSSED(NAME,3) ; 00174956 - IF NAME = "EXIT " THEN 00174957 - BEGIN 00174958 - RETURNFOUND ~ TRUE; 00174959 - EMITL(1); 00174960 - EMITPAIR(16,STD); 00174961 - EMITPAIR(10,KOM); 00174962 - EMITPAIR( 5, KOM); 00174963 - PUT(FNEXT+1, "......"); 00174964 - SCAN; 00174965 - END ELSE IF NAME="ZIP " AND NOT DCINPUT THEN 00174966 - BEGIN 00174967 - EMITO(MKS); 00174968 - EMITL(0); EMITL(0); % DUMMY FILE AND FORMAT 00174969 - EMITPAIR(-1,SSN); 00174970 - EMITB(-1,FALSE); LADR1~LAX; ADJUST; DESCREQ~FALSE; 00174971 - IF ADR } 4085 THEN BEGIN ADR~ADR+1; SEGOVF END; 00174972 - ACCIDENT~PRGDESCBLDR(0,0,ADR.[36:10]+1,NSEG); 00174973 - EMITOPDCLIT(19); 00174974 - EMITO(GFW); 00174975 - LISTART ~ ADR&NSEG[TOSEGNO]; ADJUST;SCAN; 00174976 - IF GLOBALNEXT!LPAREN THEN BEGIN FLAG(106);GO TO XIT END; 00174977 - SCAN; IF GLOBALNEXT!ID THEN BEGIN FLAG(66); GO TO XIT END; 00174978 - LINDX ~ FNEXT; SCAN; XTA ~ GET(LINDX+1); 00174979 - IF GLOBALNEXT!RPAREN THEN BEGIN FLAG(108); GO TO XIT END; 00174980 - LINDX ~ GETSPACE(LINDX); 00174981 - IF T~(LINFA~GET(LINDX)).CLASS!ARRAYID THEN 00174982 - BEGIN FLAG(66); GO TO XIT END; 00174983 - IF XREF THEN ENTERX(XTA,0&LINFA[15:15:9]); 00174984 - EMITPAIR(LADDR~LINFA.ADDR,LOD); 00174985 - IF BOOLEAN(LINFA.FORMAL) THEN 00174986 - BEGIN 00174987 - IF T ~ GET(LINDX+2)<0 THEN EMITOPDCLIT(T.SIZE) 00174988 - ELSE EMITNUM(T.SIZE); EMITOPDCLIT(LADDR-1); EMITO(CTF) END 00174989 - ELSE EMITNUM(GET(LINDX+2).BASENSIZE); EMITL(18); EMITO(STD);; 00174990 - EMITL(LINFA.CLASNSUB&0[44:47:1]); EMITL(19); EMITO(STD); 00174991 - BRANCHLIT(LISTART,TRUE); EMITL(19); EMITO(STD); 00174992 - EMITO(RTS); ADJUST; 00174993 - EMITL(1); EMITO(CHS); EMITL(19); EMITO(STD); 00174994 - EMITDESCLIT(19); EMITO(RTS); FIXB(LADR1); DESCREQ~FALSE; 00174995 - EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 00174996 - EMITL(6); % EDITCODE 6 FOR ZIP 00174997 - EMITV(NEED(".FTOUT","INTRFUNID)); SCAN 00174998 - END ELSE IF NAME = "OVERFL" THEN FAULT(2) 00174999 - ELSE IF NAME = "DVCHK " THEN FAULT(1) 00175000 - ELSE 00175001 - BEGIN 00175002 - LINK ~ NEED(NAME, SUBRID); 00175003 - IF XREF THEN ENTERX(XTA,0&GET(LINK)[15:15:5]); 00175004 - EMITO(MKS); 00175005 - SCAN; 00175006 - IF GLOBALNEXT = LPAREN THEN 00175007 - BEGIN PARAMETERS(LINK); SCAN END ELSE 00175008 - IF NOT BOOLEAN((INFC~GET(LINK+2)).[1:1]) THEN 00175009 - PUT(LINK+2,-INFC) ELSE 00175010 - IF INFC.NEXTRA ! 0 THEN 00175011 - BEGIN XTA ~ GET(LINK+1); FLAG(28) END; 00175012 - EMITV(LINK); 00175013 - END; 00175014 - XIT: 00175015 -IF DEBUGTOG THEN FLAGROUTINE(" SUB","REF ",FALSE) ; 00175016 -END SUBREF; 00175017 - 00175018 -PROCEDURE DECLAREPARMS(FNEW); VALUE FNEW; REAL FNEW; 00175019 -BEGIN 00175020 - REAL I, T, NLABELS, INFA, INFB, INFC; 00175021 -IF DEBUGTOG THEN FLAGROUTINE("DECLAR","EPARMS",TRUE ) ; 00175022 - INFA ~ GET(FNEW); 00175023 - IF INFA.SEGNO ! 0 THEN BEGIN XTA ~ NNEW; FLAG(25) END; 00175024 - INFA.SEGNO ~ NSEG; PUT(FNEW,INFA); 00175025 - ENTRYLINK[ELX] ~ 0 & FNEW[TOLINK] & NEXTSS[TOADDR]; 00175026 - FOR I ~ 1 STEP 1 UNTIL PARMS DO 00175027 - BEGIN 00175028 - EXTRAINFO[NEXTSS.IR,NEXTSS.IC] ~ PARMLINK[I]; 00175029 - NEXTSS ~ NEXTSS-1; 00175030 - IF T ~ PARMLINK[I] ! 0 THEN 00175031 - BEGIN 00175032 - GETALL(T,INFA,INFB,INFC); 00175033 - IF BOOLEAN(INFA .FORMAL) THEN 00175034 - BEGIN 00175035 - IF INFA.SEGNO = ELX THEN 00175036 - BEGIN XTA ~ INFB ; FLAG(26) END; 00175037 - END ELSE IF (INFA < 0 AND INFA.ADDR < 1024) OR BOOLEAN(INFA.CE)00175038 - THEN BEGIN XTA ~ INFB; FLAG(107) END; 00175039 - INFA ~ INFA & 1[TOFORMAL] & ELC[TOSEGNO]; 00175040 - INFC .BASE ~ I; 00175041 - PUT(T,INFA); PUT(T+2,INFC); 00175042 - END ELSE NLABELS ~ NLABELS+1; 00175043 - END; 00175044 - IF NLABELS > 0 THEN 00175045 - BEGIN ENTRYLINK[ELX ].CLASS ~ NLABELS; 00175046 - IF LABELMOM=0 THEN BEGIN BUMPLOCALS; LABELMOM~LOCALS+1536 END; 00175047 - END; 00175048 - GETALL(FNEW,INFA,INFB,INFC); 00175049 - IF BOOLEAN(INFC.[1:1]) THEN 00175050 - BEGIN 00175051 - IF INFC.NEXTRA ! PARMS THEN 00175052 - BEGIN XTA ~ INFB; FLOG(41); 00175053 - PARMS ~ INFC.NEXTRA; 00175054 - END; 00175055 - T ~ INFC.ADINFO; 00175056 - FOR I ~ 1 STEP 1 UNTIL PARMS DO 00175057 - IF NOT(PARMLINK[I] = 0 EQV 00175058 - EXTRAINFO[(T+I-1).IR,(T+I-1).IC].CLASS = LABELID) THEN 00175059 - BEGIN IF PARMLINK[I] = 0 THEN XTA ~ "* " 00175060 - ELSE XTA ~ GET(PARMLINK[I]+1); 00175061 - FLAG(40); 00175062 - END; 00175063 - END 00175064 - ELSE 00175065 - BEGIN 00175066 - IF PARMS = 0 THEN INFC ~ -INFC ELSE 00175067 - INFC ~ -(INFC & PARMS[TONEXTRA] 00175068 - & NEXTEXTRA[TOADINFO]); 00175069 - PUT(FNEW+2,INFC); 00175070 - FOR I ~ 1 STEP 1 UNTIL PARMS DO 00175071 - BEGIN 00175072 - EXTRAINFO[NEXTEXTRA.IR,NEXTEXTRA.IC] ~ 0 & 00175073 - (IF PARMLINK[I] = 0 THEN LABELID ELSE 0)[TOCLASS]; 00175074 - NEXTEXTRA ~ NEXTEXTRA+1; 00175075 - END; 00175076 - END; 00175077 - IF ELX ~ ELX+1 > MAXEL THEN BEGIN FLAG(128); ELX ~ 0 END; 00175078 -IF DEBUGTOG THEN FLAGROUTINE("DECLAR","EPARMS",FALSE) ; 00175079 -END DECLAREPARMS; 00175080 -PROCEDURE IOLIST(LEVEL); REAL LEVEL; 00175081 -BEGIN ALPHA LADR2,T; 00175082 -BOOLEAN A; 00175083 -INTEGER INDX,I,BDLINK,NSUBS; 00175084 - LABEL ROUND,XIT,ERROR,LOOP,SCRAM; 00175085 -INTEGER STREAM PROCEDURE CNTNAM(IDEN); VALUE IDEN; 00175086 -BEGIN LABEL XIT; 00175087 - SI ~ LOC IDEN; SI ~ SI + 3; TALLY ~ 1; 00175088 - 5(IF SC = " " THEN JUMP OUT TO XIT;SI ~ SI+1;TALLY ~ TALLY+1); 00175089 - XIT: CNTNAM ~ TALLY; 00175090 -END CNTNAM; 00175091 -IF DEBUGTOG THEN FLAGROUTINE(" IOL","IST ",TRUE ) ; 00175092 -ROUND: DESCREQ ~ TRUE; 00175093 - LOCALNAME ~ FALSE; 00175094 -IF GLOBALNEXT = SEMI THEN GO TO XIT; 00175095 -IF GLOBALNEXT = STAR THEN 00175096 - BEGIN IF NOT NAMEDESC THEN 00175097 - TV ~ ENTER(0&LISTSID[TOCLASS],LISTID~LISTID+1); 00175098 - LOCALNAME ~ TRUE; NAMEDESC ~ TRUE; SCAN; 00175099 - END; 00175100 -IF GLOBALNEXT = ID THEN 00175101 -BEGIN LINDX ~ FNEXT; 00175102 - SCAN; XTA ~ GET(LINDX+1); 00175103 - IF GLOBALNEXT = EQUAL THEN %RETURN TO CALLER 00175104 - BEGIN IF (LINFA~GET(GETSPACE(LINDX))).CLASS ! VARID THEN FLAG(50);00175105 - SCRAM: IF (LEVEL ~ LEVEL-1) < 0 THEN FLOG(97); 00175106 - GO TO XIT; 00175107 - END; 00175108 - 00175109 - IF DATASTMTFLAG AND SPLINK } 0 THEN %DECLARE OWN 00175110 - BEGIN 00175111 - IF BOOLEAN(GET(LINDX).FORMAL) THEN FLAG(147); 00175112 - IF SPLINK>1 THEN 00175113 - IF GET(LINDX).ADDR>1023 THEN FLAG(174); 00175114 - LINDX ~ GETSPACE(-LINDX); 00175115 - IF BOOLEAN(GET(LINDX).EQ) THEN FLAG(168); 00175116 - END ELSE LINDX ~ GETSPACE(LINDX); 00175117 - IF T ~ (LINFA~GET(LINDX)).CLASS > VARID THEN FLAG(50); 00175118 - IF XREF THEN ENTERX(XTA,C2&LINFA[15:15:9]); 00175119 - IF GLOBALNAME OR LOCALNAME THEN 00175120 - IF NAMEIND~ NAMEIND+1 GTR LSTMAX THEN FLOG(161) 00175121 - ELSE NAMLIST[NAMEIND] ~ XTA & CNTNAM(XTA)[9:45:3]; 00175122 - IF T = ARRAYID THEN 00175123 - IF GLOBALNEXT ! LPAREN THEN 00175124 - BEGIN IF SPLINK ! 1 THEN 00175125 - BEGIN 00175126 - EMITL(0); 00175127 - EMITPAIR(LADDR ~ LINFA.ADDR,LOD); 00175128 - EMITO(FTC); 00175129 - EMITDESCLIT(2); 00175130 - EMITO(INX); 00175131 - EMITO(LOD); 00175132 - END ELSE EMITPAIR(LADDR-LINFA.ADDR,LOD); 00175133 - NSUBS ~ (T ~ GET (LINDX+2)).NEXTRA; 00175134 - IF GLOBALNAME OR LOCALNAME THEN 00175135 - BEGIN 00175136 - IF NSUBS GTR SAVESUBS THEN SAVESUBS ~ NSUBS; 00175137 - IF NSUBS GTR NAMLIST[0] THEN NAMLIST[0] ~ NSUBS; 00175138 - NAMLIST[NAMEIND].[1:8] ~ NSUBS; 00175139 - INDX ~ -1; 00175140 - INFA ~ GET(NEED(".SUBAR",BLOCKID)).ADDR; 00175141 - BDLINK ~ T.ADINFO+1; 00175142 - END; 00175143 - IF BOOLEAN (LINFA.FORMAL) THEN 00175144 - BEGIN 00175145 - IF T LSS 0 THEN EMITOPDCLIT(T,SIZE) 00175146 - ELSE EMITNUM(T.SIZE); 00175147 - EMITOPDCLIT(LADDR-1); 00175148 - EMITO(CTF); 00175149 - END ELSE EMITNUM(T.BASENSIZE); 00175150 - IF GLOBALNAME OR LOCALNAME THEN 00175151 - FOR I ~ 1 STEP 1 UNTIL NSUBS DO 00175152 - BEGIN IF T ~ EXTRAINFO[(BDLINK~BDLINK-1).IR, 00175153 - BDLINK.IC] LSS 0 THEN EMITOPDCLIST(T) 00175154 - ELSE EMITNUM(T); 00175155 - EMITNUM(INDX ~ INDX+1); 00175156 - EMITDESCLIT(INFA); 00175157 - EMITO(STD); 00175158 - END; 00175159 - EMITL(18); EMITO(STD); 00175160 - END ELSE 00175161 - BEGIN SCAN; 00175162 - A ~(IF GLOBALNAME OR LOCALNAME 00175163 - THEN SUBSCRIPTS(LINDX,4) ELSE SUBSCRIPTS(LINDX,2)); 00175164 - SCAN; 00175165 - END 00175166 - ELSE EMITN(LINDX); 00175167 - IF GLOBALNAME OR LOCALNAME THEN 00175168 - BEGIN EMITOPDCLIT(18); EMITNUM(NAMEIND); 00175169 - EMITD(43,DIA); EMITD(3,DIB); EMITD(15,TRB); 00175170 - EMITL(18); EMITO(STD); 00175171 - END; 00175172 - EMITL(LINFA.CLASNSUB&0[44:47:1]); 00175173 - EMITL(20); EMITO(STD); 00175174 - IF ADR > 4083 THEN 00175175 - BEGIN ADR~ADR+1; SEGOVF END ; 00175176 - BRANCHLIT(LISTART,TRUE); 00175177 - EMITL(19); EMITO(STD); 00175178 - EMITO(RTS); ADJUST; 00175179 - GO TO LOOP; 00175180 -END; 00175181 -IF GLOBALNEXT = LPAREN THEN % RECURSE ON ( 00175182 -BEGIN EMITB(-1,FALSE); 00175183 - ADJUST; 00175184 - LADR2 ~ (ADR + 1)&LAX[TOADDR]&NSEG[TOSEGNO]; 00175185 - SCAN; LEVEL ~ LEVEL + 1; 00175186 - IOLIST(LEVEL); 00175187 - IF GLOBALNEXT ! EQUAL THEN % PHONY IMP DO 00175188 - BEGIN BRANCHES[T ~ LADR2.ADDR] ~ BRANCHX; 00175189 - BRANCHX ~ T; 00175190 - IF GLOBALNEXT ! RPAREN THEN GO TO ERROR; 00175191 - SCAN; GO TO LOOP; 00175192 - END; 00175193 - IF XREF THEN ENTERX(GET(LINDX+1),1&LINFA[15:15:9]); 00175194 - IF LINFA.SUBCLASS > REALTYPE THEN 00175195 - BEGIN XTA ~ GET(LINDX + 1); 00175196 - FLAG(84); 00175197 - END; 00175198 - EMITB(-1,FALSE); 00175199 - LADR3 ~ LAX; 00175200 - FIXB(LADR2.ADDR); 00175201 - DESCREQ ~ FALSE; 00175202 - SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102); % INITIAL VALUE 00175203 - EMITN(LINDX); EMITO(STD); 00175204 - EMITB(LADR2,FALSE); 00175205 - IF GLOBALNEXT ! COMMA THEN GO TO ERROR; 00175206 - ADJUST; 00175207 - LADR4 ~ (ADR + 1)&NSEG[TOSEGNO]; 00175208 - SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102) ELSE EMITO(GRTR); 00175209 - EMITB(LADR2,TRUE); 00175210 - EMITB(-1,FALSE); 00175211 - LADR5 ~ LAX; 00175212 - FIXB(LADR3); 00175213 - IF GLOBALNEXT ! COMMA THEN EMITL(1) 00175214 - ELSE BEGIN SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(102); END; 00175215 - EMITV(LINDX); EMITO(ADD); 00175216 - EMITN(LINDX); EMITO(SND); 00175217 - EMITB(LADR4,FALSE); 00175218 - FIXB(LADR5); 00175219 - IF GLOBALNEXT = RPAREN THEN SCAN ELSE GO TO ERROR; 00175220 - LOOP: IF GLOBALNEXT = SEMI OR GLOBALNEXT = SLASH THEN GO TO XIT; 00175221 - IF GLOBALNEXT = RPAREN THEN GO TO SCRAM; 00175222 - IF GLOBALNEXT = COMMA THEN 00175223 - BEGIN SCAN; 00175224 - IF GLOBALNEXT = SEMI THEN GO TO ERROR; 00175225 - GO TO ROUND; 00175226 - END; 00175227 - ERROR: XTA ~ NAME; 00175228 - FLAG(94); 00175229 - IF GLOBALNEXT = SEMI THEN GO TO XIT; 00175230 - SCAN; 00175231 - IF GLOBALNEXT = ID THEN GO TO ROUND; 00175232 - ERRORTOG ~ TRUE; GO TO XIT; 00175233 - END; 00175234 - IF GLOBALNEXT = RPAREN THEN GO TO SCRAM ELSE 00175235 - IF GLOBALNEXT ! SLASH THEN GO TO ERROR; 00175236 - XIT: IF DEBUGTOG THEN FLAGROUTINE(" IOL","IST ",FALSE) ; 00175237 - END IOLIST; 00175238 - INTEGER PROCEDURE FILECHECK(FILENAME,FILETYPE); 00175239 - VALUE FILENAME,FILETYPE; ALPHA FILENAME; INTEGER FILETYPE; 00175240 - BEGIN COMMENT THIS PROCEDURE RETURNS THE PRT CELL ALLOCATED TO 00175241 - THE FILE FILENAME... A CELL IS CREATED IF NONE EXISTS; 00175242 - IF DEBUGTOG THEN FLAGROUTINE(" FILEC","HECK ",TRUE); 00175243 - EMITL(IF NOTOPIO THEN 2 ELSE 5); % FOR IO DESCRIPTOR 00175244 - IF T ~ GLOBALSEARCH(FILENAME) = 0 THEN % FILE UNDECLARED 00175245 - BEGIN MAXFILES ~ MAXFILES + 1; 00175246 - BUMPPRT; 00175247 - I ~ GLOBALENTER(-0&(FILECHECK~PRTS)[TOADDR] 00175248 - &FILEID[TOCLASS],FILENAME)+2; 00175249 - INFO[I.IR,I.IC]. LINK ~ FILETYPE; 00175250 - END ELSE % FILE ALREADY EXISTS 00175251 - FILECHECK ~ GET(T).ADDR; 00175252 - IF DEBUGTOG THEN FLAGROUTINE(" FILEC","HECK ",FALSE) ; 00175253 - END FILECHECK; 00175254 - PROCEDURE INLINEFILE; 00175255 - BEGIN COMMENT THIS PROCEDURE GENERATES THE CODE TO BRING UP THE FILE...00175256 - IF THE FILE IS AN INTEGER THEN FILECHECK IS CALLED, IF THE FILE 00175257 - IS NOT AN INTEGER THEN IN-LINE CODE IS GENERATED FOR OBJECT TIME 00175258 - ANALYSIS; 00175259 - REAL TEST; 00175260 - COMMENT IF LAST INSTRUCTION WAS A LIT CALL THEN WE HAVE SEEN REFERENCE 00175261 - TO AN INTEGER FILE ID; 00175262 - IF DEBUGTOG THEN FLAGROUTINE(" INLIN","EFILE ",TRUE ) ; 00175263 - TEST~ADR ; 00175264 - IF EXPR(TRUE)>REALTYPE THEN FLAG(102) 00175265 - ELSE IF EXPRESULT=NUMCLASS THEN 00175266 - BEGIN XTA~NNEW ; 00175267 - IF EXPVALUE}1.0@5 OR EXPVALUE{0.5 THEN FLAG(33) 00175268 - ELSE BEGIN 00175269 - IF ADR LSTMAX THEN GO TO NUL; 00175459 - WSA[TOTAL] ~ I ~ 0; GO TO ROUND; 00175460 - END ELSE GO TO ROUND ELSE GO TO NUL1; 00175461 - END; 00175462 - IF NOT STRINGF THEN 00175463 - IF SLCNT > 0 THEN 00175464 - IF T = "/" THEN BEGIN SLCNT ~ SLCNT+1; GO TO ROUND; END 00175465 - ELSE 00175466 - BEGIN WSA[TOTAL] ~ 0 & SLCNT[TOREPEAT] & SLASH[TOCODE]; 00175467 - IF NOT STR THEN 00175468 - IF REPEAT < 16 AND WSA[TOTAL-1].[42:6] = 0 THEN 00175469 - WSA[TOTAL~TOTAL-1] ~ WSA[TOTAL] & SLCNT[42:44:4] 00175470 - & 1[46:47:1]; 00175471 - COMMAS~DOLLARS~BOOLEAN(SLCNT~0); NCR~BACKNCR(NCR) ; 00175472 - GO TO NUL1; 00175473 - END; 00175474 - IF NOT QF THEN IF T = """ THEN IF STRINGF ~ NOT STRINGF THEN 00175475 - BEGIN IF CODE > 4 THEN BEGIN STRINGF ~ FALSE; 00175476 - NCR ~ BACKNCR(NCR); GO TO ENDER END; 00175477 - SAVTOTAL ~ TOTAL; J~0; I~3; QF ~ TRUE; 00175478 - WSA[TOTAL] ~ 0 & HPHASE[TOCODE]; 00175479 - GO TO ROUND; 00175480 - END ELSE 00175481 - BEGIN 00175482 - WSA[SAVTOTAL] ~ WSA[SAVTOTAL] & J[TOREPEAT]; 00175483 - IF I = 0 THEN TOTAL ~ TOTAL - 1; 00175484 - CODE ~ HPHASE; 00175485 - GO TO ENDER; 00175486 - END; 00175487 - IF STRINGF THEN 00175488 - BEGIN 00175489 - STORECHAR(WSA[TOTAL],I,T); 00175490 - J ~ J + 1; QF ~ FALSE; 00175491 - IF I ~ I+1 = 8 THEN 00175492 - BEGIN 00175493 - IF TOTAL ~ TOTAL +1> LSTMAX THEN GO TO NUL; 00175494 - I ~ WSA[TOTAL] ~ 0; 00175495 - END; 00175496 - GO TO ROUND; 00175497 - END; 00175498 -CASE T OF 00175499 -BEGIN 00175500 - BEGIN ZF ~ TRUE; % 0 00175501 - NUM: DECIMAL ~ 10 | DECIMAL + T; 00175502 - IF ASK THEN 00175503 - BEGIN FLAG(183); %111-00175504 - DO BEGIN NCR~GETCHAR(NCR,T); XTA~T&XTA[12:18:30] END 00175505 - UNTIL T!"*" AND T>9 AND T!" " ; 00175506 - NCR~BACKNCR(NCR); XTA~BLANKS&XTA[18:12:30] ; 00175507 - END 00175508 - ELSE 00175509 - IF DECIMAL>4090 THEN BEGIN FLAG(172); DECIMAL~1 END ; 00175510 - IF CODE = 0 THEN REPEAT ~ DECIMAL 00175511 - ELSE IF PF THEN BEGIN IF DECIMAL>WIDTH AND WIDTH!0 AND CODE! 00175512 - VPHRASE THEN FLAG(129) END ELSE WIDTH~DECIMAL ; 00175513 - GO TO ROUND; 00175514 - END; 00175515 - GO TO NUM; GO TO NUM; GO TO NUM; % 1 2 3 00175516 - GO TO NUM; GO TO NUM; GO TO NUM; % 4 5 6 00175517 - GO TO NUM; GO TO NUM; GO TO NUM; % 7 8 9 00175518 - ; ; ; ; ; ; % # @ Q : > } 00175519 - BEGIN PLUSP ~ TRUE; GO TO ROUND; END; % + 00175520 - BEGIN CODE ~ APHASE; GO TO NOEND END; % A 00175521 - ; % B 00175522 - BEGIN CODE ~ CPHASE; GO TO NOEND END; % C 00175523 - BEGIN CODE ~ DPHASE; GO TO NOEND END; % D 00175524 - BEGIN CODE ~ EPHASE; GO TO NOEND END; % E 00175525 - BEGIN CODE ~ FPHASE; GO TO NOEND END; % F 00175526 - BEGIN CODE ~ GPHASE; GO TO NOEND END; % G 00175527 - BEGIN IF REPEAT = 0 THEN FLOG(130); % H 00175528 - IF ASK THEN BEGIN FLOG(32 ); GO SEMIC END ; 00175529 - HF ~ TRUE; I ~ 3; CODE ~ HPHASE; 00175530 - WSA[TOTAL] ~ 0 & HPHASE[TOCODE] & REPEAT[TOREPEAT]; 00175531 - GO TO ROUND; 00175532 - END; 00175533 - BEGIN CODE ~ IPHASE; GO TO NOEND END; % I 00175534 - BEGIN IF CODE < 11 OR CODE=15 THEN FLOG(134); % . 00175535 - IF CODE=0 OR PF THEN FLOG(32) ; 00175536 - PF~TRUE; DECIMAL~0; ASK~ZF~FALSE ; 00175537 - GO TO ROUND; 00175538 - END; 00175539 - GO TO RP; % [ 00175540 - ; % & 00175541 - LP: 00175542 - BEGIN IF CODE ! 0 THEN FLOG(32); % ( 00175543 - IF ASK THEN REPEAT~4095; IF REPEAT=0 AND ZF THEN FLAG(173) ;00175544 - NAMLIST[SAVLASTLP ~ PARENCT ~ PARENCT+1] ~ 0 & TOTAL[TOWIDTH]00175545 - &(IF REPEAT{0 AND PARENCT>1 THEN 1 ELSE REPEAT)[TOREPEAT] ; 00175546 - IF ASK THEN 00175547 - BEGIN ASK~VRB~FALSE ; 00175548 - WSA[TOTAL]~32&LPPHRASE[TOCODE]&4095[TOREPEAT] ; 00175549 - IF (TOTAL~TOTAL+1)>LSTMAX THEN GO NUL ; 00175550 - END ; 00175551 - ZF~BOOLEAN(REPEAT~DECIMAL~0) ; 00175552 - STR ~ TRUE; 00175553 - GO TO ROUND1; 00175554 - END; 00175555 - ; ; ; % < ~ | 00175556 - BEGIN CODE~JPHASE; WIDTH~-1; GO NOEND END ; % J 00175557 - BEGIN % K 00175558 - IF COMMAS OR CODE!0 THEN BEGIN FLAG(32); COMMAS~TRUE END 00175559 - ELSE BEGIN COMMAS~TRUE ; 00175560 -KK: DO BEGIN NCR~GETCHAR(NCR,T); XTA~T&XTA[12:18:30] END 00175561 - UNTIL T!" " ; 00175562 - IF (T<17 OR (T>25 AND T<33) OR (T>42 AND T<50) OR T>57) 00175563 - THEN BEGIN FLAG(32) ; 00175564 - IF T="*" OR T<10 THEN BEGIN DECIMAL~1; GO FL END ; 00175565 - END ; 00175566 - NCR~BACKNCR(NCR); XTA~BLANKS&XTA[18:12:30] ; 00175567 - END ; 00175568 - GO ROUND ; 00175569 - END OF K ; 00175570 - BEGIN CODE ~ LPHASE; GO TO NOEND; END; % L 00175571 - ; ; % M N 00175572 - BEGIN CODE ~ OPHASE; GO TO NOEND; END; % O 00175573 - BEGIN WSA[TOTAL] ~ 0 & PPHASE[TOCODE] % P 00175574 - & REAL(VRB)[42:47:1] 00175575 - & REAL(MINUSP)[TOSIGN] & REPEAT[TOWIDTH]&1[TOREPEAT]; 00175576 - MINUSP ~ PLUSP ~ FALSE; 00175577 - IF (DECIMAL = 0 AND NOT ZF) THEN FLOG(131); 00175578 - GO TO NUL1; 00175579 - END; 00175580 - ; ; % Q R 00175581 - BEGIN IF DOLLARS OR CODE!0 THEN FLAG(32) % $ 00175582 - ELSE BEGIN DOLLARS~TRUE; GO KK END ; 00175583 - DOLLARS~TRUE; GO ROUND ; 00175584 - END OF DOLLAR SIGN ; 00175585 - IF NOT ASK THEN % * 00175586 - BEGIN 00175587 - IF ZF OR DECIMAL NEQ 0 THEN FLAG(183); DECIMAL:=4095; %111-00175588 - IF CODE=0 THEN REPEAT~DECIMAL 00175589 - ELSE IF NOT PF THEN WIDTH~DECIMAL ; 00175590 - VRB := ASK := LISTEL := TRUE; GO ROUND; %101-00175591 - END ELSE BEGIN DECIMAL:=4095; FLAG(183); GO FL END ; %111-00175592 - BEGIN MINUSP ~ TRUE; GO TO ROUND; END; % - 00175593 - RP: 00175594 - BEGIN IF FIELD THEN BEGIN NCR ~ BACKNCR(NCR); % ) 00175595 - GO TO ENDER; END; 00175596 - IF DECIMAL ! 0 THEN FLAG(32); 00175597 - I ~ IF PARENCT = 1 THEN IF SAVLASTLP > 1 THEN 2 ELSE 1 00175598 - ELSE PARENCT; 00175599 - WSA[TOTAL]~(J~NAMLIST[I])&(TOTAL+1-J~J.[18:12])[TOLINK] 00175600 - & (IF PARENCT ~ PARENCT-1 = 0 THEN 77 ELSE 0)[TODECIMAL]; 00175601 - IF WSA[J].[1:5]=LPPHRASE AND PARENCT!0 THEN 00175602 - BEGIN WSA[J].[18:12]~TOTAL-J; WSA[TOTAL].[18:12]~TOTAL-J ;00175603 - END ; 00175604 - NAMLIST[I].[6:12] ~ 0; 00175605 - CODE ~ HPHASE; 00175606 - GO TO NUL1; 00175607 - END; 00175608 - ; ; % ; LEQ 00175609 - GO TO ROUND; % BLANKS 00175610 - BEGIN SLCNT ~ 1; % / 00175611 -SL: IF CODE=0 THEN IF ASK OR ZF OR DECIMAL!0 THEN 00175612 - BEGIN FLAG(32); ASK~ZF~BOOLEAN(DECIMAL~0) END ; 00175613 - IF CODE<5 THEN IF T="," THEN GO ROUND1 ELSE GO ROUND ELSE GO 00175614 - ENDER ; 00175615 - END; 00175616 - ; % S 00175617 - BEGIN IF REPEAT ! 0 THEN FLAG(32); % T 00175618 - CODE ~ TPHASE; 00175619 - GO TO NOEND; 00175620 - END; 00175621 - ; % U 00175622 - BEGIN VRB~TRUE; CODE~VPHRASE; WIDTH~-1; GO NOEND END ; % V 00175623 - ; % W 00175624 - BEGIN IF REPEAT = 0 THEN FLOG(130); % X 00175625 - IF STR THEN 00175626 - NEWWD: WSA[TOTAL] ~ 0 & XPHASE[TOCODE] & REPEAT[TOWIDTH] 00175627 - & 1[TOREPEAT] 00175628 - & REAL(VRB)[42:47:1] 00175629 - ELSE 00175630 - BEGIN 00175631 - IF (J~WSA[TOTAL-1]).[42:6]>0 OR (I~J.[1:5])=RTPARN 00175632 - OR (REPEAT}32 AND I!XPHASE) THEN GO NEWWD ; 00175633 - IF I=XPHASE AND (I~J.[18:12]+REPEAT){4090 THEN 00175634 - WSA[TOTAL~TOTAL-1] ~ J & I[TOWIDTH] 00175635 - ELSE IF REPEAT } 32 THEN GO TO NEWWD 00175636 - ELSE WSA[TOTAL~TOTAL-1] ~ J & REPEAT[TONUM] 00175637 - & 1[TOCNTRL]; 00175638 - END; 00175639 - GO TO NUL1; 00175640 - END; 00175641 - ; ; % Y Z 00175642 - GO SL ; % , 00175643 - GO TO LP; % % 00175644 - ; ; ; % ! = ] " 00175645 -END OF CASE STATEMENT; 00175646 -FLOG(132); % ILLEGAL CHARACTER; 00175647 -GO TO FALL; 00175648 -ENDER: IF CODE > 4 THEN 00175649 - BEGIN IF WIDTH=0 THEN FLAG(130) ; 00175650 - IF CODE=VPHRASE THEN 00175651 - BEGIN 00175652 - IF WIDTH=-1 THEN IF PF THEN FLAG(130)ELSE WIDTH~ 00175653 - DECIMAL~4094 ELSE 00175654 - IF NOT PF THEN DECIMAL~4094 ; 00175655 - END 00175656 - ELSE 00175657 - IF CODE > 10 AND CODE ! 15 THEN 00175658 - IF DECIMAL = 0 AND NOT ZF) OR NOT PF THEN FLAG(133) 00175659 - ELSE ELSE DECIMAL ~ 0; 00175660 - IF REPEAT=0 THEN REPEAT~1 ; 00175661 - IF WIDTH=-1 THEN WIDTH~0 ; 00175662 - WSA[TOTAL] ~ 0 & CODE[TOCODE] & WIDTH[TOWIDTH] 00175663 - & REPEAT[TOREPEAT] & DECIMAL[TODECIMAL] 00175664 - & REAL(COMMAS) [44:47:1] 00175665 - & REAL(VRB)[42:47:1] 00175666 - & REAL(DOLLARS)[45:47:1]; 00175667 - END ELSE IF DECIMAL ! 0 THEN FLAG(32); 00175668 -NUL1: IF PLUSP THEN FLAG(164); 00175669 - IF CODE!VPHRASE THEN 00175670 - BEGIN 00175671 - IF DOLLARS AND(CODE < 9 OR CODE > 14) THEN FLAG(166); 00175672 - IF COMMAS AND NOT(CODE = 10 OR CODE = 12 OR CODE = 9) 00175673 - THEN FLAG(165); 00175674 - END; 00175675 - VRB~ 00175676 - ERRORTOG ~ FIELD ~ PF ~ PLUSP ~ DOLLARS ~ COMMAS ~ STR ~ FALSE; 00175677 - IF CODE = HPHASE THEN STR ~ TRUE; 00175678 - CODE ~ REPEAT ~ WIDTH ~ 0; 00175679 - XTA ~ BLANKS; 00175680 - GO TO FALL; 00175681 -NOEND: IF FIELD THEN FLAG(32); 00175682 - IF CODE ! TPHASE THEN LISTEL ~ TRUE ELSE REPEAT ~ 1; 00175683 - IF REPEAT=0 AND ZF THEN FLAG(173) ; 00175684 - FIELD ~ TRUE; 00175685 -FALL: IF MINUSP THEN BEGIN FLAG(32); MINUSP ~ FALSE END; 00175686 - ASK~ZF~FALSE ; 00175687 -NUL: DECIMAL ~ 0; 00175688 - IF PARENCT = 0 THEN BEGIN SCN ~ 1; GO TO SEMIC END; 00175689 - IF CODE < 5 THEN 00175690 - IF TOTAL ~ TOTAL+1 > LSTMAX THEN 00175691 - BEGIN FLOG(78);TOTAL ~ TOTAL-2; GO TO SEMIC; END; 00175692 -GO TO ROUND; 00175693 -NOPLACE: IF(DCINPUT OR FREEFTOG) AND (STRINGF OR HF) THEN FLOG(150); 00175694 - IF TSSEDITOG THEN IF (STRINGF OR HF) AND NOT DCINPUT 00175695 - THEN TSSED(XTA,1); 00175696 - IF CONTINUE THEN IF READACARD THEN 00175697 - BEGIN IF LISTOG THEN PRINTCARD; GO TO ROUND; END; 00175698 -SCN ~ 0; NEXT ~ SEMI; 00175699 -SEMIC: 00175700 -IF SCN = 1 THEN SCAN; 00175701 -IF STRINGF THEN FLAG(22); 00175702 -IF NOT LISTEL THEN WSA[0] ~ 0; 00175703 -IF PARENCT ! 0 THEN FLAG(IF PARENCT < 0 THEN 9 ELSE 8); 00175704 -IF D ! 0 THEN PRTSAVER(D,TOTAL+1,WSA); 00175705 -IF DEBUGTOG THEN BEGIN 00175706 - WRITE(LINE,FM) ; 00175707 - FOR I~0 STEP 1 UNTIL TOTAL DO BEGIN 00175708 - WRITE(LINE,[13]//,I,(J~WSA[I].[1:5],J.[6:12],J.[18:12],J.[30:12], 00175709 - J.[41:1],J.[42:4],J.[42:5],J.[44:1],J.[45:1], 00175710 - J.[46:1],J.[46:2],J.[47:1]) ; 00175711 - IF J.[1:5]=2 THEN I~I+(J.[6:12]+2).[36:9] ; 00175712 - END ; 00175713 - WRITE(LINE[DBL]) ; 00175714 - END OF DEBUGSTUFF ; 00175715 -END FORMATER; 00175716 - 00175717 -PROCEDURE EXECUTABLE; 00175718 -BEGIN LABEL XIT; REAL T, J, TS, P; 00175719 - IF SPLINK < 0 THEN FLAG(12); 00175720 - IF LABL = BLANKS THEN GO TO XIT; 00175721 - IF T ~ SEARCH(XTA ~ LABL) = 0 THEN 00175722 - T ~ ENTER(-0 & LABELID[TOCLASS] & (ADR+1)[TOADDR] & 00175723 - NSEG[TOSEGNO], LABL) ELSE 00175724 - BEGIN IF (P ~ GET(T)).CLASS ! LABELID THEN 00175725 - BEGIN FLAG(144); GO TO XIT END; 00175726 - IF P < 0 THEN BEGIN FLAG(20); GO TO XIT END; 00175727 - TS ~ P.ADDR; 00175728 - WHILE TS ! 0 DO 00175729 - BEGIN J ~ GIT(TS); FIXB(TS+10000); TS ~ J END; 00175730 - PUT(T, P~-P & (ADR+1)[TOADDR] & NSEG[TOSEGNO]); 00175731 - IF (T ~ GET(T+2)).BASE ! 0 THEN 00175732 - T ~ PRGDESCBLDR(2, T.BASE, (ADR+1).[36:10], NSEG); 00175733 - END; 00175734 - IF XREF THEN ENTERX(LABL,1&LABELID[TOCLASS]); 00175735 - XIT: 00175736 -END EXECUTABLE; 00175737 - 00175738 -PROCEDURE IOCOMMAND(N); VALUE N; REAL N; 00175739 -COMMENT N COMMAND 00175740 - 0 READ 00175741 - 1 WRITE 00175742 - 2 PRINT 00175743 - 3 PUNCH 00175744 - 4 BACKSPACE 00175745 - 7 DATA; 00175746 -BEGIN LABEL XIT,SUCH,LISTER,NOFORM,FORMER,WRAP,DAAT,NF; 00175747 -LABEL LISTER1; 00175748 - BOOLEAN SUCHTOG, RDTRIN, FREEREAD; 00175749 - BOOLEAN FORMARY, NOFORMT; 00175750 - BOOLEAN NAMETOG; 00175751 -DEFINE DATATOG = DATASTMTFLAG#; 00175752 -REAL T, ACCIDENT, EDITCODE; 00175753 -REAL DATAB; 00175754 -PROCEDURE ACTIONLABELS(UNSEEN); VALUE UNSEEN; BOOLEAN UNSEEN; 00175755 -BEGIN LABEL EOF,ERR,RATA,XIT,ACTION,MULTI; 00175756 - BOOLEAN BACK,GOTERR,GOTEOF; 00175757 -IF UNSEEN THEN SCAN; 00175758 -EOF: IF GOTEOF THEN GO TO MULTI; 00175759 - IF BACK ~ NAME = "END " THEN GO TO ACTION; 00175760 -ERR: IF GOTERR THEN GO TO MULTI; 00175761 - IF NAME ! "ERR " THEN IF GOTEOF THEN 00175762 - BEGIN MULTI: XTA ~ NAME; FLOG(137); 00175763 - GO TO XIT; 00175764 - END ELSE GO TO RATA; 00175765 -ACTION: SCAN; 00175766 - IF NEXT = EQUAL THEN SCAN ELSE GO TO RATA; 00175767 - IF NEXT ! NUM THEN GO TO RATA; 00175768 - IF XREF THEN ENTERX(NAME,0&LABELID[TOCLASS]); 00175769 - IF BACK THEN NX1 ~ NAME ELSE NX2 ~ NAME; 00175770 - SCAN; IF NEXT = RPAREN THEN GO TO XIT; 00175771 - IF NEXT = COMMA THEN SCAN ELSE GO TO RATA; 00175772 - IF BACK THEN 00175773 - BEGIN BACK ~ NOT ( GOTEOF ~ TRUE); 00175774 - GO TO ERR; 00175775 - END; 00175776 - GOTERR ~ TRUE; 00175777 - GO TO EOF; 00175778 -RATA: XTA ~ NAME; FLOG(0); 00175779 -XIT: 00175780 -END ACTIONLABELS; 00175781 -IF DEBUGTOG THEN FLAGROUTINE(" IOCOM","MAND ",TRUE ); 00175782 -EODS~N!7 ; 00175783 -C2 ~ IF N = 0 OR N = 7 THEN 1 ELSE 0; 00175784 -SCAN; IF NEXT = SEMI THEN BEGIN FLOG(0); GO TO XIT END; 00175785 -IF N = 7 THEN 00175786 -BEGIN DATATOG ~ TRUE; 00175787 - IF LOGIFTOG THEN FLAG(101); 00175788 - LABL ~ BLANKS; 00175789 - IF SPLINK } 0 THEN %NOT BLOCK DATA STMT 00175790 - BEGIN 00175791 - IF DATAPRT=0 THEN BEGIN 00175792 - DATAPRT~PRTS~PRTS+1; ADJUST; 00175793 - DATASTRT~(ADR+1)&NSEG[TOSEGNO] END 00175794 - ELSE FIXB(DATALINK); 00175795 - EMITOPDCLIT(DATAPRT); EMITO(LNG); 00175796 - EMITB(-1, TRUE); DATAB ~ LAX; 00175797 - END; 00175798 - GO TO DAAT; 00175799 -END; 00175800 - EXECUTABLE; 00175801 -EMITO(MKS); 00175802 -IF N = 4 THEN 00175803 -BEGIN 00175804 - INLINEFILE; 00175805 - BEGIN EMITL(0); EMITL(0); EMITL(0); EMITL(0); 00175806 - EMITL(5); EMITL(0); EMITL(0); 00175807 - EMITV(NEED(".FBINB",INTRFUNID)); 00175808 - END; 00175809 - GO TO XIT; 00175810 -END; 00175811 -EDITCODE ~ NX1 ~ NX1 ~ 0; 00175812 -IF RDTRIN ~ 00175813 - N = 0 THEN IF NEXT = LPAREN THEN GO TO SUCH 00175814 - ELSE EMITDESCLIT(FILECHECK(".5 ",2+17|REAL %503-00175815 - (REMOTETOG))) 00175816 -ELSE IF N = 1 THEN IF NEXT ! LPAREN THEN FLAG(33) 00175817 - ELSE GO TO SUCH 00175818 - ELSE IF N = 2 THEN %503-00175819 - EMITDESCLIT(FILECHECK(".6 ",2+17|REAL %503-00175820 - (REMOTETOG))) 00175821 - ELSE EMITDESCLIT(FILECHECK(".PUNCH",0)); 00175822 -IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 00175823 -GO TO FORMER; 00175824 -SUCH: SCAN; RANDOMTOG~SUCHTOG~TRUE; INLINEFILE ; 00175825 - RANDOMTOG~FREEREAD~FALSE ; 00175826 - IF NEXT = EQUAL THEN % RANDOM KEY 00175827 - BEGIN SCAN; 00175828 - IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 00175829 - IF RDTRIN THEN EMITPAIR(1,ADD); 00175830 - END ELSE IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 00175831 - IF NEXT = RPAREN THEN GO TO NF; 00175832 - IF NEXT ! COMMA THEN BEGIN FLOG(114); GO TO XIT END; 00175833 - SCAN; 00175834 - IF NEXT = ID THEN 00175835 - IF NAME = "ERR " OR NAME = "END " THEN 00175836 - BEGIN ACTIONLABELS(FALSE); 00175837 - NF: IF RDTRIN THEN EMITL(0) ELSE EMITPAIR(1,SSN); 00175838 - EMITL(0); 00175839 - NOFORMT ~ TRUE; 00175840 - SCAN; GO TO NOFORM; 00175841 - END; 00175842 -FORMER: IF ADR } 4085 THEN 00175843 - BEGIN ADR ~ ADR+1; SEGOVF END; 00175844 - IF NEXT = NUM THEN % FORMAT NUMBER 00175845 - BEGIN EDITCODE ~ 1; 00175846 - IF TEST ~ LBLSHFT(NAME) { 0 THEN 00175847 - BEGIN FLAG(135); GO TO LISTER END; 00175848 - IF I ~ SEARCH(TEST) = 0 THEN % NEVER SEEN 00175849 - OFLOWHANGERS(I~ENTER(0&FORMATID[TOCLASS], TEST)) ELSE 00175850 - IF GET(I).CLASS ! FORMATID THEN 00175851 - BEGIN FLAG(143); GO TO LISTER END; 00175852 - IF XREF THEN ENTERX(TEST,0&FORMATID[TOCLASS]); 00175853 - IF GET(I).ADDR = 0 THEN 00175854 - BEGIN EMITLINK((INFC ~ GET(I + 2)).BASE); 00175855 - PUT(I + 2,INFC&ADR[TOBASE]); 00175856 - EMITL(0); EMITL(0); EMITO(NOP); 00175857 - END ELSE 00175858 - BEGIN EMITL(GET(I+ 2).BASE); 00175859 - EMITPAIR(GET(I),ADDR.LOD); 00175860 - END; 00175861 - GO TO LISTER; 00175862 -END ELSE IF RDTRIN THEN IF(FREEREAD := NEXT=SLASH) THEN GO TO LISTER 00175863 -ELSE BEGIN IF NEXT NEQ ID THEN BEGIN FLOG(116);GO TO XIT; END;END 00175864 - ELSE IF NEXT NEQ ID THEN 00175865 - BEGIN IF NEXT = STAR THEN 00175866 - BEGIN NAMEDESC := TRUE; GLOBALNAME := TRUE; 00175867 - TV := ENTER(0&LISTSID[TOCLASS],LISTID:=LISTID+1); 00175868 - SCAN; 00175869 - END; 00175870 - IF NEXT = LPAREN THEN 00175871 - BEGIN SCAN; IF EXPR(TRUE) GTR REALTYPE THEN FLAG(120) ; 00175872 - SCAN; END ELSE EMITL(0); 00175873 - IF GLOBALNAME AND (FREEREAD := NEXT = SLASH) OR FREEREAD THEN 00175874 - GO TO LISTER ELSE BEGIN FLOG(110); GO TO XIT; END; 00175875 - END; 00175876 - GETALL(I ~ FNEXT,INFA,INFB,INFC); 00175877 - IF T ~ INFA.CLASS = ARRAYID THEN % FORMAT ARRAY 00175878 - BEGIN EDITCODE ~ 1; 00175879 - FORMARY ~ TRUE; 00175880 - T ~ EXPR(FALSE); 00175881 - ADR ~ ADR-1; % ELIMINATE XCH EMITTED BY EXPR 00175882 - IF EXPRESULT ! ARRAYID THEN FLOG(116); 00175883 - GO TO LISTER1; % SCAN ALREADY DONE IN EXPR 00175884 - END ELSE 00175885 - IF T = NAMELIST THEN 00175886 - BEGIN NAMETOG := TRUE; 00175887 - IF INFA.ADDR = 0 THEN % REFERENCED, NOT DEF 00175888 - BEGIN EMITLINK(INFC.BASE); 00175889 - PUT(I+ 2,(INFC ~ INFC&ADR[TOBASE])); 00175890 - EMITL(0); EMITL(0); EMITO(NOP); 00175891 - END ELSE 00175892 - BEGIN EMITL(INFC.BASE); 00175893 - EMITPAIR(INFA.ADDR,LOD); 00175894 - END 00175895 - END 00175896 - ELSE IF T = UNKNOWN THEN % ASSUME NAMELIST 00175897 - BEGIN PUT(I,(INFA ~ INFA&NAMELIST[TOCLASS])); 00175898 - NAMETOG := TRUE; 00175899 - OFLOWHANGERS(I); 00175900 - EMITLINK(0); PUT(I + 2,INFC&ADR[TOBASE]); 00175901 - EMITL(0); EMITL(0); EMITO(NOP); 00175902 - END ELSE BEGIN XTA ~ INFB; FLOG(116); GO TO XIT END; 00175903 - SCAN; 00175904 - IF NEXT = COMMA THEN ACTIONLABELS(TRUE); 00175905 - IF SUCHTOG THEN 00175906 - IF NEXT ! RPAREN THEN FLOG(108) ELSE SCAN; 00175907 - IF NEXT ! SEMI THEN BEGIN FLOG(118); GO TO XIT END; 00175908 - EMITL(0); EDITCODE ~ 4; EMITOPDCLIT(7); EMITO(FTC); 00175909 - GO TO WRAP; 00175910 -LISTER: SCAN; 00175911 - IF FREEREAD THEN IF NOT RDTRIN THEN 00175912 - BEGIN IF NEXT ! SLASH THEN EMITO(SSN) ELSE SCAN; 00175913 - IF NEXT = LPAREN THEN 00175914 - BEGIN SCAN; IF EXPR(TRUE) > REALTYPE THEN FLAG(120);SCAN 00175915 - END ELSE EMITL(0); 00175916 - END; 00175917 -LISTER1: 00175918 - IF SUCHTOG THEN 00175919 - BEGIN IF NEXT = COMMA THEN ACTIONLABELS(TRUE); 00175920 - IF NEXT = RPAREN THEN SCAN ELSE BEGIN FLOG(108); GO TO XIT END; 00175921 - END ELSE IF NEXT=COMMA THEN SCAN ELSE IF RDTRIN THEN 00175922 - IF NEXT!SEMI THEN FLOG(114); 00175923 -NOFORM: IF NEXT=SEMI THEN 00175924 - BEGIN IF FREEREAD THEN FLOG(061) ELSE EMITL(0); GO TO WRAP END; 00175925 - IF (NEXT NEQ LPAREN) AND (NEXT NEQ ID) AND (NEXT NEQ STAR) THEN 00175926 - GO TO XIT; 00175927 - EDITCODE ~ EDITCODE + 2; 00175928 -DAAT: EMITB(-1,FALSE); LADR1 ~ LAX; ADJUST; DESCREQ ~ TRUE; 00175929 - IF ADR } 4085 THEN 00175930 - BEGIN ADR ~ ADR+1; SEGOVF; ADJUST END; 00175931 - ACCIDENT ~ PRGDESCBLDR(0,0,ADR.[36:10] + 1,NSEG); 00175932 - EMITOPDCLIT(19); EMITO(GFW); 00175933 - LISTART ~ ADR&NSEG[TOSEGNO]; ADJUST; 00175934 - LA ~ 0; IOLIST(LA); 00175935 - EMITL(1); EMITO(CHS); EMITL(19); EMITO(STD); 00175936 - EMITDESCLIT(19; EMITO(RTS); 00175937 - FIXB(LADR1); DESCREQ ~ FALSE; 00175938 - IF DATATOG THEN 00175939 - BEGIN DATASET; 00175940 - IF NEXT = SLASH THEN SCAN ELSE 00175941 - BEGIN FLOG(110); GO TO XIT END; 00175942 - IF LSTA = 0 THEN BEGIN BUMPPRT; LSTA~PRTS END; 00175943 - IF (LSTMAX - LSTI) { LSTS THEN 00175944 - BEGIN WRITEDATA(LSTI,NXAVIL ~ NXAVIL + 1,LSTP); 00175945 - LSTA ~ PRGDESCBLDR(1,LSTA,0,NXAVIL); 00175946 - LSTI ~ 0; BUMPPRT; LSTA~PRTS; 00175947 - END; 00175948 - MOVEW(LSTT,LSTP[LSTI],(LSTS ~ LSTS + 1).[36:6],LSTS); 00175949 - EMITO(MKS); EMITL(LSTI); EMITPAIR(LSTA,LOD); 00175950 - LSTI ~ LSTI + LSTS; 00175951 - EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 00175952 - EMITL(6); EMITL(0); EMITL(0); 00175953 - EMITV(NEED(".FBINB",INTRFUNID)); 00175954 - IF NEXT = COMMA THEN 00175955 - BEGIN SCAN; GO TO DAAT END; 00175956 - IF SPLINK } 0 THEN BEGIN 00175957 - EMITB(-1,FALSE); DATALINK~LAX; 00175958 - FIXB(DATAB) END; 00175959 - GO TO XIT; 00175960 - END; 00175961 - EMITPAIR(ACCIDENT,LOD); EMITOPDCLIT(7); EMITO(FTF); 00175962 -WRAP: IF NOT FREEREAD AND NOT NAMETOG THEN EMITL(EDITCODE); 00175963 -IF RDTRIN THEN 00175964 -BEGIN IF NX1 = 0 THEN EMITL(0) ELSE EMITLABELDESC(NX1); 00175965 - IF NX2 = 0 THEN EMITL(0) ELSE EMITLABELDESC(NX2); 00175966 - IF FREEREAD THEN EMITV(NEED(".FREFR", INTRFUNID)) 00175967 - ELSE IF NAMETOG THEN EMITV(NEED(".FINAM",INTRFUNID)) 00175968 - ELSE IF FORMARY THEN EMITV(NEED(".FTINT",INTRFUNID)) 00175969 - ELSE IF NOFORMT THEN EMITV(NEED(".FBINB",INTRFUNID)) 00175970 - ELSE EMITV(NEED(".FTNIN",INTRFUNID)); 00175971 -END ELSE 00175972 -IF FREEREAD THEN 00175973 - BEGIN 00175974 - IF NAMEDESC THEN 00175975 - BEGIN 00175976 - PRTSAVER(TV,NAMEIND+1,NAMLIST); 00175977 - EMITL(GET(TV+2).BASE); 00175978 - EMITPAIR(GET(TV).ADDR,LOD); 00175979 - IF NAMLIST[0] = 0 THEN EMITL(0) 00175980 - ELSE EMITPAIR(GET(GLOBALSEARCH(".SUBAR")).ADDR,LOD); 00175981 - NAMLIST[0] := NAMEIND := 0; 00175982 - END ELSE BEGIN EMITL(0);EMITL(0);EMITL(0);END; 00175983 - EMITV(NEED(".FREWR",INTRFUNID)) 00175984 - END ELSE IF NAMETOG THEN EMITV(NEED(".FONAM",INTRFUNID)) 00175985 - ELSE IF FORMARY THEN EMITV(NEED(".FTOUT",INTRFUNID)) 00175986 - ELSE BEGIN 00175987 - IF NX1=0 THEN EMITL(0) ELSE EMITLABELDESC(NX1); 00175988 - IF NX2=0 THEN EMITL(0) ELSE EMITLABELDESC(NX2); 00175989 - IF NOFORMT THEN EMITV(NEED(".FBINB",INTRFUNID)) ELSE 00175990 - EMITV(NEED(".FTNOU",INTRFUNID)); 00175991 - END; 00175992 -XIT: 00175993 - IF NAMEDESC THEN IF RDTRIN THEN FLAG(159) 00175994 - ELSE IF NOT FREEREAD THEN FLAG(160); 00175995 - DATATOG := FALSE; NAMEDESC := FALSE; GLOBALNAME := FALSE; 00175996 -IF DEBUGTOG THEN FLAGROUTINE(" IOCOM","MAND ",FALSE); 00175997 -END IOCOMMAND; 00175998 -PROCEDURE STMTFUN(LINK); VALUE LINK; REAL LINK; 00175999 -BEGIN 00176000 - DEFINE PARAM = LSTT#; 00176001 - REAL SAVEBRAD, I; 00176002 - REAL INFA, INFC, NPARMS, TYPE, PARMLINK, BEGINSUB, RETURN; 00176003 - LABEL XIT,TIX ; 00176004 - IF SPLINK < 0 THEN FLAG(12); 00176005 - LABL ~ BLANKS; 00176006 - FILETOG ~ TRUE; % PREVENTS SCANNER FROM ENTERING IDS IN INFO 00176007 - IF XREF THEN ENTERX(GET(LINK+1),0&STMTFUNID[TOCLASS] 00176008 - &(GET(LINK))[21:21:3]); 00176009 - DO 00176010 - BEGIN 00176011 - SCAN; 00176012 - IF NEXT ! ID THEN BEGIN FLOG(107); GO TO XIT END; 00176013 - PARAM[NPARMS~NPARMS+1] ~ NAME; 00176014 - SCAN; 00176015 - END UNTIL NEXT ! COMMA; 00176016 - IF NEXT ! RPAREN THEN FLOG(108) ELSE SCAN; 00176017 - IF NEXT ! EQUAL THEN BEGIN FLOG(104); GO TO XIT END; 00176018 - EMITB(-1,FALSE); SAVEBRAD ~ LAX; % BRANCH AROUND ST FUN 00176019 - ADJUST; 00176020 - BEGINSUB ~ ADR+1; 00176021 - BUMPLOCALS; EMITPAIR(RETURN~LOCALS+1536,STD); 00176022 - FOR I ~ NPARMS STEP -1 UNTIL 1 DO 00176023 - BEGIN 00176024 - IF T ~ SEARCH(PARAM[I]) ! 0 THEN 00176025 - TYPE ~ GET(T).SUBCLASS ELSE 00176026 - IF T~PARAM[I].[12:6] < "I" OR T > "N" THEN 00176027 - TYPE ~ REALTYPE ELSE TYPE ~ INTYPE; 00176028 - EMITSTORE( ENTER(0&VARID[TOCLASS]&1[TOTYPE] 00176029 - &TYPE[TOSUBCL], PARAM[I]), TYPE); 00176030 - IF XREF THEN ENTERX(NAME,0&VARID[TOCLASS]&TYPE[TOSUBCL]); 00176031 - END; 00176032 - PARMLINK ~ NEXTINFO-3; 00176033 - GETALL(LINK, INFA, XTA, INFC); 00176034 - FILETOG ~ FALSE; 00176035 - SCAN; 00176036 - IF (TYPE~(INFA~GET(LINK)).SUBCLASS)=LOGTYPE OR TYPE=COMPTYPE OR00176037 - (I~EXPR(TRUE))=LOGTYPE OR I=COMPTYPE THEN 00176038 - BEGIN IF I!TYPE THEN FLAG(139); GO TIX END ; 00176039 - IF TYPE=REALTYPE OR TYPE=INTYPE THEN 00176040 - BEGIN 00176041 - IF I=DOUBTYPE THEN BEGIN EMITO(XCH); EMITO(DEL) END; 00176042 - IF TYPE=INTYPE THEN IF I!INTYPE THEN EMITPAIR(1,IDV) ; 00176043 - GO TIX ; 00176044 - END ; 00176045 - IF I!DOUBTYPE THEN EMITPAIR(0,XCH) ; 00176046 -TIX: 00176047 - EMITOPDCLIT(RETURN) ; 00176048 - EMITO(GFW); 00176049 - FIXB(SAVEBRAD); 00176050 - IF INFA.CLASS ! UNKNOWN THEN FLAG(140); 00176051 - PUT(LINK, -INFA & 1[TOTYPE] & NSEG[TOSEGNO] 00176052 - & STMTFUNID[TOCLASS] & BEGINSUB[TOADDR]); 00176053 - PUT(LINK+2, -(0 & NPARMS[TONEXTRA] & ADR[TOBASE] 00176054 - & PARMLINK[36:36:12])); 00176055 - PARMLINK ~ PARMLINK+4; 00176056 - FOR I ~ 1 STEP 1 UNTIL NPARMS DO 00176057 - PUT(PARMLINK ~ PARMLINK-3, "......"); 00176058 - XIT: 00176059 - FILETOG ~ FALSE; 00176060 -END STMTFUN; 00176061 -PROCEDURE ASSIGNMENT; 00176062 -BEGIN 00176063 - LABEL XIT; 00176064 -BOOLEAN CHCK; 00176065 -BOOLEAN I; 00176066 -IF DEBUGTOG THEN FLAGROUTINE(" ASSIG","NMENT ",TRUE ) ; 00176067 - FX1 ~ FNEXT; 00176068 - SCAN; 00176069 - IF NEXT = LPAREN THEN 00176070 - BEGIN 00176071 -CHCK~TRUE; 00176072 - IF GET(FX1).CLASS = UNKNOWN THEN 00176073 - IF EODS THEN 00176074 - BEGIN XTA ~ GET(FX1+1); FLOG(035) ; 00176075 - PUT(FX1,GET(FX1) & ARRAYID[TOCLASS]) ; 00176076 - PUT(FX1+2,GET(FX1+2) & 1[TONEXTRA]) ; 00176077 - END 00176078 - ELSE BEGIN STMTFUN(FX1); GO TO XIT END ; 00176079 - IF XREF THEN ENTERX(GET(FX1+1),1&GET(FX1) [15:15:9]); 00176080 - EODS ~ TRUE ; 00176081 - EXECUTABLE; 00176082 - SCAN; 00176083 - I ~ SUBSCRIPTS(FX1,2); 00176084 - SCAN; 00176085 - END ELSE 00176086 - BEGIN 00176087 - EODS~TRUE ; 00176088 - EXECUTABLE; 00176089 - IF T ~ GET(FX1).CLASS = ARRAYID THEN 00176090 - BEGIN XTA ~ GET(FX1+1); FLAG(74) END; 00176091 - MOVEW(ACCUM[1],HOLDID[0],0,3); 00176092 - IF XREF THEN IF HOLDID[0].[12:12] ! "DO" THEN 00176093 - ENTERX(GET(FX1+1),1&GET(FX1)[21:21:3]&VARID[TOCLASS]); 00176094 - END; 00176095 - IF NEXT ! EQUAL THEN BEGIN FLAG(104); GO TO XIT END; 00176096 - SCAN; 00176097 - IF NEXT=SEMI OR NEXT=COMMA THEN BEGIN FLOG(0); GO TO XIT; END; 00176098 - FX2 ~ EXPR(TRUE); 00176099 - IF NEXT NEQ COMMA THEN IF HOLDID[0] = "DO" THEN IF XREF THEN 00176100 - ENTERX(HOLDID[0] ,1&GET(FX1)[21:21:3]&VARID[TOCLASS]); 00176101 - IF NEXT = COMMA THEN IF CHCK THEN FLOG(56) ELSE 00176102 - IF HOLDID[0].[12:12] ! "DO" THEN FLOG(56) ELSE 00176103 - BEGIN 00176104 - IF LOGIFTOG THEN FLAG(101); 00176105 - IF FX2 > REALTYPE THEN FLAG(102); 00176106 - IF DT ~ DT+1 > MAXDOS THEN BEGIN DT ~ 1; FLAG(138) END; 00176107 - EMITN(FX1~ CHECKDO); 00176108 - EMITO(STD); 00176109 - SCAN; 00176110 - IF NEXT=SEMI THEN BEGIN FLAG(36); GO TO XIT END; 00176111 - IF (ACCUM[0] = ", " OR ACCUM[0] = "; ") AND 00176112 - GLOBALNEXT=NUM AND ABS(FNEXT) > 1023 THEN 00176113 - BEGIN 00176114 - IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 00176115 - IDINFO:=REALID;FNEXT:=ENTER(IDINFO,"2FNV00"&DT[36:36:12]);00176116 - EMITN(FNEXT:=GETSPACE(FNEXT)); EMITO(STD); 00176117 - EMITB(-1,FALSE); LADR1:=LAX; ADJUST; 00176118 - LADR2 ~ (ADR+1) & NSEG[TOSEGNO]; EMITV(FNEXT); 00176119 - END 00176120 - ELSE BEGIN 00176121 - EMITB(-1,FALSE); LADR1:=LAX; ADJUST; 00176122 - LADR2:=(ADR+1)&NSEG[TOSEGNO]; 00176123 - IF EXPR(TRUE) > REALTYPE THEN FLAG(102) ; 00176124 - END ; 00176125 - EMITO(GRTR); 00176126 - EMITB(-1, TRUE); 00176127 - LADR3 ~ LAX; 00176128 - EMITB(-1, FALSE); 00176129 - ADJUST; 00176130 - DOTEST[DT] ~ (ADR+1) & LAX[TOADDR] & NSEG[TOSEGNO]; 00176131 - IF NEXT ! COMMA THEN EMITL(1) ELSE 00176132 - BEGIN 00176133 - SCAN; 00176134 - IF NEXT=SEMI THEN BEGIN FLAG(36); GO TO XIT END ; 00176135 - IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 00176136 - END; 00176137 - EMITV(FX1); 00176138 - EMITO(ADD); 00176139 - EMITN(FX1); 00176140 - EMITO(STN); 00176141 - EMITB(LADR2, FALSE); 00176142 - FIXB(LADR1); 00176143 - FIXB(LADR3); 00176144 - END ELSE EMITSTORE(FX1, FX2); 00176145 - XIT: 00176146 -IF DEBUGTOG THEN FLAGROUTINE(" ASSIG","NMENT ",FALSE ) ; 00176147 -END ASSIGNMENT; 00176148 -BOOLEAN PROCEDURE RINGCHECK; 00176149 -COMMENT THIS PROCEDURE PREVENTS THE POSSIBILITY OF DELINKING A 00176150 - HEADER FROM THE HEADER RING; 00176151 - BEGIN 00176152 - INTEGER I; 00176153 - I~A; 00176154 - DO 00176155 - IF I ~ GETC(I).ADDR = ROOT THEN RINGCHECK ~ TRUE 00176156 - UNTIL I = A; 00176157 - END RINGCHECK; 00176158 -PROCEDURE SETLINK(INFADDR); VALUE INFADDR; INTEGER INFADDR; 00176159 -COMMENT THIS PROCEDURE LINKS AN ELEMENT TO ITS PREVIOUS HEADER; 00176160 -BEGIN 00176161 - INTEGER LAST,I; REAL COML; LABEL XIT; 00176162 -XIT: 00176163 - LAST ~(GETC(INFADDR).LASTC)-1; 00176164 - FOR I ~ INFADDR+2 STEP 1 UNTIL LAST 00176165 - DO BEGIN IF GETC(I).CLASS = ENDCOM THEN I~GETC(I).LINK; 00176166 - IF FX1 = (COML~GETC(I)).LINK THEN 00176167 - IF INFADDR~COML.LASTC=A THEN COM[PWI].LASTC~ROOT 00176168 - ELSE GO XIT ; 00176169 - END; 00176170 -END SETLINK; 00176171 -PROCEDURE DIMENSION; 00176172 -BEGIN 00176173 - LABEL L, LOOP, ERROR ; 00176174 - BOOLEAN DOUBLED, SINGLETOG; %109-00176175 -IF DEBUGTOG THEN FLAGROUTINE(" DIMEN","SION ",TRUE ) ; 00176176 - IF LOGIFTOG THEN FLAG(101); 00176177 - LABL ~ BLANKS; 00176178 - IF NEXT=STAR THEN IF TYPE!DOUBTYPE THEN 00176179 - BEGIN 00176180 - SCAN ; 00176181 - IF NEXT=SUM AND NUMTYPE=INTYPE THEN 00176182 - BEGIN 00176183 - IF FNEXT=4 THEN 00176184 - BEGIN 00176185 - SINGLETOG ~ TRUE; %109-00176186 - IF TYPE=COMPTYPE THEN FLAG(176); GO L ; 00176187 - END ; 00176188 - IF FNEXT=8 THEN 00176189 - BEGIN 00176190 - IF TYPE=REALTYPE THEN TYPE~DOUBTYPE 00176191 - ELSE IF TYPE!COMPTYPE THEN FLAG(177) ; 00176192 - GO L ; 00176193 - END ; 00176194 - END ; 00176195 - FLAG(IF TYPE=REALTYPE THEN 178 00176196 - ELSE 177-REAL(TYPE=COMPTYPE)) ; 00176197 -L: NCR~REAL(NCR.[30:3]!0)+3"677777"+NCR; SCN~1; SCAN ; 00176198 - END ; 00176199 - LOOP: DOUBLED~FALSE; 00176200 - IF NEXT ! ID THEN BEGIN FLOG(105); GO TO ERROR END; 00176201 - FX1 ~ IF SINGLETOG THEN -FNEXT ELSE FNEXT; %109-00176202 - IF TYPE } DOUBTYPE THEN % FIX ARRAY TYPE OFR 00176203 - PUT(FX1,GET(FX1)&TYPE[TOSUBCL]); % BOUNDS ROUTINE 00176204 - IF XREF THEN BEGIN INFA ~ 0&GET(FX1)[15:15:9]; 00176205 - IF TYPE>0 THEN INFA.SUBCLASS~TYPE; 00176206 - END; 00176207 - XTA ~ INFB ~ NAME; 00176208 - SCAN; 00176209 - IF XREF THEN 00176210 - BEGIN IF INFA.CLASS = UNKWOWN THEN 00176211 - INFA.CLASS~IF NEXT=LPAREN THEN ARRAYID ELSE VARID; 00176212 - ENTERX(INFB,INFA); 00176213 - END; 00176214 - IF NEXT=LPAREN THEN BEGIN SCAN; DOUBLED~BOUNDS(FX1) END ELSE 00176215 - IF TYPE = -1 THEN FLOG(103); 00176216 - GETALL(FX1, INFA, XTA, INFC); 00176217 - IF TYPE > 0 THEN 00176218 - IF BOOLEAN(INFA.TYPEFIXED) THEN FLAG(31) ELSE 00176219 - BEGIN 00176220 - IF TYPE > LOGTYPE THEN 00176221 - IF GET(FX1+2) <0 THEN 00176222 - BEGIN 00176223 - IF NOT DOUBLED AND INFA.CLASS=1 THEN 00176224 - BEGIN 00176225 - BUMPLOCALS; 00176226 - LENGTH~LOCALS + 1536; 00176227 - PUT(FX1+2,INFC & LENGTH[TOSIZE]); 00176228 - END 00176229 - END ELSE IF NOT DOUBLED THEN 00176230 - BEGIN IF INFC.SIZE > 16383 THEN FLAG(99); 00176231 - PUT(FX1+2,INFC & (2 | INFC.SIZE)[TOSIZE]); 00176232 - END; 00176233 - PUT (FX1,INFA & 1[TOTYPF] & TYPE[TOSUBCL]); 00176234 - END; 00176235 - IF INFA < 0 THEN FLAG(39) ELSE 00176236 - IF TYPE = -2 THEN 00176237 - BEGIN 00176238 - BAPC(INFA&FX1[TOLINK]&1[TOCE]&ROOT[TOLASTC]); 00176239 - IF BOOLEAN(INFA.CE) THEN FLAG(2); 00176240 - IF BOOLEAN(INFA.EQ) THEN 00176241 - BEGIN 00176242 - COM[NEXTCOM.IR,NEXTCOM.IC].LASTC ~ A ~ INFA.ADDR; 00176243 - B~GETC(ROOT).ADDR ; 00176244 - SETLINK(A); 00176245 - IF NOT RINGCHECK THEN 00176246 - BEGIN 00176247 - COM[PWROOT].ADDR~GETC(A).ADDR ; 00176248 - PUTC(A,GETC(A)&B[TOADDR]&7[TOSUBCL]) ; 00176249 - END 00176250 - END ELSE 00176251 - PUT(FX1, INFA & 1[TOCE] & ROOT[TOADDR]); 00176252 - IF BOOLEAN(INFA.FORMAL) THEN FLAG(10); 00176253 - END; 00176254 - IF ERRORTOG THEN 00176255 - ERROR: 00176256 - WHILE NEXT ! COMMA AND NEXT ! SEMI AND NEXT ! SLASH DO SCAN; 00176257 - IF NEXT = COMMA THEN BEGIN SCAN; GO TO LOOP END; 00176258 -IF DEBUGTOG THEN FLAGROUTINE(" DIMEN","SION ",FALSE ); 00176259 -END DIMENSION; 00176260 -PROCEDURE FORMALPP(PARMSREQ, CLASS); VALUE PARMSREQ, CLASS; 00176261 - BOOLEAN PARMSREQ; REAL CLASS; 00176262 -BEGIN 00176263 - LABEL LOOP, XIT; 00176264 -IF DEBUGTOG THEN FLAGROUTINE(" FORM","ALPP ",TRUE ) ; 00176265 - PARMS ~ 0; 00176266 - SCAN; 00176267 - IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 00176268 - IF CLASS = FUNID THEN 00176269 - IF FUNVAR = 0 THEN 00176270 - BEGIN 00176271 - IF TYPE > 0 THEN 00176272 - IF FUNVAR ~ GLOBALSEARCH(NAME) ! 0 THEN 00176273 - IF BOOLEAN((T ~ GET(FUNVAR)).TYPEFIXED) AND TYPE ! T.SUBCLASS 00176274 - THEN FLAG(31); 00176275 - PUT(FUNVAR ~ FNEXT,GET(FNEXT) & VARID[TOCLASS]); 00176276 - END; 00176277 - FNEW ~ NEED(NNEW ~ NAME, CLASS); 00176278 - ENTERX(NAME,IF CLASS = FUNID THEN 00176279 - 1&GET(FNEW)[15:15:9] ELSE 1&GET(FNEW)[15:15:5]); 00176280 - SCAN; 00176281 - IF NEXT ! LPAREN THEN 00176282 - IF PARMSREQ THEN FLOG(106) ELSE ELSE 00176283 - BEGIN 00176284 - LOOP: 00176285 - SCAN; 00176286 - IF NEXT = ID THEN PARMLINK[PARMS ~ PARMS+1] ~ FNEXT ELSE 00176287 - IF NEXT=STAR AND CLASS!FUNID THEN PARMLINK[PARMS~PARMS+1]~0ELSE00176288 - FLOG(107); 00176289 - IF XREF THEN ENTERX(NAME,IF NEXT = STAR THEN 0 ELSE 00176290 - 0&GET(FNEXT)[15:15:9]); 00176291 - SCAN; 00176292 - IF NEXT = COMMA THEN GO TO LOOP; 00176293 - IF NEXT ! RPAREN THEN FLOG(108); 00176294 - SCAN; 00176295 - END; 00176296 - IF NOT ERRORTOG THEN DECLAREPARMS(FNEW); 00176297 - XIT: 00176298 -IF DEBUGTOG THEN FLAGROUTINE(" FORM","ALPP ",FALSE) ; 00176299 -END FORMALPP; 00176300 - 00176301 -PROCEDURE ENDS; FORWARD; 00176302 - 00176303 -PROCEDURE FUNCTION ; 00176304 -BEGIN 00176305 - REAL A,B,C,I; LABEL FOUND ; 00176306 - IF SPLINK NEQ 0 THEN BEGIN FLAG(5); ENDS; SEGMENTSTART; END; 00176307 - LABL ~ BLANKS; 00176308 - FORMALPP(TRUE, FUNID); 00176309 - GETALL(FNEW, INFA, INFB, INFC); 00176310 - B~NUMINTM1 ; 00176311 - WHILE A+1SUPERMAXCOM THEN 00176390 - BEGIN ROOT~0; FATAL(124) END 00176391 - ELSE ROOT~NEXTCOM ; 00176392 - PUTC(ROOT,0&HEADER[TOCLASS]&1[TOCE]&ROOT[TOADDR]) ; 00176393 - BAPC(Z); 00176394 - END ELSE 00176395 - BEGIN 00176396 - ROOT ~ T.ADINFO; 00176397 - COM[(T~GETC(ROOT).LASTC).IR,T.IC].LINK~NEXTCOM+1 ; 00176398 - IF COM[PWROOT]<0 THEN FLAG(2) ; 00176399 - END; 00176400 - DIMENSION; 00176401 - BAPC(0&ENDCOM[TOCLASS]) ; 00176402 - COM[PWROOT].LASTC~NEXTCOM ; 00176403 - PUT(T~GETC(ROOT+1)+2,GET(T)&ROOT[TOADINFO]) ; 00176404 - IF NEXT ! SEMI THEN GO TO LOOP; 00176405 -END COMMON; 00176406 -PROCEDURE ENDS; 00176407 -BEGIN 00176408 - IF SPLINK=0 THEN FLAG(184) ELSE %112-00176409 - BEGIN %112-00176410 - EODS~FALSE ; 00176411 - IF LOGIFTOG THEN FLAG(101); 00176412 - LABL ~ BLANKS; 00176413 - IF SPLINK < 0 THEN EMITO(XIT) ELSE EMITPAIR(0, KOM); 00176414 - SEGMENT((ADR+4) DIV 4, NSEG, TRUE, EDOC); 00176415 - END; %112-00176416 -END ENDS; 00176417 -PROCEDURE ENTRY; 00176418 -BEGIN 00176419 - REAL SP; 00176420 - IF SPLINK = 0 THEN FLAG(111) ELSE 00176421 - IF SPLINK = 1 THEN BEGIN ELX ~ 0; FLAG(4) END; 00176422 - LABL ~ BLANKS; 00176423 - ADJUST ; 00176424 - SP ~ GET(SPLINK); 00176425 - FORMALPP( (T~SP.CLASS) = FUNID, T); 00176426 - GETALL(FNEW, INFA, INFB, INFC); 00176427 - IF INFA.CLASS = FUNID THEN 00176428 - PUT(FNEW, INFA & 1[TOTYPE] & (SP.SUBCLASS)[TOSUBCL]); 00176429 - PUT(FNEW+2, INFC & (ADR+1)[TOBASE]); 00176430 -END ENTRY; 00176431 -PROCEDURE EQUIVALENCE; 00176432 -COMMENT THIS PROCEDURE MAKES THE COM ENTRY FOR EQUIV ITEMS AND SETS 00176433 - THE EQ BIT IN BOTH THE COM AND INFO TABLES AND LINKS 00176434 - THE HEADS OF CHAINS; 00176435 -BEGIN 00176436 - REAL P, Q, R, S; 00176437 - BOOLEAN FIRST,PCOMM; 00176438 - LABEL XIT; 00176439 - IF LOGIFTOG THEN FLAG(101); 00176440 - LABL ~ BLANKS; 00176441 - DO 00176442 - BEGIN 00176443 - FIRST ~ FALSE; 00176444 - SCAN; 00176445 - IF NEXT ! LPAREN THEN BEGIN FLOG(106); GO TO XIT END; 00176446 - IF NEXTCOM~NEXTCOM+1>SUPERMAXCOM THEN 00176447 - BEGIN ROOT~0; FATAL(124) END 00176448 - ELSE ROOT~NEXTCOM ; 00176449 - PUTC(ROOT,0&HEADER[TOCLASS]&ROOT[TOADDR]) ; 00176450 - BAPC(0); Q~0 ; 00176451 - DO 00176452 - BEGIN 00176453 - SCAN; 00176454 - IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 00176455 - IF XREF THEN ENTERX(NAME,0&GET(FNEXT)[15:15:9]); 00176456 - FX1 ~ FNEXT; 00176457 - LENGTH ~ 0; 00176458 - SCAN; 00176459 - IF NEXT = LPAREN THEN 00176460 - BEGIN 00176461 - IF GET(FX1).CLASS ! ARRAYID THEN 00176462 - BEGIN XTA ~ GET(FX1+1); FLOG(112) END; 00176463 - R ~ 0; P ~ 1; 00176464 - S ~ GET(FX1+2).ADINFO; 00176465 - DO 00176466 - BEGIN 00176467 - SCAN; 00176468 - IF NEXT ! NUM OR NUMTYPE ! INTYPE THEN FLAG(113); 00176469 - LENGTH ~ LENGTH + P|(FNEXT-1); 00176470 - P ~ P|EXTRAINFO[(S+R).IR,(S+R).IC] ; 00176471 - R ~ R-1; 00176472 - SCAN; 00176473 - END UNTIL NEXT ! COMMA; 00176474 - IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 00176475 - IF R!-1 THEN IF R~R+GET(FX1+2).NEXTRA!0 THEN 00176476 - BEGIN XTA~GET(FX1+1); FLAG(IF R>0 THEN 23 ELSE 24) END ; 00176477 - SCAN; 00176478 - END; 00176479 - IF INFA.SUBCLASS > LOGTYPE THEN LENGTH ~ 2|LENGTH ; 00176480 - BAPC(INFA&FX1[TOLINK]&LENGTH[TORELADD]&1[TOEQ]&ROOT[TOLASTC]); 00176481 - IF(PCOMM~BOOLEAN(INFA.CE)) OR BOOLEAN(INFA.EQ) THEN 00176482 - BEGIN 00176483 - IF FIRST AND PCOMM THEN BEGIN XTA~GET(FX1+1); FLAG(2) END 00176484 - ELSE IF NOT FIRST THEN FIRST ~ PCOMM; 00176485 - PUT(FX1,INFA & 1[TOEQ]); 00176486 - COM[NEXTCOM.IR,NEXTCOM.IC].LASTC ~ A ~ INFA.ADDR; 00176487 - B~GETC(ROOT).ADDR ; 00176488 - SETLINK(A); 00176489 - IF NOT RINGCHECK THEN 00176490 - BEGIN 00176491 - COM[PWROOT].ADDR~GETC(A).ADDR ; 00176492 - PUTC(A,GETC(A)&B[TOADDR]&7[TOSUBCL]) ; 00176493 - END 00176494 - END ELSE 00176495 - PUT(FX1,INFA & 1[TOEQ] & ROOT[TOADDR]); 00176496 - IF LENGTH > Q THEN Q ~ LENGTH; 00176497 - IF BOOLEAN(INFA.FORMAL) THEN 00176498 - BEGIN XTA ~ GET(FX1+1); FLAG(11) END; 00176499 - END; 00176500 - END UNTIL NEXT ! COMMA; 00176501 - IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 00176502 - SCAN; 00176503 - PUTC(ROOT+1,Q); 00176504 - BAPC(0&ENDCOM[TOCLASS]) ; 00176505 - COM[PWROOT].LASTC~NEXTCOM ; 00176506 - END UNTIL NEXT ! COMMA; 00176507 - XIT: 00176508 -END EQUIVALENCE; 00176509 -PROCEDURE EXTERNAL; 00176510 -BEGIN 00176511 - IF SPLINK < 0 THEN FLAG( 12); 00176512 - IF LOGIFTOG THEN FLAG(101); 00176513 - LABL ~ BLANKS; 00176514 - DO 00176515 - BEGIN 00176516 - SCAN; 00176517 - IF NEXT ! ID THEN FLOG(105) ELSE 00176518 - BEGIN T ~ NEED(NAME,EXTID); 00176519 - IF XREF THEN ENTERX(NAME,0&GET(T)[15:15:9]); 00176520 - SCAN; 00176521 - END; 00176522 - END UNTIL NEXT ! COMMA; 00176523 -END EXTERNAL; 00176524 -PROCEDURE CHAIN; 00176525 -BEGIN 00176526 - LABEL AGN, XIT; 00176527 - REAL T1; 00176528 - DEFINE FLG(FLG1) = BEGIN FLOG(FLG1); GO TO XIT END#; 00176529 - EXECUTABLE; 00176530 - SCAN; 00176531 - T1 ~ 2; 00176532 - IF FALSE THEN 00176533 - AGN: IF GLOBALNEXT ! COMMA THEN FLG(28); 00176534 - SCAN; 00176535 - IF EXPR(TRUE) > REALTYPE THEN FLG(102); 00176536 - IF (T1 ~ T1 - 1) ! 0 THEN GO TO AGN; 00176537 - IF GLOBALNEXT ! RPAREN THEN FLG(3); 00176538 - EMITPAIR(37,KOM); 00176539 - SCAN; 00176540 - IF GLOBALNEXT ! SEMI THEN FLOG(117); 00176541 - XIT: WHILE GLOBALNEXT ! SEMI DO SCAN; 00176542 -END CHAIN; 00176543 -PROCEDURE GOTOS; 00176544 -BEGIN LABEL XIT; 00176545 - REAL ASSIGNEDID; 00176546 - EODS~TRUE ; 00176547 - EXECUTABLE; 00176548 - SCAN; 00176549 - IF NEXT = NUM THEN 00176550 - BEGIN 00176551 - LABELBRANCH(NAME, FALSE); 00176552 - SCAN; 00176553 - GO TO XIT; 00176554 - END; 00176555 - IF NEXT = ID THEN 00176556 - BEGIN 00176557 - ASSIGNEDID ~ FNEXT; 00176558 - IF XREF THEN ENTERX(XTA,0&GET(FNEXT)[15:15:9]); 00176559 - SCAN; 00176560 - IF NEXT ! COMMA THEN FLOG(114); 00176561 - SCAN; 00176562 - IF NEXT ! LPAREN THEN FLOG(106); 00176563 - DO 00176564 - BEGIN 00176565 - SCAN; 00176566 - IF NEXT ! NUM THEN FLOG(109); 00176567 - EMITV(ASSIGNEDID); 00176568 - EMITNUM(FNEXT); 00176569 - EMITO(NEQL); 00176570 - LABELBRANCH(NAME, TRUE); 00176571 - SCAN; 00176572 - END UNTIL NEXT ! COMMA; 00176573 - IF NEXT ! RPAREN THEN FLOG(108); 00176574 - SCAN; 00176575 - EMITPAIR(1, SSN); % CAUSE INVALID INDEX TERMINATION 00176576 - EMITDESCLIT(10); 00176577 - GO TO XIT; 00176578 - END; 00176579 - IF NEXT ! LPAREN THEN FLOG(106); 00176580 - P ~ 0; 00176581 - DO 00176582 - BEGIN 00176583 - SCAN; 00176584 - IF NEXT ! NUM THEN BEGIN FLOG(109); GO TO XIT END; 00176585 - LSTT[P~P+1] ~ NAME; 00176586 - SCAN; 00176587 - END UNTIL NEXT ! COMMA; 00176588 - IF NEXT ! RPAREN THEN BEGIN FLOG(108); GO TO XIT END; 00176589 - SCAN; 00176590 - IF NEXT ! COMMA THEN BEGIN FLOG(114); GO TO XIT END; 00176591 - SCAN; 00176592 - IT ~ P+1; % DONT LET EXPR WIPE OUT LSTT 00176593 - IF EXPR(TRUE) > REALTYPE THEN FLOG(102); 00176594 - EMITPAIR(JUNK, ISN); 00176595 - EMITPAIR(1,LESS); 00176596 - EMITOPDCLIT(JUNK); 00176597 - EMITO(LOR); 00176598 - EMITOPDCLIT(JUNK); 00176599 - EMITL(3); 00176600 - EMITO(MUL); 00176601 - IF ADR+3|P > 4085 THEN BEGIN ADR~ADR+1; SEGOVF END; 00176602 - EMITO(BFC); 00176603 - EMITPAIR(1, SSN); 00176604 - EMITDESCLIT(10); 00176605 - FOR I ~ 1 STEP 1 UNTIL P DO 00176606 - BEGIN 00176607 - J ~ ADR; LABELBRANCH(LSTT[I], FALSE); 00176608 - IF ADR-J = 2 THEN EMITO(NOP); 00176609 - END; 00176610 - XIT: 00176611 - IT ~ 0; 00176612 -END GOTOS; 00176613 -PROCEDURE IFS; 00176614 -BEGIN REAL TYPE, LOGIFADR, SAVELABL; 00176615 - EODS~TRUE; 00176616 - EXECUTABLE; 00176617 - SCAN; 00176618 - IF NEXT ! LPAREN THEN FLOG(106); 00176619 - SCAN; 00176620 - IF TYPE ~ EXPR(TRUE) = COMPTYPE THEN FLAG(89); 00176621 - IF NEXT ! RPAREN THEN FLOG(108); 00176622 - IF TYPE = LOGTYPE THEN 00176623 - BEGIN 00176624 - EMITB(-1, TRUE); 00176625 - LOGIFADR ~ LAX; 00176626 - LOGIFTOG ~ TRUE; EOSTOG ~ TRUE; 00176627 - SAVELABL ~ LABL; LABL ~ BLANKS; 00176628 - STATEMENT; 00176629 - LABL ~ SAVELABL; 00176630 - LOGIFTOG ~ FALSE; EOSTOG ~ FALSE; 00176631 - FIXB(LOGIFADR); 00176632 - END ELSE 00176633 - BEGIN 00176634 - IF TYPE = DOUBTYPE THEN 00176635 - BEGIN EMITO(XCH); EMITO(DEL) END; 00176636 - SCAN; 00176637 - IF NEXT ! NUM THEN FLOG(109); 00176638 - FX1 ~ FNEXT; NX1 ~ NAME; 00176639 - SCAN; 00176640 - IF NEXT ! COMMA THEN FLOG(114); 00176641 - SCAN; 00176642 - IF NEXT ! NUM THEN FLOG(109); 00176643 - FX2 ~ FNEXT; NX2 ~ NAME; 00176644 - SCAN; 00176645 - IF NEXT ! COMMA THEN FLOG(114); 00176646 - SCAN; 00176647 - IF NEXT ! NUM THEN FLOG(109); 00176648 - FX3 ~ FNEXT; NX3 ~ NAME; 00176649 - SCAN; 00176650 - IF FX2 = FX3 THEN 00176651 - BEGIN 00176652 - EMITPAIR(0,GEQL); 00176653 - LABELBRANCH(NX1, TRUE); 00176654 - LABELBRANCH(NX3, FALSE); 00176655 - IF XREF THEN ENTERX(NX2,0&LABELID[TOCLASS]); 00176656 - END ELSE 00176657 - IF FX1 = FX3 THEN 00176658 - BEGIN 00176659 - EMITPAIR(0,NEQL); 00176660 - LABELBRANCH(NX2, TRUE); 00176661 - LABELBRANCH(NX1, FALSE); 00176662 - IF XREF THEN ENTERX(NX3,0&LABELID[TOCLASS]); 00176663 - END ELSE 00176664 - IF FX1 = FX2 THEN 00176665 - BEGIN 00176666 - EMITPAIR(0,LEQL); 00176667 - LABELBRANCH(NX3, TRUE); 00176668 - LABELBRANCH(NX1, FALSE); 00176669 - IF XREF THEN ENTERX(NX2,0&LABELID[TOCLASS]); 00176670 - END ELSE 00176671 - BEGIN 00176672 - EMITO(DUP); 00176673 - EMITPAIR(0,NEQL); 00176674 - EMITB(-1,TRUE); 00176675 - EMITPAIR(0,LESS); 00176676 - LABELBRANCH(NX3, TRUE); 00176677 - LABELBRANCH(NX1, FALSE); 00176678 - FIXB(LAX); 00176679 - EMITO(DEL); 00176680 - LABELBRANCH(NX2, FALSE); 00176681 - END; 00176682 - END; 00176683 -END IFS; 00176684 -PROCEDURE NAMEL; 00176685 -BEGIN LABEL NIM,XIT,ELMNT,WRAP; 00176686 - IF SPLINK < 0 THEN FLAG(12); 00176687 - IF LOGIFTOG THEN FLAG(101); 00176688 - LABL ~ BLANKS; 00176689 - SCAN; IF NEXT ! SLASH THEN FLOG(110); 00176690 -NIM: SCAN; IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 00176691 - IF J ~ (INFA ~ GET(LADR2 ~ FNEXT)).CLASS = UNKNOWN THEN 00176692 - PUT(LADR2,INFA&NAMELIST[TOCLASS]) 00176693 - ELSE IF J ! NAMELIST THEN 00176694 - BEGIN XTA ~ GET(LADR2 + 1); 00176695 - FLAG(20); 00176696 - END; 00176697 - LSTT[LSTS ~ LADR1 ~ 0] ~ NAME; 00176698 - IF XREF THEN ENTERX(NAME,0&NAMELIST[TOCLASS]); 00176699 - SCAN; IF NEXT ! SLASH THEN FLOG(110); 00176700 -ELMNT: SCAN; IF NEXT ! ID THEN BEGIN FLOG(105); GO TO XIT END; 00176701 - LADR1 ~ LADR1 + 1; 00176702 - IF (T ~ GET(FNEW ~ GETSPACE(FNEXT)).CLASS) > VARID THEN FLAG(48); 00176703 - GETALL(FNEW,INFA,INFB,INFC); 00176704 - IF XREF THEN ENTERX(INFB,0&INFA[15:15:9]); 00176705 - IF LSTS ~ LSTS+1 = LSTMAX THEN BEGIN FLOG(78); GO TO XIT END ELSE 00176706 - LSTT[LSTS] ~ NAME&INFA.CLASNSUB[2:38:10]&0[8:47:1]; 00176707 - IF T = ARRAYID THEN 00176708 - BEGIN J ~ INFC.ADINFO; 00176709 - I ~ INFC.NEXTRA; 00176710 - IF LSTS + I + 1 > LSTMAX THEN 00176711 - BEGIN FLOG(78); GO TO XIT END; 00176712 - LSTT[LSTS ~ LSTS + 1] ~ 0&I[1:42:6] % # DIMENSIONS 00176713 - &INFA.ADDR[7:37:11] % REL ADR 00176714 - &INFC.BASE[18:33:15] % BASE 00176715 - &INFC.SIZE[33:33:15]; % SIZE 00176716 - FOR T ~ J STEP -1 UNTIL J - I + 1 DO 00176717 - LSTT[LSTS ~ LSTS + 1] ~ EXTRAINFO[T.IR,T.IC]; 00176718 - END ELSE BEGIN LSTT[LSTS~LSTS+1]~0&(INFA.ADDR)[7:37:11]; 00176719 - IF BOOLEAN(INFA.CE) THEN LSTT[LSTS]~LSTT[LSTS]&INFC.BASE[18:33:15]00176720 - &INFC.SIZE[33:33:15] END; 00176721 - SCAN; IF NEXT = COMMA THEN GO TO ELMNT; 00176722 - IF NEXT ! SEMI AND NEXT ! SLASH THEN FLOG(115); 00176723 - LSTT[LSTS + 1] ~ 0; 00176724 - LSTT[0].[2:10] ~ LADR1; 00176725 - PRTSAVER(LADR2,LSTS + 2,LSTT); 00176726 - IF NEXT ! SEMI THEN GO TO NIM; 00176727 -XIT: 00176728 -END NAMEL; 00176729 -PROCEDURE PAUSE; 00176730 -IF DCINPUT THEN BEGIN XTA~"PAUSE "; FLOG(151) END ELSE 00176731 -BEGIN 00176732 - EODS~TRUE ; 00176733 - IF TSSEDITOG THEN TSSED("PAUSE ",2) ; 00176734 - EXECUTABLE; 00176735 - SCAN; 00176736 - IF NEXT = SEMI THEN EMITL(0) ELSE 00176737 - IF NEXT = NUM THEN 00176738 - BEGIN 00176739 - EMITNUM(NAME); 00176740 - SCAN; 00176741 - END; 00176742 - EMITPAIR(33, KOM); 00176743 - EMITO(DEL); 00176744 -END PAUSE; 00176745 -PROCEDURE TYPIT(TYP,TMPNXT); VALUE TYP; REAL TYP,TMPNXT ; 00176746 - BEGIN 00176747 - TYPF~TYP; SCAN ; 00176748 - IF NEXT=16 THEN BEGIN TMPNXT~16; FUNCTION END ELSE DIMENSION ; 00176749 - END OF TYPIT ; 00176750 -DEFINE COMPLEX =TYPIT(COMPTYPE,TEMPNEXT) #, 00176751 - LOGICAL =TYPIT(LOGTYPE ,TEMPNEXT) #, 00176752 - DOUBLEPRECISION =TYPIT(DOUBTYPE,TEMPNEXT) #, 00176753 - INTEGERS =TYPIT(INTYPE ,TEMPNEXT) #, 00176754 - REALS =TYPIT(REALTYPE,TEMPNEXT) #; 00176755 -PROCEDURE STOP; 00176756 -BEGIN 00176757 - RETURNFOUND ~ TRUE; 00176758 - EODS~TRUE; 00176759 - EXECUTABLE; 00176760 - COMMENT INITIAL SCAN ALREADY DONE; 00176761 - EMITL(1); 00176762 - EMITPAIR(16,STD); 00176763 - EMITPAIR(10, KOM); 00176764 - EMITPAIR(5, KOM); 00176765 - WHILE NEXT ! SEMI DO SCAN; 00176766 -END STOP; 00176767 -PROCEDURE RETURN; 00176768 -BEGIN LABEL EXIT; 00176769 - REAL T, XITCODE; 00176770 - RETURNFOUND ~ TRUE; 00176771 - EODS~TRUE ; 00176772 - EXECUTABLE; 00176773 - SCAN; 00176774 - IF SPLINK=0 OR SPLINK=1 THEN 00176775 - BEGIN XTA~"RETURN"; FLOG(153); GO EXIT END ; 00176776 - IF NEXT = SEMI THEN 00176777 - BEGIN 00176778 - IF (T ~ GET(SPLINK)).CLASS = FUNID THEN 00176779 - BEGIN 00176780 - EMITV(FUNVAR); 00176781 - IF T.SUBCLASS > LOGTYPE THEN EMITPAIR(JUNK, STD); 00176782 - XITCODE ~ RTN; 00176783 - END ELSE XITCODE ~ XIT; 00176784 - IF ADR } 4077 THEN 00176785 - BEGIN ADR ~ ADR+1; SEGOVF END; 00176786 - EMITOPDCLIT(1538); % F+2 00176787 - EMITPAIR(3, BFC); 00176788 - EMITPAIR(10, KOM); 00176789 - EMITO(XITCODE); 00176790 - EMITOPDCLIT(16); 00176791 - EMITPAIR(1, SUB); 00176792 - EMITPAIR(16, STD); 00176793 - EMITO(XITCODE); 00176794 - GO TO EXIT; 00176795 - END; 00176796 - IF LABELMOM = 0 THEN FLOG(145); 00176797 - IF EXPR(TRUE) > REALTYPE THEN FLAG(102); 00176798 - IF EXPRESULT = NUMCLASS THEN 00176799 - BEGIN IF XREF THEN ENTERX(EXPVALUE,0&LABELID[TOCLASS]); 00176800 - ADR ~ ADR-1;EMITL(EXPVALUE-1) 00176801 - END ELSE 00176802 - EMITPAIR(1, SUB); 00176803 - EMITOPDCLIT(LABELMOM); 00176804 - EMITO(MKS); 00176805 - EMITL(9); 00176806 - EMITOPDCLIT(5); 00176807 - EXIT: 00176808 -END RETURN; 00176809 -PROCEDURE IMPLICIT ; 00176810 - BEGIN 00176811 - REAL R1,R2,R3,R4 ; 00176812 - LABEL R,A,X,L ; 00176813 - IF NOT(LASTNEXT=42 OR LASTNEXT=1000 OR LASTNEXT=30 %110-00176814 - OR LASTNEXT=16 OR LASTNEXT = 11) %110-00176815 - THEN BEGIN FLOG(181); FILETOG~TRUE; GO X END ; 00176816 -R: EOSTOG~ERRORTOG~TRUE; FILETOG~FALSE ; 00176817 - MOVEW(ACCUM[3],ACCUM[2],0,3); SCAN; ERRORTOG~FALSE; FILETOG~TRUE ; 00176818 - IF R1~IF R2~NEXT=18 THEN INTID ELSE IF R3=26 THEN REALID ELSE 0& 00176819 - (IF R3=10 THEN DOUBTYPE ELSE IF R3=19 THEN LOGTYPE ELSE IF R3=00176820 - 6 THEN COMPTYPE ELSE 0)[TOSUBCL]=0 THEN 00176821 - BEGIN FLOG(182); GO X END ; 00176822 - SCN~2; SCAN ; 00176823 - IF NEXT = STAR THEN IF R3!10 THEN 00176824 - BEGIN SCAN ; 00176825 - IF NEXT=NUM AND NUMTYPE=INTYPE THEN 00176826 - BEGIN 00176827 - IF FNEXT=4 THEN BEGIN IF R3=6 THEN FLAG(176); GO L END ; 00176828 - IF FNEXT=8 THEN 00176829 - BEGIN 00176830 - IF R3=26 THEN R1~0&DOUBTYPE[TOSUBCL] 00176831 - ELSE IF R3!6 THEN FLAG(177) ; 00176832 - GO L; 00176833 - END ; 00176834 - END ; 00176835 - FLAG(IF R3=26 THEN 178 ELSE 177-REAL(R3=6)) ; 00176836 -L: NCR~REAL(NCR.[30:3]!0)+3"677777"+NCR; SCN~1; SCAN ; 00176837 - END ; 00176838 - IF NEXT!LPAREN THEN BEGIN FLOG(106); GO X END ; 00176839 -A: SCAN; R4~ERRORCT ; 00176840 - IF R2~NAME.[12:6]<17 OR (R2>25 AND R2<33) OR (R2>41 AND R2<50) 00176841 - OR R2>57 OR NAME.[18:30]!" " THEN FLAG(179) ; 00176842 - SCAN ; 00176843 - IF NEXT!MINUS THEN 00176844 - BEGIN IF ERRORCT=R4 THEN TIPE[IF R2!"0" THEN R2 ELSE 12]~R1 END00176845 - ELSE BEGIN 00176846 - SCAN ; 00176847 - IF R3~NAME.[12:6]<17 OR (R3>25 AND R3<33) OR (R3>41 AND R3<50) 00176848 - OR R3>57 OR NAME.[18:30]!" " THEN FLAG(179) ; 00176849 - IF R3 LEQ R2 THEN FLAG(180) ; 00176850 - IF ERRORCT=R4 THEN FOR R2~R2 STEP 1 UNTIL R3 DO 00176851 - BEGIN 00176852 - IF R2>25 AND R2<33 THEN R2~33 ELSE IF R2>41 AND R2<50 00176853 - THEN R2~50 ; 00176854 - TIPE[IF R2!"0" THEN R2 ELSE 12]~R1 ; 00176855 - END ; 00176856 - SCAN ; 00176857 - END ; 00176858 - IF NEXT=COMMA THEN GO A ; 00176859 - IF NEXT!RPAREN THEN BEGIN FLOG(108); GO X END ; 00176860 - SCAN; IF NEXT=COMMA THEN GO R ; 00176861 - IF NEXT!SEMI THEN BEGIN FLOG(117); GO X END ; 00176862 - IF SPLINK > 1 THEN 00176863 - BEGIN 00176864 - IF BOOLEAN(TYPE.[2:1]) THEN IF GET(SPLINK).CLASS=FUNID THEN 00176865 - BEGIN 00176866 - INFO[SPLINK.IR,SPLINK.IC].SUBCLASS~R3~TIPE[IF R3~GET( 00176867 - SPLINK+1).[12:6]!"0" THEN R3 ELSE 12].SUBCLASS ; 00176868 - INFO[FUNVAR.IR,FUNVAR.IC].SUBCLASS~R3 ; 00176869 - END ; 00176870 - IF R1~GET(SPLINK+2)<0 THEN 00176871 - FOR R2~R1.NEXTRA-1+R1~R1.ADINFO STEP -1 UNTIL R1 DO 00176872 - IF R3~PARMLINK[R2-R1+1]!0 THEN 00176873 - BEGIN 00176874 - EXTRAINFO[R2.IR,R2.IC].SUBCLASS~R4~TIPE[IF R4~ 00176875 - GET(R3+1).[12:6]!"0" THEN R4 ELSE 12] 00176876 - .SUBCLASS ; 00176877 - INFO[R3.IR,R3.IC].SUBCLASS~R4 ; 00176878 - END ; 00176879 - END ; 00176880 -X: WHILE NEXT!SEMI DO SCAN; FILETOG~FALSE ; 00176881 - END OF IMPLICIT ; 00176882 - 00176883 -PROCEDURE SUBROUTINE; 00176884 -BEGIN 00176885 - IF SPLINK NEQ 0 THEN BEGIN FLAG(5); ENDS; SEGMENTSTART; END; 00176886 - LABL ~ BLANKS; 00176887 - FORMALPP(FALSE, SUBRID); 00176888 - SPLINK ~ FNEW; 00176889 -END SUBROUTINE; 00176890 -PROCEDURE MEMHANDLER(N); VALUE N; REAL N ; 00176891 - BEGIN 00176892 - REAL A ; 00176893 - LABEL L1,L2,L3,XIT ; 00176894 - IF DEBUGTOG THEN FLAGROUTINE(" MEMHA","NDLER ",TRUE) ; 00176895 - IF N LEQ 2 THEN 00176896 - BEGIN % FIXED=1, VARYING=2. 00176897 - N~IF N=1 THEN 6 ELSE 0 ; 00176898 -L1: SCAN; 00176899 - IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 00176900 - IF (A~GET(GETSPACE(FNEXT))).CLASS!ARRAYID THEN 00176901 - BEGIN FLOG(35); GO XIT END ; 00176902 - IF XREF THEN ENTERX(XTA,0&A[15:15:9]) ; 00176903 - IF BOOLEAN(A.EQ) OR BOOLEAN(A.FORMAL) THEN FLAG(169) 00176904 - ELSE BEGIN 00176905 - EMITO(MKS); EMITPAIR(A.ADDR,LOD); EMITL(N) ; 00176906 - EMITV(NEED(".MEMHR",INTRFUNID)) ; 00176907 - END ; 00176908 - SCAN; IF NEXT=COMMA THEN GO L1 ; 00176909 - END 00176910 - ELSE IF N=3 THEN 00176911 - BEGIN % AUXMEMED FUNCTION OR SUBROUTINE. 00176912 - SCAN ; 00176913 - IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 00176914 - IF GET(FNEXT+1)!GET(SPLINK+1) THEN 00176915 - BEGIN FLOG(170); GO XIT END ; 00176916 - PUT(SPLINK,GET(SPLINK)&1[TOADJ]) ; 00176917 - IF XREF THEN ENTERX(XTA,0&GET(FNEXT)[15:15:9]); SCAN ; 00176918 - END 00176919 - ELSE BEGIN % RELEASE. 00176920 -L2: SCAN ; 00176921 - IF NEXT!ID THEN BEGIN FLOG(105); GO XIT END ; 00176922 - IF (A~GET(GETSPACE(FNEXT))).CLASS=ARRAYID THEN 00176923 - BEGIN 00176924 - IF BOOLEAN(A.EQ) OR BOOLEAN(A.FORMAL) THEN FLAG(169) 00176925 - ELSE BEGIN 00176926 - EMITO(MKS); EMITPAIR(A.ADDR,LOD) ; 00176927 - EMITPAIR(1,SSN) ; 00176928 - EMITV(NEED(".MEMHR",INRFUNID)) ; 00176929 - END ; 00176930 - IF XREF THEN ENTERX(XTA,0&A[15:15:9]) ; 00176931 - END 00176932 - ELSE IF A.CLASS}BLOCKID OR A.CLASS{LABELID THEN 00176933 - BEGIN FLOG(171); GO XIT END 00176934 - ELSE BEGIN 00176935 - EMITPAIR(A.ADDR,LOD); EMITPAIR(38,KOM) ; 00176936 - EMITO(DFL); GO L3 ; 00176937 - END ; 00176938 - SCAN; IF NEXT=COMMA THEN GO L2 ; 00176939 - END ; 00176940 -XIT:IF DEBUGTOG THEN FLAGROUTINE(" MEMHA","NDLER ",FALSE) ; 00176941 - END OF MEMHANDLER ; 00176942 -PROCEDURE STATEMENT; 00176943 -BEGIN LABEL DOL1, XIT; 00176944 - REAL TEMPNEXT ; 00176945 - BOOLEAN ENDTOG; %112-00176946 - DO SCAN UNTIL NEXT ! SEMI; 00176947 - IF NEXT=ID THEN ASSIGNMENT ELSE IF NEXT LEQ RSH1 THEN 00176948 - CASE(TEMPNEXT~NEXT) OF 00176949 - BEGIN 00176950 - FLOG(16); 00176951 - ASSIGN; 00176952 - IOCOMMAND(4) %BACKSPACE 00176953 - BLOCKDATA; 00176954 - CALL; 00176955 - COMMON; 00176956 - COMPLEX; 00176957 - BEGIN EXECUTABLE; SCAN END; % CONTINUE 00176958 - IOCOMMAND(7); % DATA 00176959 - BEGIN SCAN; TYPE ~ -1; DIMENSION END; 00176960 - DOUBLEPRECISION; 00176961 - BEGIN ENDS; ENDTOG:=TRUE; SCAN END; %112-00176962 - FILECONTROL(1); %ENDFILE 00176963 - ENTRY; 00176964 - EQUIVALENCE; 00176965 - EXTERNAL; 00176966 - BEGIN TYPE ~ -1; FUNCTION END; 00176967 - GOTOS; 00176968 - INTEGERS; 00176969 - LOGICAL; 00176970 - NAMEL; 00176971 - PAUSE; 00176972 - IOCOMMAND(2); %PRINT 00176973 - ; 00176974 - IOCOMMAND(3); %PUNCH 00176975 - IOCOMMAND(0); %READ 00176976 - REALS; 00176977 - RETURN; 00176978 - FILECONTROL(0); %REWIND 00176979 - BEGIN SCAN; STOP END; 00176980 - SUBROUTINE; 00176981 - IOCOMMAND(1); %WRITE 00176982 - FILECONTROL(7); %CLOSE 00176983 - FILECONTROL(6); %LOCK 00176984 - FILECONTROL(4); %PURGE 00176985 - IFS; 00176986 - FORMATER; 00176987 - CHAIN; 00176988 - MEMHANDLER(1) ; %FIXED 00176989 - MEMHANDLER(2) ; %VARYING 00176990 - MEMHANDLER(3) ; %AUXMEM FOR SUBPROGRAMS 00176991 - MEMHANDLER(4) ; %RELEASE 00176992 - IMPLICIT ; 00176993 - END ELSE IF NEXT=EOF THEN GO XIT ELSE BEGIN NEXT~0; FLOG(16) END ; 00176994 - LASTNEXT.[33:15]~TEMPNEXT ; 00176995 - IF NOT ENDTOG THEN IF SPLINK=0 THEN SPLINK:=1; %112-00176996 - ENDTOG:=FALSE; %112-00176997 - IF LABL ! BLANKS THEN 00176998 - BEGIN 00176999 - IF DT ! 0 THEN 00177000 - BEGIN 00177001 - DOL1: IF LABL = DOLAB[TEST ~ DT] THEN 00177002 - BEGIN 00177003 - EMITB(DOTEST[DT], FALSE); 00177004 - FIXB(DOTEST[DT].ADDR); 00177005 - IF DT ~ DT-1 > 0 THEN GO TO DOL1; 00177006 - END ELSE 00177007 - WHILE TEST ~ TEST-1 > 0 DO 00177008 - IF DOLAB[TEST] = LABL THEN FLAG(14); 00177009 - END; 00177010 - LABL ~ BLANKS; 00177011 - END; 00177012 - IF NEXT ! SEMI THEN 00177013 - BEGIN 00177014 - FLAG(117); 00177015 - DO SCAN UNTIL NEXT=SEMI OR NEXT=EOF ; 00177016 - END; 00177017 - ERRORTOG ~ FALSE; 00177018 - EOSTOG ~ TRUE; 00177019 - XIT: 00177020 -END STATEMENT; 00177021 - 00177022 -BOOLEAN STREAM PROCEDURE FLAGLAST(BUFF,ERR) ; 00177023 - BEGIN 00177024 - LOCAL A; SI~ERR; 8(IF SC!" " THEN JUMP OUT;SI~SI+1;TALLY~TALLY+1);00177025 - A~TALLY; SI~LOC A; SI~SI+7 ; 00177026 - IF SC<"8" THEN 00177027 - BEGIN TALLY~1; FLAGLAST~TALLY ; 00177028 - DI~BUFF;DS~46 LIT"LAST SYNTAX ERROR OCCURRED AT SEQUENCE NUMBER ";00177029 - DS~LIT"""; SI~ERR; DS~8 CHR; DS~LIT"""; 00177030 - DS~32 LIT " "; %510-00177031 - DS~32 LIT " "; %510-00177032 - END 00177033 - END FLAGLAST ; 00177034 -INTEGER PROCEDURE FIELD(X); VALUE X; INTEGER X; 00177035 -FIELD~IF X<10 THEN 1 ELSE IF X<100 THEN 2 ELSE IF X<1000 THEN 3 ELSE IF 00177036 -X<10000 THEN 4 ELSE IF X<100000 THEN 5 ELSE IF X<1000000 THEN 6 ELSE 7; 00177037 -FORMAT EOC1(/ "NUMBER OF SYNTAX ERRORS DETECTED = ",I*,".",X*, 00177038 - "NUMBER OF SEQUENCE ERRORS DETECTED = ",I*,"."), 00177039 - EOC2("PRT SIZE = ",I*,"; TOTAL SEGMENT SIZE = ",I*, 00177040 - " WORDS; DISK SIZE = ",I*," SEGS; NO. PRGM. SEGS = ",I*, 00177041 - "."), 00177042 - EOC3("ESTIMATED CORE STORAGE REQUIREMENT = ",I*," WORDS;", 00177043 - " COMPILATION TIME = ",I*," MIN, ",I*," SECS;", 00177044 - " NO. CARDS = ",I*,"."), 00177045 - EOC4("ESTIMATED CORE STORAGE REQUIREMENT = ",I*," WORDS;" 00177046 - " COMPILATION TIME = ",I*," SECS; NO. CARDS = ",I*,"."), 00177047 - EOC5("NUMBER OF TSS WARNINGS DETECTED = ",I*,".") ; 00177048 -COMMENT MAIN DRIVER FOR FORTRAN COMPILER BEGINS HERE; 00177049 -RTI ~ TIME(1); 00177050 -INITIALIZATION; 00177051 - DO STATEMENT UNTIL NEXT = EOF; 00177052 - IF NOT ENDSEGTOG THEN IF SPLINK NEQ 0 %112-00177053 - THEN BEGIN XTA:=BLANKS; FLAG(5); ENDS END; %112-00177054 - WRAPUP; 00177055 -POSTWRAPUP: 00177056 -IF TIMETOG THEN IF FIRSTCALL THEN DATIME; 00177057 -IF NOT FIRSTCALL THEN 00177058 - BEGIN 00177059 - WRITE(RITE,EOC1,FIELD(ERRORCT),ERRORCT,IF SEQERRCT=0 THEN 99 ELSE 00177060 - 5,FIELD(SEQERRCT-1),SEQERRCT-1) ; 00177061 - IF WARNED AND NOT DCINPUT THEN WRITE(RITE,EOC5,FIELD(WARNCOUNT), 00177062 - WARNCOUNT) ; 00177063 - WRITE(RITE,EOC2,FIELD(PRTS),PRTS,FIELD(TSEGSZ),TSEGSZ,FIELD(DALOC-1),00177064 - DALOC-1,FIELD(NXAVIL),NXAVIL) ; 00177065 - IF C1~(TIME(1)-RTI)/60 > 59 THEN WRITE(RITE,EOC3,FIELD(64|ESTIMATE), 00177066 - 64|ESTIMATE,FIELD(C1 DIV 60),C1 DIV 60,FIELD(C1 MOD 60),C1 MOD 60, 00177067 - FIELD(CARDCOUNT-1),CARDCOUNT-1) ELSE WRITE(RITE,EOC4,FIELD(ESTIMATE 00177068 - |64),ESTIMATE|64,FIELD(C1),C1,FIELD(CARDCOUNT-1),CARDCOUNT-1) ; 00177069 - IF ERRORCT>0 THEN IF FLAGLAST(ERRORBUFF,LASTERR) THEN WRITE(RITE,15, 00177070 - ERROBUFF[*]) ; 00177071 - END ; 00177072 -END INNER BLOCK; 00177073 -END. 00177074 + %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