github.com/retro-software.B5500-software
1
0
Fork 0
mirror of https://github.com/retro-software/B5500-software.git synced 2026-02-14 19:16:17 +00:00
Code Issues Releases Wiki Activity
Files
27423c1fa57cd2fb3353268825ed3c19ea7fd3c9
retro-software.B5500-software/Mark-XVI/SYMBOL/FORTRAN.alg_m

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