github.com/pkimpel.retro-b5500
1
0
Fork 0
mirror of https://github.com/pkimpel/retro-b5500.git synced 2026-02-14 04:04:29 +00:00
Code Releases Activity
Files
127edd65d528a268f00a5f89ced7986ffc90faab
pkimpel.retro-b5500/SYMBOL/FORTRAN.alg_m

8267 lines
670 KiB
Plaintext
Raw Blame History

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