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