Trailing-Edge
-
PDP-10 Archives
-
decuslib10-11
-
43,50530/pascmp.pas
There are 4 other files named pascmp.pas in the archive. Click here to see a list.
00100 %$L-,C-,D-,T-,V:001200000217B\
00200 program pascmp;
00300 include 'pasprm.pas'; (* set up tops10 and tops20 *)
00400 %*********************************************************
00500 * *
00600 * *
00700 * STEP-WISE DEVELOPMENT OF A PASCAL COMPILER *
00800 * ****************************************** *
00900 * *
01000 * *
01100 * STEP 5: SYNTAX ANALYSIS INCLUDING ERROR *
01200 * HANDLING; CHECKS BASED ON DECLARA- *
01300 * 15/3/73 TIONS; ADDRESS AND CODE GENERATION *
01400 * FOR A HYPOTHETICAL STACK COMPUTER *
01500 * *
01600 * *
01700 * AUTHOR: URS AMMANN *
01800 * FACHGRUPPE COMPUTERWISSENSCHAFTEN *
01900 * EIDG. TECHNISCHE HOCHSCHULE *
02000 * CH-8006 ZUERICH *
02100 * *
02200 * CODE GENERATION FOR DECSYSTEM 10 BY *
02300 * C.-O. GROSSE-LINDEMANN, F.-W. LORENZ, *
02400 * H.-H. NAGEL, P.J. STIRL *
02500 * *
02600 * MODIFICATIONS TO GENERATE RELOCATABLE OBJECT CODE *
02700 * BY E. KISICKI (DEC 74) *
02800 * *
02900 * DEBUG SYSTEM BY P. PUTFARKEN (DEC 74) *
03000 * *
03100 * INSTITUT FUER INFORMATIK, D-2 HAMBURG 13, *
03200 * SCHLUETERSTRASSE 70 / GERMANY *
03300 * *
03400 * *
03500 *********************************************************\
03600
03700
03800
03900 % HOW TO GENERATE A NEW PASCAL COMPILER
04000
04100 SOURCES:
04200 A) ASCII: PASREL.PAS
04300 RUNTIM.MAC
04400 DEBSUP.MAC
04500 DEBUG .PAS
04600 B) BINARY: PASREL.SHR
04700 PASREL.LOW
04800 PASLIB.REL (CHECK INITPROCEDURE "SEARCH LIBRARIES")
04900
05000 ! IF THE NEW COMPILER SHOULD NOT BE MADE AVAILABLE FOR GENERAL USE ON SYS,
05100 ! ENTER THE APPROPIATE DIRECTORY SPECIFICATIONS IN INITPROCEDURE "SEARCH LIBRARIES"
05200
05300
05400 STEP ACTION
05500
05600 0 SAVE ALL SOURCE FILES ON DECTAPES!!
05700 1 .COPY PASLBN.REL=PASLIB.REL
05800 2 IF THERE ARE NO CHANGES TO RUNTIM.MAC, DEBSUP.MAC, OR DEBUG.PAS
05900 THEN GOTO STEP 9
06000 3 UPDATE RUNTIM.MAC
06100 4 ASSEMBLE " --> RUNTIM.REL
06200 5 UPDATE DEBSUP.MAC
06300 6 ASSEMBLE " --> DEBSUP.REL
06400 7 UPDATE DEBUG.PAS
06500 .RUN PASREL
06600 *DEBUG.PAS --> DEBUG.REL
06700 8 .R FUDGE2
06800 *PASLBN.REL=PASLBN.REL<RUNSP>,RUNTIM.REL<RUNSP>(R)$
06900 *PASLBN.REL=PASLBN.REL<DEBSP>,DEBSUP.REL<DEBSP>(R)$
07000 *PASLBN.REL=PASLBN.REL<DEBUG>,DEBUG.REL<DEBUG>(R)$
07100 *^C
07200 --> PASLBN.REL
07300 9 UPDATE PASREL.PAS
07400 UPDATE "HEADER" IN PASREL.PAS
07500 IF THERE ARE NEW ENTRIES TO RUNSP OR DEBSP
07600 CHECK
07700 INITPROCEDURE "RUNTIME-, DEBUG-SUPPORTS", "SUPPORTS"
07800 AND
07900 PROCEDURE "SUPPORT"
08000 10 .RUN PASREL
08100 *PASREL.PAS --> PASREL.REL
08200 11 .LOAD PASREL,/SEARCH PASLBN.REL
08300 .SSAVE PASREL 36 --> PASREL.SHR
08400 PASREL.LOW
08500
08600 36 K CORE ONLY IF NO RUNTIMECHECK (C-) AND NO DEBUG OPTION (D-) , OTHERWISE MORE !
08700
08800 12 .RENAME PAS1.PAS=PASREL.PAS
08900 13 .RUN PASREL
09000 *PAS1.PAS --> PAS1.REL
09100 14 .LOAD PAS1,/SEARCH PASLBN.REL
09200 .SSAVE PAS1 36 --> PAS1.SHR
09300 PAS1.LOW
09400 14.1 .RENAME PAS2.PAS=PAS1.PAS
09500 14.2 .RUN PAS1
09600 *PAS2.PAS --> PAS2.REL
09700 14.3 .LOAD PAS2,/SEARCH PASLBN.REL
09800 .SSAVE PAS2 36 --> PAS2.SHR
09900 --> PAS2.LOW
10000 15 .R FILCOM
10100 *TTY:=PAS2.LOW,PAS1.LOW
10200 NO DIFFERENCES ENCOUNTERED
10300 *TTY:=PAS2.SHR,PAS1.SHR
10400 FILE 1) DSK:PAS2.SHR CREATED: XXX
10500 FILE 2) DSK:PAS1.SHR CREATED: XXX
10600 400005 604163 XXXXXX 604163 XXXXXX XXXXXX
10700 %FILES ARE DIFFERENT
10800
10900 16 .DELETE PASREL.*,PAS1.*,PAS2.REL,PASLIB.REL
11000 .PRINT PAS2.LST
11100 .RENAME PASREL.*=PAS2.*
11200 .RENAME PASLIB.REL=PASLBN.REL
11300
11400
11500 *******************************************************************\
11600
11700 %HINTS FOR INTERPRETING ABBREVIATED IDENTIFIERS
11800 BRACK : BRACKET "[ ]" IX : INDEX
11900 C : CURRENT L : LOCAL
12000 C : COUNTER L : LEFT
12100 CST : CONSTANT PARENT : "( )"
12200 CTP : IDENTIFIER POINTER P/PTR : POINTER
12300 EL : ELEMENT P/PROC : PROCEDURE
12400 F : FORMAL R : RIGHT
12500 F : FIRST S : STRING
12600 F : FILE SY : SYMBOL
12700 F/FUNC : FUNCTION V : VARIABLE
12800 G : GLOBAL V : VALUE
12900 ID : IDENTIFIER
13000 REL : RELATIVE REL : RELOCATION\
13100
13200 (*LOCAL CHANGE HISTORY
13300 1 CLEAN UP COMMENT SCANNING AND ALLOW /* */ BRACKETS.
13400 NOTE THAT THIS \ WOULD HAVE TERMINATED THIS COMMENT
13500 PRIOR TO FIX.
13600 2 INCREASE STACKANDHEAP, GET CORE IF NEEDED ON PROGRAM
13700 ENTRY, FIX PARAMETER PASSING BUG, LOAD PASREL FROM
13800 SYS: INSTEAD OF DSK:, GENERATE FLOAT AND FIX INLINE.
13900 (FROM HEDRICK)
14000 NB: RUNTIM has now been modified to pass all characters,
14100 including control characters as well as lower case.
14200 It no longer turns tabs into spaces. Thus it was
14300 necessary to put this file through a program that
14400 expanded tabs into spaces when they were in strings.
14500 Thus FILCOM with the old version should specify /S
14600 or lots of irrelevant differences will be found.
14700 3 MAP LOWER CASE TO UPPER EXCEPT IN STRINGS. (DOESN'T
14800 SOLVE THE PROBLEM ABOUT SETS, THOUGH.) HEDRICK.
14900 4 use SCAN for file spec's, and fix to be called by
15000 COMPIL. Hedrick.
15100 5 add /CREF switch. Hedrick.
15200 6 allow PROGRAM statement. Syntax check but ignore it.
15300 fix bug that caused lower case char. after a string to put compiler in loop
15400 allow <> for #
15500 allow LABEL declaration. Syntax check bug ignore it.
15600 with /CREF/OBJ put only 3 instructions per line (4
15700 overflow a LPT line)
15800 use standard PACK and UNPACK
15900 catch illegal characters
16000 7 add /HEAP switch for size of stack and heap
16100 treat lower case as upper in sets
16200 10 Add STRSET and STRWRITE - equivalent to RESET and
16300 REWRITE, but sets I/O into string
16400 also GETINDEX, CLOSE, ROUND, CALLI
16500 ALSO REDID RESET/REWRITE TO TAKE GOOD FILE NAMES
16600 11 Modify compiler to use new RESET/REWRITE.
16700 12 Make PASCAL programs self-expanding
16800 13 ADD DDT SYMBOL NAMES FOR ROUTINES(BLOCK-STRUCTURED)
16900 use PROGRAM name as module and entry name
17000 allow strset/write on non-TEXT files
17100 add opt. 4th arg to strset/write: limit
17200 14 allow read of string - gets rest of line
17300 add rename,dismiss,update,dumpin/out,useti/o, and xblock arg to
17400 reset and friends
17500 15 a few more arg's to some runtimes
17600 16 detect unexpected EOF
17700 17 DECUS VERSION - CHANGE DDT SYMBOLS TO BE OK FOR DEC DDT
17800 20 CMU patch: do packed struct. correctly. Did not adopt:
17900 (1) replace CAMG, etc., for text (their fix did unnecessary work for
18000 the most common cases, and didn't get all of the obscure ones)
18100 (2) use Knuth's defn of MOD (the one here is so much faster, who care about
18200 negative numbers?)
18300 (3) clean up variants in NEW (they say it is unnecessary)
18400 Also: fix ill mem ref if undef var first after READ
18500 21 allow PROGRAM <name>; (i.e. no file list)
18600 allow null field list in record (for null variant, mainly)
18700 fix MOD. Much cleaner fix than CMUs. Usually adds just one instruction
18800 fix compare of PACKED ARRAY OF CHAR. Get it all (I hope)
18900 keep new from storing tag if no id (CMU's fix)
19000 implement +,*,- as set operators
19100 22 restore MOD to be REM (Cyber does it that way)
19200 fix all my added file things to use GETFN to scan
19300 file name, so we properly handle external files, etc.
19400 fix callnonstandard to pass external files
19500 fix writewriteln so doesn't ill mem ref on undef file
19600 23 change enterbody to always zero locals. Needed to ensure
19700 that certain comparisons work, but a good thing anyway.
19800 if typechecking is on, check for following nil or 0 pointer
19900 24 do not allow comparisons except those in manual.
20000 means we don't have to zero locals on proc entry, ever.
20100 add LOC(<proc>) that returns address of proc or ftn
20200 add S:<integer> and H:<integer> comments, to set starting
20300 addr of stack and heap respectively
20400 change starting code to not disturb %rndev, etc. on restart
20500 25 add /ZERO (and $z) to control whether locals initialized
20600 to zero. Useful mostly to help find uninit.'ed pointers.
20700 26 allow record as extended lookup block
20800 add error message's for ext. lookup block
20900 don't check file pointers as if they were pointers!
21000 use getfn instead of getfilename in break,breakin,
21100 and close, to allow non-ascii files
21200 27 add NEWZ that does what NEW used to (zeros what it gets)
21300 30 fix NEW with : syntax, per Nagel.
21400 31 FIX ILL MEM REF IN READREADLN
21500 ADD ERR MSG FOR ASSIGN TO FTN NAME OUTSIDE BODY
21600 32 add APPEND
21700 33 full implementation of PROGRAM statement
21800 version numbering of output files and program
21900 allow proc and func as parameters
22000 remove LOC (subsumed by above)
22100 add $V directive for version number
22200 34 allow list of entry points in PROGRAM statement
22300 35 fix error recovery in BLOCK, especially for /NOMAIN
22400 36 ALLOW DEBUGGING MULTIPLE FILES
22500 remove T- option
22600 NB: I have not removed the variables for T-, and also
22700 supports exist for indeb. and exdeb., though they
22800 are no longer used in PASCMP.
22900 37 fix bug in static link for level one proc's
23000 40 use RESDEV as external name for DISMISS
23100 by default put request for PASLIB before FORLIB
23200 improve format of /OBJECT listing
23300 fix arg's to predefined functions
23400 fix comparison of unpacked strings
23500 41 make it restartable
23600 change kludge for file OUTPUT
23700 42 allow variable records for GET,PUT,and DUMPx
23800 Currently DUMPx implemented in kludgey way.
23900 43 add 5 locations to file block for new runtimes
24000 add PUTX
24100 add optional arg to useti
24200 allow 12 digit octal number
24300 44 Add SETPOS and CURPOS to compiler
24400 45 Add NEXTBLOCK to compiler and make check for
24500 AC overlap with APPEND,UPDATE
24600 46 Repair CALLI to use 1 for true, and accept all
24700 possible argument formats.
24800 47 Add some more functions
24900 Repair calculations for NEW with packed arrays
25000 50 Generate correct code for 400000,,0
25100 Reinitialize file ctl blocks at start
25200 Don't open INPUT or OUTPUT unless asked
25300 51 Allow mismatch of byte size for SETSTRING
25400 Fix GETLINENR
25500 52 Fixes from CMU:
25600 To CALLNONSTANDARD: when depositing directly into
25700 display, moved 2 ac's for all arg's of size 2,
25800 without checking to see if VAR. Assumed AC was
25900 unchanged by BLT.
26000 To SIMPLEEXPRESSION: optimization sometimes negated
26100 a real constant. If had been declared by CONST,
26200 future ref's were to the negated quantity!
26300 53 Problems with dynamic memory expansion:
26400 Arbitrarily asked for 40b more locations above
26500 end of stack (for runtimes). But some odd
26600 procedure calls use more. Need to figure out
26700 how much memory is used.
26800 CORERR just allocated memory up to (P). Should
26900 be 40(P), or however much is really needed.
27000 So add STKOFFMAX, to keep track of how much
27100 really needed. CORALLOC is addr of the test for
27200 sufficient memory, fixed up.
27300 54 More dynamic memory: Need to accumulate offsets
27400 above top of stack, in case of
27500 x(1,2,3,4,5,f(1,2,3,4,5,6)), etc., though an
27600 actual problem seems a bit unlikely.
27700 55 Add require source file feature
27800 56 Clean up syntax for require file
27900 57 add tops20 version
28000 60 make tops20 strings work more like tops10
28100 61 add jsys pseudo-runtime
28200 add tops20 runtimes and restrict runtimes that work only on one system
28300 add +*@ after file name to control gtfjn in tops20
28400 62 make sure there is never data above the stack pointer
28500 63 convert time, runtime, setuwp for tops20
28600 64 input:/ for tops-20
28700 empty entry in record
28800 non-local goto's
28900 fix procedure param's if not in ac's
29000 65 allow extra semicolon in case
29100 remove references to exit labels
29200 66 speed up non-local goto's
29300 67 fix external proc's as proc param's
29400 70 fix ill mem ref if certain errors in type decl
29500 71 make file name in fcb be 7 bit for tops20
29600 72 make two fixup chains for 2 word constants, to
29700 prevent giving LINK an ill mem ref
29800 73 make new use getfn for file names, to get EXTERN files
29900 74 allow new init. so tops10 version can work with emulator
30000 75 fix non-loc goto's - typo made goto chain bad
30100 76 allow a set in reset/rewrite to specify bits.
30200 allow break char set in read/readln
30300 77 fix jsys and reset set arguments
30400 100 fix ac usage in readreadln from strings
30500 101 fix fltr and fix code generation
30600 102 Add klcpu - put improved packed array code under it
30700 103 Fix pointer to global symbol table in case that level
30800 has already been output by some inner procedure
30900 104 Check stack overflow
31000 Check to be sure structures aren't too big
31100 Range check subranges in for loop and value parameters
31200 105 Use tables instead of -40B to convert from lower case
31300 106 Make subranges of reals illegal
31400 107 Abort creation of .REL file on all errors
31500 110 Allow [x..y] set construct
31600 111 Allow STRING and POINTER parameters to EXTERN proc's
31700 112 Clrbfi when error detected. Bounds check sets [a..b]
31800 113 Make real number reader handle exact things exactly
31900 Don't demand foward type ref's resolved at end of require file
32000 114 Write local fixups even if only non-loc gotos
32100 Make CREF not say .FIELDID. for local gotos
32200 maxint = 377777777777B
32300 115 Make tops10=false, kl=false work (tenex)
32400 116 IDRECSIZE entries for param, labelt type
32500 Make NEXT NIL instead of 0 when not used, for COPYCTP
32600 117 Fix enumerated type in record
32700 120 Make initialization routine use JSP, for T20/Tenex so
32800 don't have ill mem ref if emulator present
32900 121 Initialize CODEARRAY: fix bollixed INITPROC's
33000 122 KA's. This includes fixing COPYSTP so it doesn't
33100 try to follow NIL pointers. Harmless if 377777 is a
33200 legal address, but it isn't for KA's.
33300 123 Do POPF when can't find included file, so close gets done.
33400 124 Limit initprocedures to top level.
33500 Initialize CREF off
33600 125 Do POPF when expected eof inside included file.
33700 126 Detect procedures not beginning with BEGIN
33800 127 INit CREF to FALSE, fix [const..var] set construct
33900 130 Fix KA bug wherein random word in core image is garbage
34000 131 Move cixmax to pasprm.pas so tops20 can use big value
34100 132 Replace KA10 with KACPU for op codes and NOVM for old
34200 memory allocation.
34300 133 Fix JSYS to allow functions within it. Garbaged stack.
34400 134 Allow DELETE in Tops-10, too.
34500 135 Fix LOG2 for big numbers. Prevent ill mem ref's in
34600 PACK and UNPACK with syntax errors.
34700 136 Add header line at top of each page with pg. number
34800 137 Reset line no. to 1 at start of page.
34900 Fix bug in set constructors for CHAR
35000 140 Chnage order of SETMAP to closer to ASCII collating seq.
35100 141 Fix problem where REGC gets messed up by array subscript
35200 calculations when ONFIXEDREGC is in effect.
35300 Detect overflow in number scanning with JFCL.
35400 142 Make real number scanner scan anything legitimate
35500 143 Redo I/O to string in Tops-10 for new runtimes and fix
35600 onfixedregc code for packed arrays
35700 144 Allow :/ in program and :@ in reset for Tops-10
35800 145 Change external name of GET to GET. for Wharton
35900 146 Reinit count in putrelcode to avoid garbage in .REL file
36000 147 Lines start with 2 on new pages.
36100 150 Fix bug in forward type references,
36200 error recovery in fieldlist if garbage case type
36300 symbol table in forward proc's for debugger
36400 151 Fix reversed args in I,J:INTEGER in procedure decl.
36500 152 Add DISPOSE
36600 153 Fix some reg usage problems with DISPOSE
36700 154 More reg usage problems with DISPOSE
36800 155 Source file name in DEBUG block
36900 156 Detect FTNNAME^.field := value. Only bare ftn name
37000 allowed on LHS of assignment.
37100 157 Add $A- to turn off arith check
37200 160 Add compiler switch /ARITHCHECK
37300 161 fix STRINg and POINTER
37400 162 fix REGSIZE
37500 163 fix TIME for Tops-20
37600 164 use Polish fixups in CASE
37700 165 in type decl, make sure ^THING gets local defn of THING,
37800 even if it happens later and there is a higher level defn.
37900 (This requires treating ^THING as forward always.)
38000 166 make assignment to func id from inner func work
38100 initialize frecvar in fieldlist, to prevent ill mem ref
38200 with null record decl.
38300 167 improvements to edit 165
38400 170 more improvements to 165 (this time to error handling)
38500 171 allow read into packed objects
38600 allow read and write of binary files
38700 make sure default file names don't use user-declared INPUT,
38800 and OUTPUT
38900 fix NEW of pointer that is part of packed array
39000 172 option string as third arg of RESET, etc.
39100 evaluate upper bound of FOR statement only once
39200 173 allow files in any context; internal files
39300 174 fix to initprocedures from Hisgen
39400 175 make getfn take a param telling runtime validity check
39500 needed. SETSTRING, etc., do not
39600 176 better unterminated-comment error messages
39700 177 fix AC allocation in GETFILENAME
39800 200 fix addressing problem in loading file pointers
39900 201 make most manipulation of zero size objects be no-op.
40000 Previously one might stomp on the next variable.
40100 202 insufficient initialization before RESET(TTY), etc.
40200 fix POINTER passed by ref
40300 203 fix glitch in edit 202
40400 204 don't validity check the FCB for CLOSE, RCLOSE, and DISMISS
40500 205 fix AC in RENAME
40600 206 allow constants in WRITE statements for FILE OF INTEGER, etc.
40700 207 fix AC in GETFILENAME (again...)
40800 210 Allow 9 digit HEX numbers
40900 211 Fix output of string constants in .REL file
41000 212 Better error message if INPUT or OUTPUT redefined
41100 213 Fix procedure exit code if there is local variable
41200 214 Make debugger see locals of forward declared proc's
41300 215 Fix loop in CALLNONSTANDARD when args omitted in defn.
41400 216 Add $P: to set start of highseg (pure code)
41500 217 LASTFILE can be NIL even when current expr is a file, if it
41600 was gotten by indexing, etc. Replace it with a field in
41700 the ATTR, which is going to be more general.
41800 Fix FIELDLIST to set up SIZE of the TAGWITHOUTID. Did it
41900 only with TAGWITHID
42000 *)
42100
42200 CONST
42300 HEADER = 'PASCAL %12(217)';
42400
42500 DISPLIMIT = 20; MAXLEVEL = 8;
42600 STRGLGTH = 120; BITMAX = 36;
42700 (* 43 - longer file block for new runtimes *)
42800 SIZEOFFILEBLOCK=43B ; {plus size of component}
42900 OFFSET=40B; %FUER SETVERARBEITUNG DER ASCIICHARACTER\
43000 CHCNTMAX = 132; %MAXIMUM OF CHARACTERS IN ONE LINE\
43100 LEFT = 2;RIGHT = 1;BOTH = 3;NO = 0;
43200
43300 %KONSTANTEN VON BODY: \
43400 %*********************\
43500
43600 (* move cixmax to param file *)
43700 HWCSTMAX = 377777B; LABMAX = 20;
43800 (* 2 - increase default stack space *)
43900 (* 7 - stackandheap now set by switch *)
44000 (* 137 - fix set constructor for CHAR *)
44100 MAXERR = 4; BASEMAX = 71; CHARMAX = 177B;
44200
44300 %ADDRESSES:
44400 **********\
44500
44600 HAC=0; %HILFSREGISTER\
44700 TAC=1; %HILFSREGISTER AUCH FUER BYTEPOINTER\
44800 REGIN=1; %INITIALISE REGC\
44900 PARREGCMAX=6; %HIGHEST REGISTER USED FOR PARAMETERS\
45000 WITHIN=12; %FIRST REGISTER FOR WITHSTACK\
45100 NEWREG=13; %LAST PLACE OF NEW-STACK\
45200 BASIS=14; %BASIS ADDRESS STACK\
45300 TOPP=15; %FIRST FREE PLACE IN DATASTACK\
45400 PROGRST = 145B; %LOC 140B..144B RESERVED FOR DEBUG-PROGR.\
45500 (* 216 - HIGHSTART is now variable *)
45600 MAXADDR=777777B;
45700
45800
45900
46000
46100
46200 TYPE
46300 %DESCRIBING:\
46400 %***********\
46500
46600
46700 %BASIC SYMBOLS\
46800 %*************\
46900
47000 SYMBOL = (IDENT,INTCONST,REALCONST,STRINGCONST,NOTSY,MULOP,ADDOP,RELOP,
47100 LPARENT,RPARENT,LBRACK,RBRACK,COMMA,SEMICOLON,PERIOD,ARROW,
47200 COLON,BECOMES,LABELSY,CONSTSY,TYPESY,VARSY,VALUESY,FUNCTIONSY,
47300 (* 6 - add PROGRAM statement *)
47400 (* 56 - ADD INCLUDE *)
47500 PROCEDURESY,SETSY,PACKEDSY,ARRAYSY,RECORDSY,FILESY,FORWARDSY,PROGRAMSY,INCLUDESY,
47600 BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITHSY,LOOPSY,
47700 GOTOSY,EXITSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY,
47800 EXTERNSY,PASCALSY,FORTRANSY,ALGOLSY,COBOLSY,
47900 THENSY,OTHERSY,INITPROCSY,OTHERSSY);
48000
48100 OPERATOR = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,LTOP,LEOP,GEOP,GTOP,
48200 NEOP,EQOP,INOP,NOOP);
48300
48400 SETOFSYS = SET OF SYMBOL;
48500
48600 (* 23 - check for bad pointer *)
48700 (* 24 - ONLY CLEAR NEW WHEN TYPECHECKING *)
48800 (* 104 - new tops10 stackoverflow *)
48900 (* 152 - DISPOSE *)
49000 SUPPORTS = (FIRSTSUPPORT,STACKOVERFLOW,DEBSTACK,BADPOINT,ALLOCATE,CLEARALLOC,DEALLOCATE,
49100 (* 173 - internal files *)
49200 WITHFILEDEALLOCATE,
49300 (* 43 - add PUTX *)
49400 (* 64 - non-loc goto *)
49500 EXITGOTO,EXITPROGRAM,GETLINE,GETFILE,PUTLINE,PUTFILE,PUTXFILE,
49600 (* 57 - Add strset and strwrite external routines *)
49700 RESETFILE,REWRITEFILE,RESETSTRING,REWRITESTRING,GETCHARACTER,PUTPAGE,ERRORINASSIGNMENT,
49800 (* 173 - internal files *)
49900 FILEUNINITIALIZED,INITFILEBLOCK,
50000 WRITEPACKEDSTRING,WRITESTRING,WRITEBOOLEAN,READCHARACTER,READINTEGER,READREAL,
50100 (* 171 - RECORD READ/WRITE *)
50200 (* 206 - extend for constants *)
50300 READRECORD,WRITERECORD,WRITESCALAR,
50400 BREAKOUTPUT,OPENTTY,INITIALIZEDEBUG,ENTERDEBUG,INDEXERROR,WRITEOCTAL,WRITEINTEGER,WRITEREAL,
50500 (* 10 add CLOSE *)
50600 WRITEHEXADECIMAL,WRITECHARACTER,CONVERTINTEGERTOREAL,
50700 (* 14 and lots more *)
50800 (* 33 - PROGRAM statement *)
50900 CONVERTREALTOINTEGER,CLOSEFILE,READSTRING,READPACKEDSTRING,READFILENAME,
51000 NAMEFILE,DISFILE,UPFILE,APFILE,READDUMP,WRITEDUMP,SETIN,SETOUT,BREAKINPUT,
51100 (* 74 - tops20 routines *)
51200 SETPOSF,CURPOSF,NEXTBLOCKF,SPACELEFTF,GETXF,DELFILE,RELFILE,INITMEM,INITFILES,
51300 (* 163 - tops20 TIME function *)
51400 GETDAYTIME,LASTSUPPORT);
51500
51600 %CONSTANTS\
51700 %*********\
51800
51900 CSTCLASS = (INT,REEL,PSET,STRD,STRG);
52000 CSP = ^ CONSTNT;
52100 (* 55 - add require files *)
52200 STRGARR = PACKED ARRAY[1..STRGLGTH] OF CHAR;
52300 CONSTNT = RECORD
52400 SELFCSP: CSP; NOCODE: BOOLEAN;
52500 CASE CCLASS: CSTCLASS OF
52600 INT : (INTVAL: INTEGER; INTVAL1:INTEGER %TO ACCESS SECOND WORD OF PVAL\ );
52700 REEL: (RVAL: REAL);
52800 PSET: (PVAL: SET OF 0..71);
52900 STRD,
53000 STRG: (SLGTH: 0..STRGLGTH;
53100 SVAL: PACKED ARRAY [1..STRGLGTH] OF CHAR)
53200 END;
53300
53400 VALU = RECORD
53500 CASE BOOLEAN OF
53600 TRUE: (IVAL: INTEGER);
53700 FALSE: (VALP: CSP)
53800 END;
53900
54000 %DATA STRUCTURES\
54100 %***************\
54200
54300 LEVRANGE = 0..MAXLEVEL; ADDRRANGE = 0..MAXADDR; INSTRANGE = 0..677B ;
54400 RADIXRANGE = 0..37777777777B; FLAGRANGE = 0..17B;
54500 BITRANGE = 0..BITMAX; ACRANGE = 0..15; IBRANGE = 0..1; CODERANGE = 0..CIXMAX ;
54600 (* 173 - internal files *)
54700 BITS5 = 0..37B; BITS6 = 0..77B; BITS7 = 0..177B;
54800 STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,ARRAYS,RECORDS,FILES,TAGFWITHID,TAGFWITHOUTID,VARIANT);
54900 DECLKIND = (STANDARD,DECLARED);
55000 STP = ^ STRUCTURE; CTP = ^ IDENTIFIER; BTP = ^BYTEPOINT;
55100 FTP = ^FILBLCK;
55200 GTP = ^GLOBPTR ;
55300
55400 {A STRUCTURE is used whenever it is necessary to say what something is.
55500 I.e. each variable entry in the symbol table points to a STRUCTURE to
55600 say what kind of thing it is, and expressions and other structured
55700 objects use a STRUCTURE to say what kind of object is involved.
55800 SELFSTP is used for dumping out the symbol table into the object file
55900 for PASDDT.}
56000
56100 STRUCTURE = PACKED RECORD
56200 SELFSTP: STP; SIZE: ADDRRANGE;
56300 NOCODE: BOOLEAN; BITSIZE: BITRANGE;
56400 (* 173 - internal files *)
56500 HASFILE: BOOLEAN;
56600 CASE FORM: STRUCTFORM OF
56700 SCALAR: (CASE SCALKIND: DECLKIND OF
56800 DECLARED: (DB0: BITS5; FCONST: CTP));
56900 SUBRANGE: (DB1: BITS6; RANGETYPE: STP; MIN,MAX: VALU);
57000 POINTER: (DB2: BITS6; ELTYPE: STP);
57100 POWER: (DB3: BITS6; ELSET: STP);
57200 ARRAYS: (ARRAYPF: BOOLEAN; DB4: BITS5; ARRAYBPADDR: ADDRRANGE;
57300 AELTYPE,INXTYPE: STP);
57400 RECORDS: (RECORDPF: BOOLEAN; DB5: BITS5;
57500 FSTFLD: CTP; RECVAR: STP);
57600 FILES: (DB6: BITS5; FILEPF: BOOLEAN;FILTYPE: STP);
57700 TAGFWITHID,
57800 TAGFWITHOUTID: (DB7: BITS6; FSTVAR: STP;
57900 CASE BOOLEAN OF
58000 TRUE : (TAGFIELDP: CTP);
58100 FALSE : (TAGFIELDTYPE: STP));
58200 VARIANT: (DB9: BITS6; NXTVAR,SUBVAR: STP; FIRSTFIELD: CTP; VARVAL: VALU; QXLYPRTWRR: BOOLEAN)
58300 END;
58400
58500 BPOINTER = PACKED RECORD
58600 SBITS,PBITS: BITRANGE;
58700 IBIT,DUMMYBIT: IBRANGE;
58800 IREG: ACRANGE;
58900 RELADDR: ADDRRANGE
59000 END;
59100
59200 BPKIND = (RECORDD,ARRAYY);
59300
59400 BYTEPOINT = PACKED RECORD
59500 BYTE: BPOINTER;
59600 LAST :BTP;
59700 CASE BKIND:BPKIND OF
59800 RECORDD: (FIELDCP: CTP);
59900 ARRAYY : (ARRAYSP: STP)
60000 END;
60100 GLOBPTR = RECORD
60200 NEXTGLOBPTR: GTP ;
60300 FIRSTGLOB,
60400 LASTGLOB : ADDRRANGE ;
60500 FCIX : CODERANGE
60600 END ;
60700
60800 FILBLCK = PACKED RECORD
60900 NEXTFTP : FTP ;
61000 FILEIDENT : CTP
61100 END ;
61200
61300 %NAMES\
61400 %*****\
61500
61600 (* 64 - non-loc goto *)
61700 (* 111 - STRING, POINTER *)
61800 (* PARAMS is a special kind of TYPES. It is used only for
61900 predeclared identifiers describing kludgey types that are
62000 valid only in procedure parameter lists. *)
62100 IDCLASS = (TYPES,KONST,VARS,FIELD,PROC,FUNC,LABELT,PARAMS);
62200 SETOFIDS = SET OF IDCLASS;
62300 IDKIND = (ACTUAL,FORMAL);
62400 PACKKIND = (NOTPACK,PACKK,HWORDR,HWORDL);
62500 CHARWORD = PACKED ARRAY [1..5] OF CHAR;
62600 %ALFA = PACKED ARRAY [1..ALFALENG] OF CHAR;\
62700
62800 {An IDENTIFIER record is the permanent symbol table record for a
62900 simple identifier. It doesn't specify what kind of object the
63000 identifier is. (IDTYPE points to a STRUCTURE, which does that.)
63100 However it does have the address, in VADDR. The symbol table is
63200 a binary tree. LLINK and RLINK point to subtrees that are
63300 alphabetically less than or greater than this symbol. NEXT is
63400 used in constructing linked lists of identifiers, such as args
63500 to procedures, or fields in a record. SELFCTP is used for
63600 dumping out the symbol table into the object file for PASDDT.}
63700
63800 IDENTIFIER = PACKED RECORD
63900 NAME: ALFA;
64000 LLINK, RLINK: CTP;
64100 IDTYPE: STP; NEXT: CTP;
64200 SELFCTP: CTP; NOCODE: BOOLEAN;
64300 CASE KLASS: IDCLASS OF
64400 KONST: (VALUES: VALU);
64500 VARS: (VKIND: IDKIND; VLEV: LEVRANGE;
64600 CHANNEL: ACRANGE; VDUMMY: 0..31; VADDR: ADDRRANGE);
64700 FIELD: (PACKF: PACKKIND; FDUMMY: 0..7777B;
64800 FLDADDR: ADDRRANGE);
64900 %IF PACKF=PACKK THEN FLDADDR CONTAINS THE
65000 ABSOLUTE ADDRESS OF THE CORRESPONDING BYTEPOINTER
65100 -----> ENTERBODY\
65200 PROC,
65300 FUNC: (PFCHAIN: CTP; CASE PFDECKIND: DECLKIND OF
65400 STANDARD: (KEY: 1..44);
65500 DECLARED: (PFLEV: LEVRANGE; PFADDR: ADDRRANGE;
65600 CASE PFKIND: IDKIND OF
65700 ACTUAL: (FORWDECL: BOOLEAN; TESTFWDPTR: CTP;
65800 EXTERNDECL: BOOLEAN; LANGUAGE: SYMBOL;
65900 EXTERNALNAME: ALFA;
66000 LINKCHAIN: PACKED ARRAY[LEVRANGE] OF ADDRRANGE;
66100 (* 62 - clean of stack offsets *)
66200 POFFSET:ADDRRANGE)));
66300 (* 66 - non-local goto's *)
66400 LABELT: (SCOPE:LEVRANGE;NONLOCGOTO:BOOLEAN;
66500 GOTOCHAIN:ADDRRANGE;LABELADDRESS:ADDRRANGE)
66600 END;
66700
66800
66900 DISPRANGE = 0..DISPLIMIT;
67000 WHERE = (BLCK,CREC);
67100 (* 61 - new type to separate tops10 and tops20 ftns *)
67200 machine = (okname,t10name,t20name);
67300
67400 %RELOCATION\
67500 %**********\
67600
67700 RELBYTE = 0..3B %(NO,RIGHT,LEFT,BOTH)\;
67800
67900 RELWORD = PACKED ARRAY[0..17] OF RELBYTE;
68000
68100 %EXPRESSIONS\
68200 %***********\
68300
68400 ATTRKIND = (CST,VARBL,EXPR);
68500
68600 {An ATTR contains the current status of an object that is being used by
68700 the code generator. I.e. its lexical level, where it currently is
68800 (can be the permanent location, or an AC), etc. This differs from
68900 an identifier record both because it exists for things other than
69000 identifiers, e.g. constants and expressions, and because it is current
69100 state in code generation, rather than permanent symbol table value.
69200 The non-obvious fields are:
69300 DPLMT - displacement, i.e. address, possibly indexed by INDEXR,
69400 or modified by byte pointer fields, etc.
69500 EXTERNCTP - this is non-NIL only for if the expression represented
69600 is a reference to an external variable. External variables
69700 are the only case where we have to have a handle on the
69800 identifier record in the symbol table. We need this because
69900 the way externals are referred to involves changing the
70000 address for them in the symbol table every time they are
70100 refered to. Currently the only external variables allowed
70200 are files. You should be able to test EXTERNCTP <> NIL to
70300 see whether a file is external.}
70400
70500 ATTR = RECORD
70600 TYPTR: STP;
70700 CASE KIND: ATTRKIND OF
70800 CST: (CVAL: VALU);
70900 VARBL: (PACKFG: PACKKIND; INDEXR: ACRANGE; INDBIT: IBRANGE;
71000 VLEVEL: LEVRANGE; BPADDR,DPLMT: ADDRRANGE;
71100 (* 217 - add EXTERNCTP *)
71200 VRELBYTE: RELBYTE; SUBKIND: STP; EXTERNCTP: CTP);
71300 EXPR: (REG:ACRANGE)
71400 END;
71500
71600 TESTP = ^ TESTPOINTER;
71700 TESTPOINTER = PACKED RECORD
71800 ELT1,ELT2: STP;
71900 LASTTESTP: TESTP
72000 END;
72100
72200 (* 65 - remove exit labels *)
72300
72400 %TYPES FROM BODY \
72500 %****************\
72600
72700 (* 13 - ADD WRITEBLOCK FOR DDT SYMBOLS *)
72800 WRITEFORM = (WRITEENTRY,WRITENAME,WRITEHISEG,WRITEGLOBALS,WRITECODE,WRITEINTERNALS,
72900 (* 164 - add Polish fixups *)
73000 WRITEPOLISH,WRITELIBRARY,
73100 (* 173 - remove writefileblock *)
73200 WRITESYMBOLS,WRITEBLK,WRITESTART,WRITEEND);
73300
73400 UPDATEFORM = (C,D);
73500 ETP = ^ ERRORUPDATE;
73600 ERRORUPDATE = PACKED RECORD
73700 NUMBER: INTEGER;
73800 NEXT: ETP;
73900 CASE FORM: UPDATEFORM OF
74000 C: (STRING: ALFA);
74100 D: (INTVAL: INTEGER)
74200 END;
74300
74400 KSP = ^ KONSTREC;
74500 KONSTREC = PACKED RECORD
74600 (* 72 - two fixup chains for 2 word consts *)
74700 ADDR, ADDR1, KADDR: ADDRRANGE;
74800 CONSTPTR: CSP;
74900 NEXTKONST: KSP
75000 END;
75100 (* 164 - Polish fixups for CASE *)
75200 POLPT = ^ POLREC;
75300 {This record indicates a Polish fixup to be done at address WHERE in
75400 the code. The RH of WHERE is to get the BASE (assumed relocatable),
75500 adjusted by OFFSET (a constant). This is needed because the loader
75600 assumes that any address < 400000B is in the lowseg. So to get the
75700 virtual start of the CASE statement branch table we need to use
75800 this to adjust the physical start of the table by the first case
75900 index}
76000 POLREC = PACKED RECORD
76100 WHERE: ADDRRANGE;
76200 BASE: ADDRRANGE;
76300 OFFSET: INTEGER;
76400 NEXTPOL: POLPT
76500 END;
76600
76700 PDP10INSTR = PACKED RECORD
76800 INSTR : INSTRANGE ;
76900 AC : ACRANGE;
77000 INDBIT : IBRANGE;
77100 INXREG : ACRANGE;
77200 ADDRESS : ADDRRANGE
77300 END ;
77400
77500 HALFS = PACKED RECORD
77600 LEFTHALF: ADDRRANGE;
77700 RIGHTHALF: ADDRRANGE
77800 END;
77900
78000 PAGEELEM = PACKED RECORD
78100 WORD1: PDP10INSTR;
78200 LHALF: ADDRRANGE; RHALF: ADDRRANGE
78300 END;
78400 DEBENTRY = RECORD
78500 (* 36 - ALLOW MULTIPLE MODULES *)
78600 NEXTDEB: INTEGER; %WILL BE PTR TO NEXT ENTRY\
78700 LASTPAGEELEM: PAGEELEM;
78800 (* 103 - fix global id tree *)
78900 GLOBALIDTREE: CTP;
79000 STANDARDIDTREE: CTP;
79100 INTPOINT: STP;
79200 REALPOINT: STP;
79300 CHARPOINT: STP;
79400 MODNAME: ALFA;
79500 (* 155 - add source information *)
79600 SOURCE: PACKED ARRAY[1..167]OF CHAR;
79700 END;
79800
79900 (* 4 - add data structure for SCAN to return *)
80000 (* 11 - modify structure and add type for the REL file *)
80100 INTFILE = FILE OF INTEGER;
80200 RPGDATA = RECORD
80300 (* 7 - add /HEAP switch *)
80400 RELNAME:ALFA;
80500 (* 24 - allow user to set first loc of stack and heap *)
80600 STACKVAL:INTEGER;
80700 HEAPVAL:INTEGER;
80800 (* 33 - version no. *)
80900 VERVAL:INTEGER;
81000 (* 25 - add /ZERO *)
81100 (* 160 - add /ARITHCHECK *)
81200 ASW,ZSW,LSW,TSW,MSW,CSW,DSW,CRSW,RPGSW:BOOLEAN
81300 END;
81400 RPGPT = ^ RPGDATA;
81500 (* 33 - PROGRAM statement *)
81600 (* 61 - allow +* in tops20 *)
81700 PROGFILE = PACKED RECORD
81800 FILID:ALFA;
81900 NEXT:^PROGFILE;
82000 (* 64 - INPUT:/ *)
82100 wild,newgen,oldfile,interact,seeeol:Boolean
82200 END;
82300 (* 157 - See if we need INITTTY *)
82400 PROGFILEPT = ^ PROGFILE;
82500
82600 %------------------------------------------------------------------------------\
82700
82800
82900 VAR
83000 %RETURNED BY SOURCE PROGRAM SCANNER INSYMBOL:\
83100 %********************************************\
83200
83300 SY: SYMBOL; %LAST SYMBOL\
83400 OP: OPERATOR; %CLASSIFICATION OF LAST SYMBOL\
83500 VAL: VALU; %VALUE OF LAST CONSTANT\
83600 LGTH: INTEGER; %LENGTH OF LAST STRING CONSTANT\
83700 ID: ALFA; %LAST IDENTIFIER (POSSIBLY TRUNCATED)\
83800 CH: CHAR; %LAST CHARACTER\
83900
84000
84100 %COUNTERS:\
84200 %*********\
84300
84400 RTIME,
84500 I: INTEGER;
84600 SUPPORTIX: SUPPORTS;
84700 LANGUAGEIX: SYMBOL;
84800 CHCNT: 0..132; %CHARACTER COUNTER\
84900 (* 216 - variable high segment start *)
85000 HIGHSTART, %START OF HIGH SEGMENT\
85100 CODEEND, %FIRST LOCATION NOT USED FOR INSTRUCTIONS\
85200 LCMAIN,
85300 (* 5 - some new variables for CREF *)
85400 LC,IC,BEGLC,BEGIC: ADDRRANGE; %DATA LOCATION AND INSTRUCTION COUNTER\
85500 (* 176 - new vars for unterminated comment *)
85600 comment_page, comment_line: integer;
85700
85800 %SWITCHES:\
85900 %*********\
86000
86100 (* 25 - ADD /ZERO *)
86200 ZERO, %ON TO INITIALIZE LOCAL VAR'S\
86300 (* 4 - variable for COMPIL linkage *)
86400 RPGENTRY, %ON IF CALLED CALLED BY COMPIL\
86500 (* 5 - new variables for CREF *)
86600 CREF, %ON IF CREF LISTING BEING MADE\
86700 DP,BEGDP, %DECLARATION PART\
86800 RESETFLAG, %TO IGNORE SWITCHES WHICH MUST NOT BE RESET\
86900 PRTERR, %TO ALLOW FORWARD REFERENCES IN POINTER TYPE
87000 DECLARATION BY SUPPRESSING ERROR MESSAGE\
87100 MAIN, %IF FALSE COMPILER PRODUCES EXTERNAL PROCEDURE OR FUNCTION\
87200 doinitTTY, %TTYOPEN needed\
87300 TTYINUSE, %no longer used ?\
87400 TTYSEEEOL, %TTY:# in program state\
87500 DEBUG, %ENABLE DEBUGGING\
87600 DEBUGSWITCH, %INSERT DEBUGINFORMATION\
87700 LISTCODE, %LIST MACRO CODE\
87800 INITGLOBALS, %INITIALIZE GLOBAL VARIABLES\
87900 LOADNOPTR, %TRUE IF NO POINTERVARIABLE SHALL BE LOADED\
88000 (* 157 - separate control for arith overflow *)
88100 ARITHCHECK, %SWITCH FOR DETECTING ARITH ERRORS\
88200 RUNTMCHECK: BOOLEAN; %SWITCH FOR RUNTIME-TESTS\
88300 (* 24 - ALLOW USER TO SET FIRST LOC OF STACK AND HEAP *)
88400 STACK,HEAP: ADDRRANGE; %FIRST ADDR OF STACK AND HEAP\
88500 (* 12 - stackandheap no longer needed *)
88600 (* 33 - VERSION NO. *)
88700 version:packed record %version no. for output\
88800 case boolean of
88900 true:(word:integer);
89000 false:(who:0..7B;major:0..777B;minor:0..77B;edit:0..777777B)
89100 end;
89200
89300
89400 %POINTERS:\
89500 %*********\
89600
89700 LOCALPFPTR, EXTERNPFPTR: CTP; %PTRS TO LOCAL/EXTERNAL PROC/FUNC-CHAIN\
89800 (* 111 - STRING, POINTER *)
89900 (* 202 - POINTER by ref *)
90000 INTPTR,REALPTR,CHARPTR,ANYFILEPTR,STRINGPTR,POINTERPTR,POINTERREF,
90100 BOOLPTR,NILPTR,TEXTPTR: STP; %POINTERS TO ENTRIES OF STANDARD IDS\
90200 (* 135 - ill mem ref in PACK, UNPACK *)
90300 UARRTYP:STP;
90400 UTYPPTR,UCSTPTR,UVARPTR,
90500 UFLDPTR,UPRCPTR,UFCTPTR, %POINTERS TO ENTRIES FOR UNDECLARED IDS\
90600 (* 64 - non-loc goto *)
90700 ulblptr,
90800 FWPTR: CTP; %HEAD OF CHAIN OF FORW DECL TYPE IDS\
90900 ERRMPTR,ERRMPTR1: ETP; %TO CHAIN ERROR-UPDATES\
91000 (* 65 - remove exit labels *)
91100 LASTBTP: BTP; %HEAD OF BYTEPOINTERTABLE\
91200 SFILEPTR,
91300 FILEPTR: FTP;
91400 FIRSTKONST: KSP;
91500 (* 164 - Polish fixups for CASE *)
91600 FIRSTPOL: POLPT;
91700 ALFAPTR, DATEPTR: STP;
91800 FGLOBPTR,CGLOBPTR : GTP ; %POINTER TO FIRST AND CURRENT GLOBAL INITIALISATION RECORD\
91900 GLOBTESTP : TESTP ; %POINTER TO LAST PAIR OF POINTERTYPES\
92000 (* 4 - Here is the main structure for the SCAN linkage *)
92100 SCANDATA : RPGPT ; %DATA FROM SCAN OF FILE NAMES\
92200 (* 33 - PROGRAM STATEMENT *)
92300 NPROGFILE, %NEW FILE NAME\
92400 LPROGFILE, %LAST FILE NAME IN LIST\
92500 FPROGFILE:PROGFILEPT; %FIRST FILE NAME IN LIST\
92600 (* 64 - non-loc goto *)
92700 lastlabel:ctp;
92800 (* 171 - treat file names as special *)
92900 infile,outfile,ttyfile,ttyoutfile:ctp; {Pointers to ID's for
93000 INPUT, OUTPUT, TTY, TTYOUT}
93100
93200 %BOOKKEEPING OF DECLARATION LEVELS:\
93300 %**********************************\
93400
93500 (* 5 - new variable for CREF *)
93600 LEVEL,BEGLEVEL: LEVRANGE; %CURRENT STATIC LEVEL\
93700 DISX, %LEVEL OF LAST ID SEARCHED BY SEARCHID\
93800 TOP: DISPRANGE; %TOP OF DISPLAY\
93900
94000 DISPLAY: %WHERE: MEANS:\
94100 ARRAY[DISPRANGE] OF
94200 PACKED RECORD
94300 %=BLCK: ID IS VARIABLE ID\
94400 (* 5 - new variable for CREF *)
94500 BLKNAME: ALFA; %NAME OF BLOCK\
94600 FNAME: CTP; %=CREC: ID IS FIELD ID IN RECORD WITH\
94700 CASE OCCUR: WHERE OF % CONSTANT ADDRESS\
94800 CREC: (CLEV: LEVRANGE; %=VREC: ID IS FIELD ID IN RECORD WITH\
94900 CINDR: ACRANGE; % VARIABLE ADDRESS\
95000 CINDB: IBRANGE;
95100 CRELBYTE: RELBYTE;
95200 CDSPL,
95300 CLC : ADDRRANGE)
95400 END;
95500
95600
00100 %ERROR MESSAGES:\
00200 %***************\
00300
00400 ERRORFLAG: BOOLEAN; %TRUE IF SYNTACTIC ERRORS DETECTED\
00500 ERRINX: 0..MAXERR ; %NR OF ERRORS IN CURRENT SOURCE LINE\
00600 ERRLIST:
00700 ARRAY [1..MAXERR] OF
00800 PACKED RECORD
00900 ARW : 1..4;
01000 POS: 1..CHCNTMAX;
01100 NMR: 1..600;
01200 TIC: CHAR
01300 END;
01400
01500 ERRMESS15 : ARRAY [1..24] OF PACKED ARRAY [1..15] OF CHAR;
01600 (* 6 - add error msg for illegal character *)
01700 ERRMESS20 : ARRAY [1..16] OF PACKED ARRAY [1..20] OF CHAR;
01800 (* 104 - error message for too much data for address space *)
01900 ERRMESS25 : ARRAY [1..16] OF PACKED ARRAY [1..25] OF CHAR;
02000 ERRMESS30 : ARRAY [1..17] OF PACKED ARRAY [1..30] OF CHAR;
02100 (* 156 - ftnname^ := *)
02200 ERRMESS35 : ARRAY [1..18] OF PACKED ARRAY [1..35] OF CHAR;
02300 (* 31 - ADD MESSAGE FOR BAD ASSIGN TO FTN. NAME *)
02400 ERRMESS40 : ARRAY [1..13] OF PACKED ARRAY [1..40] OF CHAR;
02500 (* 24 - NEW ERROR MSG FOR LOC *)
02600 ERRMESS45 : ARRAY [1..16] OF PACKED ARRAY [1..45] OF CHAR;
02700 (* 33 - PROGRAM STATEMENT *)
02800 ERRMESS50 : ARRAY [1.. 9] OF PACKED ARRAY [1..50] OF CHAR;
02900 (* 124 - bad initprocedure *)
03000 ERRMESS55 : ARRAY [1.. 7] OF PACKED ARRAY [1..55] OF CHAR;
03100 ERRORINLINE,
03200 FOLLOWERROR : BOOLEAN;
03300 ERRLINE,
03400 BUFFER: ARRAY [1..CHCNTMAX] OF CHAR;
03500 (* 136 - listing format *)
03600 PAGECNT,SUBPAGE,CURLINE,
03700 LINECNT: INTEGER;
03800 LINENR: PACKED ARRAY [1..5] OF CHAR;
03900
04000
04100
04200
04300 %EXPRESSION COMPILATION:\
04400 %***********************\
04500
04600 GATTR: ATTR; %DESCRIBES THE EXPR CURRENTLY COMPILED\
04700 (* 105 - character mapping from lower case *)
04800 charmap,setmap:array[0..177B]of integer; %fast mapping to upper case\
04900 setmapchain:addrrange; %for external reference to runtime version of setmap\
05000
05100
05200 %COUNTERS FOR TESTS:\
05300 %*******************\
05400
05500
05600
05700 %DEBUG-SYSTEM:\
05800 %*************\
05900
06000 LASTSTOP: ADDRRANGE; %LAST BREAKPOINT\
06100 LASTLINE, %LINENUMBER FOR BREAKPOINTS\
06200 LINEDIFF, %DIFFERENCE BETWEEN ^ AND LINECNT\
06300 LASTPAGE:INTEGER; %LAST PAGE THAT CONTAINS A STOP\
06400 PAGEHEADADR, %OVERGIVE TO DEBUG.PAS\
06500 LASTPAGER: ADDRRANGE; %POINTS AT LAST PAGERECORD\
06600 PAGER: PAGEELEM; %ACTUAL PAGERECORD\
06700 DEBUGENTRY: DEBENTRY;
06800 IDRECSIZE: ARRAY[IDCLASS] OF INTEGER;
06900 STRECSIZE: ARRAY[STRUCTFORM] OF INTEGER;
07000
07100
07200
07300 %STRUCTURED CONSTANTS:\
07400 %*********************\
07500
07600 LETTERSORDIGITS,LETTERS,DIGITS,LETTERSDIGITSORLEFTARROW,HEXADIGITS: SET OF CHAR;
07700 CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS,BLOCKBEGSYS,SELECTSYS,FACBEGSYS,
07800 LANGUAGESYS,STATBEGSYS,TYPEDELS: SETOFSYS;
07900 (* 6 - add PROGRAM statement *)
08000 (* 56 - ADD INCLUDE *)
08100 RW: ARRAY [1..45%NR. OF RES. WORDS\] OF ALFA;
08200 FRW: ARRAY [1..11%ALFALENG+1\] OF 1..46%NR. OF RES. WORDS + 1\;
08300 RSY: ARRAY [1..45%NR. OF RES. WORDS\] OF SYMBOL;
08400 SSY: ARRAY [' '..'_'] OF SYMBOL;
08500 ROP: ARRAY [1..45%NR. OF RES. WORDS\] OF OPERATOR;
08600 SOP: ARRAY [' '..'_'] OF OPERATOR;
08700 (* 10 make room for 12 more proc's, 8 more ftn's *)
08800 NA: ARRAY [1..81] OF ALFA;
08900 (* 61 - new array to declare which are tops10 and tops20 *)
09000 machna: array[1..81] of machine;
09100 othermachine: machine;
09200 EXTNA: ARRAY[39..53] OF ALFA;
09300 EXTLANGUAGE: ARRAY[39..53] OF SYMBOL;
09400 MNEMONICS : ARRAY[1..45] OF PACKED ARRAY[1..60] OF CHAR ;
09500
09600
09700 %VARIABLES FROM BODY\
09800 %*******************\
09900
10000
10100 (* 173 - internal files *)
10200 {Chantab is very strange. It is used as a kludge because we need
10300 two global request chains for each of INPUT, OUTPUT, TTY, and TTYOUTPUT.
10400 So the second one is stored here. From an identifier record, you can
10500 look at CHANNEL to find which of these corresponds to that one.}
10600 CHANTAB:ARRAY[1..4] OF ADDRRANGE;
10700 FILEINBLOCK:ARRAY[LEVRANGE]OF BOOLEAN; {True is there is a local file}
10800 (* 12 - VAR'S FOR GLOBAL REF TO RUNTIMES. FOR DYNAMIC ALLOC *)
10900 LSTNEW,NEWBND: ADDRRANGE; %references to these global variables\
11000 (* 13 - ADD DATA FOR DDT SYMBOLS *)
11100 PFPOINT,PFDISP:ADDRRANGE; %ADDRESS OF FIRST CODE IN PROCEDURE\
11200 RELBLOCK: PACKED RECORD
11300 CASE BOOLEAN OF
11400 TRUE: (COMPONENT: ARRAY[1..20] OF INTEGER);
11500 FALSE: (ITEM: ADDRRANGE; COUNT: ADDRRANGE;
11600 RELOCATOR: RELWORD;
11700 CODE: ARRAY[0..17] OF INTEGER)
11800 END;
11900
12000 RNTS: RECORD
12100 NAME: ARRAY[SUPPORTS] OF ALFA;
12200 LINK: PACKED ARRAY[SUPPORTS] OF ADDRRANGE
12300 END;
12400
12500 CODE: PACKED RECORD
12600 RELOCATION: PACKED ARRAY[CODERANGE] OF RELBYTE;
12700 INFORMATION: PACKED ARRAY[CODERANGE] OF CHAR;
12800 CASE INTEGER OF
12900 1: (INSTRUCTION: PACKED ARRAY[CODERANGE] OF PDP10INSTR);
13000 2: (WORD: PACKED ARRAY[CODERANGE] OF INTEGER);
13100 3: (HALFWORD: PACKED ARRAY[CODERANGE] OF HALFS)
13200 END;
13300
13400 LABELS: ARRAY [1:LABMAX] OF
13500 RECORD
13600 LABSVAL,LABSADDR: INTEGER
13700 END;
13800 GOTOS: ARRAY [1:LABMAX] OF
13900 RECORD
14000 GOTOVAL,GOTOADDR: INTEGER
14100 END;
14200
14300 REGC, %TOP OF REGISTERSTACK\
14400 REGCMAX: ACRANGE; %MAXIMUM OF REGISTERS FOR EXPRESSION STACK\
14500 LIX,JIX,CIX,
14600 INSERTSIZE, %TOO INSERT LCMAX IN ENTRYCODE\
14700 PFSTART: INTEGER; %START OF NORMAL ENTRYCODE OF EACH FUNC. OR PROC.\
14800 IX: INTEGER;
14900 (* 54 - var's needed to keep track of stack space needed *)
15000 STKOFF, STKOFFMAX, CORALLOC: INTEGER; %STACK SPACE NEEDED ABOVE LOCALS\
15100 LCMAX: ADDRRANGE; LCP: CTP;
15200 OUTPUTREL: FILE OF INTEGER; %RELOCATABLE BINARY OUTPUT\
15300 WITHIX, %TOP OF WITH-REG STACK\
15400 HIGHESTCODE, %MAXIMUM OF HIGH SEGMENTS ADDRESS\
15500 MAINSTART, %FIRST CODE OF BODY OF MAIN\
15600 (* 16 - add CCLSW set by entry with offset=1 *)
15700 CCLSW,
15800 (* 66 - nonloc goto's *)
15900 globtopp,globbasis,
16000 STARTADDR: INTEGER; %STARTADDRESSE\
16100
16200 (* 33 - VERSION NO. *)
16300 LOOKBLOCK: ARRAY[0..6] OF INTEGER;
16400 LST,REL: PACKED ARRAY[1..3] OF CHAR ;
16500 (* 34 - entry no longer needed *)
16600 FILENAME: ALFA;
16700 DAY: PACKED ARRAY[1..9] OF CHAR;
16800 (* 125 - moved to global so insymbol can see it *)
16900 REQFILE,ENTRYDONE: BOOLEAN;
17000 (* 171 - read/write of records *)
17100 THISFILE: STP;
17200 GOTARG: BOOLEAN;
17300
17400 LIBIX: INTEGER;
17500 LIBORDER: PACKED ARRAY[1..4] OF SYMBOL;
17600 LIBRARY: ARRAY[PASCALSY..COBOLSY] OF RECORD
17700 INORDER, CALLED: BOOLEAN;
17800 NAME: ALFA;
17900 PROJNR: ADDRRANGE;
18000 PROGNR: ADDRRANGE;
18100 DEVICE: ALFA
18200 END;
18300
18400 %------------------------------------------------------------------------------\
18500
18600 INITPROCEDURE ;
18700 BEGIN
18800
18900 (* 33 - VERSION NO. *)
19000 (* 34 - using filename instead of entry *)
19100 LST:= 'LST' ; REL:= 'REL' ; FILENAME:= ' ' ; LOOKBLOCK[0] := 6;
19200
19300 MNEMONICS[ 1] := '***001***002***003***004***005***006***007***010***011***012' ;
19400 MNEMONICS[ 2] := '***013***014***015***016***017***020***021***022***023***024' ;
19500 MNEMONICS[ 3] := '***025***026***027***030***031***032***033***034***035***036' ;
19600 MNEMONICS[ 4] := '***037CALL INIT ***042***043***044***045***046CALLI OPEN ' ;
19700 MNEMONICS[ 5] := 'TTCALL***052***053***054RENAMEIN OUT SETSTSSTATO STATUS' ;
19800 MNEMONICS[ 6] := 'STATZ INBUF OUTBUFINPUT OUTPUTCLOSE RELEASMTAPE UGETF USETI ' ;
19900 (* 133 - add mnemonics for ADJSP and JSYS *)
20000 MNEMONICS[ 7] := 'USETO LOOKUPENTER UJEN ***101***102***103JSYS ADJSP ***106' ;
20100 MNEMONICS[ 8] := '***107***110***111***112***113***114***115***116***117***120' ;
20200 (* 2 - add mnemonics for KI-10, since we are using some of them *)
20300 MNEMONICS[ 9] := '***121FIX ***123***124***125FIXR FLTR UFA DFN FSC ' ;
20400 MNEMONICS[10] := 'IBP ILDB LDB IDPB DPB FAD FADL FADM FADB FADR ' ;
20500 MNEMONICS[11] := 'FADRI FADRM FADRB FSB FSBL FSBM FSBB FSBR FSBRI FSBRM ' ;
20600 MNEMONICS[12] := 'FSBRB FMP FMPL FMPM FMPB FMPR FMPRI FMPRM FMPRB FDV ' ;
20700 MNEMONICS[13] := 'FDVL FDVM FDVB FDVR FDVRI FDVRM FDVRB MOVE MOVEI MOVEM ' ;
20800 MNEMONICS[14] := 'MOVES MOVS MOVSI MOVSM MOVSS MOVN MOVNI MOVNM MOVNS MOVM ' ;
20900 MNEMONICS[15] := 'MOVMI MOVMM MOVMS IMUL IMULI IMULM IMULB MUL MULI MULM ' ;
21000 MNEMONICS[16] := 'MULB IDIV IDIVI IDIVM IDIVB DIV DIVI DIVM DIVB ASH ' ;
21100 MNEMONICS[17] := 'ROT LSH JFFO ASHC ROTC LSHC ***247EXCH BLT AOBJP ' ;
21200 MNEMONICS[18] := 'AOBJN JRST JFCL XCT ***257PUSHJ PUSH POP POPJ JSR ' ;
21300 MNEMONICS[19] := 'JSP JSA JRA ADD ADDI ADDM ADDB SUB SUBI SUBM ' ;
21400 MNEMONICS[20] := 'SUBB CAI CAIL CAIE CAILE CAIA CAIGE CAIN CAIG CAM ' ;
21500 MNEMONICS[21] := 'CAML CAME CAMLE CAMA CAMGE CAMN CAMG JUMP JUMPL JUMPE ' ;
21600 MNEMONICS[22] := 'JUMPLEJUMPA JUMPGEJUMPN JUMPG SKIP SKIPL SKIPE SKIPLESKIPA ' ;
21700 MNEMONICS[23] := 'SKIPGESKIPN SKIPG AOJ AOJL AOJE AOJLE AOJA AOJGE AOJN ' ;
21800 MNEMONICS[24] := 'AOJG AOS AOSL AOSE AOSLE AOSA AOSGE AOSN AOSG SOJ ' ;
21900 MNEMONICS[25] := 'SOJL SOJE SOJLE SOJA SOJGE SOJN SOJG SOS SOSL SOSE ' ;
22000 MNEMONICS[26] := 'SOSLE SOSA SOSGE SOSN SOSG SETZ SETZI SETZM SETZB AND ' ;
22100 MNEMONICS[27] := 'ANDI ANDM ANDB ANDCA ANDCAIANDCAMANDCABSETM SETMI SETMM ' ;
22200 MNEMONICS[28] := 'SETMB ANDCM ANDCMIANDCMMANDCMBSETA SETAI SETAM SETAB XOR ' ;
22300 MNEMONICS[29] := 'XORI XORM XORB IOR IORI IORM IORB ANDCB ANDCBIANDCBM' ;
22400 MNEMONICS[30] := 'ANDCBBEQV EQVI EQVM EQVB SETCA SETCAISETCAMSETCABORCA ' ;
22500 MNEMONICS[31] := 'ORCAI ORCAM ORCAB SETCM SETCMISETCMMSETCMBORCM ORCMI ORCMM ' ;
22600 MNEMONICS[32] := 'ORCMB ORCB ORCBI ORCBM ORCBB SETO SETOI SETOM SETOB HLL ' ;
22700 MNEMONICS[33] := 'HLLI HLLM HLLS HRL HRLI HRLM HRLS HLLZ HLLZI HLLZM ' ;
22800 MNEMONICS[34] := 'HLLZS HRLZ HRLZI HRLZM HRLZS HLLO HLLOI HLLOM HLLOS HRLO ' ;
22900 MNEMONICS[35] := 'HRLOI HRLOM HRLOS HLLE HLLEI HLLEM HLLES HRLE HRLEI HRLEM ' ;
23000 MNEMONICS[36] := 'HRLES HRR HRRI HRRM HRRS HLR HLRI HLRM HLRS HRRZ ' ;
23100 MNEMONICS[37] := 'HRRZI HRRZM HRRZS HLRZ HLRZI HLRZM HLRZS HRRO HRROI HRROM ' ;
23200 MNEMONICS[38] := 'HRROS HLRO HLROI HLROM HLROS HRRE HRREI HRREM HRRES HLRE ' ;
23300 MNEMONICS[39] := 'HLREI HLREM HLRES TRN TLN TRNE TLNE TRNA TLNA TRNN ' ;
23400 MNEMONICS[40] := 'TLNN TDN TSN TDNE TSNE TDNA TSNA TDNN TSNN TRZ ' ;
23500 MNEMONICS[41] := 'TLZ TRZE TLZE TRZA TLZA TRZN TLZN TDZ TSZ TDZE ' ;
23600 MNEMONICS[42] := 'TSZE TDZA TSZA TDZN TSZN TRC TLC TRCE TLZE TRCA ' ;
23700 MNEMONICS[43] := 'TLCA TRCN TLCN TDC TSC TDCE TSCE TDCA TSCA TDCN ' ;
23800 MNEMONICS[44] := 'TSCN TRO TLO TROE TLOE TROA TLOA TRON TLON TDO ' ;
23900 MNEMONICS[45] := 'TSO TDOE TSOE TDOA TSOA TDON TSON ***700 ' ;
24000 END;
24100
24200 INITPROCEDURE %SEARCH LIBRARIES\ ;
24300 BEGIN
24400 LIBRARY[PASCALSY].INORDER := FALSE;
24500 LIBRARY[FORTRANSY].INORDER := FALSE;
24600 LIBRARY[ALGOLSY].INORDER := FALSE;
24700 LIBRARY[COBOLSY].INORDER := FALSE;
24800 LIBRARY[PASCALSY].CALLED := FALSE;
24900 LIBRARY[FORTRANSY].CALLED := FALSE;
25000 LIBRARY[ALGOLSY].CALLED := FALSE;
25100 LIBRARY[COBOLSY].CALLED := FALSE;
25200 (* 57 - Make library a parameter *)
25300 LIBRARY[PASCALSY].NAME := PASLIB;
25400 LIBRARY[FORTRANSY].NAME := 'FORLIB ';
25500 LIBRARY[ALGOLSY].NAME := 'ALGLIB ';
25600 LIBRARY[COBOLSY].NAME := 'LIBOL ';
25700 (* 2 - library now on SYS: *)
25800 (* 57 *)
25900 LIBRARY[PASCALSY].DEVICE := PASDEV;
26000 LIBRARY[FORTRANSY].DEVICE := 'SYS ';
26100 LIBRARY[ALGOLSY].DEVICE := 'SYS ';
26200 LIBRARY[COBOLSY].DEVICE := 'SYS ';
26300 (* 57 *)
26400 LIBRARY[PASCALSY].PROJNR := PASPROJ;
26500 LIBRARY[FORTRANSY].PROJNR := 0;
26600 LIBRARY[ALGOLSY].PROJNR := 0;
26700 LIBRARY[COBOLSY].PROJNR := 0;
26800 (* 57 *)
26900 LIBRARY[PASCALSY].PROGNR := PASPROG;
27000 LIBRARY[FORTRANSY].PROGNR := 0;
27100 LIBRARY[ALGOLSY].PROGNR := 0;
27200 LIBRARY[COBOLSY].PROGNR := 0;
27300 END %SEARCH LIBRARIES\ ;
27400
27500 INITPROCEDURE %STANDARDNAMES\ ;
27600 BEGIN
27700 NA[ 1] := 'FALSE '; NA[ 2] := 'TRUE '; NA[ 3] := 'INPUT ';
27800 NA[ 4] := 'OUTPUT '; NA[ 5] := 'TTY '; NA[ 6] := 'TTYOUTPUT ';
27900 NA[ 7] := 'GET '; NA[ 8] := 'GETLN '; NA[ 9] := 'PUT ';
28000 NA[10] := 'PUTLN '; NA[11] := 'RESET '; NA[12] := 'REWRITE ';
28100 NA[13] := 'READ '; NA[14] := 'READLN '; NA[15] := 'BREAK ';
28200 NA[16] := 'WRITE '; NA[17] := 'WRITELN '; NA[18] := 'PACK ';
28300 NA[19] := 'UNPACK '; NA[20] := 'NEW '; NA[21] := 'MARK ';
28400 NA[22] := 'RELEASE '; NA[23] := 'GETLINENR '; NA[24] := 'PUT8BITSTO';
28500 NA[25] := 'PAGE '; NA[26] := 'DATE '; NA[27] := 'RUNTIME ';
28600 NA[28] := 'TIME '; NA[29] := 'ABS '; NA[30] := 'SQR ';
28700 NA[31] := 'TRUNC '; NA[32] := 'ODD '; NA[33] := 'ORD ';
28800 NA[34] := 'CHR '; NA[35] := 'PRED '; NA[36] := 'SUCC ';
28900 NA[37] := 'EOF '; NA[38] := 'EOLN '; NA[39] := 'SIN ';
29000 NA[40] := 'COS '; NA[41] := 'EXP '; NA[42] := 'SQRT ';
29100 NA[43] := 'LN '; NA[44] := 'ARCTAN '; NA[45] := 'LOG ';
29200 NA[46] := 'SIND '; NA[47] := 'COSD '; NA[48] := 'SINH ';
29300 NA[49] := 'COSH '; NA[50] := 'TANH '; NA[51] := 'ARCSIN ';
29400 NA[52] := 'ARCCOS '; NA[53] := 'RANDOM ';
29500 (* 10 make room for 12 more proc's, 8 more ftn's *)
29600 NA[54] := 'STRSET '; NA[55] := 'STRWRITE ';
29700 NA[56] := 'GETINDEX '; NA[57] := 'CLOSE ';
29800 NA[58] := 'CALLI '; NA[59] := 'RENAME ';
29900 NA[60] := 'DISMISS '; NA[61] := 'UPDATE ';
30000 NA[62] := 'DUMPIN '; NA[63] := 'DUMPOUT ';
30100 NA[64] := 'USETI '; NA[65] := 'USETO ';
30200 (* 27 - add NEWZ *)
30300 NA[66] := 'BREAKIN '; NA[67] := 'NEWZ ';
30400 NA[68] := 'APPEND '; NA[69] := 'PUTX ';
30500 (* 44 - SETPOS,CURPOS, SKIP *)
30600 NA[70] := 'SETPOS '; NA[71] := 'NEXTBLOCK ';
30700 (* 61 - tops20 system version *)
30800 na[72] := 'GETX '; na[73] := 'DELETE ';
30900 na[74] := 'RCLOSE '; na[75] := 'JSYS ';
31000 (* 152 - add DISPOSE *)
31100 na[76] := 'DISPOSE '; na[77] := 'NEXTFILE ';
31200 na[78] := 'CURPOS '; na[79] := 'SPACELEFT ';
31300 na[80] := 'ROUND '; na[81] := 'RECSIZE ';
31400 machna[24] := t10name; machna[58] := t10name;
31500 machna[62] := t10name; machna[63] := t10name;
31600 machna[64] := t10name; machna[65] := t10name;
31700 (* 134 - remove t20name entry for DELETE *)
31800 machna[71] := t10name;
31900 machna[74] := t20name; machna[75] := t20name;
32000 machna[77] := t20name; machna[79] := t10name;
32100 END %STANDARDNAMES\ ;
32200
32300 INITPROCEDURE %EXTERNAL NAMES\;
32400 BEGIN
32500 EXTNA[39] := 'SIN '; EXTLANGUAGE[39] := FORTRANSY;
32600 EXTNA[40] := 'COS '; EXTLANGUAGE[40] := FORTRANSY;
32700 EXTNA[41] := 'EXP '; EXTLANGUAGE[41] := FORTRANSY;
32800 EXTNA[42] := 'SQRT '; EXTLANGUAGE[42] := FORTRANSY;
32900 EXTNA[43] := 'ALOG '; EXTLANGUAGE[43] := FORTRANSY;
33000 EXTNA[44] := 'ATAN '; EXTLANGUAGE[44] := FORTRANSY;
33100 EXTNA[45] := 'ALOG10 '; EXTLANGUAGE[45] := FORTRANSY;
33200 EXTNA[46] := 'SIND '; EXTLANGUAGE[46] := FORTRANSY;
33300 EXTNA[47] := 'COSD '; EXTLANGUAGE[47] := FORTRANSY;
33400 EXTNA[48] := 'SINH '; EXTLANGUAGE[48] := FORTRANSY;
33500 EXTNA[49] := 'COSH '; EXTLANGUAGE[49] := FORTRANSY;
33600 EXTNA[50] := 'TANH '; EXTLANGUAGE[50] := FORTRANSY;
33700 EXTNA[51] := 'ASIN '; EXTLANGUAGE[51] := FORTRANSY;
33800 EXTNA[52] := 'ACOS '; EXTLANGUAGE[52] := FORTRANSY;
33900 EXTNA[53] := 'RAN '; EXTLANGUAGE[53] := FORTRANSY;
34000
34100 END %EXTERNAL NAMES\;
34200
34300 INITPROCEDURE %RUNTIME-, DEBUG-SUPPORTS\ ;
34400 BEGIN
34500
34600 RNTS.NAME[STACKOVERFLOW] := 'CORERR ';
34700 (* 104 - new tops10 stackoverflow for better checking *)
34800 RNTS.NAME[DEBSTACK] := 'DCORER ';
34900 (* 23 - check for bad pointer *)
35000 RNTS.NAME[BADPOINT] := 'PTRER. ';
35100 RNTS.NAME[ALLOCATE] := 'NEW ';
35200 RNTS.NAME[CLEARALLOC] := 'NEWCL. ';
35300 (* 152 - DISPOSE *)
35400 RNTS.NAME[DEALLOCATE] := 'DISPOS ';
35500 (* 173 - internal file *)
35600 RNTS.NAME[WITHFILEDEALLOCATE] := 'DISPF. ';
35700 (* 64 - non-loc goto *)
35800 rnts.name[exitgoto] := 'GOTOC. ';
35900 RNTS.NAME[EXITPROGRAM] := 'END ';
36000 RNTS.NAME[GETLINE] := 'GETLN ';
36100 RNTS.NAME[GETFILE] := 'GET. ';
36200 RNTS.NAME[PUTLINE] := 'PUTLN ';
36300 RNTS.NAME[PUTFILE] := 'PUT ';
36400 (* 43 - add PUTX *)
36500 RNTS.NAME[PUTXFILE] := 'PUTX ';
36600 RNTS.NAME[RESETFILE] := 'RESETF ';
36700 RNTS.NAME[REWRITEFILE] := 'REWRIT ';
36800 (* 57 - do strset and strwrite at runtime *)
36900 RNTS.NAME[RESETSTRING] := 'STSET. ';
37000 RNTS.NAME[REWRITESTRING] := 'STWR. ';
37100 RNTS.NAME[WRITEOCTAL] := 'WRTOCT ';
37200 RNTS.NAME[WRITEHEXADECIMAL] := 'WRTHEX ';
37300 RNTS.NAME[WRITEINTEGER] := 'WRTINT ';
37400 RNTS.NAME[WRITECHARACTER] := 'WRITEC ';
37500 RNTS.NAME[WRITEREAL] := 'WRTREA ';
37600 RNTS.NAME[WRITEBOOLEAN] := 'WRTBOL ';
37700 RNTS.NAME[WRITESTRING] := 'WRTUST ';
37800 RNTS.NAME[WRITEPACKEDSTRING] := 'WRTPST ';
37900 RNTS.NAME[WRITERECORD] := '.WRREC ';
38000 RNTS.NAME[WRITESCALAR] := '.WRSCA ';
38100 RNTS.NAME[READINTEGER] := '.READI ';
38200 RNTS.NAME[READCHARACTER] := '.READC ';
38300 RNTS.NAME[READREAL] := '.READR ';
38400 RNTS.NAME[READRECORD] := '.READD ';
38500 RNTS.NAME[CONVERTINTEGERTOREAL] := 'INTREA ';
38600 RNTS.NAME[CONVERTREALTOINTEGER] := 'TRUNC ';
38700 RNTS.NAME[BREAKOUTPUT] := 'BREAK ';
38800 RNTS.NAME[OPENTTY] := 'TTYPR. ';
38900 RNTS.NAME[INITIALIZEDEBUG] := 'INDEB. ';
39000 RNTS.NAME[ENTERDEBUG] := 'EXDEB. ';
39100 RNTS.NAME[GETCHARACTER] := 'GETCH ';
39200 RNTS.NAME[PUTPAGE] := 'PUTPG ';
39300 RNTS.NAME[INDEXERROR] := 'INXERR ';
39400 RNTS.NAME[ERRORINASSIGNMENT] := 'SRERR ';
39500 RNTS.NAME[FILEUNINITIALIZED] := 'ILFIL. ';
39600 RNTS.NAME[INITFILEBLOCK] := 'INITB. ';
39700 (* 10 ADD CLOSE *)
39800 RNTS.NAME[CLOSEFILE] := 'CLOFIL ';
39900 (* 14 AND STRING READERS *)
40000 RNTS.NAME[READSTRING] := 'READUS ';
40100 RNTS.NAME[READPACKEDSTRING] := 'READPS ';
40200 RNTS.NAME[READFILENAME] := 'GETFN. ';
40300 RNTS.NAME[NAMEFILE] := 'RENAME ';
40400 (* 40 - change name so won't conflict with FORTRAN *)
40500 RNTS.NAME[DISFILE] := 'RESDEV ';
40600 RNTS.NAME[UPFILE] := 'UPDATE ';
40700 RNTS.NAME[APFILE] := 'APPEND ';
40800 RNTS.NAME[READDUMP] := 'DUMPIN ';
40900 RNTS.NAME[WRITEDUMP] := 'DUMPOU ';
41000 RNTS.NAME[SETIN] := 'USETIN ';
41100 RNTS.NAME[SETOUT] := 'USETOU ';
41200 RNTS.NAME[BREAKINPUT] := 'BREAKI ';
41300 RNTS.NAME[SETPOSF] := 'SETPOS ';
41400 RNTS.NAME[CURPOSF] := 'CURPOS ';
41500 RNTS.NAME[NEXTBLOCKF] := 'NEXTBL ';
41600 rnts.name[spaceleftf] := 'SPCLF. ';
41700 rnts.name[getxf] := 'GETX. ';
41800 (* 74 - Tops20 runtimes *)
41900 rnts.name[delfile] := 'DELF. ';
42000 rnts.name[relfile] := 'RELF. ';
42100 rnts.name[initmem] := 'PASIM. ';
42200 (* 120 - New calling convention, so changed name *)
42300 rnts.name[initfiles] := 'PASIF. ';
42400 rnts.name[getdaytime] := 'DAYTM. ';
42500
42600 END %RUNTIME-, DEBUG-SUPPORTS\ ;
42700
42800 INITPROCEDURE %INITSCALARS\ ;
42900 BEGIN
43000 CHANTAB[1] := 0; CHANTAB[2] := 0; CHANTAB[3] := 0; CHANTAB[4] := 0;
43100 (* 65 - remove exit labels *)
43200 FWPTR := NIL; LASTBTP := NIL; FGLOBPTR := NIL ; FILEPTR := NIL ;
43300 LOCALPFPTR:=NIL; EXTERNPFPTR:= NIL; GLOBTESTP := NIL; ERRMPTR := NIL;
43400 (* 24 - INITIALZE HEAP AND STACK *)
43500 HEAP := 0; STACK := 0;
43600
43700 LISTCODE := FALSE; LOADNOPTR := TRUE; INITGLOBALS := FALSE ; RUNTMCHECK := TRUE;
43800 (* 157 - separate control for arith error *)
43900 ARITHCHECK := TRUE;
44000 TTYINUSE := TRUE; FOLLOWERROR := FALSE; ERRORINLINE := FALSE; RESETFLAG := TRUE;
44100 (* 172 *)
44200 TTYSEEEOL := FALSE;
44300 DP := TRUE; PRTERR := TRUE; ERRORFLAG := FALSE ; MAIN := TRUE;
44400 ENTRYDONE := FALSE; DEBUG := FALSE; DEBUGSWITCH := FALSE;
44500 (* 176 *)
44600 comment_page := 0;
44700 (* 33 - PROGRAM *)
44800 FPROGFILE := NIL; LPROGFILE := NIL;
44900 (* 64 - non-loc goto *)
45000 lastlabel := nil;
45100
45200 LC := PROGRST; %START OF LOWSEGMENT AVAILABLE TO PROGRAM\
45300 (* 136 - listing format *)
45400 CHCNT := 0; LINECNT := 1; PAGECNT := 1; SUBPAGE := 0;
45500 LASTLINE := -1; LASTPAGE := 0;
45600 (* 12 - initialize new variables for dynamic core *)
45700 LIBIX := 0; ERRINX := 0; LSTNEW := 0; NEWBND := 0;
45800 END %INITSCALARS\ ;
45900
46000 INITPROCEDURE %INITSETS\ ;
46100 BEGIN
46200 DIGITS := ['0'..'9'];
46300 LETTERS := ['A'..'Z'];
46400 HEXADIGITS := ['0'..'9','A'..'F'];
46500 LETTERSORDIGITS := [ '0'..'9','A'..'Z'];
46600 LETTERSDIGITSORLEFTARROW := ['0'..'9','A'..'Z','_'];
46700 LANGUAGESYS := [FORTRANSY,ALGOLSY,COBOLSY,PASCALSY];
46800 CONSTBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT];
46900 SIMPTYPEBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT] ;
47000 TYPEBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,ARROW,PACKEDSY,ARRAYSY,RECORDSY,SETSY,FILESY] ;
47100 TYPEDELS := [ARRAYSY,RECORDSY,SETSY,FILESY];
47200 (* 56 - add require files *)
47300 BLOCKBEGSYS := [INCLUDESY,LABELSY,CONSTSY,TYPESY,VARSY,INITPROCSY,PROCEDURESY,FUNCTIONSY,BEGINSY];
47400 SELECTSYS := [ARROW,PERIOD,LBRACK];
47500 FACBEGSYS := [INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,LBRACK,NOTSY];
47600 STATBEGSYS := [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,LOOPSY,FORSY,WITHSY,CASESY]
47700 END %INITSETS\ ;
47800
47900 INITPROCEDURE %RESWORDS\ ;
48000 BEGIN
48100 RW[ 1] := 'IF '; RW[ 2] := 'DO '; RW[ 3] := 'OF ';
48200 RW[ 4] := 'TO '; RW[ 5] := 'IN '; RW[ 6] := 'OR ';
48300 RW[ 7] := 'END '; RW[ 8] := 'FOR '; RW[ 9] := 'VAR ';
48400 RW[10] := 'DIV '; RW[11] := 'MOD '; RW[12] := 'SET ';
48500 RW[13] := 'AND '; RW[14] := 'NOT '; RW[15] := 'THEN ';
48600 RW[16] := 'ELSE '; RW[17] := 'WITH '; RW[18] := 'GOTO ';
48700 RW[19] := 'LOOP '; RW[20] := 'CASE '; RW[21] := 'TYPE ';
48800 RW[22] := 'FILE '; RW[23] := 'EXIT '; RW[24] := 'BEGIN ';
48900 RW[25] := 'UNTIL '; RW[26] := 'WHILE '; RW[27] := 'ARRAY ';
49000 RW[28] := 'CONST '; RW[29] := 'LABEL '; RW[30] := 'ALGOL ';
49100 RW[31] := 'COBOL '; RW[32] := 'EXTERN '; RW[33] := 'PASCAL ';
49200 RW[34] := 'RECORD '; RW[35] := 'DOWNTO '; RW[36] := 'PACKED ';
49300 RW[37] := 'OTHERS '; RW[38] := 'REPEAT '; RW[39] := 'FORTRAN ';
49400 (* 6 - add PROGRAM statement *)
49500 (* 56 - ADD INCLUDE *)
49600 RW[40] := 'FORWARD '; RW[41] := 'PROGRAM '; RW[42] := 'INCLUDE ';
49700 RW[43] := 'FUNCTION '; RW[44] := 'PROCEDURE ';
49800 RW[45] := 'INITPROCED';
49900 FRW[1] := 1; FRW[2] := 1; FRW[3] := 7; FRW[4] := 15; FRW[5] := 24;
50000 FRW[6] := 32; FRW[7] := 39; FRW[8] := 43; FRW[9] := 44; FRW[10] := 45;
50100 FRW[11] := 46;
50200 END %RESWORDS\ ;
50300
50400 INITPROCEDURE %SYMBOLS\ ;
50500 BEGIN
50600 RSY[1] := IFSY; RSY[2] := DOSY; RSY[3] := OFSY; RSY[4] := TOSY;
50700 RSY[5] := RELOP; RSY[6] := ADDOP; RSY[7] := ENDSY; RSY[8] := FORSY;
50800 RSY[9] := VARSY; RSY[10] := MULOP; RSY[11] := MULOP; RSY[12] := SETSY;
50900 RSY[13] := MULOP; RSY[14] := NOTSY; RSY[15] := THENSY;
51000 RSY[16] := ELSESY; RSY[17] := WITHSY; RSY[18] := GOTOSY;
51100 RSY[19] := LOOPSY; RSY[20] := CASESY; RSY[21] := TYPESY;
51200 RSY[22] := FILESY; RSY[23] := EXITSY; RSY[24] := BEGINSY;
51300 RSY[25] := UNTILSY; RSY[26] := WHILESY; RSY[27] := ARRAYSY;
51400 RSY[28] := CONSTSY; RSY[29] := LABELSY;
51500 RSY[30] := ALGOLSY; RSY[31] := COBOLSY;
51600 RSY[32] := EXTERNSY; RSY[33] := PASCALSY; RSY[34] := FORTRANSY;
51700 RSY[34] := RECORDSY; RSY[35]:= DOWNTOSY; RSY[36] := PACKEDSY;
51800 RSY[37] := OTHERSSY; RSY[38]:= REPEATSY; RSY[39] := FORTRANSY;
51900 (* 6 - add PROGRAM statement *)
52000 (* 56 - ADD INCLUDE *)
52100 RSY[40] := FORWARDSY; RSY[41] := PROGRAMSY; RSY[42] := INCLUDESY; RSY[43] := FUNCTIONSY;
52200 RSY[44] := PROCEDURESY; RSY[45] := INITPROCSY;
52300
52400 SSY['A'] := OTHERSY; SSY['B'] := OTHERSY; SSY['C'] := OTHERSY;
52500 SSY['D'] := OTHERSY; SSY['E'] := OTHERSY; SSY['F'] := OTHERSY;
52600 SSY['G'] := OTHERSY; SSY['H'] := OTHERSY; SSY['I'] := OTHERSY;
52700 SSY['J'] := OTHERSY; SSY['K'] := OTHERSY; SSY['L'] := OTHERSY;
52800 SSY['M'] := OTHERSY; SSY['N'] := OTHERSY; SSY['O'] := OTHERSY;
52900 SSY['P'] := OTHERSY; SSY['Q'] := OTHERSY; SSY['R'] := OTHERSY;
53000 SSY['S'] := OTHERSY; SSY['T'] := OTHERSY; SSY['U'] := OTHERSY;
53100 SSY['V'] := OTHERSY; SSY['W'] := OTHERSY; SSY['X'] := OTHERSY;
53200 SSY['Y'] := OTHERSY; SSY['Z'] := OTHERSY; SSY['0'] := OTHERSY;
53300 SSY['1'] := OTHERSY; SSY['2'] := OTHERSY; SSY['3'] := OTHERSY;
53400 SSY['4'] := OTHERSY; SSY['5'] := OTHERSY; SSY['6'] := OTHERSY;
53500 SSY['7'] := OTHERSY; SSY['8'] := OTHERSY; SSY['9'] := OTHERSY;
53600 SSY['_'] := OTHERSY;
53700 SSY['+'] := ADDOP; SSY['-'] := ADDOP; SSY['*'] := MULOP;
53800 SSY['/'] := MULOP; SSY['('] := LPARENT; SSY[')'] := RPARENT;
53900 SSY['$'] := OTHERSY; SSY['='] := RELOP; SSY[' '] := OTHERSY;
54000 SSY[','] := COMMA; SSY['.'] := PERIOD; SSY[''''] := OTHERSY;
54100 SSY['['] := LBRACK; SSY[']'] := RBRACK; SSY[':'] := COLON;
54200 SSY['#'] := RELOP; SSY['%'] := OTHERSY; SSY['!'] := ADDOP;
54300 SSY['&'] := MULOP; SSY['^'] := ARROW; SSY['\'] := OTHERSY;
54400 SSY['<'] := RELOP; SSY['>'] := RELOP; SSY['@'] := RELOP;
54500 SSY['"'] := RELOP; SSY['?'] := NOTSY; SSY[';'] := SEMICOLON;
54600 END %SYMBOLS\ ;
54700
54800 INITPROCEDURE %OPERATORS\ ;
54900 BEGIN
55000 ROP[ 1] := NOOP; ROP[ 2] := NOOP; ROP[ 3] := NOOP; ROP[ 4] := NOOP;
55100 ROP[ 5] := INOP; ROP[ 6] := OROP; ROP[ 7] := NOOP; ROP[ 8] := NOOP;
55200 ROP[ 9] := NOOP; ROP[10] := IDIV; ROP[11] := IMOD; ROP[12] := NOOP;
55300 ROP[13] :=ANDOP; ROP[14] := NOOP; ROP[15] := NOOP; ROP[16] := NOOP;
55400 ROP[17] := NOOP; ROP[18] := NOOP; ROP[19] := NOOP; ROP[20] := NOOP;
55500 ROP[21] := NOOP; ROP[22] := NOOP; ROP[23] := NOOP; ROP[24] := NOOP;
55600 ROP[25] := NOOP; ROP[26] := NOOP; ROP[27] := NOOP; ROP[28] := NOOP;
55700 ROP[29] := NOOP; ROP[30] := NOOP; ROP[31] := NOOP; ROP[32] := NOOP;
55800 ROP[33] := NOOP; ROP[34] := NOOP; ROP[35] := NOOP; ROP[36] := NOOP;
55900 ROP[37] := NOOP; ROP[38] := NOOP; ROP[39] := NOOP; ROP[40] := NOOP;
56000 (* 6 - add PROGRAM statement *)
56100 (* 56 - ADD INCLUDE *)
56200 ROP[41] := NOOP; ROP[42] := NOOP; ROP[43] := NOOP; ROP[44] := NOOP; ROP[45] := NOOP;
56300
56400 SOP['+'] := PLUS; SOP['-'] := MINUS; SOP['*'] := MUL; SOP['/'] := RDIV;
56500 SOP['='] := EQOP; SOP['#'] := NEOP; SOP['!'] := OROP; SOP['&'] := ANDOP;
56600 SOP['<'] := LTOP; SOP['>'] := GTOP; SOP['@'] := LEOP; SOP['"'] := GEOP;
56700 SOP[' '] := NOOP; SOP['$'] := NOOP; SOP['%'] := NOOP; SOP['('] := NOOP;
56800 SOP[')'] := NOOP; SOP[','] := NOOP; SOP['.'] := NOOP; SOP['0'] := NOOP;
56900 SOP['1'] := NOOP; SOP['2'] := NOOP; SOP['3'] := NOOP; SOP['4'] := NOOP;
57000 SOP['5'] := NOOP; SOP['6'] := NOOP; SOP['7'] := NOOP; SOP['8'] := NOOP;
57100 SOP['9'] := NOOP; SOP[':'] := NOOP; SOP[';'] := NOOP; SOP['?'] := NOOP;
57200 SOP['A'] := NOOP; SOP['B'] := NOOP; SOP['C'] := NOOP; SOP['D'] := NOOP;
57300 SOP['E'] := NOOP; SOP['F'] := NOOP; SOP['G'] := NOOP; SOP['H'] := NOOP;
57400 SOP['I'] := NOOP; SOP['J'] := NOOP; SOP['K'] := NOOP; SOP['L'] := NOOP;
57500 SOP['M'] := NOOP; SOP['N'] := NOOP; SOP['O'] := NOOP; SOP['P'] := NOOP;
57600 SOP['Q'] := NOOP; SOP['R'] := NOOP; SOP['S'] := NOOP; SOP['T'] := NOOP;
57700 SOP['U'] := NOOP; SOP['V'] := NOOP; SOP['W'] := NOOP; SOP['X'] := NOOP;
57800 SOP['Y'] := NOOP; SOP['Z'] := NOOP; SOP['['] := NOOP; SOP['\'] := NOOP;
57900 SOP[']'] := NOOP; SOP['^'] := NOOP; SOP['_'] := NOOP; SOP[''''] := NOOP;
58000 END %OPERATORS\ ;
58100
58200 INITPROCEDURE %RECORDSIZES\;
58300 BEGIN
58400 IDRECSIZE[TYPES] := 5;
58500 IDRECSIZE[KONST] := 6;
58600 IDRECSIZE[VARS] := 6;
58700 IDRECSIZE[FIELD] := 6;
58800 IDRECSIZE[PROC] := 5;
58900 IDRECSIZE[FUNC] := 8;
59000 (* 116 - define size of the new types for copyctp *)
59100 IDRECSIZE[PARAMS] := 5;
59200 IDRECSIZE[LABELT] := 6;
59300 STRECSIZE[SCALAR] := 2;
59400 STRECSIZE[SUBRANGE]:=4;
59500 STRECSIZE[POINTER]:= 2;
59600 STRECSIZE[POWER] := 2;
59700 STRECSIZE[ARRAYS] := 3;
59800 STRECSIZE[RECORDS]:= 3;
59900 STRECSIZE[FILES] := 2;
60000 STRECSIZE[TAGFWITHID]:=3;
60100 STRECSIZE[TAGFWITHOUTID] := 3;
60200 STRECSIZE[VARIANT] :=4
60300 END;
60400
60500 INITPROCEDURE %ERRORMESSAGES\ ;
60600 BEGIN
60700 ERRMESS15[ 1] := '":" expected ';
60800 ERRMESS15[ 2] := '")" expected ';
60900 ERRMESS15[ 3] := '"(" expected ';
61000 ERRMESS15[ 4] := '"[" expected ';
61100 ERRMESS15[ 5] := '"]" expected ';
61200 ERRMESS15[ 6] := '";" expected ';
61300 ERRMESS15[ 7] := '"=" expected ';
61400 ERRMESS15[ 8] := '"," expected ';
61500 ERRMESS15[ 9] := '":=" expected ';
61600 ERRMESS15[10] := '"OF" expected ';
61700 ERRMESS15[11] := '"DO" expected ';
61800 ERRMESS15[12] := '"IF" expected ';
61900 ERRMESS15[13] := '"END" expected ';
62000 ERRMESS15[14] := '"THEN" expected';
62100 ERRMESS15[15] := '"EXIT" expected';
62200 ERRMESS15[16] := 'Illegal symbol ';
62300 ERRMESS15[17] := 'No sign allowed';
62400 ERRMESS15[18] := 'Number expected';
62500 ERRMESS15[19] := 'Not implemented';
62600 ERRMESS15[20] := 'Error in type ';
62700 (* 35 - new error - no longer need old one, so we replaced*)
62800 ERRMESS15[21] := 'Compiler error ';
62900 ERRMESS15[22] := '"." expected ';
63000 ERRMESS15[23] := 'Error in factor';
63100 ERRMESS15[24] := 'Too many digits';
63200
63300 ERRMESS20[ 1] := '"BEGIN" expected ';
63400 ERRMESS20[ 2] := '"UNTIL" expected ';
63500 ERRMESS20[ 3] := 'Error in options ';
63600 ERRMESS20[ 4] := 'Constant too large ';
63700 ERRMESS20[ 5] := 'Digit must follow ';
63800 ERRMESS20[ 6] := 'Exponent too large ';
63900 ERRMESS20[ 7] := 'Constant expected ';
64000 ERRMESS20[ 8] := 'Simple type expected';
64100 ERRMESS20[ 9] := 'Identifier expected ';
64200 ERRMESS20[10] := 'Realtype not allowed';
64300 ERRMESS20[11] := 'Multidefined label ';
64400 ERRMESS20[12] := 'Filename expected ';
64500 ERRMESS20[13] := 'Set type expected ';
64600 ERRMESS20[14] := 'Undeclared exitlabel';
64700 ERRMESS20[15] := 'Undeclared label ';
64800 (* 6 - add error msg for illegal character *)
64900 ERRMESS20[16] := 'Illegal character ';
65000
65100 ERRMESS25[ 1] := '"TO"/"DOWNTO" expected ';
65200 ERRMESS25[ 2] := '8 OR 9 in octal number ';
65300 ERRMESS25[ 3] := 'Identifier not declared ';
65400 ERRMESS25[ 4] := 'File not allowed here ';
00100 ERRMESS25[ 5] := 'Integer constant expected';
00200 ERRMESS25[ 6] := 'Error in parameterlist ';
00300 ERRMESS25[ 7] := 'Already forward declared ';
00400 ERRMESS25[ 8] := 'This format for real only';
00500 ERRMESS25[ 9] := 'Varianttype must be array';
00600 ERRMESS25[10] := 'Type conflict of operands';
00700 ERRMESS25[11] := 'Multidefined case label ';
00800 ERRMESS25[12] := 'Octal for integer only ';
00900 ERRMESS25[13] := 'Array index out of bounds';
01000 (* 26 - two new error messages for reset/rewrite/update *)
01100 ERRMESS25[14] := 'Must be array or record ';
01200 ERRMESS25[15] := 'Must be at least 5 words ';
01300 (* 104 - error message for too much data for address space *)
01400 ERRMESS25[16] := 'Data won''t fit in memory ';
01500
01600 ERRMESS30[ 1] := 'String constant is too long ';
01700 ERRMESS30[ 2] := 'Identifier already declared ';
01800 ERRMESS30[ 3] := 'Subrange bounds must be scalar';
01900 ERRMESS30[ 4] := 'Incompatible subrange types ';
02000 ERRMESS30[ 5] := 'Incompatible with tagfieldtype';
02100 ERRMESS30[ 6] := 'Index type may not be integer ';
02200 ERRMESS30[ 7] := 'Type of variable is not array ';
02300 ERRMESS30[ 8] := 'Type of variable is not record';
02400 ERRMESS30[ 9] := 'No such field in this record ';
02500 ERRMESS30[10] := 'Expression too complicated ';
02600 ERRMESS30[11] := 'Illegal type of operand(s) ';
02700 ERRMESS30[12] := 'Tests on equality allowed only';
02800 ERRMESS30[13] := 'Strict inclusion not allowed ';
02900 (* 24 - CAN'T COMPARE RECORDS OR ARRAYS NOW *)
03000 ERRMESS30[14] := 'Structure comparison illegal ';
03100 ERRMESS30[15] := 'Illegal type of expression ';
03200 ERRMESS30[16] := 'Value of case label too large ';
03300 ERRMESS30[17] := 'Too many nested withstatements';
03400
03500 ERRMESS35[ 1] := 'String constant contains "<CR><LF>"';
03600 ERRMESS35[ 2] := 'Basetype requires more than 72 bits';
03700 ERRMESS35[ 3] := 'Basetype must be scalar or subrange';
03800 ERRMESS35[ 4] := 'More than 12 files declared by user';
03900 ERRMESS35[ 5] := 'File as value parameter not allowed';
04000 ERRMESS35[ 6] := 'Procedure too long (too much code) ';
04100 ERRMESS35[ 7] := 'No packed structure allowed here ';
04200 ERRMESS35[ 8] := 'Variant must belong to tagfieldtype';
04300 ERRMESS35[ 9] := 'Type of operand(s) must be boolean ';
04400 ERRMESS35[10] := 'Set element types not compatible ';
04500 ERRMESS35[11] := 'Assignment to files not allowed ';
04600 ERRMESS35[12] := 'Too many labels in this procedure ';
04700 ERRMESS35[13] := 'Too many cases in case statement ';
04800 ERRMESS35[14] := 'Control variable may not be formal ';
04900 ERRMESS35[15] := 'Illegal type of for-controlvariable';
05000 ERRMESS35[16] := 'Type of filecomponent must be char ';
05100 ERRMESS35[17] := 'Constant not in bounds of subrange ';
05200 (* 156 ftn^ := *)
05300 ERRMESS35[18] := 'Illegal when assigning to function ';
05400
05500 ERRMESS40[ 1] := 'Identifier is not of appropriate class ';
05600 ERRMESS40[ 2] := 'Tagfield type must be scalar or subrange';
05700 ERRMESS40[ 3] := 'Index type must be scalar or subrange ';
05800 ERRMESS40[ 4] := 'Too many nested scopes of identifiers ';
05900 ERRMESS40[ 5] := 'Pointer forward reference unsatisfied ';
06000 ERRMESS40[ 6] := 'Previous declaration was not forward ';
06100 ERRMESS40[ 7] := 'Type of variable must be file or pointer';
06200 ERRMESS40[ 8] := 'Missing corresponding variantdeclaration';
06300 ERRMESS40[ 9] := 'Too many variants in call of NEW (max 6)';
06400 ERRMESS40[10] := 'More than four errors in this sourceline';
06500 ERRMESS40[11] := 'No initialisation on records or files ';
06600 (* 31 - new message *)
06700 ERRMESS40[12] := 'Assignment to func. must be in its body ';
06800 ERRMESS40[13] := 'Too many parameters (must fit in AC''s) ';
06900
07000 ERRMESS45[ 1] := 'Low bound may not be greater than high bound ';
07100 ERRMESS45[ 2] := 'Identifier or "CASE" expected in fieldlist ';
07200 ERRMESS45[ 3] := 'Too many nested procedures and/or functions ';
07300 ERRMESS45[ 4] := 'File declaration in procedures not allowed ';
07400 ERRMESS45[ 5] := 'Missing result type in function declaration ';
07500 ERRMESS45[ 6] := 'Assignment to formal function is not allowed ';
07600 ERRMESS45[ 7] := 'Index type is not compatible with declaration';
07700 ERRMESS45[ 8] := 'Error in type of standard procedure parameter';
07800 ERRMESS45[ 9] := 'Error in type of standard function parameter ';
07900 ERRMESS45[10] := 'Real and string tagfields not implemented ';
08000 ERRMESS45[11] := 'Set element type must be scalar or subrange ';
08100 ERRMESS45[12] := 'In initprocedure only assignments possible ';
08200 ERRMESS45[13] := 'No constant or expression for VAR argument ';
08300 ERRMESS45[14] := 'EXTERN declaration not allowed in procedures ';
08400 ERRMESS45[15] := 'Body of forward declared procedure missing ';
08500 (* 24 - NEW ERROR MSG FOR LOC *)
08600 ERRMESS45[16] := 'Must be user-declared PASCAL proc. or func. ';
08700
08800 ERRMESS50[ 1] := 'Too many forward references of procedure entries ';
08900 ERRMESS50[ 2] := 'Assignment to standard function is not allowed ';
09000 ERRMESS50[ 3] := 'Parameter type does not agree with declaration ';
09100 ERRMESS50[ 4] := 'Initialisation only by assignment of constants ';
09200 ERRMESS50[ 5] := 'Label type incompatible with selecting expression ';
09300 ERRMESS50[ 6] := 'Statement must end with ";","END","ELSE"or"UNTIL" ';
09400 ERRMESS50[ 7] := 'Not allowed in initprocedures (packed structure?) ';
09500 (* 33 - PROGRAM *)
09600 ERRMESS50[ 8] := 'File mentioned in PROGRAM statement not declared ';
09700 (* 211 - better err msg *)
09800 ERRMESS50[ 9] := 'Variable mentioned in PROGRAM statement not a file';
09900
10000 ERRMESS55[ 1] := 'Function result type must be scalar,subrange or pointer';
10100 ERRMESS55[ 2] := 'Forward decl. func:repetition of resulttype not allowed';
10200 ERRMESS55[ 3] := 'Forward decl.: repetition of parameter list not allowed';
10300 ERRMESS55[ 4] := 'Number of parameters does not agree with declaration ';
10400 ERRMESS55[ 5] := 'Resulttype of parameter func. does not agree with decl.';
10500 ERRMESS55[ 6] := 'Selected expression must have type of control variable ';
10600 (* 124 - detect bad initproc *)
10700 ERRMESS55[ 7] := 'INITPROCEDURE can''t be within a procedure or function ';
10800 END %ERROR MESSAGES\ ;
10900
11000 (* 105 - new mapping from lower case *)
11100 initprocedure %character mapping tables\ ;
11200 begin
11300 charmap[0B] := 0B; charmap[1B] := 1B; charmap[2B] := 2B; charmap[3B] := 3B;
11400 charmap[4B] := 4B; charmap[5B] := 5B; charmap[6B] := 6B; charmap[7B] := 7B;
11500 charmap[10B] := 10B; charmap[11B] := 11B; charmap[12B] := 12B; charmap[13B] := 13B;
11600 charmap[14B] := 14B; charmap[15B] := 15B; charmap[16B] := 16B; charmap[17B] := 17B;
11700 charmap[20B] := 20B; charmap[21B] := 21B; charmap[22B] := 22B; charmap[23B] := 23B;
11800 charmap[24B] := 24B; charmap[25B] := 25B; charmap[26B] := 26B; charmap[27B] := 27B;
11900 charmap[30B] := 30B; charmap[31B] := 31B; charmap[32B] := 32B; charmap[33B] := 33B;
12000 charmap[34B] := 34B; charmap[35B] := 35B; charmap[36B] := 36B; charmap[37B] := 37B;
12100 charmap[40B] := 40B; charmap[41B] := 41B; charmap[42B] := 42B; charmap[43B] := 43B;
12200 charmap[44B] := 44B; charmap[45B] := 45B; charmap[46B] := 46B; charmap[47B] := 47B;
12300 charmap[50B] := 50B; charmap[51B] := 51B; charmap[52B] := 52B; charmap[53B] := 53B;
12400 charmap[54B] := 54B; charmap[55B] := 55B; charmap[56B] := 56B; charmap[57B] := 57B;
12500 charmap[60B] := 60B; charmap[61B] := 61B; charmap[62B] := 62B; charmap[63B] := 63B;
12600 charmap[64B] := 64B; charmap[65B] := 65B; charmap[66B] := 66B; charmap[67B] := 67B;
12700 charmap[70B] := 70B; charmap[71B] := 71B; charmap[72B] := 72B; charmap[73B] := 73B;
12800 charmap[74B] := 74B; charmap[75B] := 75B; charmap[76B] := 76B; charmap[77B] := 77B;
12900 charmap[100B] := 100B; charmap[101B] := 101B; charmap[102B] := 102B; charmap[103B] := 103B;
13000 charmap[104B] := 104B; charmap[105B] := 105B; charmap[106B] := 106B; charmap[107B] := 107B;
13100 charmap[110B] := 110B; charmap[111B] := 111B; charmap[112B] := 112B; charmap[113B] := 113B;
13200 charmap[114B] := 114B; charmap[115B] := 115B; charmap[116B] := 116B; charmap[117B] := 117B;
13300 charmap[120B] := 120B; charmap[121B] := 121B; charmap[122B] := 122B; charmap[123B] := 123B;
13400 charmap[124B] := 124B; charmap[125B] := 125B; charmap[126B] := 126B; charmap[127B] := 127B;
13500 charmap[130B] := 130B; charmap[131B] := 131B; charmap[132B] := 132B; charmap[133B] := 133B;
13600 charmap[134B] := 134B; charmap[135B] := 135B; charmap[136B] := 136B; charmap[137B] := 137B;
13700 charmap[140B] := 140B; charmap[141B] := 101B; charmap[142B] := 102B; charmap[143B] := 103B;
13800 charmap[144B] := 104B; charmap[145B] := 105B; charmap[146B] := 106B; charmap[147B] := 107B;
13900 charmap[150B] := 110B; charmap[151B] := 111B; charmap[152B] := 112B; charmap[153B] := 113B;
14000 charmap[154B] := 114B; charmap[155B] := 115B; charmap[156B] := 116B; charmap[157B] := 117B;
14100 charmap[160B] := 120B; charmap[161B] := 121B; charmap[162B] := 122B; charmap[163B] := 123B;
14200 charmap[164B] := 124B; charmap[165B] := 125B; charmap[166B] := 126B; charmap[167B] := 127B;
14300 charmap[170B] := 130B; charmap[171B] := 131B; charmap[172B] := 132B; charmap[173B] := 173B;
14400 charmap[174B] := 174B; charmap[175B] := 175B; charmap[176B] := 176B; charmap[177B] := 177B;
14500 (* 140 - redid numbers to make it come in the same order as ASCII *)
14600 setmap[0B] := 0B; setmap[1B] := 0B; setmap[2B] := 0B; setmap[3B] := 0B;
14700 setmap[4B] := 0B; setmap[5B] := 0B; setmap[6B] := 0B; setmap[7B] := 0B;
14800 setmap[10B] := 0B; setmap[11B] := 1B; setmap[12B] := 0B; setmap[13B] := 0B;
14900 setmap[14B] := 0B; setmap[15B] := 0B; setmap[16B] := 0B; setmap[17B] := 0B;
15000 setmap[20B] := 0B; setmap[21B] := 0B; setmap[22B] := 0B; setmap[23B] := 0B;
15100 setmap[24B] := 0B; setmap[25B] := 0B; setmap[26B] := 0B; setmap[27B] := 0B;
15200 setmap[30B] := 0B; setmap[31B] := 0B; setmap[32B] := 0B; setmap[33B] := 0B;
15300 setmap[34B] := 0B; setmap[35B] := 0B; setmap[36B] := 0B; setmap[37B] := 0B;
15400 setmap[40B] := 2B; setmap[41B] := 3B; setmap[42B] := 4B; setmap[43B] := 5B;
15500 setmap[44B] := 6B; setmap[45B] := 7B; setmap[46B] := 10B; setmap[47B] := 11B;
15600 setmap[50B] := 12B; setmap[51B] := 13B; setmap[52B] := 14B; setmap[53B] := 15B;
15700 setmap[54B] := 16B; setmap[55B] := 17B; setmap[56B] := 20B; setmap[57B] := 21B;
15800 setmap[60B] := 22B; setmap[61B] := 23B; setmap[62B] := 24B; setmap[63B] := 25B;
15900 setmap[64B] := 26B; setmap[65B] := 27B; setmap[66B] := 30B; setmap[67B] := 31B;
16000 setmap[70B] := 32B; setmap[71B] := 33B; setmap[72B] := 34B; setmap[73B] := 35B;
16100 setmap[74B] := 36B; setmap[75B] := 37B; setmap[76B] := 40B; setmap[77B] := 41B;
16200 setmap[100B] := 42B; setmap[101B] := 43B; setmap[102B] := 44B; setmap[103B] := 45B;
16300 setmap[104B] := 46B; setmap[105B] := 47B; setmap[106B] := 50B; setmap[107B] := 51B;
16400 setmap[110B] := 52B; setmap[111B] := 53B; setmap[112B] := 54B; setmap[113B] := 55B;
16500 setmap[114B] := 56B; setmap[115B] := 57B; setmap[116B] := 60B; setmap[117B] := 61B;
16600 setmap[120B] := 62B; setmap[121B] := 63B; setmap[122B] := 64B; setmap[123B] := 65B;
16700 setmap[124B] := 66B; setmap[125B] := 67B; setmap[126B] := 70B; setmap[127B] := 71B;
16800 setmap[130B] := 72B; setmap[131B] := 73B; setmap[132B] := 74B; setmap[133B] := 75B;
16900 setmap[134B] := 76B; setmap[135B] := 77B; setmap[136B] := 100B; setmap[137B] := 101B;
17000 setmap[140B] := 102B; setmap[141B] := 43B; setmap[142B] := 44B; setmap[143B] := 45B;
17100 setmap[144B] := 46B; setmap[145B] := 47B; setmap[146B] := 50B; setmap[147B] := 51B;
17200 setmap[150B] := 52B; setmap[151B] := 53B; setmap[152B] := 54B; setmap[153B] := 55B;
17300 setmap[154B] := 56B; setmap[155B] := 57B; setmap[156B] := 60B; setmap[157B] := 61B;
17400 setmap[160B] := 62B; setmap[161B] := 63B; setmap[162B] := 64B; setmap[163B] := 65B;
17500 setmap[164B] := 66B; setmap[165B] := 67B; setmap[166B] := 70B; setmap[167B] := 71B;
17600 setmap[170B] := 72B; setmap[171B] := 73B; setmap[172B] := 74B; setmap[173B] := 103B;
17700 setmap[174B] := 104B; setmap[175B] := 105B; setmap[176B] := 106B; setmap[177B] := 107B;
17800 end; %character mapping tables\
17900
18000 %-------------------------------------------------------------------------------\
18100
18200 (* 40 - make it restartable *)
18300 procedure reinit;
18400 begin
18500 CHANTAB[1] := 0; CHANTAB[2] := 0; CHANTAB[3] := 0; CHANTAB[4] := 0;
18600 (* 65 - remove exit labels *)
18700 FWPTR := NIL; LASTBTP := NIL; FGLOBPTR := NIL ; FILEPTR := NIL ;
18800 LOCALPFPTR:=NIL; EXTERNPFPTR:= NIL; GLOBTESTP := NIL; ERRMPTR := NIL;
18900 (* 24 - INITIALZE HEAP AND STACK *)
19000 HEAP := 0; STACK := 0;
19100 (* 124 - initialize CREF *)
19200 (* 125 - and REQFILE *)
19300 CREF := false; reqfile := false;
19400
19500 LISTCODE := FALSE; LOADNOPTR := TRUE; INITGLOBALS := FALSE ; RUNTMCHECK := TRUE;
19600 (* 157 - separate check for arith error *)
19700 ARITHCHECK := TRUE;
19800 TTYINUSE := TRUE; FOLLOWERROR := FALSE; ERRORINLINE := FALSE; RESETFLAG := TRUE;
19900 (* 172 - end of line *)
20000 TTYSEEEOL := FALSE;
20100 DP := TRUE; PRTERR := TRUE; ERRORFLAG := FALSE ; MAIN := TRUE;
20200 ENTRYDONE := FALSE; DEBUG := FALSE; DEBUGSWITCH := FALSE;
20300 (* 176 *)
20400 comment_page := 0;
20500 (* 33 - PROGRAM *)
20600 FPROGFILE := NIL; LPROGFILE := NIL;
20700
20800 (* 216 - variables high seg start *)
20900 highstart := 400000B;
21000 IC := HIGHSTART; %START OF HIGHSEGMENT\
21100 LC := PROGRST; %START OF LOWSEGMENT AVAILABLE TO PROGRAM\
21200 (* 136 - listing format *)
21300 CHCNT := 0; LINECNT := 1; PAGECNT := 1; SUBPAGE := 0; CURLINE := 1;
21400 LASTLINE := -1; LASTPAGE := 0;
21500 (* 12 - initialize new variables for dynamic core *)
21600 LIBIX := 0; ERRINX := 0; LSTNEW := 0; NEWBND := 0;
21700 with pager.word1 do
21800 begin instr:=0;ac:=0;indbit:=0;inxreg:=0;address:=0 end;
21900 pager.lhalf := 0; pager.rhalf := 0;
22000 debugentry.lastpageelem := pager;
22100 laststop := 0; lastpager := 0;
22200 (* 103 - changed type for idtree's *)
22300 debugentry.standardidtree := nil;
22400 debugentry.globalidtree := nil;
22500 filename := ' ';
22600 LIBRARY[PASCALSY].INORDER := FALSE;
22700 LIBRARY[FORTRANSY].INORDER := FALSE;
22800 LIBRARY[ALGOLSY].INORDER := FALSE;
22900 LIBRARY[COBOLSY].INORDER := FALSE;
23000 LIBRARY[PASCALSY].CALLED := FALSE;
23100 LIBRARY[FORTRANSY].CALLED := FALSE;
23200 LIBRARY[ALGOLSY].CALLED := FALSE;
23300 LIBRARY[COBOLSY].CALLED := FALSE;
23400 (* 105 - map lower case better *)
23500 setmapchain := 0;
23600 end;
23700
23800 (* 136 - new listing format *)
23900
24000 procedure pagehead;
24100 begin
24200 page;
24300 write(header,' ',day,' ',scandata^.relname);
24400 if reqfile
24500 then write(' ****Included file****');
24600 write(' Page ',pagecnt:0);
24700 if subpage > 0
24800 then write('-',subpage:0);
24900 writeln;
25000 writeln;
25100 curline := 1;
25200 end;
25300
25400 procedure newline;
25500 begin
25600 writeln;
25700 curline := curline+1;
25800 if curline > 53
25900 then begin
26000 subpage := subpage + 1;
26100 pagehead;
26200 end
26300 end;
26400
26500 PROCEDURE NEWPAGER;
26600 BEGIN
26700 WITH PAGER, WORD1 DO
26800 BEGIN
26900 AC := PAGECNT DIV 16;
27000 INXREG := PAGECNT MOD 16; ADDRESS := LASTPAGER;
27100 LHALF := LASTLINE; RHALF := LASTSTOP;
27200 LASTLINE := -1
27300 END
27400 END;
27500
27600 (* 5 - reorganized printing somewhat for CREF *)
27700 (* The FILCOM is a bit misleading here, as global changes have been made *)
27800 PROCEDURE BEGOFLINE;
27900 BEGIN
28000 IF CREF THEN WRITE(CHR(177B),'A');
28100 IF CHCNT > CHCNTMAX THEN CHCNT := CHCNTMAX;
28200 IF LISTCODE
28300 THEN
28400 BEGIN
28500 (* 5 - more of the CREF change *)
28600 IF BEGDP
28700 THEN
28800 BEGIN
28900 WRITE(BEGLC:6:O);
29000 IF (BEGLC < PROGRST) OR (BEGLEVEL > 1)
29100 THEN WRITE(' ')
29200 ELSE WRITE('''')
29300 END
29400 ELSE WRITE(BEGIC:6:O,'''');
29500 WRITE(' ':2)
29600 END;
29700 IF LINENR='-----'
29800 THEN WRITE(LINECNT:5)
29900 ELSE WRITE(LINENR) ;
30000 WRITE(' ':3);
30100 END;
30200
30300 PROCEDURE WRITEBUFFER;
30400 BEGIN
30500 IF LISTCODE
30600 THEN
30700 BEGIN
30800 (* 5 - more CREF *)
30900 IF CREF THEN WRITE(CHR(177B),'B'); BEGOFLINE;
31000 (* 136 - listing format *)
31100 WRITE(BUFFER:CHCNT); FOR CHCNT := 1 TO 17 DO BUFFER[CHCNT] := ' '; CHCNT := 17;
31200 newline;
31300 END
31400 END;
31500
31600 PROCEDURE GETNEXTLINE;
31700 BEGIN
31800 LOOP
31900 GETLINENR(LINENR);
32000 EXIT IF INPUT^ # CHR(14B); %TEST END OF PAGE\
32100 IF DEBUG AND (LASTLINE > -1)
32200 THEN NEWPAGER;
32300 (* 136 - listing format *)
32400 PAGECNT := PAGECNT + 1; SUBPAGE := 0;
32500 pagehead;
32600 (* 137 - reset line to 1 on each page *)
32700 linecnt := 1;
32800 READLN; %TO OVERREAD SECOND CARRIAGE RETURN IN PAGE MARK\
32900 END;
33000 IF CREF
33100 THEN WRITE(CHR(177B),'B');
33200 BEGIC:=IC;BEGLC:=LC;BEGDP:=DP;BEGLEVEL:=LEVEL;
33300 END;
33400
33500 (* 56 - needed for file switch *)
33600 PROCEDURE BEGSTUFF;
33700 BEGIN
33800 IF CREF
33900 THEN WRITE(CHR(177B),'B');
34000 BEGIC:=IC;BEGLC:=LC;BEGDP:=DP;BEGLEVEL:=LEVEL;
34100 CHCNT:=0
34200 END;
34300
34400 (* 16 - DETECT UNEXPECTED EOF *)
34500 (* 41 - make restartable *)
34600 PROCEDURE PASXIT(VAR A,B,C:FILE); EXTERN;
34700 (* 55 - ADD PROC'S FOR REQUIRE FILES *)
34800 PROCEDURE PUSHF(VAR F:FILE;S:STRGARR;L:INTEGER); EXTERN;
34900 PROCEDURE POPF(VAR F:FILE); EXTERN;
35000 (* 107 - moved declaration of analys so can be used several places *)
35100 procedure analys(var f:file); extern;
35200 (* 112 - clrbfi when error detected *)
35300 procedure clribf; extern;
35400 (* 141 - better detection of number overflow *)
35500 function overflow:Boolean; extern;
35600 (* 155 - source file name *)
35700 procedure curname(var f:file;var s:string); extern;
35800
35900 (* 56 - SEPARATE OUT STUFF NEEDED FOR FILE SWITCH *)
36000 PROCEDURE ENDSTUFF;
36100 VAR
36200 I,K: INTEGER;
36300 BEGIN
36400 (* 5 - more CREF *)
36500 BEGOFLINE;
36600 (* 136 - listing format *)
36700 WRITE(BUFFER:CHCNT); NEWLINE;
36800 IF ERRORINLINE
36900 THEN %OUTPUT ERROR MESSAGES\
37000 BEGIN
37100 IF LISTCODE
37200 THEN K := 11
37300 ELSE K := 2;
37400 WRITE(' ':K,'***** '); LISTCODE := FALSE;
37500 IF LINENR = '-----'
37600 THEN WRITE(TTY,LINECNT:5)
37700 ELSE WRITE(TTY,LINENR);
37800 WRITELN(TTY,' ':3,BUFFER:CHCNT); WRITE(TTY,'P*',PAGECNT:3,'** ');
37900 (* 5 - more CREF *)
38000 FOR K:=1 TO CHCNT DO
38100 IF BUFFER[K] = CHR(11B)
38200 THEN ERRLINE[K] := CHR(11B);
38300 (* 136 - LISTING FORMAT *)
38400 WRITE(ERRLINE : CHCNT); WRITELN(TTY,ERRLINE : CHCNT); NEWLINE;
38500 FOR K := 1 TO ERRINX DO
38600 WITH ERRLIST[K] DO
38700 BEGIN
38800 WRITE(' ':15,ARW:1,'.',TIC,': '); WRITE(TTY,ARW:1,'.',TIC,': ');
38900 IF ERRMPTR # NIL
39000 THEN
39100 BEGIN
39200 ERRMPTR1 := ERRMPTR;
39300 WHILE ERRMPTR1 # NIL DO
39400 WITH ERRMPTR1^ DO
39500 BEGIN
39600 IF NMR = NUMBER
39700 THEN
39800 BEGIN
39900 CASE FORM OF
40000 C:
40100 BEGIN
40200 WRITE(STRING:10,' --> ');WRITE(TTY,STRING:10,' --> ')
40300 END;
40400 D:
40500 BEGIN
40600 WRITE(INTVAL:5,' --> ');WRITE(TTY,INTVAL:5,' --> ')
40700 END
40800 END;
40900 NUMBER := 0; ERRMPTR1 := NIL
41000 END
41100 ELSE ERRMPTR1 := NEXT
41200 END
41300 END;
41400 I := NMR MOD 50;
41500 CASE NMR DIV 50 OF
41600 3:
41700 BEGIN
41800 WRITE(ERRMESS15[I]); WRITE(TTY,ERRMESS15[I])
41900 END;
42000 4:
42100 BEGIN
42200 WRITE(ERRMESS20[I]); WRITE(TTY,ERRMESS20[I])
42300 END;
42400 5:
42500 BEGIN
42600 WRITE(ERRMESS25[I]); WRITE(TTY,ERRMESS25[I])
42700 END;
42800 6:
42900 BEGIN
43000 WRITE(ERRMESS30[I]); WRITE(TTY,ERRMESS30[I])
43100 END;
43200 7:
43300 BEGIN
43400 WRITE(ERRMESS35[I]); WRITE(TTY,ERRMESS35[I])
43500 END;
43600 8:
43700 BEGIN
43800 WRITE(ERRMESS40[I]); WRITE(TTY,ERRMESS40[I])
43900 END;
44000 9:
44100 BEGIN
44200 WRITE(ERRMESS45[I]); WRITE(TTY,ERRMESS45[I])
44300 END;
44400 10:
44500 BEGIN
44600 WRITE(ERRMESS50[I]); WRITE(TTY,ERRMESS50[I])
44700 END;
44800 11:
44900 BEGIN
45000 WRITE(ERRMESS55[I]); WRITE(TTY,ERRMESS55[I])
45100 END
45200 END;
45300 (* 136 - LISTING FORMAT *)
45400 newline; WRITELN(TTY)
45500 END;
45600 (* 26 - break not needed for TTY *)
45700 ERRINX := 0; ERRORINLINE := FALSE;
45800 FOR I := 1 TO CHCNT DO ERRLINE [I] := ' ';
45900 ERRMPTR := NIL
46000 END;
46100 (* 56 -SEPARATE OUT STUFF NEEDED FOR FILE SWITCH *)
46200 END;
46300
46400 PROCEDURE ENDOFLINE(OKEOF:BOOLEAN);
46500 BEGIN
46600 ENDSTUFF;
46700 (* 16 - DETECT UNEXPECTED EOF *)
46800 IF EOF(INPUT) AND NOT OKEOF
46900 THEN BEGIN
47000 (* 136 - LISTING FORMAT *)
47100 WRITE('Unexpected end of file'); NEWLINE;
47200 WRITELN(TTY,'? Unexpected end of file');
47300 (* 176 - error for unexpected EOF in a comment *)
47400 if comment_page <> 0 then (* we're in a comment *)
47500 begin
47600 write('Unterminated Comment at ',comment_page:0,
47700 '/',comment_line:0); NEWLINE;
47800 writeln(tty,'? Unterminated Comment at ',comment_page:0,
47900 '/',comment_line:0)
48000 end;
48100 (* 41 - make restartable *)
48200 (* 107 - abort creation of rel file on error *)
48300 rewrite(outputrel);
48400 (* 112 - clrbfi when error *)
48500 clribf;
48600 (* 125 - popf to be sure we get main file closed in reqfile *)
48700 if reqfile
48800 then begin
48900 close(input);
49000 popf(input)
49100 end;
49200 PASXIT(INPUT,OUTPUT,OUTPUTREL)
49300 END;
49400 READLN;
49500 (* 147 - move incr linecnt here so first line of new page is 1 *)
49600 LINECNT := LINECNT + 1;
49700 IF NOT EOF(INPUT)
49800 THEN GETNEXTLINE;
49900 (* 136 - listing format *)
50000 CHCNT := 0
50100 END %ENDOFLINE\ ;
50200
50300 PROCEDURE ERROR(FERRNR: INTEGER);
50400 VAR
50500 LPOS,LARW : INTEGER;
50600 BEGIN
50700 IF NOT FOLLOWERROR
50800 THEN
50900 BEGIN
51000 ERRORFLAG := TRUE ;
51100 IF ERRINX >= MAXERR
51200 THEN
51300 BEGIN
51400 ERRLIST[MAXERR].NMR := 410; ERRINX := MAXERR
51500 END
51600 ELSE
51700 BEGIN
51800 ERRINX := ERRINX + 1;
51900 WITH ERRLIST[ERRINX] DO BEGIN NMR := FERRNR; TIC := '^' END
52000 END;
52100 FOLLOWERROR := TRUE; ERRORINLINE := TRUE;
52200 IF (FERRNR # 215)
52300 AND (FERRNR # 356)
52400 AND (FERRNR # 405)
52500 AND (FERRNR # 464)
52600 THEN
52700 IF EOLN(INPUT)
52800 THEN ERRLINE [CHCNT] := '^'
52900 ELSE ERRLINE [CHCNT-1] := '^'
53000 ELSE ERRLIST[ERRINX].TIC := ' ';
53100 IF ERRINX > 1
53200 THEN
53300 WITH ERRLIST [ ERRINX-1] DO
53400 BEGIN
53500 LPOS := POS; LARW := ARW
53600 END;
53700 WITH ERRLIST [ERRINX] DO
53800 BEGIN
53900 POS := CHCNT;
54000 IF ERRINX = 1
54100 THEN ARW := 1
54200 ELSE
54300 IF LPOS = CHCNT
54400 THEN ARW := LARW
54500 ELSE ARW := LARW + 1
54600 END;
54700 END;
54800 END %ERROR\ ;
54900
55000 PROCEDURE ERRORWITHTEXT ( FERRNR: INTEGER; FTEXT: ALFA ) ;
55100 BEGIN
55200 ERROR(FERRNR); NEWZ(ERRMPTR1,C);
55300 WITH ERRMPTR1^ DO
55400 BEGIN
55500 NUMBER := FERRNR; STRING := FTEXT;
55600 NEXT := ERRMPTR
55700 END;
55800 ERRMPTR := ERRMPTR1
55900 END %ERROR WITH TEXT\ ;
56000
56100 PROCEDURE INSYMBOL;
56200 %READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS
56300 DESCRIPTION IN THE GLOBAL VARIABLES SY, OP, ID, VAL AND LGTH\
56400 (* 114 - prevent recursive comment scanning *)
56500 LABEL 2;
56600 CONST
56700 (* 210 - allow 9 digit hex numbers *)
56800 hexmax = 9;
56900 DIGMAX = 12; MAX8 = 37777777777B;
57000 TEST8 = 40000000000B;
57100 MIN8 = 400000000000B;
57200 (* 142 - better real number scanning *)
57300 MAX10 = 3435973836; {maximum number, sans last digit}
57400 MAX16 = 17777777777B;
57500 MAXEXP = 35;
57600 type
57700 (* 43 - allow 12 digit octal no. *)
57800 numconv=record case Boolean of
57900 true:(oct:packed array[1:digmax]of 0..7);
58000 false:(int:integer)
58100 end;
58200 (* 210 - allow 9 digit hex numbers *)
58300 hexconv=record case Boolean of
58400 true:(hex:packed array[1..hexmax] of 0..15);
58500 false:(int:integer)
58600 end;
58700 VAR
58800 (* 133 - make real numbers be read exactly *)
58900 I,K,ASCALE,SCALE,EXP,IVAL: INTEGER;
59000 RVAL,R,FAC: REAL; STRINGTOOLONG,SIGN: BOOLEAN;
59100 DIGIT: ARRAY [1..DIGMAX] OF 0..9;
59200 STRING: ARRAY [1..STRGLGTH] OF CHAR;
59300 LVP: CSP;
59400 (* 43 - allow 12 digit octal no. *)
59500 nc:numconv;
59600 (* 210 - allow 9 digit hex numbers *)
59700 hc:hexconv;
59800
59900 PROCEDURE NEXTCH;
60000 BEGIN
60100 IF EOLN(INPUT)
60200 THEN CH := ' '
60300 ELSE
60400 BEGIN
60500 %READ(CH);\ CH := INPUT^; GET(INPUT); %THIS CHANGE SAVES 3 INSTRUCTIONS AT RUN-TIME\
60600 CHCNT := CHCNT + 1;
60700 IF CHCNT <= CHCNTMAX
60800 THEN BUFFER[CHCNT] := CH
60900 (* 3 - map lower case to upper. Need separate NEXTCH for strings now,
61000 since we don't do mapping there. *)
61100 END;
61200 (* 105 - improve lower case mapping *)
61300 ch := chr(charmap[ord(ch)]);
61400 END;
61500
61600 PROCEDURE NEXTSTRCH;
61700 BEGIN
61800 IF EOLN(INPUT)
61900 THEN CH := ' '
62000 ELSE
62100 BEGIN
62200 CH := INPUT^; GET(INPUT);
62300 CHCNT := CHCNT + 1;
62400 IF CHCNT <= CHCNTMAX
62500 THEN BUFFER[CHCNT] := CH
62600 END
62700 END;
62800
62900 PROCEDURE OPTIONS;
63000 VAR
63100 LCH : CHAR; LSWITCH : BOOLEAN;
63200 BEGIN
63300 REPEAT
63400 NEXTCH; LCH := CH;
63500 IF NOT (CH IN ['\','*'])
63600 THEN NEXTCH;
63700 IF NOT (CH IN ['+','-'])
63800 (* 24 - S AND H FOR STACK AND HEAP *)
63900 (* 33 - version *)
64000 (* 216 - variable start of hiseg *)
64100 THEN IF (LCH IN ['P','H','S','V']) AND (CH = ':')
64200 THEN BEGIN
64300 NEXTCH;
64400 INSYMBOL;
64500 IF SY # INTCONST
64600 THEN ERROR(203)
64700 (* 24 - S AND H FOR STACK AND HEAP *)
64800 ELSE BEGIN
64900 (* 33 - version *)
65000 IF LCH IN ['H','S']
65100 THEN BEGIN
65200 IF (VAL.IVAL MOD 1000B) = 0
65300 THEN VAL.IVAL := VAL.IVAL -1;
65400 VAL.IVAL := (VAL.IVAL DIV 1000B)*1000B + 777B;
65500 END;
65600 (* 216 - settable high seg *)
65700 IF LCH IN ['H','S','P']
65800 THEN IF (VAL.IVAL < 0) OR (VAL.IVAL > MAXADDR)
65900 THEN ERROR(203);
66000 IF LCH = 'S'
66100 THEN STACK := VAL.IVAL
66200 (* 33 - version *)
66300 ELSE IF LCH = 'H'
66400 THEN HEAP := VAL.IVAL
66500 (* 216 - variable start of hi seg *)
66600 ELSE IF LCH = 'P'
66700 THEN BEGIN
66800 IF RESETFLAG
66900 THEN BEGIN
67000 HIGHSTART := VAL.IVAL;
67100 IC := HIGHSTART
67200 END
67300 END
67400 ELSE VERSION.WORD := VAL.IVAL
67500 END
67600 END
67700 ELSE ERROR(203)
67800 ELSE
67900 BEGIN
68000 LSWITCH := CH = '+';
68100 (* 157 - use CASE instead of IF nest *)
68200 CASE LCH OF
68300 'L': LISTCODE := LSWITCH;
68400 'T': IF RESETFLAG THEN TTYINUSE := LSWITCH;
68500 'M': IF RESETFLAG THEN MAIN := LSWITCH;
68600 'C': BEGIN RUNTMCHECK := LSWITCH; ARITHCHECK := LSWITCH END;
68700 'A': ARITHCHECK := LSWITCH;
68800 'Z': ZERO := LSWITCH;
68900 'D': BEGIN
69000 DEBUGSWITCH := LSWITCH;
69100 (* 36 - allow us to reset debug at beginning *)
69200 if resetflag
69300 then debug := lswitch
69400 else IF LSWITCH
69500 THEN DEBUG := TRUE
69600 END
69700 END
69800 END;
69900 IF EOLN(INPUT)
70000 (* 16 - EOF *)
70100 THEN ENDOFLINE(FALSE);
70200 IF NOT ((CH IN ['\','*']) OR (LCH = 'H'))
70300 THEN NEXTCH
70400 UNTIL CH # ','
70500 END %OPTIONS\ ;
70600
70700 (* 1 - reorganized a bit here, mainly to improve comment scanning *)
70800 PROCEDURE NEWCH;
70900 BEGIN
71000 (* 16 - EOF *)
71100 IF EOLN(INPUT) THEN ENDOFLINE(FALSE);
71200 NEXTCH
71300 END;
71400
71500 PROCEDURE SCANCOMMENT(STOPCH:CHAR);
71600 BEGIN
71700 (* 176 - error for unexpected EOF in a comment *)
71800 comment_page := pagecnt; { pagecnt had better not be 0 }
71900 comment_line := linecnt;
72000 NEWCH;
72100 IF CH='$' THEN OPTIONS;
72200 (* 105 - curly brackets are now comments *)
72300 if (stopch = '\') or (stopch = '}')
72400 then while ch # stopch do newch
72500 ELSE REPEAT WHILE CH#'*' DO NEWCH; NEXTCH UNTIL CH=STOPCH;
72600 (* 176 - error for unexpected EOF in a comment *)
72700 comment_page := 0;
72800 (* 114 - prevent deep recursion in comment scanning *)
72900 NEWCH;
73000 END;
73100
73200 BEGIN 2:
73300 %INSYMBOL\
73400 WHILE (CH = ' ') OR (ORD(CH) = 11B) DO
73500 BEGIN
73600 IF EOLN(INPUT)
73700 (* 16 - EOF *)
73800 THEN ENDOFLINE(FALSE);
73900 NEXTCH;
74000 END;
74100 (* 1 - code removed here for comments. Handled better elsewhere *)
74200 CASE CH OF
74300 'A','B','C','D','E','F','G','H','I',
74400 'J','K','L','M','N','O','P','Q','R',
74500 'S','T','U','V','W','X','Y','Z':
74600 BEGIN
74700 K := 0 ; ID := ' ';
74800 REPEAT
74900 IF K < ALFALENG
75000 THEN
75100 BEGIN
75200 K := K + 1; ID[K] := CH
75300 END ;
75400 NEXTCH
75500 UNTIL NOT (CH IN LETTERSDIGITSORLEFTARROW);
75600 FOR I := FRW[K] TO FRW[K+1] - 1 DO
75700 IF RW[I] = ID
75800 THEN
75900 BEGIN
76000 SY := RSY[I]; OP := ROP[I]; GOTO 1
76100 END;
76200 SY := IDENT; OP := NOOP;
76300 1:
76400 END;
76500 '0','1','2','3','4','5','6','7','8','9':
76600 BEGIN
76700 (* 141 - better way to check overflow *)
76800 if overflow then; {clear old errors}
76900 SY := INTCONST; OP := NOOP;
77000 (* 64 - non-loc goto *)
77100 id := ' ';
77200 I := 0;
77300 REPEAT
77400 I := I + 1;
77500 if i <= alfaleng
77600 then id[i] := ch;
77700 IF I <= DIGMAX
77800 (* 142 - better real scanning *)
77900 THEN DIGIT[I] := ORD(CH) - ORD('0');
78000 NEXTCH
78100 UNTIL NOT (CH IN DIGITS);
78200 IVAL := 0;
78300 IF CH = 'B'
78400 THEN
78500 BEGIN
78600 (* 43 - allow 12 digit octal no. *)
78700 (* 142 - better real number scanning *)
78800 if i > digmax
78900 then begin
79000 error(174);
79100 i := digmax
79200 end;
79300 nc.int:=0;
79400 FOR K := 1 TO I DO
79500 IF DIGIT[K] IN [8,9]
79600 THEN ERROR(252)
79700 else nc.oct[k+digmax-i]:=digit[k];
79800 val.ival := nc.int;
79900 NEXTCH
80000 END
80100 ELSE
80200 BEGIN
80300 (* 142 - better real number scanning *)
80400 scale := 0;
80500 FOR K := 1 TO I DO
80600 if scale > 0
80700 then scale := scale + 1
80800 else if ival < max10
80900 then ival := 10*ival + digit[k]
81000 else if (ival = max10) and (digit[k] <= 7)
81100 then ival := 10*ival + digit[k]
81200 else scale := scale + 1;
81300 IF CH = '.'
81400 THEN
81500 BEGIN
81600 NEXTCH;
81700 IF CH = '.'
81800 THEN CH := ':'
81900 ELSE
00100 BEGIN
00200 (* 142 - better real scanning *)
00300 SY := REALCONST;
00400 IF NOT (CH IN DIGITS)
00500 THEN ERROR(205)
00600 ELSE
00700 REPEAT
00800 if scale > 0
00900 then scale := scale + 1
01000 else if ival < max10
01100 then ival := 10*ival + (ord(ch)-ord('0'))
01200 else if (ival = max10) and (ch <= '7')
01300 then ival := 10*ival + (ord(ch)-ord('0'))
01400 else scale := scale + 1;
01500 SCALE := SCALE - 1; NEXTCH
01600 UNTIL NOT (CH IN DIGITS);
01700 END
01800 END;
01900 IF CH = 'E'
02000 THEN
02100 BEGIN
02200 (* 142 - better real scan *)
02300 sy := realconst;
02400 NEXTCH;
02500 SIGN := CH='-';
02600 IF (CH='+') OR (CH='-')
02700 THEN NEXTCH;
02800 EXP := 0;
02900 IF NOT (CH IN DIGITS)
03000 THEN ERROR(205)
03100 ELSE
03200 REPEAT
03300 EXP := 10*EXP + (ORD(CH) - ORD('0'));
03400 NEXTCH
03500 UNTIL NOT (CH IN DIGITS);
03600 IF SIGN
03700 THEN SCALE := SCALE - EXP
03800 ELSE SCALE := SCALE + EXP;
03900 END;
04000 (* 142 - better real scan *)
04100 if sy = realconst
04200 then begin
04300 rval := ival;
04400 IF SCALE # 0
04500 THEN
04600 BEGIN
04700 (* 113 - reorganized to handle exact fractions exactly *)
04800 FAC := 10.0;
04900 ASCALE := ABS(SCALE);
05000 (* 141 - prevent overflow for exp > 32 *)
05100 LOOP
05200 IF ODD(ASCALE)
05300 THEN if scale > 0
05400 then rval := rval*FAC
05500 else rval := rval/fac;
05600 ASCALE := ASCALE DIV 2;
05700 EXIT IF ASCALE=0;
05800 FAC := SQR(FAC);
05900 END;
06000 (* 141 - better overflow error handling *)
06100 IF OVERFLOW
06200 THEN BEGIN
06300 ERROR(206);
06400 RVAL := 0.0
06500 END;
06600 END;
06700 (* 142 - better real scanning *)
06800 newz(lvp,reel);
06900 lvp^.rval := rval;
07000 val.valp := lvp
07100 end {real}
07200 else {integer}
07300 if scale = 0
07400 then VAL.IVAL := IVAL
07500 else begin
07600 error(204);
07700 val.ival := 0
07800 end;
07900 END
08000 END;
08100 '"':
08200 BEGIN
08300 SY := INTCONST; OP := NOOP; IVAL := 0; I := 0; hc.int := 0;
08400 NEXTCH;
08500 WHILE CH IN HEXADIGITS DO
08600 BEGIN
08700 i := i + 1;
08800 if i <= hexmax then
08900 IF CH IN DIGITS
09000 THEN digit[i] := 16*IVAL + ORD(CH) - ORD('0')
09100 ELSE digit[i] := 16*IVAL + ORD(CH) - 67B;
09200 NEXTCH
09300 END;
09400 if i > hexmax then
09500 begin
09600 error(174);
09700 i := hexmax
09800 end;
09900 for k := 1 to i do
10000 hc.hex[k+hexmax-i] := digit[k];
10100 VAL.IVAL := hc.int;
10200 END;
10300 '''':
10400 BEGIN
10500 LGTH := 0; SY := STRINGCONST; OP := NOOP;STRINGTOOLONG := FALSE;
10600 REPEAT
10700 REPEAT
10800 (* 3 - different NEXTCH so don't map lower case, etc. *)
10900 NEXTSTRCH;
11000 IF LGTH < STRGLGTH
11100 THEN
11200 BEGIN
11300 LGTH := LGTH + 1; STRING[LGTH] := CH
11400 END
11500 ELSE STRINGTOOLONG := TRUE
11600 UNTIL (EOLN(INPUT)) OR (CH = '''');
11700 IF STRINGTOOLONG
11800 THEN ERROR(301);
11900 IF EOLN(INPUT) AND (CH#'''')
12000 THEN ERROR(351)
12100 (* 3 - different NEXTCH so don't map lower case, etc. *)
12200 (* 6 - don't use nextstrch for char after end of string[caused loop] *)
12300 ELSE NEXTCH %this is embedded ' or char after string\
12400 UNTIL CH # '''';
12500 LGTH := LGTH - 1; %NOW LGTH = NR OF CHARS IN STRING\
12600 IF LGTH = 1
12700 THEN VAL.IVAL := ORD(STRING[1])
12800 ELSE
12900 BEGIN
13000 NEWZ(LVP,STRG:LGTH);
13100 WITH LVP^ DO
13200 BEGIN
13300 SLGTH := LGTH;
13400 FOR I := 1 TO LGTH DO SVAL[I] := STRING[I]
13500 END;
13600 VAL.VALP := LVP
13700 END
13800 END;
13900 ':':
14000 BEGIN
14100 OP := NOOP; NEXTCH;
14200 IF CH = '='
14300 THEN
14400 BEGIN
14500 SY := BECOMES; NEXTCH
14600 END
14700 ELSE SY := COLON
14800 END;
14900 '.':
15000 BEGIN
15100 OP := NOOP; NEXTCH;
15200 IF CH = '.'
15300 THEN
15400 BEGIN
15500 SY := COLON; NEXTCH
15600 END
15700 ELSE SY := PERIOD
15800 END;
15900 '?','*','&','+','-','!','\',
16000 (* 1 - / now handled elsewhere *)
16100 '@','#','=',
16200 ')','[',']',',',';','^','_','$':
16300 BEGIN
16400 SY := SSY[CH]; OP := SOP[CH];
16500 NEXTCH
16600 END;
16700
16800 '(':
16900 BEGIN
17000 NEXTCH;
17100 (* 1 - improved comment scanning *)
17200 IF CH='*' THEN BEGIN SCANCOMMENT(')'); GOTO 2 END
17300 ELSE BEGIN SY := LPARENT; OP := NOOP END
17400 END;
17500
17600
17700 '{':
17800 BEGIN SCANCOMMENT('}'); GOTO 2 END;
17900 '%':
18000 BEGIN SCANCOMMENT('\'); GOTO 2 END;
18100
18200 '/':
18300 BEGIN
18400 NEXTCH;
18500 IF CH='*' THEN BEGIN SCANCOMMENT('/'); GOTO 2 END
18600 ELSE BEGIN SY := MULOP; OP := RDIV END
18700 END;
18800
18900
19000 '<','>':
19100 BEGIN
19200 SY := SSY[CH]; OP := SOP[CH]; NEXTCH;
19300 IF CH = '='
19400 THEN
19500 BEGIN
19600 IF OP = LTOP
19700 THEN OP := LEOP
19800 ELSE OP := GEOP;
19900 NEXTCH
20000 END
20100 (* 6 - allow <> for not equals *)
20200 ELSE IF (CH = '>') AND (OP = LTOP)
20300 THEN
20400 BEGIN
20500 OP := NEOP;
20600 NEXTCH
20700 END
20800 END;
20900 (* 6 - add error msg in case of illegal character *)
21000 OTHERS:
21100 BEGIN
21200 ERROR(216);
21300 NEWCH;
21400 INSYMBOL
21500 END
21600 END %CASE\
21700 END %INSYMBOL\ ;
21800
21900 PROCEDURE ENTERID(FCP: CTP);
22000 %ENTER ID POINTED AT BY FCP INTO THE NAME-TABLE,
22100 WHICH ON EACH DECLARATION LEVEL IS ORGANISED AS
22200 AN UNBALANCED BINARY TREE\
22300 VAR
22400 NAM: ALFA; LCP, LCP1: CTP; LLEFT: BOOLEAN;
22500 BEGIN
22600 NAM := FCP^.NAME;
22700 (* 5 - CREF *)
22800 IF CREF
22900 THEN WRITE(CHR(1B),CHR(21),NAM,' ',DISPLAY[TOP].BLKNAME,CHR(2B));
23000 LCP := DISPLAY[TOP].FNAME;
23100 IF LCP = NIL
23200 THEN
23300 DISPLAY[TOP].FNAME := FCP
23400 ELSE
23500 BEGIN
23600 REPEAT
23700 LCP1 := LCP;
23800 IF LCP^.NAME <= NAM
23900 THEN
24000 BEGIN
24100 IF LCP^.NAME = NAM
24200 THEN ERROR(302) %NAME CONFLICT\;
24300 LCP := LCP^.RLINK; LLEFT := FALSE
24400 END
24500 ELSE
24600 BEGIN
24700 LCP := LCP^.LLINK; LLEFT := TRUE
24800 END
24900 UNTIL LCP = NIL;
25000 IF LLEFT
25100 THEN LCP1^.LLINK := FCP
25200 ELSE LCP1^.RLINK := FCP
25300 END;
25400 WITH FCP^ DO
25500 BEGIN
25600 LLINK := NIL; RLINK := NIL; SELFCTP := NIL
25700 END
25800 END %ENTERID\ ;
25900
26000 PROCEDURE SEARCHSECTION(FCP: CTP; VAR FCP1: CTP);
26100 %TO FIND RECORD FIELDS AND FORWARD DECLARED PROCEDURE ID'S
26200 --> PROCEDURE PROCEDUREDECLARATION
26300 --> PROCEDURE SELECTOR\
26400 BEGIN
26500 WHILE FCP # NIL DO
26600 WITH FCP^ DO
26700 BEGIN
26800 IF NAME = ID
26900 THEN GOTO 1;
27000 IF NAME < ID
27100 THEN FCP := RLINK
27200 ELSE FCP := LLINK
27300 END;
27400 1:
27500 FCP1 := FCP
27600 END %SEARCHSECTION\ ;
27700
27800 PROCEDURE SEARCHID(FIDCLS: SETOFIDS; VAR FCP: CTP);
27900 VAR
28000 LCP: CTP;
28100 BEGIN
28200 FOR DISX := TOP DOWNTO 0 DO
28300 BEGIN
28400 LCP := DISPLAY[DISX].FNAME;
28500 WHILE LCP # NIL DO
28600 WITH LCP^ DO
28700 IF NAME = ID
28800 THEN
28900 IF KLASS IN FIDCLS
29000 THEN GOTO 1
29100 ELSE
29200 BEGIN
29300 IF PRTERR
29400 THEN ERROR(401);
29500 (* 170 - fix error handling for forwards *)
29600 GOTO 2
29700 END
29800 ELSE
29900 IF NAME < ID
30000 THEN
30100 LCP := RLINK
30200 ELSE LCP := LLINK
30300 END;
30400 2: LCP := NIL; {Use NIL if don't find something better below}
30500 (* 5 - save some info for so CREF will know the block name *)
30600 DISX := TOP; %IF FORWARD, WILL BE IN THIS BLOCK\
30700 (* 114 - use only real block names *)
30800 (* 116 - more elegant way to do this *)
30900 WHILE DISPLAY[DISX].OCCUR <> BLCK DO
31000 DISX := DISX - 1;
31100 %SEARCH NOT SUCCSESSFUL; SUPPRESS ERROR MESSAGE IN CASE
31200 OF FORWARD REFERENCED TYPE ID IN POINTER TYPE DEFINITION
31300 --> PROCEDURE SIMPLETYPE\
31400 IF PRTERR
31500 THEN
31600 BEGIN
31700 ERROR(253);
31800 %TO AVOID RETURNING NIL, REFERENCE AN ENTRY
31900 FOR AN UNDECLARED ID OF APPROPRIATE CLASS
32000 --> PROCEDURE ENTERUNDECL\
32100 IF TYPES IN FIDCLS
32200 THEN LCP := UTYPPTR
32300 ELSE
32400 IF VARS IN FIDCLS
32500 THEN LCP := UVARPTR
32600 ELSE
32700 IF FIELD IN FIDCLS
32800 THEN LCP := UFLDPTR
32900 ELSE
33000 IF KONST IN FIDCLS
33100 THEN LCP := UCSTPTR
33200 ELSE
33300 IF PROC IN FIDCLS
33400 THEN LCP := UPRCPTR
33500 (* 64 - non-loc gotos *)
33600 ELSE IF FUNC IN FIDCLS
33700 THEN LCP := UFCTPTR
33800 ELSE LCP := ULBLPTR;
33900 END;
34000 1:
34100 (* 5 - CREF *)
34200 IF CREF
34300 THEN WRITE(CHR(1B),CHR(21),ID,' ',DISPLAY[DISX].BLKNAME);
34400 FCP := LCP
34500 END %SEARCHID\ ;
34600
34700 PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN,FMAX: INTEGER);
34800 %GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE\
34900 %ASSUME (FSP # NIL) AND (FSP^.FORM <= SUBRANGE) AND (FSP # INTPTR)
35000 AND NOT COMPTYPES(REALPTR,FSP)\
35100 BEGIN
35200 WITH FSP^ DO
35300 IF FORM = SUBRANGE
35400 THEN
35500 BEGIN
35600 FMIN := MIN.IVAL; FMAX := MAX.IVAL
35700 END
35800 ELSE
35900 BEGIN
36000 FMIN := 0;
36100 IF FSP = CHARPTR
36200 THEN FMAX := 177B
36300 ELSE
36400 IF FCONST # NIL
36500 THEN
36600 FMAX := FCONST^.VALUES.IVAL
36700 ELSE FMAX := 0
36800 END
36900 END %GETBOUNDS\ ;
37000
37100 (* 6 - move error stuff outside BLOCK so PROGSTAT can use it *)
37200 PROCEDURE SKIPIFERR(FSYINSYS:SETOFSYS; FERRNR:INTEGER; FSKIPSYS: SETOFSYS);
37300 VAR
37400 I,OLDCHCNT,OLDLINECNT : INTEGER;
37500 BEGIN
37600 IF NOT (SY IN FSYINSYS)
37700 THEN
37800 BEGIN
37900 ERROR(FERRNR);
38000 OLDLINECNT := LINECNT; OLDCHCNT := CHCNT;
38100 WHILE NOT (SY IN FSKIPSYS OR FSYINSYS) DO
38200 BEGIN
38300 IF OLDLINECNT # LINECNT
38400 THEN OLDCHCNT := 1;
38500 FOR I := OLDCHCNT TO CHCNT-1 DO
38600 IF I <= CHCNTMAX
38700 THEN ERRLINE [I] := '*';
38800 OLDCHCNT := CHCNT; OLDLINECNT := LINECNT; ERRORINLINE := TRUE;
38900 INSYMBOL
39000 END;
39100 %SKIP INPUT STRING UNTIL RELEVANT SYMBOL FOUND\
39200 END;
39300 FOLLOWERROR := FALSE
39400 END;
39500
39600 PROCEDURE IFERRSKIP(FERRNR: INTEGER; FSYS: SETOFSYS);
39700 BEGIN
39800 SKIPIFERR(FSYS,FERRNR,FSYS)
39900 END;
40000
40100 PROCEDURE ERRANDSKIP(FERRNR: INTEGER; FSYS: SETOFSYS);
40200 BEGIN
40300 SKIPIFERR([ ],FERRNR,FSYS)
40400 END;
40500
40600 (* 6 - add PROGRAM statement *)
40700 PROCEDURE PROGSTAT;
40800 (* 34 - allow list of entry point names *)
40900 VAR STSYM,ENDSYM:SYMBOL;
41000 BEGIN
41100 IF SY=PROGRAMSY
41200 THEN
41300 BEGIN
41400 (* 34 - allow entry point names *)
41500 IF MAIN
41600 THEN BEGIN STSYM:=LPARENT; ENDSYM := RPARENT END
41700 ELSE BEGIN STSYM:=COMMA; ENDSYM := SEMICOLON END;
41800 INSYMBOL;
41900 IF SY # IDENT THEN ERROR(209);
42000 (* 33 NO LONGER NEED ENTRY *)
42100 FILENAME := ID;
42200 INSYMBOL;
42300 (* 34 - DIFFERENT SYNTAX FOR ENTRY POINTS *)
42400 IF SY = STSYM
42500 THEN BEGIN
42600 REPEAT
42700 INSYMBOL;
42800 IF NOT (SY = IDENT)
42900 THEN ERROR(209);
43000 (* 33 - USE FILE NAMES *)
43100 NEWZ(NPROGFILE);
43200 NPROGFILE^.FILID := ID;
43300 NPROGFILE^.NEXT := NIL;
43400 IF FPROGFILE = NIL
43500 THEN BEGIN
43600 FPROGFILE := NPROGFILE;
43700 LPROGFILE := NPROGFILE
43800 END
43900 ELSE BEGIN
44000 LPROGFILE^.NEXT := NPROGFILE;
44100 LPROGFILE := NPROGFILE
44200 END;
44300 INSYMBOL;
44400 (* 61 - allow +* in tops20 *)
44500 (* 144 - allow this stuff in tops10, too *)
44600 if (sy=colon) and main
44700 then begin
44800 insymbol;
44900 while sy in [addop,mulop,relop] do
45000 begin
45100 if (op = mul) and (not tops10)
45200 then nprogfile^.wild := true
45300 else if op = plus
45400 then nprogfile^.newgen := true
45500 else if op = minus
45600 then nprogfile^.oldfile := true
45700 (* 64 - input:/ *)
45800 else if op = rdiv
45900 then nprogfile^.interact := true
46000 (* 172 - new EOLN treatment *)
46100 else if op = neop
46200 then nprogfile^.seeeol := true
46300 else error(158);
46400 insymbol
46500 end;
46600 end;
46700 (* 34 - DIFFERENT SYNTAX FOR ENTRY POINTS *)
46800 IFERRSKIP(158,[ENDSYM,COMMA])
46900 UNTIL SY=ENDSYM;
47000 IF MAIN THEN INSYMBOL
47100 END;
47200 (* 21 - Allow null file list in prog. statement *)
47300 IFERRSKIP(156,[SEMICOLON]);
47400 INSYMBOL
47500 END
47600 END;
47700
47800 PROCEDURE BLOCK(FPROCP: CTP; FSYS,LEAVEBLOCKSYS: SETOFSYS);
47900 VAR
48000 (* 56 - add reqfile for require files *)
48100 (* 125 - reqfile moved *)
48200 (* 65 - remove exit labels *)
48300 LSY: SYMBOL;
48400 (* 136 - listing format *)
48500 ORIGLINENR:PACKED ARRAY[1:5]OF CHAR;
48600 ORIGPAGECNT,ORIGSUBPAGE,ORIGLINECNT:INTEGER;
48700 ORIGPAGE:PAGEELEM; ORIGCH:CHAR;
48800 (* 24 - testpacked no longer needed *)
48900 LCPAR: ADDRRANGE;%SAVES LOCATION FROM WHERE
49000 LOCAL AREAS ARE SET TO ZERO\
49100 HEAPMARK,GLOBMARK: INTEGER;
49200 FORWPTR : CTP; %TEST FOR FORWORD DECLARED PROCEDURES\
49300
49400
49500 PROCEDURE CONSTANT(FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU);
49600 VAR
49700 LSP,LSP1: STP; LCP: CTP; SIGN: (NONE,POS,NEG);
49800 BEGIN
49900 LSP := NIL; FVALU.IVAL := 0;
50000 SKIPIFERR(CONSTBEGSYS,207,FSYS);
50100 IF SY IN CONSTBEGSYS
50200 THEN
50300 BEGIN
50400 IF SY = STRINGCONST
50500 THEN
50600 BEGIN
50700 IF LGTH = 1
50800 THEN LSP := CHARPTR
50900 ELSE
51000 IF LGTH = ALFALENG
51100 THEN LSP := ALFAPTR
51200 ELSE
51300 BEGIN
51400 NEWZ(LSP,ARRAYS); NEWZ(LSP1,SUBRANGE);
51500 WITH LSP^ DO
51600 BEGIN
51700 AELTYPE := CHARPTR; INXTYPE := LSP1;
51800 SIZE := (LGTH+4) DIV 5; ARRAYPF := TRUE;
51900 (* 211 - make PASDDT able to see this *)
52000 BITSIZE := BITMAX; SELFSTP := NIL
52100 END;
52200 WITH LSP1^ DO
52300 BEGIN
52400 SIZE := 1; BITSIZE := BITMAX;
52500 MIN.IVAL := 1; MAX.IVAL := LGTH; RANGETYPE := NIL
52600 END
52700 END;
52800 FVALU := VAL; INSYMBOL
52900 END
53000 ELSE
53100 BEGIN
53200 SIGN := NONE;
53300 IF (SY = ADDOP) AND (OP IN [PLUS,MINUS])
53400 THEN
53500 BEGIN
53600 IF OP = PLUS
53700 THEN SIGN := POS
53800 ELSE SIGN := NEG;
53900 INSYMBOL
54000 END;
54100 IF SY = IDENT
54200 THEN
54300 BEGIN
54400 SEARCHID([KONST],LCP);
54500 WITH LCP^ DO
54600 BEGIN
54700 LSP := IDTYPE; FVALU := VALUES
54800 END;
54900 IF SIGN # NONE
55000 THEN
55100 IF LSP = INTPTR
55200 THEN
55300 BEGIN
55400 IF SIGN = NEG
55500 THEN FVALU.IVAL := -FVALU.IVAL
55600 END
55700 ELSE
55800 IF LSP = REALPTR
55900 THEN
56000 BEGIN
56100 IF SIGN = NEG
56200 THEN
56300 FVALU.VALP^.RVAL := -FVALU.VALP^.RVAL
56400 END
56500 ELSE ERROR(167);
56600 INSYMBOL;
56700 END
56800 ELSE
56900 IF SY = INTCONST
57000 THEN
57100 BEGIN
57200 IF SIGN = NEG
57300 THEN VAL.IVAL := -VAL.IVAL;
57400 LSP := INTPTR; FVALU := VAL; INSYMBOL
57500 END
57600 ELSE
57700 IF SY = REALCONST
57800 THEN
57900 BEGIN
58000 IF SIGN = NEG
58100 THEN VAL.VALP^.RVAL := -VAL.VALP^.RVAL;
58200 LSP := REALPTR; FVALU := VAL; INSYMBOL
58300 END
58400 ELSE ERRANDSKIP(168,FSYS)
58500 END;
58600 IFERRSKIP(166,FSYS);
58700 END;
58800 FSP := LSP
58900 END %CONSTANT\ ;
59000
59100 FUNCTION COMPTYPES(FSP1,FSP2: STP) : BOOLEAN;
59200 %DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND FSP2 ARE COMPATIBLE\
59300 VAR
59400 NXT1,NXT2: CTP; COMP: BOOLEAN; LMIN,LMAX,I: INTEGER;
59500 LTESTP1,LTESTP2: TESTP;
59600 BEGIN
59700 IF FSP1 = FSP2
59800 THEN COMPTYPES := TRUE
59900 ELSE
60000 IF (FSP1 # NIL) AND (FSP2 # NIL)
60100 THEN
60200 IF FSP1^.FORM = FSP2^.FORM
60300 THEN
60400 CASE FSP1^.FORM OF
60500 SCALAR:
60600 COMPTYPES := FALSE;
60700 % IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE
60800 NOT RECOGNIZED TO BE COMPATIBLE\
60900 SUBRANGE:
61000 COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2^.RANGETYPE);
61100 POINTER:
61200 BEGIN
61300 COMP := FALSE; LTESTP1 := GLOBTESTP; LTESTP2 := GLOBTESTP;
61400 WHILE LTESTP1 # NIL DO
61500 WITH LTESTP1^ DO
61600 BEGIN
61700 IF (ELT1 = FSP1^.ELTYPE) AND (ELT2 = FSP2^.ELTYPE)
61800 THEN COMP := TRUE;
61900 LTESTP1 := LASTTESTP
62000 END;
62100 IF NOT COMP
62200 THEN
62300 BEGIN
62400 NEWZ(LTESTP1);
62500 WITH LTESTP1^ DO
62600 BEGIN
62700 ELT1 := FSP1^.ELTYPE;
62800 ELT2 := FSP2^.ELTYPE;
62900 LASTTESTP := GLOBTESTP
63000 END;
63100 GLOBTESTP := LTESTP1; COMP := COMPTYPES(FSP1^.ELTYPE,FSP2^.ELTYPE)
63200 END;
63300 COMPTYPES := COMP; GLOBTESTP := LTESTP2
63400 END;
63500 POWER:
00100 COMPTYPES := COMPTYPES(FSP1^.ELSET,FSP2^.ELSET);
00200 ARRAYS:
00300 BEGIN
00400 GETBOUNDS (FSP1^.INXTYPE,LMIN,LMAX);
00500 I := LMAX-LMIN;
00600 GETBOUNDS (FSP2^.INXTYPE,LMIN,LMAX);
00700 COMPTYPES := COMPTYPES(FSP1^.AELTYPE,FSP2^.AELTYPE)
00800 AND (FSP1^.ARRAYPF = FSP2^.ARRAYPF) AND ( I = LMAX - LMIN ) ;
00900 END;
01000 %ALTERNATIVES: -- ADD A THIRD BOOLEAN TERM: INDEXTYPE MUST
01100 BE COMPATIBLE. MAY GIVE TROUBLE FOR ASSIGNMENT OF STRINGCONSTANTS
01200 -- ADD A FOURTH BOOLEAN TERM: LOWBOUNDS MUST
01300 BE THE SAME\
01400 RECORDS:
01500 BEGIN
01600 NXT1 := FSP1^.FSTFLD; NXT2 := FSP2^.FSTFLD; COMP := TRUE;
01700 WHILE (NXT1 # NIL) AND (NXT2 # NIL) DO
01800 BEGIN
01900 COMP := COMPTYPES(NXT1^.IDTYPE,NXT2^.IDTYPE) AND COMP;
02000 NXT1 := NXT1^.NEXT; NXT2 := NXT2^.NEXT
02100 END;
02200 COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL)
02300 AND (FSP1^.RECVAR = NIL) AND (FSP2^.RECVAR = NIL)
02400 END;
02500 %IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE
02600 IFF NO VARIANTS OCCUR\
02700 FILES:
02800 COMPTYPES := COMPTYPES(FSP1^.FILTYPE,FSP2^.FILTYPE)
02900 END %CASE\
03000 ELSE %FSP1^.FORM # FSP2^.FORM\
03100 IF FSP1^.FORM = SUBRANGE
03200 THEN
03300 COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2)
03400 ELSE
03500 IF FSP2^.FORM = SUBRANGE
03600 THEN
03700 COMPTYPES := COMPTYPES(FSP1,FSP2^.RANGETYPE)
03800 ELSE COMPTYPES := FALSE
03900 ELSE COMPTYPES := TRUE
04000 END %COMPTYPES\ ;
04100
04200 FUNCTION STRING(FSP: STP) : BOOLEAN;
04300 BEGIN
04400 STRING := FALSE;
04500 IF FSP # NIL
04600 THEN
04700 IF FSP^.FORM = ARRAYS
04800 THEN
04900 IF COMPTYPES(FSP^.AELTYPE,CHARPTR)
05000 THEN STRING := TRUE
05100 END %STRING\ ;
05200
05300 PROCEDURE TYP(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE;
05400 VAR FBITSIZE: BITRANGE);
05500 VAR
05600 (* 173 - internal files *)
05700 FHASFILE,LHASFILE:BOOLEAN;
05800 LSP,LSP1,LSP2: STP; OLDTOP: DISPRANGE; LCP: CTP;
05900 LSIZE,DISPL: ADDRRANGE; I,LMIN,LMAX: INTEGER;
06000 PACKFLAG: BOOLEAN; LBITSIZE: BITRANGE;
06100 LBTP: BTP; BITCOUNT:INTEGER;
06200
06300 (* 104 - check structure sizes *)
06400 function checksize(i:addrrange):addrrange;
06500 begin
06600 (* 216 - settable high start *)
06700 if abs(i) < highstart
06800 then checksize := i
06900 else begin
07000 error(266);
07100 checksize := 0
07200 end
07300 end;
07400
07500 FUNCTION LOG2(FVAL: INTEGER): BITRANGE;
07600 VAR
07700 E: BITRANGE; H: INTEGER;
07800 BEGIN
07900 E :=0;
08000 H := 1;
08100 (* 135 - numbers > 200 000 000 000B didn't work. *)
08200 {There are two complicating issues here:
08300 1 - 200 000 000 000 is the highest power of 2, so the
08400 loop below goes forever for them
08500 2 - the caller has often added 1, thus making 377 777 777 777
08600 into 400 000 000 000, which is negative!!
08700 In both of these cases we want to return 35}
08800 IF (FVAL-1) >= 200000000000B
08900 THEN E := 35
09000 ELSE REPEAT
09100 E := E + 1; H := H * 2
09200 UNTIL FVAL <= H;
09300 LOG2 := E
09400 END %LOG2\;
09500
09600 PROCEDURE SIMPLETYPE(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE;
09700 VAR FBITSIZE: BITRANGE);
09800 VAR
09900 LSP,LSP1: STP; LCP,LCP1: CTP; TTOP: DISPRANGE;
10000 LCNT: INTEGER; LVALU: VALU; LBITSIZE: BITRANGE;
10100 BEGIN
10200 FSIZE := 1;
10300 SKIPIFERR(SIMPTYPEBEGSYS,208,FSYS);
10400 IF SY IN SIMPTYPEBEGSYS
10500 THEN
10600 BEGIN
10700 IF SY = LPARENT
10800 THEN
10900 BEGIN
11000 TTOP := TOP; %DECL. CONSTS LOCAL TO INNERMOST BLOCK\
11100 WHILE DISPLAY[TOP].OCCUR # BLCK DO TOP := TOP - 1;
11200 NEWZ(LSP,SCALAR,DECLARED);
11300 LSP^.SIZE := 1;
11400 LCP1 := NIL; LCNT := 0;
11500 REPEAT
11600 INSYMBOL;
11700 IF SY = IDENT
11800 THEN
11900 BEGIN
12000 NEWZ(LCP,KONST);
12100 WITH LCP^ DO
12200 BEGIN
12300 NAME := ID; IDTYPE := LSP; NEXT := LCP1;
12400 VALUES.IVAL := LCNT;
12500 END;
12600 ENTERID(LCP);
12700 LCNT := LCNT + 1;
12800 LCP1 := LCP; INSYMBOL
12900 END
13000 ELSE ERROR(209);
13100 IFERRSKIP(166,FSYS OR [COMMA,RPARENT])
13200 UNTIL SY # COMMA;
13300 TOP := TTOP;
13400 WITH LSP^ DO
13500 BEGIN
13600 SELFSTP := NIL; FCONST := LCP1; BITSIZE := LOG2(LCNT)
13700 END;
13800 IF SY = RPARENT
13900 THEN INSYMBOL
14000 ELSE ERROR(152)
14100 END
14200 ELSE
14300 BEGIN
14400 IF SY = IDENT
14500 THEN
14600 BEGIN
14700 SEARCHID([TYPES,KONST],LCP);
14800 INSYMBOL;
14900 IF LCP^.KLASS = KONST
15000 THEN
15100 BEGIN
15200 NEWZ(LSP,SUBRANGE);
15300 WITH LSP^, LCP^ DO
15400 BEGIN
15500 SELFSTP := NIL; RANGETYPE := IDTYPE;
15600 IF STRING(RANGETYPE)
15700 THEN
15800 BEGIN
15900 ERROR(303); RANGETYPE := NIL
16000 END;
16100 MIN := VALUES; SIZE := 1
16200 END;
16300 IF SY = COLON
16400 THEN INSYMBOL
16500 ELSE ERROR(151);
16600 CONSTANT(FSYS,LSP1,LVALU);
16700 WITH LSP^ DO
16800 BEGIN
16900 MAX := LVALU;
17000 IF MIN.IVAL<0
17100 THEN BITSIZE := BITMAX
17200 ELSE BITSIZE := LOG2(MAX.IVAL + 1);
17300 IF RANGETYPE # LSP1
17400 THEN ERROR(304)
17500 END;
17600 END
17700 ELSE
17800 BEGIN
17900 LSP := LCP^.IDTYPE;
18000 IF LSP # NIL
18100 THEN FSIZE := LSP^.SIZE;
18200 END
18300 END %SY = IDENT\
18400 ELSE
18500 BEGIN
18600 NEWZ(LSP,SUBRANGE);
18700 CONSTANT(FSYS OR [COLON],LSP1,LVALU);
18800 IF STRING(LSP1)
18900 THEN
19000 BEGIN
19100 ERROR(303); LSP1 := NIL
19200 END;
19300 WITH LSP^ DO
19400 BEGIN
19500 RANGETYPE := LSP1; MIN := LVALU; SIZE := 1
19600 END;
19700 IF SY = COLON
19800 THEN INSYMBOL
19900 ELSE ERROR(151);
20000 CONSTANT(FSYS,LSP1,LVALU);
20100 WITH LSP^ DO
20200 BEGIN
20300 SELFSTP := NIL; MAX := LVALU;
20400 IF MIN.IVAL<0
20500 THEN BITSIZE := BITMAX
20600 ELSE BITSIZE := LOG2(MAX.IVAL + 1);
20700 IF RANGETYPE # LSP1
20800 THEN ERROR(304)
20900 END
21000 END;
21100 IF LSP # NIL
21200 THEN
21300 WITH LSP^ DO
21400 IF FORM = SUBRANGE
21500 THEN
21600 IF RANGETYPE # NIL
21700 THEN
21800 IF RANGETYPE = REALPTR
21900 THEN
22000 (* 106 - make subranges of real illegal *)
22100 error(210)
22200 ELSE
22300 IF MIN.IVAL > MAX.IVAL
22400 THEN ERROR(451)
22500 END;
22600 FSP := LSP;
22700 IF LSP#NIL
22800 THEN FBITSIZE := LSP^.BITSIZE
22900 ELSE FBITSIZE := 0;
23000 IFERRSKIP(166,FSYS)
23100 END
23200 ELSE
23300 BEGIN
23400 FSP := NIL; FBITSIZE := 0
23500 END
23600 END %SIMPLETYPE\ ;
23700
23800 (* 173 - internal files *)
23900 PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FRECVAR: STP; VAR FFIRSTFIELD: CTP; VAR FHASFILE:BOOLEAN);
24000 VAR
24100 LHASFILE:BOOLEAN;
24200 LCP,LCP1,NXT,NXT1: CTP; LSP,LSP1,LSP2,LSP3,LSP4,TAGSP: STP;
24300 MINSIZE,MAXSIZE,LSIZE: ADDRRANGE; LVALU: VALU;
24400 LBITSIZE: BITRANGE;
24500 LBTP: BTP; MINBITCOUNT:INTEGER;
24600 LID : ALFA ;
24700
24800 PROCEDURE RECSECTION( VAR FCP: CTP; FSP: STP );
24900 BEGIN
25000 IF NOT PACKFLAG OR (LSIZE > 1) OR (LBITSIZE = 36)
25100 THEN
25200 BEGIN
25300 IF BITCOUNT > 0
25400 THEN
25500 BEGIN
25600 DISPL := DISPL + 1; BITCOUNT := 0
25700 END;
25800 WITH FCP^ DO
25900 BEGIN
26000 IDTYPE := FSP; FLDADDR := DISPL;
26100 PACKF := NOTPACK; FCP := NEXT;
26200 DISPL := DISPL + LSIZE
26300 END
26400 END
26500 ELSE %PACK RECORD-SECTION\
26600
26700 BEGIN
26800 BITCOUNT := BITCOUNT + LBITSIZE;
26900 IF BITCOUNT>BITMAX
27000 THEN
27100 BEGIN
27200 DISPL := DISPL + 1;
27300 BITCOUNT := LBITSIZE
27400 END;
27500 IF (LBITSIZE = 18) AND (BITCOUNT IN [18,36])
27600 THEN
27700 BEGIN
27800 WITH FCP^ DO
27900 BEGIN
28000 IDTYPE := FSP;
28100 FLDADDR := DISPL;
28200 IF BITCOUNT = 18
28300 THEN PACKF := HWORDL
28400 ELSE PACKF := HWORDR;
28500 FCP := NEXT
28600 END
28700 END
28800 ELSE
28900 BEGIN
29000 NEWZ(LBTP,RECORDD);
29100 WITH LBTP^.BYTE DO
29200 BEGIN
29300 SBITS := LBITSIZE;
29400 PBITS := BITMAX - BITCOUNT;
29500 RELADDR := DISPL;
29600 DUMMYBIT := 0;
29700 IBIT := 0;
29800 IREG := TAC
29900 END;
30000 WITH LBTP^ DO
30100 BEGIN
30200 LAST := LASTBTP; FIELDCP := FCP
30300 END;
30400 LASTBTP := LBTP;
30500 WITH FCP^ DO
30600 BEGIN
30700 IDTYPE := FSP;
30800 PACKF := PACKK;
30900 FCP := NEXT
31000 END
31100 END
31200 END
31300 END % RECSECTION \ ;
31400 BEGIN
31500 (* 173 - internal files *)
31600 (* 166 - In case of null record declaration, FRECVAR was getting junk.
31700 I don't understand the logic of this routine, but initializing
31800 it to NIL seems safe enough *)
31900 NXT1 := NIL; LSP := NIL; FRECVAR := NIL; FHASFILE := FALSE;
32000 (* 21 - Allow null fieldlist (added FSYS OR to next statement) *)
32100 (* 65 - allow extra semicolons *)
32200 while sy=semicolon do
32300 insymbol;
32400 SKIPIFERR(FSYS OR [IDENT,CASESY],452,FSYS);
32500 WHILE SY = IDENT DO
32600 BEGIN
32700 NXT := NXT1;
32800 LOOP
32900 IF SY = IDENT
33000 THEN
33100 BEGIN
33200 NEWZ(LCP,FIELD);
33300 WITH LCP^ DO
33400 BEGIN
33500 NAME := ID; IDTYPE := NIL; NEXT := NXT
33600 END;
33700 NXT := LCP;
33800 ENTERID(LCP);
33900 INSYMBOL
34000 END
34100 ELSE ERROR(209);
34200 SKIPIFERR([COMMA,COLON],166,FSYS OR [SEMICOLON,CASESY]);
34300 EXIT IF SY # COMMA;
34400 INSYMBOL
34500 END;
34600 IF SY = COLON
34700 THEN INSYMBOL
34800 ELSE ERROR(151);
34900 TYP(FSYS OR [CASESY,SEMICOLON],LSP,LSIZE,LBITSIZE);
35000 IF LSP # NIL
35100 THEN
35200 (* internal files *)
35300 IF (LSP^.FORM = FILES) OR LSP^.HASFILE
35400 THEN FHASFILE := TRUE;
35500 WHILE NXT # NXT1 DO RECSECTION(NXT,LSP); %RESERVES SPACE FOR ONE RECORDSECTION \
35600 NXT1 := LCP;
35700 (* 64 - allow null entry *)
35800 WHILE SY = SEMICOLON DO
35900 BEGIN
36000 INSYMBOL;
36100 SKIPIFERR(FSYS OR [IDENT,CASESY,SEMICOLON],452,FSYS)
36200 END
36300 END %WHILE\;
36400 NXT := NIL;
36500 WHILE NXT1 # NIL DO
36600 WITH NXT1^ DO
36700 BEGIN
36800 LCP := NEXT; NEXT := NXT; NXT := NXT1; NXT1 := LCP
36900 END;
37000 FFIRSTFIELD := NXT;
37100 IF SY = CASESY
37200 THEN
37300 BEGIN
37400 LCP:=NIL; %POSSIBILITY OF NO TAGFIELDIDENTIFIER\
37500 INSYMBOL;
37600 IF SY = IDENT
37700 THEN
37800 BEGIN
37900 LID := ID ;
38000 INSYMBOL ;
38100 IF (SY#COLON) AND (SY#OFSY)
38200 THEN
38300 BEGIN
38400 ERROR(151) ;
38500 ERRANDSKIP(160,FSYS OR [LPARENT])
38600 END
38700 ELSE
38800 BEGIN
38900 IF SY = COLON
39000 THEN
39100 BEGIN
39200 NEWZ(LSP,TAGFWITHID);
39300 NEWZ(LCP,FIELD) ;
39400 WITH LCP^ DO
39500 BEGIN
39600 NAME := LID ; IDTYPE := NIL ; NEXT := NIL
39700 END ;
39800 ENTERID(LCP) ;
39900 INSYMBOL ;
40000 IF SY # IDENT
40100 THEN
40200 BEGIN
40300 ERRANDSKIP(209,FSYS OR [LPARENT]) ; GOTO 1
40400 END
40500 ELSE
40600 BEGIN
40700 LID := ID ;
40800 INSYMBOL ;
40900 IF SY # OFSY
41000 THEN
41100 BEGIN
41200 ERRANDSKIP(160,FSYS OR [LPARENT]) ; GOTO 1
41300 END
41400 END
41500 END
41600 ELSE NEWZ(LSP,TAGFWITHOUTID) ;
41700 WITH LSP^ DO
41800 BEGIN
41900 SIZE:= 0 ; SELFSTP := NIL ;
42000 FSTVAR := NIL;
42100 IF FORM=TAGFWITHID
42200 THEN TAGFIELDP:=NIL
42300 ELSE TAGFIELDTYPE := NIL
42400 END;
42500 FRECVAR := LSP;
42600 ID := LID ;
42700 SEARCHID([TYPES],LCP1) ;
42800 TAGSP := LCP1^.IDTYPE;
42900 IF TAGSP # NIL
43000 THEN
43100 IF (TAGSP^.FORM <= SUBRANGE) OR STRING(TAGSP)
43200 THEN
43300 BEGIN
43400 IF COMPTYPES(REALPTR,TAGSP)
43500 THEN ERROR(210)
43600 ELSE
43700 IF STRING(TAGSP)
43800 THEN ERROR(169);
43900 WITH LSP^ DO
44000 BEGIN
44100 BITSIZE := TAGSP^.BITSIZE;
44200 IF FORM = TAGFWITHID
44300 THEN TAGFIELDP := LCP
44400 ELSE TAGFIELDTYPE := TAGSP;
44500 END;
44600 IF LCP # NIL
44700 THEN
44800 BEGIN
44900 LBITSIZE :=TAGSP^.BITSIZE;
45000 LSIZE := TAGSP^.SIZE;
45100 RECSECTION(LCP,TAGSP); %RESERVES SPACE FOR THE TAGFIELD \
45200 (* 217 - set up SIZE field even when no tag field, for NEW *)
45300 END;
45400 IF BITCOUNT > 0
45500 (* 104 - check structure sizes *)
45600 THEN LSP^.SIZE:=CHECKSIZE(DISPL + 1)
45700 ELSE LSP^.SIZE:= CHECKSIZE(DISPL);
45800 END
45900 ELSE ERROR(402);
46000
46100 INSYMBOL;
46200 END
46300 END
46400 (* 150 - fix ill mem ref trying to follow tagsp if not set *)
46500 ELSE BEGIN TAGSP := NIL; ERRANDSKIP(209,FSYS OR [LPARENT]) END ;
46600 1:
46700 LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL; MINBITCOUNT:=BITCOUNT;
46800 (* 65 - allow extra semicolons *)
46900 while sy=semicolon do
47000 insymbol;
47100 LOOP
47200 LSP2 := NIL;
47300 LOOP
47400 CONSTANT(FSYS OR [COMMA,COLON,LPARENT],LSP3,LVALU);
47500 IF NOT COMPTYPES(TAGSP,LSP3)
47600 THEN ERROR(305);
47700 NEWZ(LSP3,VARIANT);
47800 WITH LSP3^ DO
47900 BEGIN
48000 NXTVAR := LSP1; SUBVAR := LSP2; VARVAL := LVALU;
48100 BITSIZE := LSP^.BITSIZE; SELFSTP := NIL
48200 END;
48300 LSP1 := LSP3; LSP2 := LSP3;
48400 EXIT IF SY # COMMA;
48500 INSYMBOL;
48600 END;
48700 IF SY = COLON
48800 THEN INSYMBOL
48900 ELSE ERROR(151);
49000 IF SY = LPARENT
49100 THEN INSYMBOL
49200 ELSE ERROR(153);
49300 (* 173 - internal files *)
49400 FIELDLIST(FSYS OR [RPARENT,SEMICOLON],LSP2,LCP,LHASFILE);
49500 FHASFILE := FHASFILE OR LHASFILE;
49600 IF DISPL > MAXSIZE
49700 THEN MAXSIZE := DISPL;
49800 WHILE LSP3 # NIL DO
49900 BEGIN
50000 LSP4 := LSP3^.SUBVAR; LSP3^.SUBVAR := LSP2; LSP3^.FIRSTFIELD := LCP;
50100 (* 20 - deleted if bitcount>0 use displ+1 - done in fieldlist *)
50200 (* 104 - check structure sizes *)
50300 LSP3^.SIZE := CHECKSIZE(DISPL) ;
50400 LSP3 := LSP4
50500 END;
50600 IF SY = RPARENT
50700 THEN
50800 BEGIN
50900 INSYMBOL;
51000 IFERRSKIP(166,FSYS OR [SEMICOLON])
51100 END
51200 ELSE ERROR(152);
51300 (* 65 - allow extra semicolons *)
51400 while sy=semicolon
51500 do insymbol;
51600 exit if sy in fsys;
51700 DISPL := MINSIZE;
51800 BITCOUNT:=MINBITCOUNT; %RESTAURATION \
51900 END;
52000 DISPL := MAXSIZE;
52100 LSP^.FSTVAR := LSP1;
52200 END %IF SY = CASESY\
52300 ELSE
52400 IF LSP # NIL
52500 THEN
52600 IF LSP^.FORM = ARRAYS
52700 THEN FRECVAR := LSP
52800 ELSE FRECVAR := NIL;
52900 (* 20 - fix packed records - from CMU *)
53000 IF BITCOUNT > 0 THEN
53100 BEGIN DISPL:=DISPL+1; BITCOUNT := 0 END
53200 END %FIELDLIST\ ;
53300
53400 BEGIN
53500 %TYP\
53600 (* 173 - internal files *)
53700 FHASFILE := FALSE;
53800 SKIPIFERR(TYPEBEGSYS,170,FSYS);
53900 PACKFLAG := FALSE;
54000 IF SY IN TYPEBEGSYS
54100 THEN
54200 BEGIN
54300 IF SY IN SIMPTYPEBEGSYS
54400 THEN SIMPLETYPE(FSYS,FSP,FSIZE,FBITSIZE)
54500 ELSE
54600 %^\
00100 IF SY = ARROW
00200 THEN
00300 BEGIN
00400 NEWZ(LSP,POINTER); FSP := LSP;
00500 LBITSIZE := 18;
00600 WITH LSP^ DO
00700 BEGIN
00800 SELFSTP := NIL; ELTYPE := NIL; SIZE := 1; BITSIZE := LBITSIZE
00900 END;
01000 INSYMBOL;
01100 IF SY = IDENT
01200 THEN
01300 BEGIN
01400 (* 165 - fix scoping problem with pointer ref's *)
01500 {All declarations of the form ^THING must be treated as forward references.
01600 The problem is that we want to use the local declaration of THING if there
01700 is any. So we have to wait til we have seen all type declarations before
01800 we can look up pointer references.}
01900 NEWZ(LCP,TYPES);
02000 WITH LCP^ DO
02100 BEGIN
02200 NAME := ID; IDTYPE := LSP;
02300 NEXT := FWPTR
02400 END;
02500 FWPTR := LCP;
02600 INSYMBOL;
02700 FBITSIZE:=18
02800 END
02900 ELSE ERROR(209);
03000 END
03100 ELSE
03200 BEGIN
03300 IF SY = PACKEDSY
03400 THEN
03500 BEGIN
03600 INSYMBOL;
03700 SKIPIFERR(TYPEDELS,170,FSYS);
03800 PACKFLAG := TRUE
03900 END;
04000 %ARRAY\
04100 IF SY = ARRAYSY
04200 THEN
04300 BEGIN
04400 INSYMBOL;
04500 IF SY = LBRACK
04600 THEN INSYMBOL
04700 ELSE ERROR(154);
04800 LSP1 := NIL;
04900 LOOP
05000 NEWZ(LSP,ARRAYS);
05100 WITH LSP^ DO
05200 BEGIN
05300 AELTYPE := LSP1; INXTYPE := NIL; SELFSTP := NIL;
05400 ARRAYPF := PACKFLAG; SIZE := 1
05500 END;
05600 LSP1 := LSP;
05700 SIMPLETYPE(FSYS OR [COMMA,RBRACK,OFSY],LSP2,LSIZE,LBITSIZE);
05800 IF LSP2 # NIL
05900 THEN
06000 IF LSP2^.FORM <= SUBRANGE
06100 THEN
06200 BEGIN
06300 IF LSP2 = REALPTR
06400 THEN
06500 BEGIN
06600 ERROR(210); LSP2 := NIL
06700 END
06800 ELSE
06900 IF LSP2 = INTPTR
07000 THEN
07100 BEGIN
07200 ERROR(306); LSP2 := NIL
07300 END;
07400 LSP^.INXTYPE := LSP2
07500 END
07600 ELSE
07700 BEGIN
07800 ERROR(403); LSP2 := NIL
07900 END;
08000 EXIT IF SY # COMMA;
08100 INSYMBOL
08200 END;
08300 IF SY = RBRACK
08400 THEN INSYMBOL
08500 ELSE ERROR(155);
08600 IF SY = OFSY
08700 THEN INSYMBOL
08800 ELSE ERROR(160);
08900 TYP(FSYS,LSP,LSIZE,LBITSIZE);
09000 IF LSP # NIL
09100 THEN
09200 (* 173 - internal files *)
09300 IF (LSP^.FORM = FILES) OR (LSP^.HASFILE)
09400 THEN FHASFILE := TRUE;
09500 REPEAT
09600 WITH LSP1^ DO
09700 BEGIN
09800 LSP2 := AELTYPE; AELTYPE := LSP;
09900 IF INXTYPE # NIL
10000 THEN
10100 BEGIN
10200 GETBOUNDS(INXTYPE,LMIN,LMAX);
10300 (* 104 - check structure sizes *)
10400 lmin := checksize(lmin);
10500 lmax := checksize(lmax);
10600 I := LMAX - LMIN + 1;
10700 IF ARRAYPF AND (LBITSIZE<=18)
10800 THEN
10900 BEGIN
11000 NEWZ(LBTP,ARRAYY);
11100 WITH LBTP^,BYTE DO
11200 BEGIN
11300 SBITS := LBITSIZE;
11400 PBITS := BITMAX; DUMMYBIT := 0;
11500 IBIT := 0; IREG := TAC; RELADDR := 0;
11600 LAST := LASTBTP; LASTBTP := LBTP;
11700 ARRAYSP := LSP1;
11800 END;
11900 LSIZE := (I+(BITMAX DIV LBITSIZE)-1) DIV (BITMAX DIV LBITSIZE);
12000 END
12100 ELSE
12200 BEGIN
12300 LSIZE := LSIZE * I;
12400 ARRAYPF := FALSE
12500 END;
12600 LBITSIZE := BITMAX;
12700 BITSIZE := LBITSIZE;
12800 (* 104 - check structure sizes *)
12900 SIZE := CHECKSIZE(LSIZE);
13000 END
13100 END;
13200 LSP := LSP1; LSP1 := LSP2
13300 UNTIL LSP1 = NIL
13400 END
13500 ELSE
13600 %RECORD\
13700 IF SY = RECORDSY
13800 THEN
13900 BEGIN
14000 INSYMBOL;
14100 OLDTOP := TOP;
14200 IF TOP < DISPLIMIT
14300 THEN
14400 BEGIN
14500 (* 5 - save block name for CREF *)
14600 TOP := TOP + 1; DISPLAY[TOP].FNAME := NIL;
14700 DISPLAY[TOP].BLKNAME := '.FIELDID. ';
14800 (* 117 - fix enumerated types in record *)
14900 DISPLAY[TOP].OCCUR := CREC
15000 END
15100 ELSE ERROR(404);
15200 DISPL := 0;
15300 BITCOUNT:=0;
15400 (* 173 - internal files *)
15500 FIELDLIST(FSYS-[SEMICOLON] OR [ENDSY],LSP1,LCP,LHASFILE);
15600 FHASFILE := FHASFILE OR LHASFILE;
15700
15800 LBITSIZE := BITMAX;
15900 NEWZ(LSP,RECORDS);
16000 WITH LSP^ DO
16100 BEGIN
16200 SELFSTP := NIL;
16300 FSTFLD := %LCP;\ DISPLAY[TOP].FNAME;
16400 RECVAR := LSP1;
16500 (* 20 - FIX PACKED RECORDS - FROM CMU - DELETED CODE NOW IN FIELDLIST *)
16600 (* 104 - check structure sizes *)
16700 SIZE := CHECKSIZE(DISPL);
16800 BITSIZE := LBITSIZE; RECORDPF := PACKFLAG;
16900 END;
17000 TOP := OLDTOP;
17100 IF SY = ENDSY
17200 THEN INSYMBOL
17300 ELSE ERROR(163)
17400 END
17500 ELSE
17600 %SET\
17700 IF SY = SETSY
17800 THEN
17900 BEGIN
18000 INSYMBOL;
18100 IF SY = OFSY
18200 THEN INSYMBOL
18300 ELSE ERROR(160);
18400 SIMPLETYPE(FSYS,LSP1,LSIZE,LBITSIZE);
18500 IF LSP1 # NIL
18600 THEN
18700 WITH LSP1^ DO
18800 CASE FORM OF
18900 SCALAR:
19000 IF (LSP1=REALPTR) OR (LSP1=INTPTR)
19100 THEN ERROR(352)
19200 ELSE
19300 IF SCALKIND =DECLARED
19400 THEN
19500 IF FCONST^.VALUES.IVAL > BASEMAX
19600 THEN ERROR(352);
19700 SUBRANGE:
19800 IF ( RANGETYPE = REALPTR )
19900 OR ( ( RANGETYPE # CHARPTR ) AND ((MAX.IVAL > BASEMAX) OR (MIN.IVAL < 0) ) )
20000 THEN ERROR(352);
20100 OTHERS:
20200 BEGIN
20300 ERROR(353); LSP1 := NIL
20400 END
20500 END;
20600 LBITSIZE := BITMAX;
20700 NEWZ(LSP,POWER);
20800 WITH LSP^ DO
20900 BEGIN
21000 SELFSTP := NIL; ELSET := LSP1; SIZE:=2; BITSIZE := LBITSIZE
21100 END;
21200 END
21300 ELSE
21400 %FILE\
21500 IF SY = FILESY
21600 THEN
21700 BEGIN
21800 FHASFILE := TRUE;
21900 INSYMBOL;
22000 IF SY = OFSY
22100 THEN INSYMBOL
22200 ELSE ERROR(160);
22300 TYP(FSYS,LSP1,LSIZE,LBITSIZE);
22400 NEWZ(LSP,FILES);
22500 LBITSIZE := BITMAX;
22600 WITH LSP^ DO
22700 BEGIN
22800 SELFSTP := NIL;
22900 (* 104 - check structure sizes *)
23000 FILTYPE := LSP1;
23100 (* 173 - internal files *)
23200 SIZE := CHECKSIZE(LSIZE) + SIZEOFFILEBLOCK;
23300 FILEPF := PACKFLAG; BITSIZE := LBITSIZE
23400 END;
23500 IF LSP1 # NIL
23600 THEN
23700 IF (LSP1^.FORM = FILES) OR (LSP1^.HASFILE)
23800 THEN
23900 BEGIN
24000 ERROR(254); LSP^.FILTYPE := NIL
24100 END;
24200 (* 70 - fix ill mem ref if type error *)
24300 END
24400 ELSE LSP := NIL;
24500 FSP := LSP; FBITSIZE := LBITSIZE
24600 END;
24700 IFERRSKIP(166,FSYS)
24800 END
24900 ELSE FSP := NIL;
25000 IF FSP = NIL
25100 THEN
25200 BEGIN
25300 FSIZE := 1;FBITSIZE := 0
25400 END
25500 (* 173 - internal files *)
25600 ELSE BEGIN
25700 FSIZE := FSP^.SIZE;
25800 FSP^.HASFILE := FHASFILE
25900 END
26000 END %TYP\ ;
26100
26200 PROCEDURE LABELDECLARATION;
26300 VAR
26400 (* 64 - NON-LOCAL GOTOS *)
26500 lcp:ctp;
26600 BEGIN
26700 (* 6 - remove error message. Allow LABEL declaration but ignore it *)
26800 LOOP
26900 IF SY = INTCONST
27000 THEN
27100 BEGIN
27200 newz(lcp,labelt);
27300 with lcp^ do
27400 begin
27500 scope := level; name := id; idtype := nil;
27600 next := lastlabel; lastlabel := lcp;
27700 gotochain := 0; labeladdress := 0
27800 end;
27900 enterid(lcp);
28000 1:
28100 INSYMBOL
28200 END
28300 ELSE ERROR(255);
28400 IFERRSKIP(166,FSYS OR [COMMA,SEMICOLON]);
28500 EXIT IF SY # COMMA;
28600 INSYMBOL
28700 END;
28800 IF SY = SEMICOLON
28900 THEN INSYMBOL
29000 ELSE ERROR(156)
29100 END %LABELDECLARATION\ ;
29200
29300 PROCEDURE CONSTANTDECLARATION;
29400 VAR
29500 LCP: CTP; LSP: STP; LVALU: VALU;
29600 BEGIN
29700 SKIPIFERR([IDENT],209,FSYS);
29800 WHILE SY = IDENT DO
29900 BEGIN
30000 NEWZ(LCP,KONST);
30100 WITH LCP^ DO
30200 BEGIN
30300 NAME := ID; IDTYPE := NIL; NEXT := NIL
30400 END;
30500 INSYMBOL;
30600 IF (SY = RELOP) AND (OP = EQOP)
30700 THEN INSYMBOL
30800 ELSE ERROR(157);
30900 (* 56 - REQ FILE SYNTAX *)
31000 CONSTANT(FSYS OR [SEMICOLON,PERIOD],LSP,LVALU);
31100 ENTERID(LCP);
31200 LCP^.IDTYPE := LSP; LCP^.VALUES := LVALU;
31300 IF SY = SEMICOLON
31400 THEN
31500 BEGIN
31600 INSYMBOL;
31700 IFERRSKIP(166,FSYS OR [IDENT])
31800 END
31900 (* 56 - REQ FILE SYNTAX *)
32000 ELSE IF NOT ((SY=PERIOD) AND REQFILE)
32100 THEN ERROR(156)
32200 END
32300 END %CONSTANTDECLARATION\ ;
32400
32500 PROCEDURE TYPEDECLARATION;
32600 VAR
32700 LCP,LCP1,LCP2: CTP; LSP: STP; LSIZE: ADDRRANGE;
32800 LBITSIZE: BITRANGE;
32900 BEGIN
33000 SKIPIFERR([IDENT],209,FSYS);
33100 WHILE SY = IDENT DO
33200 BEGIN
33300 NEWZ(LCP,TYPES);
33400 WITH LCP^ DO
33500 BEGIN
33600 (* 116 - be sure NEXT is NIL when unused, for COPYCTP *)
33700 NAME := ID; IDTYPE := NIL; NEXT := NIL;
33800 END;
33900 INSYMBOL;
34000 IF (SY = RELOP) AND (OP = EQOP)
34100 THEN INSYMBOL
34200 ELSE ERROR(157);
34300 (* 56 - REQ FILE SYNTAX *)
34400 TYP(FSYS OR [SEMICOLON,PERIOD],LSP,LSIZE,LBITSIZE);
34500 ENTERID(LCP);
34600 WITH LCP^ DO
34700 BEGIN
34800 IDTYPE := LSP;
34900 (* 165 - fix scoping for pointer ref's *)
35000 END;
35100 IF SY = SEMICOLON
35200 THEN
35300 BEGIN
35400 INSYMBOL;
35500 IFERRSKIP(166,FSYS OR [IDENT]);
35600 END
35700 (* 56 - REQ FILE SYNTAX *)
35800 ELSE IF NOT ((SY=PERIOD) AND REQFILE)
35900 THEN ERROR(156)
36000 END;
36100 (* 113 - don't check for forw. ref's satisfied in req. file *)
36200 END %TYPEDECLARATION\ ;
36300
36400 (* 166 - must resolve forwards separately, in case of TYPE section
36500 in required file but none in main *)
36600 PROCEDURE FWDRESOLVE;
36700 BEGIN
36800 {For each forward request, look up the variable requested. If
36900 you find the request, use it. Note that all declarations of
37000 the form ^THING produce forward requests. This is to force
37100 THING to be looked up after all type declarations have been
37200 processed, so we get the local definition if there is one.}
37300 WHILE FWPTR # NIL DO
37400 BEGIN
37500 (* 165 - fix scoping problem with pointers *)
37600 ID := FWPTR^.NAME;
37700 PRTERR := FALSE; %NO ERROR IF SEARCH NOT SUCCESSFUL\
37800 SEARCHID([TYPES],LCP); PRTERR := TRUE;
37900 IF LCP <> NIL
38000 THEN IF LCP^.IDTYPE # NIL
38100 THEN IF LCP^.IDTYPE^.FORM = FILES
38200 THEN ERROR(254)
38300 ELSE FWPTR^.IDTYPE^.ELTYPE := LCP^.IDTYPE
38400 ELSE
38500 ELSE ERRORWITHTEXT(405,FWPTR^.NAME);
38600 FWPTR := FWPTR^.NEXT
38700 END
38800 END %FWDRESOLVE\ ;
38900
39000 PROCEDURE VARIABLEDECLARATION;
39100 VAR
39200 LCP,NXT: CTP; LSP: STP; LSIZE: ADDRRANGE;
39300 LBITSIZE: BITRANGE; II: INTEGER;
39400 (* 173 - removed lfileptr *)
39500 BEGIN
39600 NXT := NIL;
39700 REPEAT
39800 LOOP
39900 IF SY = IDENT
40000 THEN
40100 BEGIN
40200 NEWZ(LCP,VARS);
40300 WITH LCP^ DO
40400 BEGIN
40500 NAME := ID; NEXT := NXT;
40600 IDTYPE := NIL; VKIND := ACTUAL; VLEV := LEVEL
40700 END;
40800 ENTERID(LCP);
40900 NXT := LCP;
41000 INSYMBOL;
41100 END
41200 ELSE ERROR(209);
41300 SKIPIFERR(FSYS OR [COMMA,COLON] OR TYPEDELS,166,[SEMICOLON]);
41400 EXIT IF SY # COMMA;
41500 INSYMBOL
41600 END;
41700 IF SY = COLON
41800 THEN INSYMBOL
41900 ELSE ERROR(151);
42000 TYP(FSYS OR [SEMICOLON] OR TYPEDELS,LSP,LSIZE,LBITSIZE);
42100 (* 24 - testpacked no longer needed *)
42200 (* 173 - internal files *)
42300 IF LSP <> NIL
42400 THEN IF (LSP^.FORM = FILES) OR LSP^.HASFILE
42500 THEN FILEINBLOCK[LEVEL] := TRUE;
42600 WHILE NXT # NIL DO
42700 WITH NXT^ DO
42800 BEGIN
42900 IDTYPE := LSP; VADDR := LC;
43000 LC := LC + LSIZE ;
43100 (* 173 - internal files - removed file code here *)
43200 NXT := NEXT ;
43300 END;
43400 IF SY = SEMICOLON
43500 THEN
43600 BEGIN
43700 INSYMBOL;
43800 IFERRSKIP(166,FSYS OR [IDENT])
43900 END
44000 ELSE ERROR(156)
44100 UNTIL (SY # IDENT) AND NOT (SY IN TYPEDELS);
44200 (* 167 - code removed from here. It is now part of FWDRESOLVE,
44300 which is called right after this procedure *)
44400 END %VARIABLEDECLARATION\ ;
44500
44600 PROCEDURE PROCEDUREDECLARATION(FSY: SYMBOL);
44700 VAR
44800 OLDLEV: 0..MAXLEVEL; LSY: SYMBOL; LCP,LCP1: CTP; LSP: STP;
44900 FORW: BOOLEAN; OLDTOP: DISPRANGE; LNXT: CTP;
45000 (* 62 - clean up stack offsets *)
45100 LLC,LCM: ADDRRANGE; TOPPOFFSET: ADDRRANGE;
45200
45300 PROCEDURE PARAMETERLIST(FSY: SETOFSYS; VAR FPAR: CTP; VAR TOPPOFFSET: ADDRRANGE);
45400 VAR
45500 LCP,LCP1,LCP2,LCP3: CTP; LSP: STP; LKIND: IDKIND;
45600 (* 62 - clean up stack offset *)
45700 REGC:INTEGER;
45800 BEGIN
45900 LCP1 := NIL; REGC := REGIN+1;
46000 SKIPIFERR(FSY OR [LPARENT],256,FSYS);
46100 IF SY = LPARENT
46200 THEN
46300 BEGIN
46400 IF FORW
46500 THEN ERROR(553);
46600 INSYMBOL;
46700 SKIPIFERR([IDENT,VARSY,PROCEDURESY,FUNCTIONSY],256,FSYS OR [RPARENT]);
46800 WHILE SY IN [IDENT,VARSY,PROCEDURESY,FUNCTIONSY] DO
46900 BEGIN
47000 IF SY = PROCEDURESY
47100 THEN
47200 BEGIN
47300 (* 33 - PROC PARAM.S *)
47400 REPEAT
47500 INSYMBOL;
47600 IF SY = IDENT
47700 THEN
47800 BEGIN
47900 NEWZ(LCP,PROC,DECLARED,FORMAL);
48000 WITH LCP^ DO
48100 BEGIN
48200 NAME := ID; IDTYPE := NIL; NEXT := LCP1;
48300 PFLEV := LEVEL; PFADDR := LC
48400 END;
48500 ENTERID(LCP);
48600 (* 62 - clean up stack offset *)
48700 LCP1 := LCP; LC := LC + 1; REGC := REGC+1;
48800 INSYMBOL
48900 END
49000 ELSE ERROR(209);
49100 IFERRSKIP(256,FSYS OR [COMMA,SEMICOLON,RPARENT])
49200 UNTIL SY # COMMA
49300 END
49400 ELSE
49500 IF SY = FUNCTIONSY
49600 THEN
49700 BEGIN
49800 (* 33 - PROC PARAM.S *)
49900 LCP2 := NIL;
00100 REPEAT
00200 INSYMBOL;
00300 IF SY = IDENT
00400 THEN
00500 BEGIN
00600 NEWZ(LCP,FUNC,DECLARED,FORMAL);
00700 WITH LCP^ DO
00800 BEGIN
00900 NAME := ID; IDTYPE := NIL; NEXT := LCP2;
01000 PFLEV := LEVEL; PFADDR := LC
01100 END;
01200 ENTERID(LCP);
01300 (* 62 - clean up stack offset *)
01400 LCP2 := LCP; LC := LC + 1; REGC := REGC+1;
01500 INSYMBOL;
01600 END;
01700 IF NOT (SY IN [COMMA,COLON] OR FSYS)
01800 THEN
01900 ERRANDSKIP(256,FSYS OR [COMMA,SEMICOLON,RPARENT])
02000 UNTIL SY # COMMA;
02100 IF SY = COLON
02200 THEN
02300 BEGIN
02400 INSYMBOL;
02500 IF SY = IDENT
02600 THEN
02700 BEGIN
02800 SEARCHID([TYPES],LCP);
02900 LSP := LCP^.IDTYPE;
03000 IF LSP # NIL
03100 THEN
03200 IF NOT (LSP^.FORM IN [SCALAR,SUBRANGE,POINTER])
03300 THEN
03400 BEGIN
03500 ERROR(551); LSP := NIL
03600 END;
03700 LCP3 := LCP2;
03800 WHILE LCP2 # NIL DO
03900 BEGIN
04000 LCP2^.IDTYPE := LSP; LCP := LCP2;
04100 LCP2 := LCP2^.NEXT
04200 END;
04300 LCP^.NEXT := LCP1; LCP1 := LCP3;
04400 INSYMBOL
04500 END
04600 ELSE ERROR(209);
04700 IFERRSKIP(256,FSYS OR [SEMICOLON,RPARENT])
04800 END
04900 ELSE ERROR(151)
05000 END
05100 ELSE
05200 BEGIN
05300 IF SY = VARSY
05400 THEN
05500 BEGIN
05600 LKIND := FORMAL; INSYMBOL
05700 END
05800 ELSE LKIND := ACTUAL;
05900 LCP2 := NIL;
06000 LOOP
06100 IF SY = IDENT
06200 THEN
06300 BEGIN
06400 NEWZ(LCP,VARS);
06500 WITH LCP^ DO
06600 BEGIN
06700 NAME := ID; IDTYPE := NIL;
06800 VKIND := LKIND; NEXT := LCP2; VLEV := LEVEL;
06900 END;
07000 ENTERID(LCP);
07100 LCP2 := LCP;
07200 INSYMBOL;
07300 END
07400 ELSE ERROR(256);
07500 IF NOT (SY IN [COMMA,COLON] OR FSYS)
07600 THEN
07700 ERRANDSKIP(256,FSYS OR [COMMA,SEMICOLON,RPARENT])
07800 EXIT IF SY # COMMA;
07900 INSYMBOL
08000 END;
08100 IF SY = COLON
08200 THEN
08300 BEGIN
08400 INSYMBOL;
08500 (* 15 - ALLOW :FILE AS KLUDGEY THING THAT MATCHES ALL FILES *)
08600 IF SY IN [IDENT,FILESY]
08700 THEN
08800 BEGIN
08900 IF SY=IDENT
09000 THEN BEGIN
09100 (* 111 - STRING, POINTER *)
09200 SEARCHID([TYPES,PARAMS],LCP);
09300 (* PARAMS IS A PREDECLARED IDENTIFIER DESCRIBING
09400 A CLASS OF PARAMETERS WITH REDUCED TYPE CHECKING,
09500 E.G. STRING OR POINTER *)
09600 LSP := LCP^.IDTYPE;
09700 END
09800 ELSE LSP:=ANYFILEPTR;
09900 IF LSP # NIL
10000 THEN
10100 IF (LKIND = ACTUAL) AND (LSP^.FORM = FILES)
10200 THEN
10300 ERROR(355);
10400 (* 151 - fix reversed args in case I,J:INTEGER *)
10500 {LCP2 is reversed at the moment. Put it forwards so memory alloc is right}
10600 LCP3 := NIL;
10700 WHILE LCP2 # NIL DO
10800 BEGIN
10900 LCP := LCP2;
11000 LCP2 := LCP2^.NEXT;
11100 LCP^.NEXT := LCP3;
11200 LCP3 := LCP;
11300 END;
11400 WHILE LCP3 # NIL DO
11500 BEGIN
11600 WITH LCP3^ DO
11700 BEGIN
11800 IDTYPE := LSP;
11900 VADDR := LC;
12000 (* 161 - fix POINTER and STRING *)
12100 (* 202 - pointer by ref *)
12200 {POINTER and STRING are passed by a kludgey mechanism. Since it uses 2 AC's
12300 we choose to call this thing call by value, with a size of 2. STRING
12400 works the same for value and ref anyway. POINTER doesn't, so we
12500 use pointerref instead of pointerptr to distinguish. If we call these
12600 things 2-word quantities passed by value, then mostly the right thing
12700 happens automatically. The only other place special code is required
12800 is in CALLNONSTANDARD where by use a special routine in place of LOAD,
12900 to do the actually funny passing.}
13000 if (lsp = stringptr) or (lsp = pointerptr)
13100 then if (lsp = pointerptr) and
13200 (vkind = formal)
13300 {If it is POINTER called by ref, use a special tag, POINTERREF }
13400 then begin
13500 idtype := pointerref;
13600 vkind := actual
13700 end
13800 {In any case, consider it actual so the size = 2 works }
13900 else vkind := actual;
14000 IF VKIND = FORMAL
14100 THEN LC := LC + 1
14200 ELSE
14300 IF IDTYPE # NIL
14400 THEN LC := LC + IDTYPE^.SIZE;
14500 (* 62 - clean up stack offset *)
14600 IF IDTYPE = NIL
14700 THEN REGC := REGC+1
14800 ELSE IF (VKIND = ACTUAL) AND (IDTYPE^.SIZE = 2)
14900 THEN REGC := REGC+2
15000 ELSE REGC := REGC+1
15100 END;
15200 LCP := LCP3;
15300 LCP3 := LCP3^.NEXT;
15400 (* 151 - CONS the new thing on individually instead of APPENDing the whole
15500 string, in order to avoid getting I and J reversed in I,J:INTEGER *)
15600 {Note that we are here reversing the order again. This is because the
15700 whole thing gets reversed below.}
15800 LCP^.NEXT := LCP1;
15900 LCP1 := LCP;
16000 END;
16100 INSYMBOL
16200 END
16300 ELSE ERROR(209);
16400 IFERRSKIP(256,FSYS OR [SEMICOLON,RPARENT])
16500 END
16600 ELSE ERROR(151);
16700 END;
16800 IF SY = SEMICOLON
16900 THEN
17000 BEGIN
17100 INSYMBOL;
17200 SKIPIFERR(FSYS OR [IDENT,VARSY,PROCEDURESY,FUNCTIONSY],256,[RPARENT])
17300 END
17400 END %WHILE\ ;
17500 IF SY = RPARENT
17600 THEN
17700 BEGIN
17800 INSYMBOL;
17900 IFERRSKIP(166,FSY OR FSYS)
18000 END
18100 ELSE ERROR(152);
18200 LCP3 := NIL;
18300 %REVERSE POINTERS\
18400 WHILE LCP1 # NIL DO
18500 WITH LCP1^ DO
18600 BEGIN
18700 LCP2 := NEXT; NEXT := LCP3;
18800 LCP3 := LCP1; LCP1 := LCP2
18900 END;
19000 FPAR := LCP3
19100 END
19200 ELSE FPAR := NIL;
19300 (* 62 - clean up stack offset *)
19400 IF (REGC - 1) > PARREGCMAX
19500 THEN TOPPOFFSET := LC - 1
19600 ELSE TOPPOFFSET := 0;
19700 END %PARAMETERLIST\ ;
19800
19900 BEGIN
20000 %PROCEDUREDECLARATION\
20100 LLC := LC;
20200 IF FSY = PROCEDURESY
20300 THEN LC := 1
20400 ELSE LC := 2;
20500 IF SY = IDENT
20600 THEN
20700 BEGIN
20800 (* 5 - CREF *)
20900 IF CREF
21000 THEN WRITE(CHR(15B),CHR(10),ID);
21100 SEARCHSECTION(DISPLAY[TOP].FNAME,LCP); %DECIDE WHETHER FORW.\
21200 IF LCP # NIL
21300 THEN
21400 WITH LCP^ DO
21500 BEGIN
21600 IF KLASS = PROC
21700 THEN
21800 FORW := FORWDECL AND (FSY = PROCEDURESY) AND (PFKIND = ACTUAL)
21900 ELSE
22000 IF KLASS = FUNC
22100 THEN
22200 FORW := FORWDECL AND (FSY = FUNCTIONSY) AND (PFKIND = ACTUAL)
22300 ELSE FORW := FALSE;
22400 IF NOT FORW
22500 THEN ERROR(406)
22600 END
22700 ELSE FORW := FALSE;
22800 IF NOT FORW
22900 THEN
23000 BEGIN
23100 IF FSY = PROCEDURESY
23200 THEN NEWZ(LCP,PROC,DECLARED,ACTUAL)
23300 ELSE NEWZ(LCP,FUNC,DECLARED,ACTUAL);
23400 WITH LCP^ DO
23500 BEGIN
23600 (* 116 - be sure NEXT is NIL when unused, for COPYCTP *)
23700 NAME := ID; IDTYPE := NIL; TESTFWDPTR := NIL; NEXT := NIL;
23800 FORWDECL := FALSE; EXTERNDECL := FALSE; LANGUAGE := PASCALSY;
23900 PFLEV := LEVEL; PFADDR := 0; FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0
24000 END;
24100 ENTERID(LCP)
24200 END
24300 ELSE
24400 BEGIN
24500 LCP1 := LCP^.NEXT;
24600 WHILE LCP1 # NIL DO
24700 BEGIN
24800 WITH LCP1^ DO
24900 IF KLASS = VARS
25000 THEN
25100 IF IDTYPE # NIL
25200 THEN
25300 BEGIN
25400 LCM := VADDR + IDTYPE^.SIZE;
25500 IF LCM > LC
25600 THEN LC := LCM
25700 END;
25800 LCP1 := LCP1^.NEXT
25900 END
26000 END;
26100 INSYMBOL
26200 END
26300 ELSE
26400 BEGIN
26500 ERROR(209);
26600 IF FSY = PROCEDURESY
26700 THEN LCP := UPRCPTR
26800 ELSE LCP := UFCTPTR
26900 END;
27000 OLDLEV := LEVEL; OLDTOP := TOP;
27100 IF LEVEL < MAXLEVEL
27200 THEN LEVEL := LEVEL + 1
27300 ELSE ERROR(453);
27400 IF TOP < DISPLIMIT
27500 THEN
27600 BEGIN
27700 TOP := TOP + 1;
27800 WITH DISPLAY[TOP] DO
27900 BEGIN
28000 (* 5 - save block name for CREF *)
28100 FNAME := NIL; OCCUR := BLCK; BLKNAME := LCP^.NAME;
28200 IF DEBUG THEN BEGIN
28300 (* 214 - use ULBLPTR because UPRCPTR will not have NEXT treated
28400 properly *)
28500 {This is a dummy entry in the symbol table strictly for the debugger.
28600 The debugger looks at its NEXT field to find the procedure name}
28700 NEWZ(LCP1); LCP1^ := ULBLPTR^;
28800 LCP1^.NEXT := LCP;
28900 ENTERID(LCP1);
29000 IF FORW AND (LCP^.NEXT # NIL)
29100 THEN BEGIN
29200 (* 150 - removed lcp1^.llink := lcp^.next. LCP^.NEXT is a tree containing
29300 the parameters. It needs to be put into the symbol table. Since
29400 all legal symbols > blanks, just put it in Rlink. Previously got
29500 all symbols twice in debugger! *)
29600 LCP1^.RLINK := LCP^.NEXT
29700 END
29800 END
29900 ELSE IF FORW THEN FNAME := LCP^.NEXT
30000 END %WITH DISPLAY[TOP]\
30100 END
30200 ELSE ERROR(404);
30300 IF FSY = PROCEDURESY
30400 THEN
30500 BEGIN
30600 (* 62 - clean up stack offset *)
30700 PARAMETERLIST([SEMICOLON],LCP1,TOPPOFFSET);
30800 IF NOT FORW
30900 THEN WITH LCP^ DO
31000 BEGIN NEXT := LCP1; POFFSET := TOPPOFFSET END
31100 END
31200 ELSE
31300 BEGIN
31400 (* 62 - clean up stack offset *)
31500 PARAMETERLIST([SEMICOLON,COLON],LCP1,TOPPOFFSET);
31600 IF NOT FORW
31700 THEN WITH LCP^ DO
31800 BEGIN NEXT := LCP1; POFFSET := TOPPOFFSET END;
31900 IF SY = COLON
32000 THEN
32100 BEGIN
32200 INSYMBOL;
32300 IF SY = IDENT
32400 THEN
32500 BEGIN
32600 IF FORW
32700 THEN ERROR(552);
32800 SEARCHID([TYPES],LCP1);
32900 LSP := LCP1^.IDTYPE;
33000 LCP^.IDTYPE := LSP;
33100 IF LSP # NIL
33200 THEN
33300 IF NOT (LSP^.FORM IN [SCALAR,SUBRANGE,POINTER])
33400 THEN
33500 BEGIN
33600 ERROR(551); LCP^.IDTYPE := NIL
33700 END;
33800 INSYMBOL
33900 END
34000 ELSE ERRANDSKIP(209,FSYS OR [SEMICOLON])
34100 END
34200 ELSE
34300 IF NOT FORW
34400 THEN ERROR(455)
34500 END;
34600 IF SY = SEMICOLON
34700 THEN INSYMBOL
34800 ELSE ERROR(156);
34900 IF SY = FORWARDSY
35000 THEN
35100 BEGIN
35200 IF FORW
35300 THEN ERROR(257)
35400 ELSE
35500 WITH LCP^ DO
35600 BEGIN
35700 TESTFWDPTR := FORWPTR; FORWPTR := LCP; FORWDECL := TRUE
35800 END;
35900 INSYMBOL;
36000 IF SY = SEMICOLON
36100 THEN INSYMBOL
36200 ELSE ERROR(156);
36300 IFERRSKIP(166,FSYS)
36400 END % SY = FORWARDSY \
36500 ELSE
36600 WITH LCP^ DO
36700 BEGIN
36800 IF SY = EXTERNSY
36900 THEN
37000 BEGIN
37100 IF FORW
37200 THEN ERROR(257)
37300 ELSE EXTERNDECL := TRUE;
37400 INSYMBOL;
37500 IF LEVEL # 2
37600 THEN ERROR(464);
37700 IF SY IN LANGUAGESYS
37800 THEN
37900 BEGIN
38000 LANGUAGE := SY;
38100 INSYMBOL
38200 END;
38300 IF (LIBIX = 0) OR (NOT LIBRARY[LANGUAGE].INORDER)
38400 THEN
38500 BEGIN
38600 LIBIX:= LIBIX+1;
38700 LIBORDER[LIBIX]:= LANGUAGE;
38800 LIBRARY[LANGUAGE].INORDER:= TRUE
38900 END;
39000 PFLEV := 1; PFCHAIN := EXTERNPFPTR; EXTERNPFPTR := LCP;
39100 IF SY = SEMICOLON
39200 (* 56 - ACCEPT SYNTAX OF REQUIRE FILE *)
39300 THEN BEGIN
39400 INSYMBOL;
39500 IFERRSKIP(166,FSYS)
39600 END
39700 ELSE IF NOT((SY=PERIOD) AND REQFILE)
39800 THEN ERROR(166)
39900 END % SY = EXTERNSY \
40000 ELSE
40100 BEGIN
40200 (* 55 - ONLY EXTERN DECL'S ALLOWED IN REQUIRE FILE *)
40300 IF REQFILE
40400 THEN ERROR(169);
40500 PFCHAIN := LOCALPFPTR; LOCALPFPTR := LCP; FORWDECL := FALSE;
40600 BLOCK(LCP,FSYS,[BEGINSY,FUNCTIONSY,PROCEDURESY,PERIOD,SEMICOLON]);
40700 IF SY = SEMICOLON
40800 THEN
40900 BEGIN
41000 INSYMBOL;
41100 SKIPIFERR([BEGINSY,PROCEDURESY,FUNCTIONSY],166,FSYS)
41200 END
41300 ELSE
41400 IF MAIN OR (LEVEL > 2) OR (SY # PERIOD)
41500 THEN ERROR(156)
41600 END % SY # EXTERNSY \
41700 END % SY # FORWARDSY \ ;
41800 LEVEL := OLDLEV; TOP := OLDTOP; LC := LLC;
41900 (* 5 - CREF *)
42000 IF CREF
42100 THEN WRITE(CHR(16B),CHR(10),LCP^.NAME)
42200 END %PROCEDUREDECLARATION\ ;
42300
42400 PROCEDURE BODY(FSYS: SETOFSYS);
42500 CONST
42600 (* 173 - rework for internal files *)
42700 FILEOF = 1B; FILEOL = 2B; FILSTA = 11B; FILTST=40B;
42800 FILBFH =26B; FILLNR = 31B;
42900 (* 43 - new stuff for blocked files *)
43000 (* 50 - new labels for reinit *)
43100 FILCMP =43B; filbll=36b;
43200 (* 61 - tops20 *)
43300 filjfn =4b;
43400 VAR
43500 (* 217 - removed LASTFILE, EXTERNCTP in the ATTR record now plays its role *)
43600 IDTREE: ADDRRANGE; %POINTER(IN THE USER'S CODE) TO THE IDENTIFIER-TREE\
43700
43800 PROCEDURE FULLWORD(FRELBYTE: RELBYTE; FLEFTH: ADDRRANGE; FRIGHTH: ADDRRANGE);
43900 BEGIN
44000 %FULLWORD\
44100 CIX := CIX + 1;
44200 IF CIX > CIXMAX
44300 THEN
44400 BEGIN
44500 IF FPROCP = NIL THEN ERRORWITHTEXT(356,'MAIN ')
44600 ELSE ERRORWITHTEXT(356, FPROCP^.NAME);
44700 CIX := 0
44800 END;
44900 WITH CODE, HALFWORD[CIX] DO
45000 BEGIN
45100 LEFTHALF := FLEFTH;
45200 RIGHTHALF := FRIGHTH;
45300 INFORMATION[CIX] := 'W'; RELOCATION[CIX] := FRELBYTE
45400 END;
45500 IC := IC + 1
45600 END %FULLWORD\ ;
45700
45800 (* 164 - routine to allow Polish fixup in case ADDR can't be done by compiler *)
45900
46000 procedure insertpolish(place,original:addrrange;adjust:integer);
46100 var pol:polpt;
46200 {This routine requests the loader to fix up the right half of PLACE, by
46300 putting in ORIGINAL (assumed relocatable) + ADJUST (assumed absolute).
46400 A POLREC is created, and the actual request is put in the file by
46500 WRITEMC(WRITEPOLISH).}
46600 begin
46700 if abs(adjust) > 377777B
46800 then error(266)
46900 else begin
47000 new(pol);
47100 with pol^ do
47200 begin
47300 where := place;
47400 base := original;
47500 offset := adjust;
47600 nextpol := firstpol {Link into chain of requests - FIRSTPOL}
47700 end;
47800 firstpol := pol
47900 end;
48000 end;
48100
48200 PROCEDURE INSERTADDR(FRELBYTE: RELBYTE; FCIX:CODERANGE;FIC:ADDRRANGE);
48300 BEGIN
48400 IF NOT ERRORFLAG
48500 THEN
48600 WITH CODE DO
48700 BEGIN
48800 INSTRUCTION[FCIX].ADDRESS := FIC;
48900 RELOCATION[FCIX] := FRELBYTE
49000 END
49100 END;
49200
49300 PROCEDURE INCREMENTREGC;
49400 BEGIN
49500 REGC := REGC + 1 ;
49600 IF REGC > REGCMAX
49700 THEN
49800 BEGIN
49900 ERROR(310) ; REGC := REGIN
50000 END
50100 END ;
50200
50300 PROCEDURE DEPCST(KONSTTYP:CSTCLASS; FATTR:ATTR);
50400 VAR
50500 II:INTEGER; LKSP,LLKSP: KSP; LCSP: CSP;
50600 NEUEKONSTANTE,GLEICH:BOOLEAN; LCIX: CODERANGE;
50700 BEGIN
50800 I:=1;
50900 NEUEKONSTANTE:=TRUE; LKSP := FIRSTKONST;
51000 WHILE (LKSP#NIL) AND NEUEKONSTANTE DO
51100 WITH LKSP^,CONSTPTR^ DO
51200 BEGIN
51300 IF CCLASS = KONSTTYP
51400 THEN
51500 CASE KONSTTYP OF
51600 REEL:
51700 IF RVAL = FATTR.CVAL.VALP^.RVAL
51800 THEN
51900 NEUEKONSTANTE := FALSE;
52000 INT:
52100 IF INTVAL = FATTR.CVAL.IVAL
52200 THEN
52300 NEUEKONSTANTE := FALSE;
52400 PSET:
52500 IF PVAL = FATTR.CVAL.VALP^.PVAL
52600 THEN
52700 NEUEKONSTANTE := FALSE;
52800 STRD,
52900 STRG:
53000 IF FATTR.CVAL.VALP^.SLGTH = SLGTH
53100 THEN
53200 BEGIN
53300 GLEICH := TRUE;
53400 II := 1;
53500 REPEAT
53600 IF FATTR.CVAL.VALP^.SVAL[II] # SVAL[II]
53700 THEN
53800 GLEICH := FALSE;
53900 II:=II+1
54000 UNTIL (II>SLGTH) OR NOT GLEICH;
54100 IF GLEICH
54200 THEN NEUEKONSTANTE := FALSE
54300 END
54400 END %CASE\;
54500 LLKSP := LKSP; LKSP := NEXTKONST
54600 END %WHILE\;
54700 IF NOT NEUEKONSTANTE
54800 THEN
54900 WITH LLKSP^ DO
55000 BEGIN
55100 INSERTADDR(RIGHT,CIX,ADDR); CODE.INFORMATION[CIX]:= 'C';
55200 IF KONSTTYP IN [PSET,STRD]
55300 THEN
55400 BEGIN
55500 INSERTADDR(RIGHT,CIX-1,ADDR1); CODE.INFORMATION[CIX-1]:= 'C'; ADDR1 := IC-2;
55600 END;
55700 ADDR:= IC-1
55800 END
55900 ELSE
56000 BEGIN
56100 IF KONSTTYP = INT
56200 THEN
56300 BEGIN
56400 NEWZ(LCSP,INT); LCSP^.INTVAL := FATTR.CVAL.IVAL
56500 END
56600 ELSE
56700 LCSP := FATTR.CVAL.VALP;
56800 CODE.INFORMATION[CIX] := 'C';
56900 IF KONSTTYP IN [PSET,STRD]
57000 THEN CODE.INFORMATION[CIX-1] := 'C';
57100 NEWZ(LKSP);
57200 WITH LKSP^ DO
57300 BEGIN
57400 ADDR := IC-1;
57500 (* 72 - two fixup chains for 2 word consts *)
57600 if konsttyp in [strd,pset]
57700 then addr1 := ic-2;
57800 CONSTPTR := LCSP; NEXTKONST := NIL
57900 END;
58000 IF FIRSTKONST = NIL
58100 THEN FIRSTKONST := LKSP
58200 ELSE LLKSP^.NEXTKONST := LKSP
58300 END
58400 END %DEPCST\;
58500
58600 PROCEDURE MACRO(FRELBYTE : RELBYTE;
58700 FINSTR : INSTRANGE;
58800 FAC : ACRANGE;
58900 FINDBIT : IBRANGE;
59000 FINXREG : ACRANGE;
59100 FADDRESS : INTEGER);
59200 BEGIN
59300 IF NOT INITGLOBALS
59400 THEN
59500 BEGIN
59600 CIX := CIX + 1;
59700 IF CIX > CIXMAX
59800 THEN
59900 BEGIN
60000 IF FPROCP = NIL
60100 THEN ERRORWITHTEXT(356,'MAIN ')
60200 ELSE ERRORWITHTEXT(356, FPROCP^.NAME);
60300 CIX := 0
60400 END;
60500 WITH CODE, INSTRUCTION[CIX] DO
60600 BEGIN
60700 INSTR :=FINSTR;
60800 AC :=FAC;
60900 INDBIT :=FINDBIT;
61000 INXREG :=FINXREG;
61100 ADDRESS :=FADDRESS;
61200 INFORMATION[CIX]:= ' '; RELOCATION[CIX] := FRELBYTE
00100 END;
00200 IC := IC + 1
00300 END
00400 ELSE ERROR(507)
00500 END %MACRO\;
00600
00700 PROCEDURE MACRO5(FRELBYTE: RELBYTE; FINSTR : INSTRANGE; FAC,FINXREG : ACRANGE; FADDRESS : INTEGER);
00800 BEGIN
00900 MACRO(FRELBYTE,FINSTR,FAC,0,FINXREG,FADDRESS)
01000 END;
01100
01200 PROCEDURE MACRO4(FINSTR: INSTRANGE;FAC, FINXREG: ACRANGE;FADDRESS: INTEGER);
01300 BEGIN
01400 MACRO(NO,FINSTR,FAC,0,FINXREG,FADDRESS)
01500 END;
01600
01700 PROCEDURE MACRO3(FINSTR : INSTRANGE; FAC:ACRANGE; FADDRESS: INTEGER);
01800 BEGIN
01900 MACRO(NO,FINSTR,FAC,0,0,FADDRESS)
02000 END;
02100
02200 PROCEDURE MACRO4R(FINSTR : INSTRANGE; FAC,FINXREG : ACRANGE; FADDRESS : INTEGER);
02300 BEGIN
02400 MACRO(RIGHT,FINSTR,FAC,0,FINXREG,FADDRESS)
02500 END;
02600
02700 PROCEDURE MACRO3R(FINSTR : INSTRANGE; FAC:ACRANGE; FADDRESS: INTEGER);
02800 BEGIN
02900 MACRO(RIGHT,FINSTR,FAC,0,0,FADDRESS)
03000 END;
03100
03200 PROCEDURE PUTPAGER;
03300 BEGIN
03400 WITH PAGER DO
03500 BEGIN
03600 LASTPAGER := IC;
03700 WITH WORD1 DO MACRO4R(304B%CAIA\,AC,INXREG,ADDRESS);
03800 FULLWORD(RIGHT,LHALF,RHALF);
03900 LASTPAGE := PAGECNT
04000 END
04100 END;
04200
04300 PROCEDURE PUTLINER;
04400 BEGIN
04500 IF PAGECNT # LASTPAGE
04600 THEN PUTPAGER;
04700 IF LINECNT # LASTLINE
04800 THEN %BREAKPOINT\
04900 BEGIN
05000 IF LINENR # '-----'
05100 THEN
05200 BEGIN
05300 LINECNT := 0;
05400 FOR I := 1 TO 5 DO LINECNT := 10*LINECNT + ORD(LINENR[I]) - ORD('0')
05500 END;
05600 LINEDIFF := LINECNT - LASTLINE;
05700 IF LINEDIFF > 255
05800 THEN
05900 BEGIN
06000 MACRO3R(334B%SKIPA\,0,LASTSTOP);
06100 LASTSTOP := IC-1;
06200 MACRO3(320B%JUMP\,0,LASTLINE)
06300 END
06400 ELSE
06500 BEGIN
06600 MACRO4R(320B%JUMP\,LINEDIFF MOD 16,LINEDIFF DIV 16, LASTSTOP); %NOOP\
06700 LASTSTOP := IC - 1
06800 END;
06900 LASTLINE := LINECNT
07000 END
07100 END;
07200
07300 PROCEDURE SUPPORT(FSUPPORT: SUPPORTS);
07400 BEGIN
07500 CASE FSUPPORT OF
07600 (* 23 - check for bad pointer *)
07700 BADPOINT,
07800 ERRORINASSIGNMENT,
07900 INDEXERROR : MACRO3R(265B%JSA\,HAC,RNTS.LINK[FSUPPORT]);
08000 (* 12 - NOW STACKOVERFLOW IS NOT AN ERROR - GETS MORE MEMORY *)
08100 (* 74 - add initmem for 10 version under emulator *)
08200 (* 104 - debstack for tops-10 debugging stack check *)
08300 (* 120 - new calling method for INITFILES, for T20/Tenex *)
08400 INITFILES,INITMEM,STACKOVERFLOW,DEBSTACK: MACRO3R(265B%JSP\,TAC,RNTS.LINK[FSUPPORT]);
08500 (* 64 - non-local gotos *)
08600 EXITPROGRAM : MACRO3R(254B%JRST\,0,RNTS.LINK[FSUPPORT]);
08700 OTHERS : MACRO3R(260B%PUSHJ\,TOPP,RNTS.LINK[FSUPPORT])
08800 END;
08900 CODE.INFORMATION[CIX]:= 'E';
09000 RNTS.LINK[FSUPPORT]:= IC-1
09100 END;
09200
09300 PROCEDURE ENTERBODY;
09400 VAR
09500 I: INTEGER; LCP : CTP;
09600 (* 66 - NON-LOC GOTO *)
09700 LBTP: BTP; NONLOC,INLEVEL: BOOLEAN;
09800 BEGIN
09900 LBTP := LASTBTP;
10000 (* 13 - ADD DATA FOR DDT SYMBOLS *)
10100 PFPOINT := IC;
10200 WHILE LBTP # NIL DO
10300 BEGIN
10400 WITH LBTP^ DO
10500 CASE BKIND OF
10600 RECORDD: FIELDCP^.FLDADDR := IC;
10700 ARRAYY : ARRAYSP^.ARRAYBPADDR := IC
10800 END;
10900 LBTP := LBTP^.LAST;
11000 IC := IC + 1
11100 END;
11200 (* 66 - NON-LOC GOTO *)
11300 LCP:=LASTLABEL;
11400 INLEVEL:=TRUE; NONLOC:=FALSE;
11500 WHILE(LCP#NIL) AND INLEVEL DO
11600 WITH LCP^ DO
11700 IF SCOPE=LEVEL
11800 THEN BEGIN
11900 NONLOC := NONLOC OR NONLOCGOTO;
12000 LCP := NEXT
12100 END
12200 ELSE INLEVEL := FALSE;
12300 IF FPROCP # NIL
12400 THEN
12500 BEGIN
12600 FULLWORD(NO,0,377777B); IDTREE := CIX; %IF DEBUG, INSERT TREEPOINTER HERE\
12700 (* 13 - SAVE START ADDRESS FOR DDT SYMBOL *)
12800 PFDISP := IC;
12900 WITH FPROCP^ DO
13000 IF PFLEV > 1
13100 THEN
13200 FOR I := MAXLEVEL DOWNTO PFLEV+1 DO
13300 MACRO4(540B%HRR\,BASIS,BASIS,-1);
13400 PFSTART := IC;
13500 (* 62 - clean up stack offset *)
13600 if fprocp^.poffset # 0
13700 then macro4(262B%pop\,topp,topp,-fprocp^.poffset-1);
13800 (* 37 - fix static link for level one procedures *)
13900 if fprocp^.pflev = 1
14000 then macro4(512b%hllzm\,basis,topp,-fprocp^.poffset-1)
14100 ELSE MACRO4(202B%MOVEM\,BASIS,TOPP,-FPROCP^.POFFSET-1);
14200 if fprocp^.poffset # 0
14300 then begin
14400 macro4(201B%movei\,basis,topp,-fprocp^.poffset);
14500 (* 104 - several changes below to allow detection stack overflow *)
14600 macro3(504B%hrl\,basis,basis);
14700 end
14800 ELSE MACRO3(507B%HRLS\,BASIS,TOPP);
14900 (* 115 - tenex *)
15000 IF KLCPU AND NOT TOPS10
15100 THEN MACRO3(105B%ADJSP\,TOPP,0)
15200 ELSE MACRO4(541B%HRRI\,TOPP,TOPP,0);
15300 INSERTSIZE := CIX;
15400 (* 66 - NONLOC GOTO *)
15500 IF NONLOC
15600 THEN MACRO4(506B%HRLM\,TOPP,BASIS,0);
15700 (* If anyone has done a non-local goto into this block, save the
15800 stack pointer here where the goto can recover it. *)
15900 (* 53 - figure out later how many loc's above stack we need *)
16000 (* 57 - LIMIT CORE ALLOCATION TO TOPS-10 VERSION *)
16100 IF TOPS10 THEN BEGIN
16200 IF RUNTMCHECK
16300 THEN BEGIN
16400 MACRO4(201B%MOVEI\,HAC,TOPP,0); CORALLOC := CIX;
16500 %Will be fixed up - get highest core needed \
16600 MACRO4(301B%CAIL\,HAC,BASIS,0); %check wraparound > 777777\
16700 MACRO4(303B%CAILE\,HAC,NEWREG,0); %see if need more\
16800 SUPPORT(DEBSTACK)
16900 END
17000 ELSE BEGIN %NOT DEBUG\
17100 MACRO4(307B%CAIG\,NEWREG,TOPP,0); CORALLOC := CIX;
17200 %will be fixed up - fails if wrap around 777777\
17300 SUPPORT(STACKOVERFLOW);
17400 END
17500 END;
17600 (* 24 - NOW ZERO ONLY IF RUNTIME CHECKING ON *)
17700 (* 25 - SEPARATE SWITCH /ZERO FOR THIS NOW *)
17800 IF ZERO
17900 THEN BEGIN
18000 IF LCPAR < LC %ANY VARIABLES?\
18100 THEN MACRO4(402B%SETZM\,0,BASIS,LCPAR);
18200 IF LCPAR < (LC-1) %MORE THAN ONE?\
18300 THEN BEGIN
18400 MACRO4(505B%HRLI\,TAC,BASIS,LCPAR);
18500 MACRO4(541B%HRRI\,TAC,BASIS,LCPAR+1);
18600 MACRO4(251B%BLT\,TAC,BASIS,LC-1)
18700 END
18800 END;
18900 REGC := REGIN+1;
19000 LCP := FPROCP^.NEXT;
19100 WHILE LCP # NIL DO
19200 WITH LCP^ DO
19300 BEGIN
19400 (* 33 - proc param.'s*)
19500 IF KLASS # VARS
19600 THEN
19700 BEGIN
19800 IF REGC <= PARREGCMAX
19900 THEN BEGIN
20000 MACRO4(202B%MOVEM\,REGC,BASIS,PFADDR);
20100 REGC := REGC+1
20200 END
20300 END
20400 ELSE
20500 IF IDTYPE # NIL
20600 THEN
20700 IF (VKIND=FORMAL) OR (IDTYPE^.SIZE=1)
20800 THEN %COPY PARAMETERS FROM REGISTERS INTO LOCAL CELLS\
20900 BEGIN
21000 IF REGC <= PARREGCMAX
21100 THEN
21200 BEGIN
21300 MACRO4(202B%MOVEM\,REGC,BASIS,VADDR); REGC := REGC + 1
21400 END
21500 END
21600 ELSE
21700 IF IDTYPE^.SIZE=2
21800 THEN
21900 BEGIN
22000 IF REGC < PARREGCMAX
22100 THEN
22200 BEGIN
22300 MACRO4(202B%MOVEM\,REGC,BASIS,VADDR);
22400 MACRO4(202B%MOVEM\,REGC+1,BASIS,VADDR+1);
22500 REGC:=REGC+2
22600 END
22700 (* 2 - bug fix for parameter passing *)
22800 ELSE REGC:=PARREGCMAX+1
22900 END
23000 (* 201 - zero size things *)
23100 ELSE IF IDTYPE^.SIZE > 0
23200 THEN BEGIN
23300 IF REGC <= PARREGCMAX
23400 THEN %COPY MULTIPLE VALUES INTO LOCAL CELLS\
23500 BEGIN
23600 MACRO3(504B%HRL\,TAC,REGC); REGC := REGC + 1
23700 END
23800 ELSE
23900 MACRO4(504B%HRL\,TAC,BASIS,VADDR);
24000 MACRO4(541B%HRRI\,TAC,BASIS,VADDR);
24100 MACRO4(251B%BLT\,TAC,BASIS,VADDR+IDTYPE^.SIZE-1)
24200 END
24300 (* 201 - zero size things *)
24400 ELSE {zero size}
24500 REGC := REGC + 1;
24600 LCP := LCP^.NEXT;
24700 END
24800 END
24900 ELSE MAINSTART := IC
25000 END %ENTERBODY\;
25100
25200 PROCEDURE LEAVEBODY;
25300 VAR
25400 J,K : ADDRRANGE ;
25500 LFILEPTR: FTP; LKSP: KSP ;
25600 (* 33 - PROGRAM *)
25700 LCP : CTP; OLDID : ALFA;
25800 PROCEDURE ALFACONSTANT(FSTRING:ALFA);
25900 VAR LCSP:CSP;
26000 BEGIN
26100 NEW(LCSP,STRG);
26200 WITH LCSP^ DO
26300 BEGIN
26400 SLGTH := 10; FOR I := 1 TO 10 DO SVAL[I] := FSTRING[I]
26500 END;
26600 WITH GATTR DO
26700 BEGIN
26800 TYPTR := ALFAPTR;
26900 KIND := CST; CVAL.VALP := LCSP
27000 END
27100 END;
27200 BEGIN
27300 IF DEBUG
27400 THEN PUTLINER;
27500 IF FPROCP # NIL
27600 THEN
27700 (* 173 - internal files - close them *)
27800 if fileinblock[level]
27900 then begin
28000 {We have to close any files in this block before we can change TOPP,
28100 or we might be playing with locals above the stack! So this is
28200 coded like a non-local goto - new basis in regc, new topp in regc+1}
28300 regc := regin+1;
28400 (* 213 - forgot to subtract 1 from TOPP to simulate POPJ *)
28500 {simulate HRLS TOPP,BASIS. But have to subtract 1
28600 since there would have been a POPJ TOPP, later.
28700 Because of this, things that would be -1(TOPP) are
28800 now (TOPP)}
28900 macro4(505B%hrli\,regc+1,basis,-1);
29000 macro3(544B%hlr\,regc+1,regc+1);
29100 {simulate HLRS BASIS,-1(TOPP), but note that -1 has
29200 already been done}
29300 macro4(544B%hlr\,regc,regc+1,0);
29400 macro3(504B%hrl\,regc,regc);
29500 {now get return address from where POPJ TOPP, would
29600 get it, i.e. (TOPP). However note that -1 has been
29700 done}
29800 macro4(550B%hrrz\,regc+2,regc+1,1);
29900 support(exitgoto)
30000 end
30100 else
30200 BEGIN
30300 (* 104 - keep LH=RH in topp for tops20 adjsp *)
30400 MACRO3(507B%HRLS\,TOPP,BASIS);
30500 MACRO4(547B%HLRS\,BASIS,TOPP,-1);
30600 MACRO3(263B%POPJ\,TOPP,0);
30700 END
30800 ELSE
30900 BEGIN
31000 IF MAIN
31100 THEN
31200 BEGIN
31300 SUPPORT(EXITPROGRAM);
31400 STARTADDR := IC;
31500 (* 2 - get some core by default if none there *)
31600 (* 12 - REDO INITIALIZATION FOR DYNAMIC EXPANDING CORE *)
31700 (* 16 - change entry code in case execute-only or entry at +1 *)
31800 (* 24 - CHANGE AGAIN TO ALLOW ST. ADDR OF HEAP AND STACK SPECIFIED *)
31900 MACRO3R(254B%JRST\,1,IC+2); %PORTAL - IN CASE EXEC-ONLY\
32000 MACRO3R(254B%JRST\,1,IC+2); %IN CASE OFFSET =1\
32100 MACRO3(634B%TDZA\,1,1); %NORMAL ENTRY - ZERO AND SKIP\
32200 MACRO3(201B%MOVEI\,1,1); %CCL ENTRY - SET TO ONE\
32300 MACRO3R(202B%MOVEM\,1,CCLSW); %STORE CCL VALUE\
32400 MACRO3R(200B%MOVE\,1,CCLSW+4); %SEE IF INIT DONE\
32500 MACRO3R(326B%JUMPN\,1,IC+5); %YES - DON'T RESAVE AC'S\
32600 MACRO3R(202B%MOVEM\,0,CCLSW+1); %RUNNAME\
32700 MACRO3R(202B%MOVEM\,7B,CCLSW+2); %RUNPPN\
32800 MACRO3R(202B%MOVEM\,11B,CCLSW+3); %RUNDEV\
32900 MACRO3R(476B%SETOM\,0,CCLSW+4); %SAY WE HAVE DONE IT\
33000 (* 132 - separate KA10 into NOVM and KACPU *)
33100 IF (HEAP = 0) AND (NOT NOVM)
33200 (* 216 - variable start of high seg *)
33300 THEN HEAP := HIGHSTART - 1;
33400 MACRO3(201B%MOVEI\,BASIS,HEAP); %LSTNEW_377777\
33500 MACRO3R(202B%MOVEM\,BASIS,LSTNEW); %WILL GET GLOBAL FIXUP\
33600 LSTNEW := IC-1;
33700 MACRO3(201B%MOVEI\,BASIS,HEAP+1); %NEWBND_400000\
33800 MACRO3R(202B%MOVEM\,BASIS,NEWBND); %GLOBAL FIXUP\
33900 NEWBND := IC-1;
34000 IF STACK#0
34100 THEN MACRO3(201B%MOVEI\,BASIS,STACK)
34200 ELSE MACRO3(550B%HRRZ\,BASIS,115B); %BASIS_.JBHRL\
34300 MACRO3(306B%CAIN\,BASIS,0); %IF NO HISEG\
34400 (* 216 - variable start of high seg *)
34500 MACRO3(201B%MOVEI\,BASIS,HIGHSTART - 1); %START STACK 400000\
34600 MACRO3(200B%MOVE\,NEWREG,BASIS); %NEWREG=HIGHEST ALLOC\
34700 MACRO3(271B%ADDI\,BASIS,1); %BASIS=NEXT TO USE\
34800 MACRO4(505B%HRLI\,BASIS,BASIS,0);
34900 MACRO4(541B%HRRI\,TOPP,BASIS,0); %GETS FIXED UP\
35000 INSERTSIZE:= CIX;
35100 (* 104 - KEEP LH=RH FOR TOPS20 ADJSP *)
35200 MACRO3(504B%HRL\,TOPP,TOPP);
35300 (* 66 - nonloc goto's *)
35400 macro3r(202B%movem\,basis,globbasis);
35500 macro3r(202B%movem\,topp,globtopp);
35600 (* 17 - LEAVE .JBFF ALONE, SINCE BUFFER HEADERS POINT INTO FREE AREA *)
35700 (* 57 - LIMIT UUO'S AND CORE ALLOC TO TOPS-10 VERSION *)
35800 IF TOPS10 THEN BEGIN
35900 (* 122 - seem not to need to save .jbff any more *)
36000 { MACRO3(550B%HRRZ\,1,121B); %.JBFF\
36100 MACRO3(506B%HRLM\,1,120B); %TO LH(.JBSA)\
36200 } MACRO3(047B,0,0%RESET-UUO\); %.JBFF=.JBSA\
36300 (* 74 - new init stuff for tops10 under emulator *)
36400 support(initmem);
36500 (* 53 - figure out later how many loc's above stack we need *)
36600 (* 130 - leave in dummy CAI in KA version so there is some place for the CORALLOC fixup to go *)
36700 MACRO4(300B%CAI\,NEWREG,TOPP,0); CORALLOC := CIX; %Will be fixed up later\
36800 (* 122 - already get core in initmem for KA *)
36900 (* 132 - separate KA10 into novm and kacpu *)
37000 if not novm
37100 THEN SUPPORT(STACKOVERFLOW); % GET CORE FOR STACK\
37200 (* 34 - TRAP ARITH EXCEPTIONS WHEN CHECKING *)
37300 IF ARITHCHECK
37400 THEN BEGIN
37500 MACRO3(201B%MOVEI\,1,110B); %TRAP ALL ARITH. EXCEPTIONS\
37600 MACRO3(047B%CALLI\,1,16B); %APRENB - TURN ON APR SYS\
37700 END;
37800 (* 57 - INIT ALL IN RUNTIMES FOR NON-TOPS10 *)
37900 END
38000 ELSE MACRO3(201B%MOVEI\,2,ORD(ARITHCHECK));
38100 (* 50 - reinit file ctl. blocks *)
38200 support(initfiles);
38300 doinitTTY := false;
38400 LFILEPTR := SFILEPTR ;
38500 REGC := REGIN + 1 ;
38600 (* 33 - PROGRAM *)
38700 (* 50 - changed logic to only open INPUT and OUTPUT if in pgm state *)
38800 LPROGFILE := FPROGFILE;
38900 WHILE LPROGFILE # NIL DO
39000 BEGIN
39100 PRTERR := FALSE; OLDID := ID; ID := LPROGFILE^.FILID;
39200 SEARCHID([VARS],LCP);
39300 PRTERR := TRUE; ID := OLDID;
39400 IF LCP = NIL
39500 THEN ERRORWITHTEXT(508,LPROGFILE^.FILID)
39600 ELSE
39700 WITH LCP^ DO
39800 BEGIN
39900 IF IDTYPE#NIL THEN IF IDTYPE^.FORM#FILES
40000 THEN ERRORWITHTEXT(509,LPROGFILE^.FILID);
40100 MACRO3R(201B%MOVEI\,REGC,VADDR);
40200 IF (VLEV = 0) AND (NOT MAIN)
40300 THEN BEGIN
40400 VADDR := IC -1;
40500 CODE.INFORMATION[CIX] := 'E'
40600 END;
40700 ALFACONSTANT(LPROGFILE^.FILID);
40800 MACRO3(551B%HRRZI\,REGC+1,0);DEPCST(STRG,GATTR);
40900 (* 61 - set up flags for gtjfn *)
41000 i := 60023b; %mandatory flags for gtjfn\
41100 if lprogfile^.wild
41200 then i := i + 100B;
41300 if lprogfile^.newgen
41400 then i := i + 400000B;
41500 if lprogfile^.oldfile
41600 then i := i + 100000B;
41700 macro3(505B%hrli\,regc+1,i);
41800 (* 172 - end of line proc *)
41900 if lcp = ttyfile
42000 then ttyseeeol := lprogfile^.seeeol;
42100 if not ((lcp = ttyfile) or (lcp = ttyoutfile))
42200 then SUPPORT(READFILENAME)
42300 END;
42400 (* 171 - handle input and output as special - many changes to lcp = in/outfile *)
42500 if (lcp = infile)
42600 and not lprogfile^.interact
42700 then doinitTTY := true;
42800 if (lcp = infile) or (lcp = outfile)
42900 then begin
43000 macro3(201B%movei\,regc-1,0); {AC1=0 for text file}
43100 macro3(403B%setzb\,regc+1,regc+2);
43200 macro3(403B%setzb\,regc+3,regc+4);
43300 (* 64 - input:/ *)
43400 (* 157 - always open INPUT interactive - do GET below *)
43500 if lcp = infile
43600 then macro3(201B%movei\,regc+3,1);
43700 macro3(403B%setzb\,regc+5,regc+6);
43800 (* 172 - new eoln handling *)
43900 if (lcp = infile) and lprogfile^.seeeol
44000 then if tops10
44100 then macro3(201B%movei\,regc+5,40000B)
44200 else macro3(201B%movei\,regc+6,20B);
44300 if lcp = infile
44400 then support(resetfile)
44500 else support(rewritefile)
44600 end;
44700 LPROGFILE := LPROGFILE^.NEXT
44800 END;
44900 (* 15 - ZERO ALL ARGS TO OPEN *)
45000 TTYINUSE := TTYINUSE OR DEBUG;
45100 WHILE LFILEPTR # NIL DO
45200 WITH LFILEPTR^ , FILEIDENT^ DO
45300 (* 50 - only open TTY here, as INPUT and OUTPUT done above *)
45400 begin
45500 if (fileident = ttyfile) or (fileident = ttyoutfile)
45600 then
45700 BEGIN
45800 MACRO3R(201B%MOVEI\,REGC,VADDR) ;
45900 macro3(201B%movei\,regc-1,0); {0=text file}
46000 (* 202 - fix illegal option *)
46100 macro3(403B%setzb\,regc+1,regc+2);
46200 macro3(403B%setzb\,regc+3,regc+4);
46300 (* 172 - new EOL *)
46400 macro3(403B%setzb\,regc+5,regc+6);
46500 if (fileident = ttyfile) and ttyseeeol
46600 then if tops10
46700 then macro3(201B%movei\,regc+5,40000B)
46800 else macro3(201B%movei\,regc+6,20B);
46900 (* 36 - allow debugging non-main modules *)
47000 IF fileident = ttyfile
47100 THEN
47200 SUPPORT(RESETFILE)
47300 ELSE
47400 SUPPORT(REWRITEFILE) ;
47500 end;
47600 (* 3 - Removed OPENTTY because of RUNTIM changes *)
47700 LFILEPTR := NEXTFTP ;
47800 END ;
47900 if doinitTTY
48000 then support(opentty);
48100 macro3(200b%move\,tac,74b); %get .jbddt\
48200 macro3(602b%trne\,tac,777777b); %if zero RH\
48300 macro3(603b%tlne\,tac,777777b); %or non-0 LH\
48400 macro3r(254b%jrst\,0,mainstart); %isn't PASDDT\
48500 macro4(260b%pushj\,topp,tac,-2); %init pt. is start-2\
48600 MACRO3R(254B%JRST\,0,MAINSTART);
48700 END;
48800 END;
48900 CODEEND := IC;
49000 LKSP:= FIRSTKONST;
49100 WHILE LKSP # NIL DO
49200 WITH LKSP^,CONSTPTR^ DO
49300 BEGIN
49400 KADDR:= IC;
49500 CASE CCLASS OF
49600 INT,
49700 REEL: IC := IC + 1 ;
49800 PSET: IC := IC + 2 ;
49900 STRD,
50000 STRG: IC := IC + (SLGTH+4) DIV 5
50100 END ;
50200 %CASE\
50300 LKSP := NEXTKONST
50400 END %WITH , WHILE\;
50500 IF DEBUGSWITCH
50600 THEN
50700 BEGIN
50800 IF (LEVEL > 1) AND ( DISPLAY[TOP].FNAME # NIL )
50900 THEN INSERTADDR(RIGHT,IDTREE,IC)
51000 END
51100 ELSE
51200 IF LEVEL = 1
51300 THEN HIGHESTCODE := IC
51400 END%LEAVEBODY\;
51500
51600 PROCEDURE FETCHBASIS(VAR FATTR: ATTR);
51700 VAR
51800 P,Q: INTEGER;
51900 BEGIN
52000 WITH FATTR DO
52100 IF VLEVEL>1
52200 THEN
52300 BEGIN
52400 P := LEVEL - VLEVEL;
52500 IF P=0
52600 THEN
52700 IF INDEXR=0
52800 THEN INDEXR := BASIS
52900 ELSE MACRO3(270B%ADD\,INDEXR,BASIS)
53000 ELSE
53100 BEGIN
53200 MACRO4(540B%HRR\,TAC,BASIS,-1);
53300 FOR Q := P DOWNTO 2 DO
53400 MACRO4(540B%HRR\,TAC,TAC,-1);
53500 IF INDEXR=0
53600 THEN INDEXR := TAC
53700 ELSE MACRO3(270B%ADD\,INDEXR,TAC)
53800 END;
53900 VLEVEL:=1 %DA IN WITHSTATEMENT DIE MOEGLICHKEIT BESTEHT,
54000 DASS ES 2-MAL DURCH FETCHBASIS LAEUFT\
54100 END
54200 END;
54300 %FETCHBASIS\
54400
54500 PROCEDURE GETPARADDR;
54600 BEGIN
54700 FETCHBASIS(GATTR);
54800 WITH GATTR DO
54900 BEGIN
55000 INCREMENTREGC;
55100 MACRO5(VRELBYTE,200B%MOVE\,REGC,INDEXR,DPLMT);
55200 INDEXR := REGC; VRELBYTE:= NO;
55300 INDBIT := 0; VLEVEL := 1; DPLMT := 0;
55400 END
55500 END;
55600
55700 {Warning to future modifiers: At the end of EXPRESSION, there is code that
55800 second-guesses the register allocation in this procedure. If you change
55900 the register allocation here, please look at that code.}
56000 PROCEDURE MAKECODE(FINSTR: INSTRANGE; FAC: ACRANGE; VAR FATTR: ATTR);
56100 VAR
56200 LINSTR: INSTRANGE; LREGC: ACRANGE;
56300 BEGIN
56400 WITH FATTR DO
56500 IF TYPTR#NIL
56600 THEN
56700 BEGIN
56800 CASE KIND OF
56900 CST:
57000 IF TYPTR=REALPTR
57100 THEN
57200 BEGIN
57300 MACRO3(FINSTR,FAC,0); DEPCST(REEL,FATTR)
57400 END
57500 ELSE
57600 IF TYPTR^.FORM=SCALAR
57700 THEN
57800 WITH CVAL DO
57900 IF ((IVAL >= 0) AND (IVAL <= MAXADDR))
58000 OR
58100 (* 50 - correct code for 400000,,0 *)
58200 ((ABS(IVAL) <= HWCSTMAX+1) AND (IVAL # 400000000000B)
58300 AND
58400 ((FINSTR = 200B%MOVE\) OR (IVAL >= 0)))
58500 THEN
58600 BEGIN
58700 IF FINSTR=200B%MOVE\
58800 THEN
58900 IF IVAL < 0
59000 THEN FINSTR := 571B%HRREI\
59100 ELSE FINSTR := 551B%HRRZI\
59200 ELSE
59300 IF (FINSTR>=311B) AND (FINSTR <= 317B)
59400 THEN FINSTR := FINSTR - 10B %E.G. CAML --> CAIL\
59500 ELSE FINSTR := FINSTR+1;
59600 MACRO3(FINSTR,FAC,IVAL);
59700 END
59800 ELSE
59900 BEGIN
60000 MACRO3(FINSTR,FAC,0); DEPCST(INT,FATTR)
60100 END
60200 ELSE
60300 IF TYPTR=NILPTR
60400 THEN
60500 BEGIN
60600 IF FINSTR=200B%MOVE\
60700 THEN FINSTR := 571B%HRREI\
60800 ELSE
60900 IF (FINSTR>=311B) AND (FINSTR<=317B)
61000 THEN FINSTR := FINSTR-10B
61100 ELSE FINSTR := FINSTR+1;
61200 MACRO3(FINSTR,FAC,377777B);
61300 END
61400 ELSE
61500 IF TYPTR^.FORM=POWER
61600 THEN
61700 BEGIN
61800 MACRO3(FINSTR,FAC,0); MACRO3(FINSTR,FAC-1,0); DEPCST(PSET,FATTR);
61900 END
62000 ELSE
62100 IF TYPTR^.FORM=ARRAYS
62200 THEN
62300 IF TYPTR^.SIZE = 1
62400 THEN
62500 BEGIN
62600 MACRO3(FINSTR,FAC,0); DEPCST(STRG,FATTR)
62700 END
62800 ELSE
62900 IF TYPTR^.SIZE = 2
63000 THEN
63100 BEGIN
63200 FATTR.CVAL.VALP^.CCLASS := STRD;
63300 MACRO3(FINSTR,FAC,0); MACRO3(FINSTR,FAC-1,0); DEPCST(STRD,FATTR);
63400 END;
63500 VARBL:
63600 BEGIN
63700 FETCHBASIS(FATTR); LREGC := FAC;
63800 IF (INDEXR>REGIN) AND (INDEXR<=REGCMAX) AND ((PACKFG#NOTPACK) OR (FINSTR=200B%MOVE\))
63900 THEN
64000 IF (TYPTR^.SIZE = 2) AND LOADNOPTR
64100 THEN LREGC := INDEXR+1
64200 ELSE LREGC := INDEXR
64300 ELSE
64400 IF (PACKFG#NOTPACK) AND (FINSTR#200B%MOVE\)
64500 THEN
64600 BEGIN
64700 INCREMENTREGC; LREGC := REGC
64800 END;
64900 CASE PACKFG OF
65000 NOTPACK:
65100 BEGIN
65200 IF (TYPTR^.SIZE = 2) AND LOADNOPTR
65300 THEN
65400 (* 141 - protect against obscure case where INDEXR = LREGC *)
65500 IF LREGC <> INDEXR
65600 THEN BEGIN
65700 MACRO5(VRELBYTE,FINSTR,LREGC,INDEXR,DPLMT+1);
65800 MACRO5(VRELBYTE,FINSTR,LREGC-1,INDEXR,DPLMT)
65900 END
66000 ELSE BEGIN
66100 MACRO5(VRELBYTE,FINSTR,LREGC-1,INDEXR,DPLMT);
66200 MACRO5(VRELBYTE,FINSTR,LREGC,INDEXR,DPLMT+1)
66300 END
66400 ELSE MACRO(VRELBYTE,FINSTR,LREGC,INDBIT,INDEXR,DPLMT);
66500 END;
66600 PACKK:
66700 BEGIN
66800 MACRO5(VRELBYTE,201B%MOVEI\,TAC,INDEXR,DPLMT);
66900 IF (BPADDR>REGIN) AND (BPADDR<=REGCMAX)
67000 THEN
67100 IF (INDEXR<=REGIN) OR (BPADDR<INDEXR)
67200 THEN LREGC := BPADDR
67300 ELSE LREGC := INDEXR;
67400 MACRO3R(135B%LDB\,LREGC,BPADDR);
67500 END;
67600 HWORDL: MACRO5(VRELBYTE,554B%HLRZ\,LREGC,INDEXR,DPLMT);
67700 HWORDR: MACRO5(VRELBYTE,550B%HRRZ\,LREGC,INDEXR,DPLMT)
67800 END %CASE\;
67900 IF (FINSTR#200B%MOVE\) AND (PACKFG#NOTPACK)
68000 THEN
68100 MACRO3(FINSTR,FAC,LREGC)
68200 ELSE FAC := LREGC
68300 END;
68400 EXPR:
68500 IF FINSTR#200B%MOVE\
68600 THEN
68700 IF TYPTR^.SIZE = 2
68800 THEN
68900 BEGIN
69000 MACRO3(FINSTR,FAC,REG); MACRO3(FINSTR,FAC-1,REG-1)
69100 END
69200 ELSE MACRO3(FINSTR,FAC,REG)
69300 END %CASE\;
69400 KIND := EXPR; REG := FAC;
69500 END;
69600 END;
69700
69800 PROCEDURE LOAD(VAR FATTR: ATTR);
69900 BEGIN
70000 WITH FATTR DO
70100 IF TYPTR#NIL
70200 THEN
70300 IF KIND#EXPR
70400 THEN
70500 BEGIN
70600 INCREMENTREGC ;
70700 IF (TYPTR^.SIZE = 2) AND LOADNOPTR
70800 THEN INCREMENTREGC ;
70900 MAKECODE(200B%MOVE\,REGC,FATTR);REGC := REG
71000 END;
71100 END;
71200 %LOAD\
71300
71400 (* 104 - common procedure for improved range check on subranges *)
71500 procedure loadsubrange(var gattr:attr;lsp:stp);
71600 var slattr:attr; srmin,srmax:integer;
71700 begin
71800 GETBOUNDS(LSP,SRMIN,SRMAX);
71900 IF (GATTR.KIND=CST)
72000 THEN
72100 IF (GATTR.CVAL.IVAL >= SRMIN) AND (GATTR.CVAL.IVAL <=SRMAX)
72200 THEN LOAD (GATTR)
72300 ELSE ERROR (367)
72400 ELSE
72500 BEGIN
72600 IF RUNTMCHECK AND (( GATTR.KIND#VARBL) OR (GATTR.SUBKIND # LSP))
72700 THEN
72800 BEGIN
72900 LOAD (GATTR);
73000 WITH SLATTR DO
73100 BEGIN
73200 TYPTR:=INTPTR;
73300 KIND :=CST;
73400 CVAL.IVAL:=SRMAX
73500 END;
73600 MAKECODE(317B%CAMG\,REGC,SLATTR);
73700 SLATTR.KIND:=CST;
73800 SLATTR.CVAL.IVAL:=SRMIN;
73900 MAKECODE(315B%CAMGE\,REGC,SLATTR);
74000 SUPPORT(ERRORINASSIGNMENT)
74100 END
74200 ELSE LOAD (GATTR);
74300 END
74400 end;
74500
74600 PROCEDURE STORE(FAC: ACRANGE; VAR FATTR: ATTR);
74700 VAR
74800 LATTR: ATTR;
74900 BEGIN
75000 LATTR := FATTR;
75100 WITH LATTR DO
75200 IF TYPTR # NIL
75300 THEN
75400 BEGIN
75500 FETCHBASIS(LATTR);
75600 CASE PACKFG OF
75700 NOTPACK:
75800 BEGIN
75900 IF TYPTR^.SIZE = 2
76000 THEN
76100 BEGIN
76200 MACRO5(VRELBYTE,202B%MOVEM\,FAC,INDEXR,DPLMT+1); FAC := FAC-1
76300 END;
76400 MACRO(VRELBYTE,202B%MOVEM\,FAC,INDBIT,INDEXR,DPLMT)
76500 END;
76600 PACKK:
76700 BEGIN
76800 MACRO5(VRELBYTE,201B%MOVEI\,TAC,INDEXR,DPLMT);
76900 MACRO3R(137B%DPB\,FAC,BPADDR);
77000 END;
77100 HWORDL: MACRO5(VRELBYTE,506B%HRLM\,FAC,INDEXR,DPLMT);
77200 HWORDR: MACRO5(VRELBYTE,542B%HRRM\,FAC,INDEXR,DPLMT)
77300 END %CASE\ ;
77400 END %WITH\ ;
77500 END %STORE\ ;
77600
77700 {Warning to future modifiers: At the end of EXPRESSION, there is code that
77800 second-guesses the register allocation in this procedure. If you change
77900 the register allocation here, please look at that code.}
78000 PROCEDURE LOADADDRESS;
78100 BEGIN
78200 INCREMENTREGC ;
78300 BEGIN
78400 WITH GATTR DO
78500 IF TYPTR # NIL
78600 THEN
78700 BEGIN
78800 CASE KIND OF
78900 CST:
79000 IF STRING(TYPTR)
00100 THEN
00200 BEGIN
00300 MACRO3(201B%MOVEI\,REGC,0);
00400 DEPCST(STRG,GATTR)
00500 END
00600 ELSE ERROR(171);
00700 VARBL:
00800 BEGIN
00900 IF (INDEXR>REGIN) AND (INDEXR <= REGCMAX)
01000 THEN REGC := INDEXR;
01100 FETCHBASIS(GATTR);
01200 CASE PACKFG OF
01300 NOTPACK: MACRO(VRELBYTE,201B%MOVEI\,REGC,INDBIT,INDEXR,DPLMT);
01400 PACKK,HWORDL,HWORDR: ERROR(357)
01500 END;
01600 END;
01700 EXPR: ERROR(171)
01800 END;
01900 KIND := VARBL; DPLMT := 0; INDEXR:=REGC; INDBIT:=0; VRELBYTE := NO
02000 END
02100 END
02200 END %LOADADDRESS\ ;
02300
02400 PROCEDURE WRITEMC(WRITEFLAG:WRITEFORM);
02500 CONST
02600 (* 155 *)
02700 MAXSIZE %OF CONSTANT-, STRUCTURE-, AND ID.-RECORD\ = 44 %WORDS\ ;
02800 TYPE
02900 WANDELFORM=(KONSTANTE,PDP10CODE,REALCST,STRCST,SIXBITCST,HALFWD,PDP10BP,RADIX) ;
03000 RECORDFORM=(NONE,CONSTNTREC,STRUCTUREREC,IDENTIFREC,DEBUGREC);
03100 BIGALFA = PACKED ARRAY[1..15] OF CHAR ;
03200 VAR
03300 I,J,L : INTEGER; LLISTCODE: BOOLEAN; CHECKER: CTP;
03400 LIC : ADDRRANGE; LFIRSTKONST: KSP; LRELBYTE: RELBYTE;
03500 STRING: ARRAY[1..6] OF CHAR; LFILEPTR: FTP; SWITCHFLAG: FLAGRANGE;
03600 FILBLOCKADR : ADDRRANGE ; CODEARRAY: BOOLEAN; LICMOD4: ADDRRANGE;
03700 LSIZE: 1..MAXSIZE; RUN1: BOOLEAN; SAVELISTCODE: BOOLEAN;
03800 CSP0: CSP; %INSTEAD OF NIL\
03900 RELARRAY, RELEMPTY: ARRAY[1..MAXSIZE] OF RELBYTE;
04000 WANDLUNG : PACKED RECORD
04100 CASE WANDELFORM OF
04200 KONSTANTE:(WKONST :INTEGER);
04300 PDP10CODE:(WINSTR :PDP10INSTR);
04400 REALCST :(WREAL: REAL);
04500 STRCST :(WSTRING:CHARWORD);
04600 SIXBITCST:(WSIXBIT:PACKED ARRAY[1..6] OF 0..77B);
04700 HALFWD :(WLEFTHALF:ADDRRANGE ; WRIGHTHALF : ADDRRANGE);
04800 PDP10BP :(WBYTE: BPOINTER);
04900 RADIX :(FLAG: FLAGRANGE; SYMBOL: RADIXRANGE)
05000
05100 END;
05200 ICWANDEL: PACKED RECORD
05300 CASE VARIANTE:INTEGER OF
05400 1:(ICVAL: ADDRRANGE);
05500 2:(ICCSP: CSP);
05600 3:(ICCTP: CTP);
05700 4:(ICSTP: STP)
05800 END;
05900 RECORDWANDEL: PACKED RECORD
06000 CASE RECORDFORM OF
06100 NONE: (WORD:ARRAY[1..MAXSIZE] OF INTEGER);
06200 CONSTNTREC:(CONSTREC: CONSTNT);
06300 STRUCTUREREC:(STRUCTREC: STRUCTURE);
06400 IDENTIFREC:(IDENTREC: IDENTIFIER);
06500 DEBUGREC:(DEBUGREC: DEBENTRY)
06600 END;
06700
06800 PROCEDURE NEUEZEILE;
06900 BEGIN
07000 (* 6 - if CREFing, less stuff fits on a line *)
07100 IF CREF
07200 THEN LICMOD4 := LIC MOD 3
07300 ELSE LICMOD4 := LIC MOD 4;
07400 IF (LICMOD4 = 0) AND LISTCODE AND (LIC > 0)
07500 THEN
07600 BEGIN
07700 (* 136 - LISTING FORMAT *)
07800 newline ;
07900 IF RELBLOCK.ITEM = 1
08000 THEN
08100 BEGIN
08200 WRITE(LIC:6:O);
08300 IF LIC >= PROGRST
08400 THEN WRITE('''')
08500 ELSE WRITE(' ')
08600 END
08700 ELSE WRITE(' ':7)
08800 END
08900 END %NEUEZEILE\ ;
09000
09100 PROCEDURE PUTRELCODE;
09200 VAR
09300 I: INTEGER;
09400
09500 BEGIN
09600 WITH RELBLOCK DO
09700 (* 146 - Move count := 0 outside the test, since we must zero count in
09800 the case where COUNT = 1 and ITEM = 1. *)
09900 BEGIN
10000 IF ((COUNT > 1) OR (ITEM # 1)) AND (COUNT > 0)
10100 THEN
10200 BEGIN
10300 FOR I:= COUNT+1 TO 18 DO RELOCATOR[I-1] := NO;
10400 FOR I:= 1 TO COUNT+2 DO
10500 BEGIN
10600 OUTPUTREL^:= COMPONENT[I];
10700 PUT(OUTPUTREL)
10800 END;
10900 END;
11000 (* 146 *)
11100 COUNT := 0;
11200 END;
11300 END;
11400
11500 PROCEDURE SHOWRELOCATION(FSIDE: RELBYTE; FRELBYTE: RELBYTE);
11600 BEGIN
11700 IF (FRELBYTE = FSIDE) OR (FRELBYTE = BOTH)
11800 THEN WRITE('''')
11900 ELSE WRITE(' ')
12000 END;
12100
12200 PROCEDURE WRITEBLOCKST( FITEM: ADDRRANGE);
12300 VAR
12400 WANDLUNG: PACKED RECORD
12500 CASE BOOLEAN OF
12600 TRUE: (WKONST: INTEGER);
12700 FALSE: (WLEFTHALF: ADDRRANGE;WRIGHTHALF: ADDRRANGE)
12800 END;
12900 BEGIN
13000 WITH RELBLOCK , WANDLUNG DO
13100 BEGIN
13200 IF COUNT # 0
13300 THEN PUTRELCODE;
13400 ITEM:= FITEM;
13500 IF ITEM = 1
13600 THEN
13700 BEGIN
13800 WLEFTHALF:= 0;
13900 WRIGHTHALF:= LIC;
14000 CODE[0]:= WKONST;
14100 IF WRIGHTHALF < PROGRST
14200 THEN RELOCATOR[0] := NO
14300 ELSE RELOCATOR[0] := RIGHT;
14400 COUNT:= 1
14500 END
14600 END
14700 END;
14800
14900 PROCEDURE WRITEWORD(FRELBYTE: RELBYTE; FWORD: INTEGER);
15000 VAR
15100 WANDLUNG: PACKED RECORD
15200 CASE BOOLEAN OF
15300 TRUE: (WKONST: INTEGER);
15400 FALSE: (WLEFTHALF: ADDRRANGE; WRIGHTHALF: ADDRRANGE)
15500 END;
15600 BEGIN
15700 WITH WANDLUNG DO
15800 BEGIN
15900 WKONST := FWORD;
16000 WITH RELBLOCK DO
16100 BEGIN
16200 IF COUNT = 0
16300 THEN WRITEBLOCKST(ITEM);
16400 CODE[COUNT]:= FWORD;
16500 IF FRELBYTE IN [LEFT,BOTH]
16600 THEN
16700 IF (WLEFTHALF < PROGRST) OR (WLEFTHALF = 377777B)
16800 THEN FRELBYTE := FRELBYTE - LEFT;
16900 IF FRELBYTE IN [RIGHT,BOTH]
17000 THEN
17100 IF (WRIGHTHALF < PROGRST) OR (WRIGHTHALF = 377777B)
17200 THEN FRELBYTE := FRELBYTE - RIGHT;
17300 RELOCATOR[COUNT]:= FRELBYTE; LRELBYTE := FRELBYTE;
17400 COUNT := COUNT+1;
17500 IF COUNT = 18
17600 THEN PUTRELCODE
17700 END;
17800 IF LLISTCODE
17900 THEN
18000 BEGIN
18100 NEUEZEILE;
18200 IF LIC > 0
18300 THEN WRITE(' ':13);
18400 (* 173 - remove writefileblocks *)
18500 IF WRITEFLAG > WRITELIBRARY
18600 THEN WRITE(' ':7)
18700 ELSE
18800 BEGIN
18900 WRITE(WLEFTHALF:6:O); SHOWRELOCATION(LEFT,FRELBYTE)
19000 END;
19100 WRITE(WRIGHTHALF:6:O); SHOWRELOCATION(RIGHT,FRELBYTE); WRITE(' ':3)
19200 END;
19300 IF NOT CODEARRAY
19400 THEN LIC := LIC + 1
19500 END
19600 END;
19700
19800 FUNCTION RADIX50( FNAME: ALFA): RADIXRANGE;
19900 VAR
20000 I: INTEGER; OCTALCODE, RADIXVALUE: RADIXRANGE;
20100
20200 BEGIN
20300 RADIXVALUE:= 0;
20400 I:=1;
20500 WHILE (FNAME[I] # ' ') AND (I <= 6) DO
20600 BEGIN
20700 IF FNAME[I] IN DIGITS
20800 THEN OCTALCODE:= ORD(FNAME[I])-ORD('0')+1
20900 ELSE
21000 IF FNAME[I] IN LETTERS
21100 THEN OCTALCODE:= ORD(FNAME[I])-ORD('A')+11
21200 ELSE
21300 CASE FNAME[I] OF
21400 '.': OCTALCODE:= 37;
21500 '$': OCTALCODE:= 38;
21600 '%': OCTALCODE:= 39
21700 END;
21800 RADIXVALUE:= RADIXVALUE*50B; RADIXVALUE:= RADIXVALUE+OCTALCODE; I:=I+1
21900 END;
22000 RADIX50:= RADIXVALUE
22100 END;
22200
22300 PROCEDURE WRITEPAIR( FRELBYTE: RELBYTE; FADDR1, FADDR2: ADDRRANGE);
22400 BEGIN
22500 WITH WANDLUNG DO
22600 BEGIN
22700 WLEFTHALF:= FADDR1;
22800 WRIGHTHALF:= FADDR2;
22900 WRITEWORD(FRELBYTE,WKONST)
23000 END
23100 END;
23200
23300 PROCEDURE WRITEIDENTIFIER( FFLAG: FLAGRANGE; FSYMBOL: ALFA);
23400 BEGIN
23500 LLISTCODE := FALSE;
23600 WITH WANDLUNG DO
23700 BEGIN
23800 IF LISTCODE AND (WRITEFLAG > WRITEHISEG)
23900 THEN
24000 BEGIN
24100 (* 40 - if CREFing, less stuff fits on a line *)
24200 IF ((NOT CREF) AND (LIC MOD 4 = 0) OR
24300 CREF AND (LIC MOD 3 = 0)) AND (LIC > 0)
24400 THEN
24500 BEGIN
24600 (* 136 - LISTING FORMAT *)
24700 NEWLINE;
24800 WRITE(' ':7)
24900 END;
25000 IF LIC > 0
25100 THEN WRITE(' ':13); WRITE(FSYMBOL:6,' ':11)
25200 END;
25300 (* 40 - print format *)
25400 if listcode and cref then lic := lic+1;
25500 IF FFLAG # 6B
25600 THEN
25700 BEGIN
25800 FLAG:= FFLAG; SYMBOL:= RADIX50(FSYMBOL)
25900 END;
26000 WRITEWORD(NO,WKONST); LLISTCODE := LISTCODE
26100 END
26200 END;
26300
26400 PROCEDURE WRITEFIRSTLINE ;
26500 BEGIN
26600 IF LISTCODE
26700 THEN
26800 BEGIN
26900 (* 136 - LISTING FORMAT *)
27000 NEWLINE;
27100 (* 6 - if CREFing, less stuff fits on a line *)
27200 IF CREF
27300 THEN LICMOD4 := LIC MOD 3
27400 ELSE LICMOD4 := LIC MOD 4;
27500 IF LICMOD4 > 0
27600 THEN
27700 BEGIN
27800 WRITE(LIC-LICMOD4:6:O);
27900 IF LIC >= PROGRST
28000 THEN WRITE('''')
28100 ELSE WRITE(' ');
28200 WRITE(' ':LICMOD4*30);
28300 IF (WRITEFLAG = WRITECODE) AND CODEARRAY
28400 THEN WRITE(' ':2)
28500 END
28600 END
28700 END ;
28800
28900 PROCEDURE WRITEHEADER(FTEXT: BIGALFA);
29000 BEGIN
29100 LIC := 0;
29200 IF LISTCODE
29300 THEN
29400 BEGIN
29500 (* 136 - LISTING FORMAT *)
29600 NEWLINE;
29700 WRITE(FTEXT:15,':',' ':4)
29800 END
29900 END;
30000
30100 (*173 - remove writefileblocks *)
30200
30300 PROCEDURE MCGLOBALS;
30400 BEGIN
30500 %MCGLOBALS\
30600 IF LISTCODE AND (FGLOBPTR # NIL)
30700 THEN WRITEBUFFER;
30800 WHILE FGLOBPTR # NIL DO
30900 WITH FGLOBPTR^ DO
31000 BEGIN
31100 LIC := FIRSTGLOB ; WRITEFIRSTLINE ;
31200 J := FCIX ;
31300 WRITEBLOCKST(1);
31400 FOR I := FIRSTGLOB TO LASTGLOB DO
31500 BEGIN
31600 WANDLUNG.WINSTR := CODE.INSTRUCTION[J] ; J := J + 1 ;
31700 WRITEWORD(NO,WANDLUNG.WKONST) ;
31800 END ;
31900 FGLOBPTR := NEXTGLOBPTR
32000 END;
32100 END %MCGLOBALS\;
32200
32300 PROCEDURE MCCODE;
32400
32500 PROCEDURE WRITERECORD;
32600 BEGIN
32700 FOR I := 1 TO LSIZE DO WRITEWORD(RELARRAY[I], RECORDWANDEL.WORD[I] )
32800 END;
32900
33000 (* 211 - MAKE CONSTANTS WORK IN THE DEBUGGER *)
33100 FUNCTION CONSTRECSIZE(FCSP: CSP): INTEGER;
33200 BEGIN
33300 WITH FCSP^ DO
33400 CASE CCLASS OF
33500 INT,PSET: CONSTRECSIZE := 5;
33600 REEL : CONSTRECSIZE := 4;
33700 STRD,STRG:CONSTRECSIZE := 4 + (SLGTH+4) DIV 5
33800 END
33900 END;
34000
34100 PROCEDURE COPYCSP(FCSP:CSP);
34200 BEGIN
34300 IF FCSP # NIL
34400 THEN WITH FCSP^ DO
34500 IF RUN1
34600 THEN
34700 BEGIN
34800 IF SELFCSP = CSP0%NIL\
34900 THEN WITH ICWANDEL DO
35000 BEGIN
35100 ICVAL := IC; SELFCSP := ICCSP;
35200 NOCODE := TRUE;
35300 IC := IC + CONSTRECSIZE(FCSP)
35400 END
35500 END
35600 ELSE
35700 IF NOCODE
35800 THEN
35900 BEGIN
36000 RECORDWANDEL.CONSTREC := FCSP^;
36100 LSIZE := CONSTRECSIZE(FCSP);
36200 RELARRAY := RELEMPTY;
36300 WRITERECORD; NOCODE := FALSE
36400 END
36500 END %COPYCSP\;
36600
36700 PROCEDURE COPYSTP(FSP:STP); FORWARD;
36800
36900 PROCEDURE COPYCTP(FCP:CTP);
37000 BEGIN
37100 IF FCP # NIL
37200 THEN WITH FCP^ DO
37300 IF RUN1 AND (SELFCTP=NIL) OR NOT RUN1 AND NOCODE
37400 THEN
37500 BEGIN
37600 IF RUN1
37700 THEN
37800 WITH ICWANDEL DO
37900 BEGIN
38000 ICVAL := IC;
38100 SELFCTP := ICCTP; NOCODE := TRUE;
38200 IC := IC + IDRECSIZE[KLASS]
38300 END %WITH\
38400 ELSE %NOW RUN 2\
38500 WITH RECORDWANDEL DO
38600 BEGIN
38700 RELARRAY := RELEMPTY;
38800 IDENTREC := FCP^;
38900 WITH IDENTREC DO
39000 BEGIN
39100 IF LLINK#NIL
39200 THEN
39300 BEGIN
39400 LLINK:=LLINK^.SELFCTP; RELARRAY[3] := 1
39500 END;
39600 IF RLINK#NIL
39700 THEN
39800 BEGIN
39900 RLINK:=RLINK^.SELFCTP; RELARRAY[3] := RELARRAY[3] + 2
40000 END;
40100 IF NEXT #NIL
40200 THEN
40300 BEGIN
40400 NEXT := NEXT^.SELFCTP; RELARRAY[4] := 1B
40500 END;
40600 IF IDTYPE # NIL
40700 THEN
40800 BEGIN
40900 IF KLASS = KONST
41000 THEN
41100 IF IDTYPE^.FORM > POINTER
41200 THEN
41300 (* 211 - FIX CONSTANT PRINTING *)
41400 BEGIN
41500 VALUES.VALP := VALUES.VALP^.SELFCSP;
41600 RELARRAY[6] := 1B
41700 END
41800 ELSE
41900 IF IDTYPE = REALPTR
42000 THEN
42100 BEGIN
42200 WANDLUNG.WREAL := VALUES.VALP^.RVAL;
42300 VALUES.IVAL := WANDLUNG.WKONST
42400 END;
42500 IF KLASS=VARS
42600 THEN
42700 IF VLEV<2
42800 THEN RELARRAY[6] := 2;
42900 IF KLASS = FIELD
43000 THEN
43100 IF PACKF = PACKK
43200 THEN RELARRAY[6] := 2;
43300 IDTYPE:=IDTYPE^.SELFSTP; RELARRAY[4] := RELARRAY[4] + 2
43400 END
43500 END;
43600 LSIZE := IDRECSIZE[KLASS]; WRITERECORD;
43700 NOCODE := FALSE
43800 END %WITH RECORDWANDEL\;
43900 COPYCTP(LLINK);
44000 COPYCTP(RLINK);
44100 COPYSTP(IDTYPE);
44200 (* 214 - fix debugger problem with foward declared proc's *)
44300 {The following is somewhat of a kludge. We don't want to do COPYCTP
44400 on the NEXT field of a procedure. If we did, the following could
44500 happen:
44600 procedure foo(x:integer); forward;
44700 ...
44800 foo(1);
44900 ...
45000 procedure foo;
45100 var i,j;
45200 When the final declaration of FOO is supplied, the symbol table is
45300 initialized from symboltable(FOO)^.NEXT, which contains the parameters,
45400 as supplied in the forward decl. Then I and J are added to the symbol
45500 table. The result is that X points to I and J in the symbol table
45600 tree. This is all fine. The problem comes when the identifier
45700 record for FOO is put into the .REL file before the final declaration.
45800 If COPYCTP traces the NEXT field, then the identifier records for all
45900 the parameters are also put out. Since a given identifier is put out
46000 only once, this means that X is put into the .REL file before pointers
46100 to I and J are added to it. The effect is that the debugger can't
46200 see I and J.
46300 It turns out that the debugger never uses the NEXT field of a
46400 procedure entry. Thus it is not crucial to have a correctly mapped
46500 value when the identifier record for the procedure is put out.
46600 If we don't call COPYCTP on NEXT, then the NEXT field put into the
46700 .REL file will be junk, but at least records for the parameters won't
46800 be put out prematurely. They will get put out eventually even without
46900 tracing NEXT, since they will show up in the symbol table for the
47000 procedure when it is finally declared. That should suffice.}
47100
47200 IF NOT (KLASS IN [PROC,FUNC])
47300 THEN COPYCTP(NEXT);
47400 IF (KLASS = KONST) AND (IDTYPE # NIL)
47500 THEN
47600 IF IDTYPE^.FORM > POINTER
47700 THEN COPYCSP(VALUES.VALP)
47800 END %WITH FCP^\
47900 END %COPYCTP\;
48000
48100 PROCEDURE COPYSTP;
48200 BEGIN
48300 IF FSP # NIL
48400 THEN WITH FSP^ DO
48500 IF RUN1 AND (SELFSTP = NIL) OR NOT RUN1 AND NOCODE
48600 THEN
48700 BEGIN
48800 IF RUN1
48900 THEN
49000 WITH ICWANDEL DO
49100 BEGIN
49200 NOCODE:=TRUE;
49300 ICVAL := IC; SELFSTP := ICSTP;
49400 IC := IC + STRECSIZE[FORM]
49500 END
49600 ELSE %NOW RUN 2\
49700 IF NOCODE
49800 THEN WITH RECORDWANDEL DO
49900 BEGIN
50000 RELARRAY := RELEMPTY; RELARRAY[2] := 1;
50100 STRUCTREC := FSP^;
50200 WITH STRUCTREC DO
50300 CASE FORM OF
50400 SCALAR:
50500 IF SCALKIND = DECLARED
50600 THEN
50700 IF FCONST#NIL
50800 THEN FCONST:=FCONST^.SELFCTP;
50900 SUBRANGE:
51000 BEGIN
00100 RANGETYPE:=RANGETYPE^.SELFSTP; RELARRAY[2]:=1
00200 END;
00300 POINTER:
00400 IF ELTYPE # NIL
00500 THEN ELTYPE := ELTYPE^.SELFSTP;
00600 POWER: ELSET := ELSET^.SELFSTP;
00700 ARRAYS:
00800 BEGIN
00900 (* 122 - DON'T FOLLOW NILS ON FUDGED TYPES *)
01000 IF AELTYPE#NIL
01100 THEN AELTYPE := AELTYPE^.SELFSTP;
01200 IF INXTYPE#NIL
01300 THEN INXTYPE := INXTYPE^.SELFSTP;
01400 RELARRAY[3] := 3
01500 END;
01600 RECORDS:
01700 BEGIN
01800 IF FSTFLD # NIL
01900 THEN FSTFLD := FSTFLD^.SELFCTP;
02000 IF RECVAR # NIL
02100 THEN
02200 BEGIN
02300 RECVAR := RECVAR^.SELFSTP; RELARRAY[3] := 2
02400 END
02500 END;
02600 FILES: IF FILTYPE # NIL
02700 THEN FILTYPE := FILTYPE^.SELFSTP;
02800 TAGFWITHID,
02900 TAGFWITHOUTID:
03000 BEGIN
03100 FSTVAR := FSTVAR^.SELFSTP;
03200 IF FORM = TAGFWITHID
03300 THEN TAGFIELDP := TAGFIELDP^.SELFCTP
03400 ELSE TAGFIELDTYPE := TAGFIELDTYPE^.SELFSTP;
03500 RELARRAY[3] := 2
03600 END;
03700 VARIANT:
03800 BEGIN
03900 IF SUBVAR # NIL
04000 THEN SUBVAR := SUBVAR^.SELFSTP;
04100 IF FIRSTFIELD # NIL
04200 THEN
04300 BEGIN
04400 FIRSTFIELD := FIRSTFIELD^.SELFCTP; RELARRAY[3]:=1
04500 END;
04600 IF NXTVAR # NIL
04700 THEN
04800 BEGIN
04900 NXTVAR := NXTVAR^.SELFSTP; RELARRAY[3] :=RELARRAY[3] + 2
05000 END;
05100 END
05200 END %CASE\;
05300 LSIZE := STRECSIZE[FORM]; WRITERECORD;
05400 NOCODE := FALSE
05500 END %RUN 2\;
05600 CASE FORM OF
05700 SCALAR:
05800 IF SCALKIND = DECLARED
05900 THEN COPYCTP(FCONST);
06000 SUBRANGE:COPYSTP(RANGETYPE);
06100 POINTER: COPYSTP(ELTYPE);
06200 POWER: COPYSTP(ELSET);
06300 ARRAYS:
06400 BEGIN
06500 COPYSTP(AELTYPE);
06600 COPYSTP(INXTYPE)
06700 END;
06800 RECORDS:
06900 BEGIN
07000 COPYCTP(FSTFLD);
07100 COPYSTP(RECVAR)
07200 END;
07300 FILES: COPYSTP(FILTYPE);
07400 TAGFWITHID,
07500 TAGFWITHOUTID:
07600 BEGIN
07700 COPYSTP(FSTVAR);
07800 IF FORM = TAGFWITHID
07900 THEN COPYCTP(TAGFIELDP)
08000 ELSE COPYSTP(TAGFIELDTYPE)
08100 END;
08200 VARIANT:
08300 BEGIN
08400 COPYSTP(NXTVAR);
08500 COPYSTP(SUBVAR);
08600 COPYCTP(FIRSTFIELD)
08700 END
08800 END %CASE\
08900 END %WITH\
09000 END %COPYSTP\;
09100
09200 BEGIN
09300 %MCCODE\
09400 CODEARRAY := FALSE; LLISTCODE:= FALSE;
09500 IF LISTCODE
09600 THEN WRITEBUFFER;
09700 IF LASTBTP # NIL
09800 THEN
09900 WITH LASTBTP^ DO
10000 CASE BKIND OF
10100 RECORDD: LIC := FIELDCP^.FLDADDR ;
10200 ARRAYY : LIC := ARRAYSP^.ARRAYBPADDR
10300 END ;
10400 WRITEFIRSTLINE ; WRITEBLOCKST(1);
10500 WHILE LASTBTP # NIL DO
10600 BEGIN
10700 WITH LASTBTP^,BYTE DO
10800 BEGIN
10900 IF LISTCODE
11000 THEN
11100 BEGIN
11200 NEUEZEILE;
11300 IF LICMOD4 = 0
11400 THEN WRITE(' ':7)
11500 ELSE WRITE(' ':5);
11600 WRITE(' POINT ',SBITS:2,',') ;
11700 IF IBIT = 0
11800 THEN WRITE(' ')
11900 ELSE WRITE(' @') ;
12000 WRITE(RELADDR:5:O,'(',IREG:2:O,'),',35-PBITS:2) ;
12100 END;
12200 WITH WANDLUNG DO
12300 BEGIN
12400 WBYTE := BYTE;
12500 WRITEWORD(NO,WKONST)
12600 END;
12700 LASTBTP := LAST
12800 END
12900 END % WHILE\ ;
13000 LIC := CODEEND - CIX - 1 ; CODEARRAY := TRUE;
13100 WRITEBLOCKST(1); WRITEFIRSTLINE;
13200 FOR I := 0 TO CIX DO
13300 WITH CODE, INSTRUCTION[I], HALFWORD[I] DO
13400 BEGIN
13500 LRELBYTE := RELOCATION[I]; WRITEWORD(LRELBYTE,WORD[I]);
13600 IF LISTCODE
13700 THEN
13800 BEGIN
13900 NEUEZEILE;
14000 IF LICMOD4 = 0
14100 THEN WRITE(' ':7)
14200 ELSE WRITE(' ':5);
14300 CASE INFORMATION[I] OF
14400 'W':
14500 BEGIN
14600 WRITE(' ':6,LEFTHALF :6:O); SHOWRELOCATION(LEFT,LRELBYTE);
14700 WRITE(RIGHTHALF:6:O); SHOWRELOCATION(RIGHT,LRELBYTE);
14800 WRITE(' ':5)
14900 END;
15000 %'B': WITH WANDLUNG.WBYTE DO
15100 BEGIN
15200 WANDLUNG.WKONST := WORD[I];
15300 WRITE(' POINT ',SBITS:2,',');
15400 IF IBIT = 0 THEN WRITE(' ') ELSE WRITE(' @');
15500 WRITE(RELADDR:5:O,'(',IREG:2:O,'),',35-PBITS:2)
15600 END;\
15700 OTHERS:
15800 BEGIN
15900 (* 6 - UNPACK CAN'T DO THIS NOW *)
16000 %UNPACK(MNEMONICS[(INSTR+9) DIV 10],((INSTR+9) MOD 10)*6+1,STRING,6);\
16100 FOR J := 1 TO 6 DO
16200 STRING[J] := MNEMONICS[(INSTR+9) DIV 10, ((INSTR+9) MOD 10)*6 + J];
16300 WRITE(' ',STRING:6, ' ',AC:2:O,', ');
16400 IF INDBIT = 0
16500 THEN WRITE(' ')
16600 ELSE WRITE('@');
16700 WRITE(ADDRESS:6:O); SHOWRELOCATION(RIGHT,LRELBYTE);
16800 IF INXREG > 0
16900 THEN WRITE('(',INXREG:2:O,')',INFORMATION[I]:1)
17000 ELSE WRITE(' ':4,INFORMATION[I]:1)
17100 END
17200 END
17300 END;
17400 LIC := LIC + 1
17500 END %FOR \ ;
17600 CODEARRAY := FALSE; LLISTCODE := LISTCODE;
17700 IF FIRSTKONST # NIL
17800 THEN
17900 BEGIN
18000 LFIRSTKONST := FIRSTKONST; WRITEFIRSTLINE; WRITEBLOCKST(1);
18100 WHILE LFIRSTKONST # NIL DO
18200 BEGIN
18300 WITH LFIRSTKONST^.CONSTPTR^ DO
18400 CASE CCLASS OF
18500 INT,
18600 REEL: WRITEWORD(NO,INTVAL) ;
18700 PSET:
18800 BEGIN
18900 % THE SET IS PICKED UP
19000 AND WRITTEN OUT AS TWO OCTAL NUMBERS \
19100 WRITEWORD(NO,INTVAL) ;
19200 WRITEWORD(NO,INTVAL1) ;
19300 END ;
19400 STRD,
19500 STRG: WITH WANDLUNG DO
19600 BEGIN
19700 J :=0; WKONST := 0;
19800 FOR I := 1 TO SLGTH DO
19900 BEGIN
20000 J := J+1;
20100 WSTRING[J] := SVAL[I];
20200 IF J=5
20300 THEN
20400 BEGIN
20500 J := 0;
20600 WRITEWORD(NO,WKONST);
20700 WKONST := 0
20800 END
20900 END;
21000 IF J#0
21100 THEN
21200 WRITEWORD(NO,WKONST)
21300 END
21400 END;
21500 LFIRSTKONST := LFIRSTKONST^.NEXTKONST
21600 END %WHILE\
21700 END;
21800 IF DEBUG
21900 THEN
22000 BEGIN
22100 IF DEBUGSWITCH
22200 THEN
22300 BEGIN
22400 (* 103 - globalidtree moved below *)
22500 WRITEFIRSTLINE;
22600 FOR RUN1 := TRUE DOWNTO FALSE DO COPYCTP(DISPLAY[TOP].FNAME);
22700 IF LEVEL = 1
22800 THEN
22900 BEGIN
23000 (* 103 - new way to set globalidtree and standardidtree *)
23100 FOR RUN1 := TRUE DOWNTO FALSE DO COPYCTP(DISPLAY[0].FNAME);
23200 if display[top].fname = nil
23300 then debugentry.globalidtree := nil
23400 else debugentry.globalidtree := display[top].fname^.selfctp;
23500 debugentry.standardidtree := display[0].fname^.selfctp;
23600 END;
23700 END %DEBUGSWITCH\;
23800 IF LEVEL = 1
23900 THEN
24000 BEGIN
24100 WITH DEBUGENTRY DO
24200 BEGIN
24300 NEWPAGER; LASTPAGEELEM := PAGER;
24400 INTPOINT := INTPTR^. SELFSTP;
24500 REALPOINT := REALPTR^.SELFSTP;
24600 CHARPOINT := CHARPTR^.SELFSTP;
24700 (* 36 - ALLOW MULTIPLE MODULES *)
24800 NEXTDEB := 0; %LINK WILL MAKE THIS PTR TO SIMILAR ENTRY IN NEXT MODULE\
24900 MODNAME := FILENAME;
25000 CURNAME(INPUT,SOURCE);
25100 END;
25200 PAGEHEADADR := IC;
25300 LSIZE := 44; %LENGTH OF DEBUGENTRY-RECORD\
25400 RELARRAY[1] := 0;
25500 FOR I:=2 TO 8 DO RELARRAY[I] := 1;
25600 FOR I:= 9 TO LSIZE DO RELARRAY[I] := 0;
25700 RECORDWANDEL.DEBUGREC := DEBUGENTRY;
25800 IC := IC + LSIZE;
25900 WRITERECORD;
26000 HIGHESTCODE := IC;
26100 (* 40 - fix printing format *)
26200 (* 136 - LISTING FORMAT *)
26300 if listcode then NEWLINE;
26400 WRITEHEADER('LINK IN CHAIN 1');
26500 LLISTCODE := FALSE;
26600 WRITEBLOCKST(12B); %LINK BLOCK\
26700 WRITEPAIR(NO,0,1); %LINK NUMBER 1\
26800 LLISTCODE := LISTCODE;
26900 WRITEPAIR(RIGHT,0,PAGEHEADADR); %NEXTDEB FIELD\
27000 (* NB: LOCATION 141/2 ARE NOW HANDLED BY DEBSUP. 143 GETS .LNKEND FOR THE
27100 LINK SET UP ABOVE *)
27200 END;
27300 (* 5 - CREF *)
27400 END;
27500 (* 136 - LISTING FORMAT *)
27600 IF LISTCODE THEN NEWLINE;
27700 END %MCCODE\;
27800
27900 PROCEDURE MCVARIOUS;
28000 VAR
28100 (* 17 - MAKE SYMBOLS ACCEPTABLE TO DEC DDT *)
28200 INLEVEL: BOOLEAN; PNAME:ALFA;
28300 BEGIN
28400 %MCVARIOUS\
28500 CASE WRITEFLAG OF
28600
28700 (* 13 - ADD WRITEBLOCK FOR DDT SYMBOLS *)
28800 (* 16 - MAKE ACCEPTABLE TO DEC DDT *)
28900 WRITEBLK:
29000 BEGIN
29100 PNAME := DISPLAY[TOP].BLKNAME;
29200 (* 40 - fix print format *)
29300 WRITEHEADER('LOCAL SYMBOLS ');
29400 WRITEBLOCKST(2);
29500 WRITEIDENTIFIER(2B,PNAME);
29600 WRITEPAIR(RIGHT,0,PFSTART);
29700 I:=5;
29800 WHILE PNAME[I]=' ' DO I:=I-1;
29900 IF PFDISP#PFSTART
30000 THEN BEGIN
30100 PNAME[I+1]:='.';
30200 WRITEIDENTIFIER(2B,PNAME);
30300 WRITEPAIR(RIGHT,0,PFDISP)
30400 END;
30500 IF PFPOINT#PFDISP
30600 THEN BEGIN
30700 PNAME[I+1]:='%';
30800 WRITEIDENTIFIER(2B,PNAME);
30900 WRITEPAIR(RIGHT,0,PFPOINT)
31000 END
31100 END;
31200 (* 164 - add Polish fixups *)
31300 WRITEPOLISH:
31400 BEGIN
31500 WRITEHEADER('POLISH FIXUPS ');
31600 WHILE FIRSTPOL <> NIL DO
31700 WITH FIRSTPOL^ DO
31800 BEGIN
31900 {A Polish fixup block looks like this:
32000 type 11
32100 operator,,0 0 means next half word is operand
32200 operand1,,0
32300 operand2,,-1 -1 means put in RH of result addr
32400 place to put result,,0
32500 }
32600 WRITEBLOCKST(11B);
32700 IF OFFSET < 0
32800 THEN WRITEPAIR(NO,4,0) {4 - SUB}
32900 ELSE WRITEPAIR(NO,3,0); {3 - ADD}
33000 WRITEPAIR(LEFT,BASE,0);
33100 WRITEPAIR(NO,ABS(OFFSET),777777B);
33200 WRITEPAIR(LEFT,WHERE,0);
33300 PUTRELCODE;
33400 FIRSTPOL := NEXTPOL; {CDR down list}
33500 END;
33600 if cref and listcode then NEWLINE;
33700 END;
33800
33900 WRITEINTERNALS:
34000 BEGIN
34100 WRITEHEADER('LOCAL REQUESTS '); INLEVEL := TRUE;
34200 WRITEBLOCKST(8); CHECKER := LOCALPFPTR;
34300 WHILE (CHECKER # NIL) AND INLEVEL DO
34400 WITH CHECKER^ DO
34500 IF PFLEV = LEVEL
34600 THEN
34700 BEGIN
34800 IF PFADDR # 0
34900 THEN
35000 FOR I := 0 TO MAXLEVEL DO
35100 IF LINKCHAIN[I] # 0
35200 THEN WRITEPAIR(BOTH,LINKCHAIN[I],PFADDR-I);
35300 CHECKER:= PFCHAIN
35400 END
35500 ELSE INLEVEL := FALSE;
35600 IF LEVEL > 1
35700 THEN LOCALPFPTR := CHECKER;
35800 WHILE FIRSTKONST # NIL DO
35900 WITH FIRSTKONST^, CONSTPTR^ DO
36000 BEGIN
36100 WRITEPAIR(BOTH,ADDR,KADDR);
36200 (* 72 - two fixup chains for 2 word consts *)
36300 IF (CCLASS IN [PSET,STRD]) AND (ADDR1 <> 0)
36400 THEN WRITEPAIR(BOTH,ADDR1,KADDR+1);
36500 FIRSTKONST:= NEXTKONST
36600 END;
36700 (* 64 - non-local gotos *)
36800 inlevel := true;
36900 while (lastlabel # nil) and inlevel do
37000 with lastlabel^ do
37100 if scope = level
37200 then begin
37300 if gotochain # 0
37400 then if labeladdress = 0
37500 then errorwithtext(215,name)
37600 else writepair(both,gotochain,labeladdress);
37700 lastlabel := next
37800 end
37900 else inlevel := false;
38000 (* 40 - print format *)
38100 (* 136 - LISTING FORMAT *)
38200 if cref and listcode then NEWLINE;
38300 END;
38400 WRITEEND:
38500 BEGIN
38600 WRITEHEADER('HIGHSEG-BREAK ');
38700 WRITEBLOCKST(5);
38800 WRITEPAIR(RIGHT,0,HIGHESTCODE);
38900 WRITEHEADER('LOWSEG-BREAK ');
39000 WRITEPAIR(RIGHT,0,LCMAIN); PUTRELCODE
39100 END;
39200
39300 WRITESTART:
39400 IF MAIN
39500 THEN
39600 BEGIN
39700 (* 33 - VERSION NO. *)
39800 WRITEHEADER('VERSION NUMBER ');
39900 LIC := 137B;
40000 (* 40 - fix print format *)
40100 WRITEBLOCKST(1);
40200 if listcode then with version do
40300 write(' ',who:1:o,' ',major:3:o,' ',minor:2:o,' ',edit:6:o);
40400 llistcode := false;
40500 WRITEWORD(NO,VERSION.WORD);
40600 llistcode := listcode;
40700 WRITEHEADER('STARTADDRESS ');
40800 WRITEBLOCKST(7);
40900 WRITEPAIR(RIGHT,0,STARTADDR)
41000 END;
41100
41200 WRITEENTRY:
41300 BEGIN
41400 WRITEBLOCKST(4);
41500 (* 34 - USE LIST OF ENTRIES IN PROGRAM IF APPROPRIATE *)
41600 IF MAIN OR (FPROGFILE = NIL)
41700 THEN WRITEIDENTIFIER(0,FILENAME)
41800 ELSE
41900 BEGIN
42000 NPROGFILE := FPROGFILE;
42100 WHILE NPROGFILE # NIL DO
42200 BEGIN
42300 WRITEIDENTIFIER(0,NPROGFILE^.FILID);
42400 NPROGFILE := NPROGFILE^.NEXT
42500 END
42600 END
42700 END;
42800
42900 WRITENAME:
43000 BEGIN
43100 WRITEBLOCKST(6);
43200 WRITEIDENTIFIER(0,FILENAME)
43300 END;
43400
43500 WRITEHISEG:
43600 BEGIN
43700 LLISTCODE := FALSE;
43800 WRITEBLOCKST(3);
43900 (* 216 - allow high seg to start other than 400000 *)
44000 WRITEPAIR(NO,HIGHSTART,HIGHSTART);
44100 END
44200 END %CASE\
44300 END %MCVARIOUS\ ;
44400
44500 PROCEDURE MCSYMBOLS;
44600 VAR
44700 ENTRYFOUND: BOOLEAN; POLHEADERDONE:Boolean; chan:integer;
44800 BEGIN
44900 %MCSYMBOLS\
45000 WRITEHEADER('ENTRYPOINT(S) ');
45100 WRITEBLOCKST(2);
45200 SAVELISTCODE := LISTCODE;
45300 LISTCODE := FALSE;
45400 FOR SWITCHFLAG := 1B TO 2B DO
45500 BEGIN
45600 IF MAIN
45700 THEN
45800 BEGIN
45900 WRITEIDENTIFIER(SWITCHFLAG,FILENAME);
46000 WRITEPAIR(RIGHT,0,STARTADDR)
46100 END
46200 ELSE
46300 BEGIN
46400 (* 34 - LOOK FOR FTN=FILENAME ONLY IF NOT SPEC. IN PROGRAM STATE. *)
46500 CHECKER := LOCALPFPTR;
46600 IF FPROGFILE=NIL
46700 THEN ENTRYFOUND := FALSE
46800 ELSE ENTRYFOUND := TRUE;
46900 WHILE CHECKER # NIL DO
47000 WITH CHECKER^ DO
47100 BEGIN
47200 IF PFADDR # 0
47300 THEN
47400 BEGIN
47500 IF NOT ENTRYFOUND
47600 (* 34 - USING FILENAME FOR ENTRY NOW *)
47700 THEN ENTRYFOUND := FILENAME = NAME;
47800 WRITEIDENTIFIER(SWITCHFLAG,NAME);
47900 WRITEPAIR(RIGHT,0,PFADDR);
48000 IF PFCHAIN = NIL
48100 THEN
48200 IF NOT ENTRYFOUND
48300 THEN
48400 BEGIN
48500 (* 34 - USING FILENAME FOR ENTRY NOW *)
48600 WRITEIDENTIFIER(SWITCHFLAG,FILENAME);
48700 WRITEPAIR(RIGHT,0,PFADDR)
48800 END
48900 END;
49000 CHECKER:= PFCHAIN
49100 END
49200 END;
49300 LISTCODE := SAVELISTCODE; LIC := 0
49400 END;
49500 IF MAIN
49600 THEN
49700 BEGIN
49800 SWITCHFLAG:= 1B; WRITEHEADER('GLOBAL SYMBOLS ');
49900 (* 16 - ADD CCL SWITCH *)
50000 WRITEIDENTIFIER(SWITCHFLAG,'%CCLSW ');
50100 WRITEPAIR(RIGHT,0,CCLSW);
50200 WRITEIDENTIFIER(SWITCHFLAG,'%RNNAM ');
50300 WRITEPAIR(RIGHT,0,CCLSW+1);
50400 WRITEIDENTIFIER(SWITCHFLAG,'%RNPPN ');
50500 WRITEPAIR(RIGHT,0,CCLSW+2);
50600 WRITEIDENTIFIER(SWITCHFLAG,'%RNDEV ');
50700 WRITEPAIR(RIGHT,0,CCLSW+3);
50800 END
50900 ELSE
51000 BEGIN
51100 SWITCHFLAG:= 14B; WRITEHEADER('GLOBAL REQUESTS')
51200 END;
51300 FILEPTR := SFILEPTR;
51400 WHILE FILEPTR # NIL DO
51500 WITH FILEPTR^, FILEIDENT^ DO
51600 BEGIN
51700 IF VADDR # 0
51800 THEN
51900 BEGIN
52000 WRITEIDENTIFIER(SWITCHFLAG,NAME);
52100 WRITEPAIR(RIGHT,0,VADDR)
52200 END;
52300 FILEPTR:= NEXTFTP
52400 END;
52500 IF MAIN
52600 THEN WRITEHEADER('GLOBAL REQUESTS');
52700 CHECKER:= EXTERNPFPTR;
52800 WHILE CHECKER # NIL DO
52900 WITH CHECKER^ DO
53000 BEGIN
53100 IF LINKCHAIN[0] # 0
53200 THEN
53300 BEGIN
53400 IF PFLEV = 0
53500 THEN WRITEIDENTIFIER(14B,EXTERNALNAME)
53600 ELSE WRITEIDENTIFIER(14B,NAME);
53700 WRITEPAIR(RIGHT,0,LINKCHAIN[0])
53800 END;
53900 CHECKER:= PFCHAIN
54000 END;
54100 (* 12 - ADD EXTERNAL REF TO RUNTIMES FOR DYNAMIC CORE ALLOC *)
54200 IF LSTNEW # 0
54300 THEN BEGIN
54400 WRITEIDENTIFIER(14B,'LSTNEW ');
54500 WRITEPAIR(RIGHT,0,LSTNEW); % GLOBAL FIXUP TO INIT. CODE\
54600 END;
54700 IF NEWBND # 0
54800 THEN BEGIN
54900 WRITEIDENTIFIER(14B,'NEWBND ');
55000 WRITEPAIR(RIGHT,0,NEWBND); % DITTO \
55100 END;
55200 (* 105 - improve lower case mapping in sets *)
55300 if setmapchain # 0
55400 then begin
55500 writeidentifier (14B,'.STCHM ');
55600 writepair (right,0,setmapchain)
55700 end;
55800 FOR SUPPORTIX:= SUCC(FIRSTSUPPORT) TO PRED(LASTSUPPORT) DO
55900 IF RNTS.LINK[SUPPORTIX] # 0
56000 THEN
56100 BEGIN
56200 WRITEIDENTIFIER(14B,RNTS.NAME[SUPPORTIX]);
56300 WRITEPAIR(RIGHT,0,RNTS.LINK[SUPPORTIX])
56400 END;
56500 (* 36 - 141 is now set up elsewhere *)
56600 {In non-main modules, if there are references to TTY^, etc., a
56700 Polish fixup may be needed to resolve them.}
56800 polheaderdone := false;
56900 FILEPTR := SFILEPTR;
57000 IF NOT MAIN THEN WHILE FILEPTR # NIL DO
57100 WITH FILEPTR^, FILEIDENT^ DO
57200 begin
57300 if chantab[channel] <> 0
57400 then begin
57500 if not polheaderdone
57600 then begin
57700 writeheader('SYMBOLIC POLISH');
57800 polheaderdone := true;
57900 end;
58000 {A Polish fixup block looks like this:
58100 type 11
58200 operator,,2 2 means next word is global req - that is operand
58300 operand1
58400 0,,operand2 0 means next half word is operand
58500 -1,,place to put -1 means put in RH of result addr
58600 }
58700 writeblockst(11B);
58800 writepair(no,3,2); {add}
58900 writeidentifier(0,name);
59000 writepair(no,0,filcmp);
59100 writepair(right,777777B,chantab[channel]);
59200 putrelcode;
59300 end;
59400 FILEPTR:= NEXTFTP
59500 END;
59600 if polheaderdone and cref and listcode then NEWLINE;
59700 END %MCSYMBOLS\ ;
59800
59900 PROCEDURE MCLIBRARY;
60000 BEGIN
60100 %MCLIBRARY\
60200 WRITEHEADER('LINK LIBRARIES ');
60300 WRITEBLOCKST(15);
60400 FOR L := 1 TO 2 DO
60500 BEGIN
60600 FOR I := 1 TO LIBIX DO
60700 WITH LIBRARY[LIBORDER[I]] DO
60800 IF CALLED
60900 THEN WITH WANDLUNG DO
61000 BEGIN
61100 FOR J := 1 TO 6 DO WSIXBIT[J] := ORD(NAME[J]) - 40B;
61200 WRITEIDENTIFIER(6B,NAME);
61300 WRITEPAIR(NO,PROJNR,PROGNR);
61400 FOR J := 1 TO 6 DO WSIXBIT[J] := ORD(DEVICE[J]) - 40B;
61500 WRITEIDENTIFIER(6B,DEVICE); LIC := LIC + 1
61600 END;
61700 I := 1;
61800 (* 40 - load PASLIB first *)
61900 for languageix := pascalsy to fortransy do
62000 WITH LIBRARY[LANGUAGEIX] DO
62100 BEGIN
62200 CALLED := (NOT INORDER AND CALLED) OR (LANGUAGEIX = PASCALSY);
62300 LIBORDER[I] := LANGUAGEIX; I := I + 1
62400 END;
62500 LIBIX := 2
62600 END;
62700 END %MCLIBRARY\;
62800
62900 BEGIN
63000 %WRITEMC\
63100 (* 121 - missing initialization - fix bollixed INITPROC's *)
63200 CODEARRAY := FALSE;
63300 IF NOT ERRORFLAG
63400 THEN
63500 BEGIN
63600 (* 5 - CREF *)
63700 IF CREF AND LISTCODE
63800 THEN WRITE(CHR(177B),'F');
63900 FOR I:=1 TO MAXSIZE DO RELEMPTY[I] := 0;
64000 WITH ICWANDEL DO
64100 BEGIN
64200 ICVAL := 0;
64300 CSP0 := ICCSP
64400 END;
64500 LLISTCODE := LISTCODE;
64600 CASE WRITEFLAG OF
64700 WRITEGLOBALS : MCGLOBALS; %LINK-ITEM 01B\
64800 WRITECODE : MCCODE; %LINK-ITEM 01B\
64900 WRITESYMBOLS : MCSYMBOLS; %LINK-ITEM 02B\
65000 WRITEBLK, %LINK-ITEM 02B\
65100 WRITEINTERNALS, %LINK-ITEM 10B\
65200 (* 164 - Polish fixups *)
65300 WRITEPOLISH, %LINK-ITEM 11B\
65400 WRITEENTRY, %LINK-ITEM 04B\
65500 WRITEEND, %LINK-ITEM 05B\
65600 WRITESTART, %LINK-ITEM 07B\
65700 WRITEHISEG, %LINK-ITEM 03B\
65800 WRITENAME : MCVARIOUS; %LINK-ITEM 06B\
65900 WRITELIBRARY : MCLIBRARY %LINK-ITEM 17B\
66000 END %CASE\;
66100 IF LISTCODE AND (WRITEFLAG > WRITEHISEG)
66200 (* 5 - CREF *)
66300 (* 136 - LISTING FORMAT *)
66400 THEN NEWLINE;
66500 IF CREF AND LISTCODE
66600 THEN WRITE(CHR(177B),'B')
66700 END %IF ERRORFLAG\
66800 ELSE
66900 IF WRITEFLAG = WRITECODE
67000 THEN LASTBTP := NIL
67100 END %WRITEMC\;
67200
67300 PROCEDURE STATEMENT(FSYS,STATENDS: SETOFSYS);
67400 TYPE
67500 VALUEKIND = (ONREGC,ONFIXEDREGC,TRUEJMP,FALSEJMP);
67600 VAR
67700 LCP: CTP; IX,J: INTEGER;
67800
67900 PROCEDURE EXPRESSION(FSYS: SETOFSYS; FVALUE:VALUEKIND); FORWARD;
68000
68100 PROCEDURE MAKEREAL(VAR FATTR: ATTR);
68200 BEGIN
68300 IF FATTR.TYPTR=INTPTR
68400 THEN
68500 BEGIN
68600 LOAD(FATTR);
00100 (* 2 - hard code FLOAT using KI-10 op code *)
00200 (* 101 - fix code generation for fltr *)
00300 (* 122 - add back KA-10 code *)
00400 (* 132 - separate KA10 into NOVM and KACPU *)
00500 if kacpu
00600 then begin
00700 macro3(201B%movei\,tac,fattr.reg);
00800 support(convertintegertoreal);
00900 end
01000 ELSE WITH CODE.INSTRUCTION[CIX] DO
01100 IF (INSTR = 200B%MOVE\) AND (AC = FATTR.REG)
01200 THEN INSTR := 127B%FLTR\
01300 ELSE MACRO3(127B%FLTR\,FATTR.REG,FATTR.REG);
01400 FATTR.TYPTR := REALPTR
01500 END;
01600 IF GATTR.TYPTR=INTPTR
01700 THEN MAKEREAL(GATTR)
01800 END;
01900
02000 PROCEDURE SELECTOR(FSYS: SETOFSYS; FCP: CTP);
02100 VAR
02200 LATTR: ATTR; LCP: CTP; LSP: STP;
02300 LMIN,LMAX,INDEXVALUE,INDEXOFFSET: INTEGER;
02400 OLDIC: ACRANGE;
02500
02600 PROCEDURE SUBLOWBOUND;
02700 BEGIN
02800 IF LMIN > 0
02900 THEN MACRO3(275B%SUBI\,REGC,LMIN)
03000 ELSE
03100 IF LMIN < 0
03200 THEN MACRO3(271B%ADDI\,REGC,-LMIN);
03300 IF RUNTMCHECK
03400 THEN
03500 BEGIN
03600 MACRO3(301B%CAIL\,REGC,0);
03700 MACRO3(303B%CAILE\,REGC,LMAX-LMIN);
03800 SUPPORT(INDEXERROR)
03900 END
04000 END;
04100
04200 BEGIN
04300 WITH FCP^, GATTR DO
04400 BEGIN
04500 TYPTR := IDTYPE; KIND := VARBL; PACKFG := NOTPACK;
04600 CASE KLASS OF
04700 VARS:
04800 BEGIN
04900 VLEVEL := VLEV; DPLMT := VADDR; INDEXR := 0;
05000 IF VLEV > 1
05100 THEN VRELBYTE:= NO
05200 ELSE VRELBYTE:= RIGHT;
05300 EXTERNCTP := NIL;
05400 (* 217 - We want to set EXTERNCTP in case this is an external variable.
05500 At the moment this is only files, and the following test
05600 works *)
05700 IF IDTYPE^.FORM = FILES
05800 THEN IF (VLEV=0) AND (NOT MAIN)
05900 THEN EXTERNCTP := FCP;
06000 IF VKIND=ACTUAL
06100 THEN INDBIT:=0
06200 ELSE INDBIT:=1
06300 END;
06400 FIELD:
06500 WITH DISPLAY[DISX] DO
06600 IF OCCUR = CREC
06700 THEN
06800 BEGIN
06900 VLEVEL := CLEV; PACKFG := PACKF; VRELBYTE:= CRELBYTE;
07000 IF PACKFG = PACKK
07100 THEN
07200 BEGIN
07300 BPADDR := FLDADDR;
07400 DPLMT := CDSPL
07500 END
07600 ELSE DPLMT := CDSPL+FLDADDR;
07700 INDEXR := CINDR; INDBIT:=CINDB
07800 END
07900 ELSE
08000 ERROR(171);
08100 FUNC:
08200 IF PFDECKIND = STANDARD
08300 THEN ERROR(502)
08400 ELSE
08500 IF PFLEV = 0
08600 THEN ERROR(502) %EXTERNAL FCT\
08700 ELSE
08800 IF PFKIND = FORMAL
08900 THEN ERROR(456)
09000 (* 31 - BE SURE WE'RE IN THE BODY OF THE FTN *)
09100 ELSE IF (LEVEL <= PFLEV) OR (DISPLAY[PFLEV+1].BLKNAME # NAME)
09200 THEN ERROR(412)
09300 ELSE
09400 BEGIN
09500 (* 166 - use pflev+1 for vlevel, to allow assignment from inner function *)
09600 VLEVEL := PFLEV + 1; VRELBYTE := NO;
09700 DPLMT := 1; %IMPL. RELAT. ADDR. OF FCT. RESULT\
09800 INDEXR :=0; INDBIT :=0
09900 END
10000 END;
10100 %CASE\
10200 END %WITH\;
10300 IFERRSKIP(166,SELECTSYS OR FSYS);
10400 WHILE SY IN SELECTSYS DO
10500 BEGIN
10600 (* 156 - error for selector on ftn name *)
10700 IF FCP^.KLASS = FUNC
10800 THEN ERROR(368);
10900 %[\
11000 IF SY = LBRACK
11100 THEN
11200 BEGIN
11300 IF GATTR.INDBIT = 1
11400 THEN GETPARADDR;
11500 OLDIC := GATTR.INDEXR;
11600 INDEXOFFSET := 0 ;
11700 LOOP
11800 LATTR := GATTR; INDEXVALUE := 0 ;
11900 WITH LATTR DO
12000 IF TYPTR # NIL
12100 THEN
12200 BEGIN
12300 IF TYPTR^.FORM # ARRAYS
12400 THEN
12500 BEGIN
12600 ERROR(307); TYPTR := NIL
12700 END;
12800 LSP := TYPTR
12900 END;
13000 INSYMBOL;
13100 EXPRESSION(FSYS OR [COMMA,RBRACK],ONREGC);
13200 IF GATTR.KIND#CST
13300 THEN LOAD(GATTR)
13400 ELSE INDEXVALUE := GATTR.CVAL.IVAL ;
13500 IF GATTR.TYPTR # NIL
13600 THEN
13700 IF GATTR.TYPTR^.FORM # SCALAR
13800 THEN ERROR(403);
13900 IF LATTR.TYPTR # NIL
14000 THEN
14100 WITH LATTR,TYPTR^ DO
14200 BEGIN
14300 IF COMPTYPES(INXTYPE,GATTR.TYPTR)
14400 THEN
14500 BEGIN
14600 IF INXTYPE # NIL
14700 THEN
14800 BEGIN
14900 GETBOUNDS(INXTYPE,LMIN,LMAX);
15000 IF GATTR.KIND = CST
15100 THEN
15200 IF (INDEXVALUE < LMIN) OR (INDEXVALUE > LMAX)
15300 THEN ERROR(263)
15400 END
15500 END
15600 ELSE ERROR(457);
15700 TYPTR := AELTYPE ;
15800 END ;
15900 EXIT IF SY # COMMA;
16000 WITH LATTR DO
16100 IF TYPTR#NIL
16200 THEN
16300 IF GATTR.KIND = CST
16400 THEN DPLMT := DPLMT +( INDEXVALUE - LMIN ) * TYPTR^.SIZE
16500 ELSE
16600 BEGIN
16700 SUBLOWBOUND;
16800 IF TYPTR^.SIZE > 1
16900 THEN MACRO3(221B%IMULI\,REGC,TYPTR^.SIZE);
17000 IF OLDIC = 0
17100 THEN OLDIC := REGC
17200 ELSE
17300 IF OLDIC > REGCMAX
17400 THEN
17500 BEGIN
17600 MACRO3(270B%ADD\,REGC,OLDIC);
17700 OLDIC := REGC
17800 END
17900 ELSE
18000 BEGIN
18100 MACRO3(270B%ADD\,OLDIC,REGC) ;
18200 REGC := REGC - 1
18300 END;
18400 INDEXR := OLDIC
18500 END ;
18600 GATTR := LATTR ;
18700 END;
18800 %LOOP\
18900 WITH LATTR DO
19000 IF TYPTR # NIL
19100 THEN
19200 BEGIN
19300 IF GATTR.KIND = CST
19400 THEN INDEXOFFSET := ( INDEXVALUE - LMIN ) * TYPTR^.SIZE
19500 ELSE
19600 BEGIN
19700 IF (TYPTR^.SIZE > 1) OR RUNTMCHECK
19800 THEN SUBLOWBOUND
19900 ELSE INDEXOFFSET := -LMIN;
20000 IF TYPTR^.SIZE > 1
20100 THEN MACRO3(221B%IMULI\,REGC,TYPTR^.SIZE);
20200 INDEXR := REGC ;
20300 END ;
20400 IF LSP^.ARRAYPF
20500 THEN
20600 BEGIN
20700 (* 102 - kl array code *)
20800 if not klcpu
20900 THEN INCREMENTREGC;
21000 IF INDEXR=OLDIC
21100 THEN
21200 BEGIN
21300 INCREMENTREGC; INDEXR := 0
21400 END;
21500 (* 102 - kl adjbp code *)
21600 if not klcpu then begin
21700 MACRO4(571B%HRREI\,REGC,INDEXR,INDEXOFFSET);
21800 INCREMENTREGC; %TEST FOR IDIVI-INSTRUCTION\
21900 REGC := REGC-1; INDEXOFFSET := 0;
22000 MACRO3R(200B%MOVE\,REGC-1,LSP^.ARRAYBPADDR);
22100 MACRO3(231B%IDIVI\,REGC,BITMAX DIV LSP^.AELTYPE^.BITSIZE);
22200 MACRO3(133B%IBP\,0,REGC-1);
22300 MACRO3R(365B%SOJGE\,REGC+1,IC-1);
22400 BPADDR := REGC-1; PACKFG := PACKK; INDEXR := REGC;
22500 (* 102 - kl adjbp code *)
22600 end
22700 else begin (* kl code*)
22800 macro4(571B%hrrei\,regc,indexr,indexoffset+1);
22900 macro3r(133B%adjbp\,regc,lsp^.arraybpaddr);
23000 bpaddr := regc; packfg := packk; indexr := 0;
23100 indexoffset := 0;
23200 end;
23300 END;
23400 DPLMT := DPLMT + INDEXOFFSET ;
23500 KIND := VARBL ;
23600 IF ( OLDIC # INDEXR ) AND ( OLDIC # 0 )
23700 THEN
23800 BEGIN
23900 (* 102 - new packed array code *)
24000 if indexr = 0
24100 then indexr := oldic
24200 ELSE IF OLDIC > REGCMAX
24300 THEN MACRO3(270B%ADD\,INDEXR,OLDIC)
24400 ELSE
24500 BEGIN
24600 MACRO3(270B%ADD\,OLDIC,INDEXR);
24700 REGC := REGC - 1;
24800 INDEXR := OLDIC
24900 END
25000 END
25100 END %WITH.. IF TYPTR # NIL\ ;
25200 GATTR := LATTR ;
25300 IF SY = RBRACK
25400 THEN INSYMBOL
25500 ELSE ERROR(155)
25600 END %IF SY = LBRACK\
25700 ELSE
25800 %.\
25900 IF SY = PERIOD
26000 THEN
26100 BEGIN
26200 WITH GATTR DO
26300 BEGIN
26400 IF TYPTR # NIL
26500 THEN
26600 IF TYPTR^.FORM # RECORDS
26700 THEN
26800 BEGIN
26900 ERROR(308); TYPTR := NIL
27000 END;
27100 IF INDBIT=1
27200 THEN GETPARADDR;
27300 INSYMBOL;
27400 IF SY = IDENT
27500 THEN
27600 BEGIN
27700 IF TYPTR # NIL
27800 THEN
27900 BEGIN
28000 SEARCHSECTION(TYPTR^.FSTFLD,LCP);
28100 (* 5 - CREF *)
28200 IF CREF
28300 THEN WRITE(CHR(1B),CHR(21),ID,' .FIELDID. ');
28400 IF LCP = NIL
28500 THEN
28600 BEGIN
28700 ERROR(309); TYPTR := NIL
28800 END
28900 ELSE
29000 WITH LCP^ DO
29100 BEGIN
29200 TYPTR := IDTYPE;PACKFG := PACKF;
29300 IF PACKFG = PACKK
29400 THEN
29500 BPADDR := FLDADDR
29600 ELSE
29700 DPLMT := DPLMT + FLDADDR;
29800 END
29900 END;
30000 INSYMBOL
30100 END %SY = IDENT\
30200 ELSE ERROR(209)
30300 END %WITH GATTR\
30400 END %IF SY = PERIOD\
30500 ELSE
30600 %^\
30700 BEGIN
30800 IF GATTR.TYPTR # NIL
30900 THEN
31000 WITH GATTR,TYPTR^ DO
31100 (* 173 - changes for internal files, since we can't assume FILPTR is set up *)
31200 IF FORM = FILES
31300 THEN BEGIN
31400 TYPTR := FILTYPE;
31500 {What we are trying to do here is to generate code like
31600 MOVEI 2,INPUT+FILCMP
31700 In the usual case, we just do a loadaddress on the file, after add
31800 filcmp to the displacement. There are two cases where this won't
31900 work:
32000 - when the address is an external reference, since it then
32100 becomes an address in a fixup chain, and can't have FILCMP
32200 added to it at compile time. Thus we have a separate
32300 fixup chain stored in CHANTAB which the loader will add
32400 FILCMP to after fixing up.
32500 - when the thing is indirect, since we have to add the displacemtn
32600 after doing the indirection. The only solution there is
32700 an ADDI, as far as I can see.
32800 Hamburg used to just do a LOAD, which works because at INPUT there
32900 is a pointer to INPUT+FILCMP. I can't do that because if the
33000 FCB isn't initialized that will be garbage, and I need the real
33100 address to do the validity check}
33200 WITH FCP^ DO
33300 IF (VLEV = 0) AND (NOT MAIN)
33400 THEN BEGIN
33500 INCREMENTREGC;
33600 MACRO3R(201B%MOVEI\,REGC,CHANTAB[CHANNEL]);
33700 CHANTAB[CHANNEL] := IC-1;
33800 CODE.INFORMATION[CIX] := 'E';
33900 WITH GATTR DO
34000 BEGIN
34100 KIND := VARBL; DPLMT := 0; INDEXR:=REGC;
34200 INDBIT:=0; VRELBYTE := NO
34300 END
34400 END
34500 (* 200 - fix addressing *)
34600 ELSE IF INDBIT = 0
34700 THEN BEGIN
34800 DPLMT := DPLMT + FILCMP;
34900 LOADADDRESS;
35000 END
35100 ELSE BEGIN
35200 LOADADDRESS;
35300 MACRO3(271B%ADDI\,REGC,FILCMP)
35400 END;
35500 IF RUNTMCHECK
35600 THEN BEGIN
35700 {See if the file is open. A magic value of 314157 is left in FILTST if so }
35800 MACRO4(200B%MOVE\,HAC,REGC,FILTST-FILCMP);
35900 MACRO3(302B%CAIE\,HAC,314157B);
36000 SUPPORT(FILEUNINITIALIZED)
36100 END
36200 END
36300 ELSE IF FORM = POINTER
36400 THEN
36500 BEGIN
36600 TYPTR := ELTYPE;
36700 IF TYPTR # NIL
36800 THEN WITH GATTR DO
36900 BEGIN
37000 LOADNOPTR := FALSE;
37100 LOAD(GATTR); LOADNOPTR := TRUE;
37200 (* 23 - check for bad pointer *)
37300 (* 26 - but not for file *)
37400 IF RUNTMCHECK
37500 THEN BEGIN
37600 MACRO3(302B%CAIE\,REG,0);
37700 MACRO3(306B%CAIN\,REG,377777B);
37800 SUPPORT(BADPOINT)
37900 END;
38000 INDEXR := REG; DPLMT := 0; INDBIT:=0;
38100 PACKFG := NOTPACK; KIND := VARBL;
38200 VRELBYTE:= NO
38300 END
38400 END
38500 ELSE ERROR(407);
38600 INSYMBOL
38700 END;
38800 IFERRSKIP(166,FSYS OR SELECTSYS)
38900 END;
39000 %WHILE\
39100 WITH GATTR DO
39200 IF TYPTR#NIL
39300 THEN
39400 IF TYPTR^.SIZE = 2
39500 THEN
39600 BEGIN
39700 IF INDBIT = 1
39800 THEN GETPARADDR;
39900 IF (INDEXR>REGIN) AND (INDEXR<=REGCMAX)
40000 THEN INCREMENTREGC
40100 END
40200 END %SELECTOR\ ;
40300
40400 PROCEDURE CALL(FSYS: SETOFSYS; FCP: CTP);
40500 VAR
40600 (* 10 - ALLOW MORE RUNTIMES *)
40700 LKEY: 1..44;
40800 LFOLLOWERROR, NORIGHTPARENT : BOOLEAN;
40900
41000 (* 33 - allow use with non-TEXT files *)
41100 (* 171 - allow read/write of records *)
41200 (* 173 - completely new getfilename *)
41300 (* 204 - don't check validty of file to be closed *)
41400 PROCEDURE GETFILENAME(DEFAULTFILE:CTP;TEXTPROC:BOOLEAN;
41500 VAR FILETYPE:STP;VAR GOTARG:BOOLEAN;CHECK:BOOLEAN);
41600 VAR
41700 (* 177 - fix AC *)
41800 GOTFILE : BOOLEAN; FILEREGC: ACRANGE;
41900 {When we are finished we will have loaded a file into REGC, and parsed
42000 the next parameter if there is one, using EXPRESSION with REGC incremented}
42100 BEGIN
42200 INCREMENTREGC; {by default we will load into 3}
42300 FILEREGC := REGC; {but file goes into 2, which this still is}
42400 {REGC = 2}
42500 GOTARG := FALSE; NORIGHTPARENT := TRUE; GOTFILE := FALSE;
42600 IF SY = LPARENT
42700 THEN BEGIN
42800 NORIGHTPARENT := FALSE;
42900 INSYMBOL;
43000 EXPRESSION(FSYS OR [COMMA,RPARENT,COLON],ONFIXEDREGC);
43100 {REGC = 3 if expression (file can't be), 2 otherwise}
43200 GOTFILE := FALSE;
43300 {We have an expression, see if it is a legal file. If so, load it into
43400 REGC (note: no incrementregc first) and do a few tests. We have to do
43500 our own loading mostly to avoid the INCREMENTREGC done by LOADADDRESS}
43600 WITH GATTR DO
43700 IF TYPTR <> NIL
43800 THEN WITH TYPTR^ DO
43900 IF FORM = FILES
44000 THEN BEGIN
44100 IF TEXTPROC
44200 THEN IF NOT (COMPTYPES(FILTYPE,CHARPTR))
44300 THEN ERROR(366);
44400 {Yes, it is a legal file. Now load it}
44500 {If TTY that is supposed to be mapped to TTYOUTPUT, handle that}
44600 (* 217 - EXTERNCTP instead of LASTFILE *)
44700 IF (EXTERNCTP = TTYFILE) AND (DEFAULTFILE = OUTFILE)
44800 THEN BEGIN
44900 EXTERNCTP := TTYOUTFILE;
45000 MACRO3R(201B%MOVEI\,REGC,TTYOUTFILE^.VADDR);
45100 END
45200 ELSE BEGIN
45300 FETCHBASIS(GATTR);
45400 MACRO(VRELBYTE,201B%MOVEI\,REGC,INDBIT,INDEXR,DPLMT);
45500 END;
45600 KIND := VARBL; DPLMT := 0; INDEXR:=REGC;
45700 INDBIT:=0; VRELBYTE := NO;
45800 (* 217 - allow complex file expr's *)
45900 IF EXTERNCTP <> NIL
46000 THEN BEGIN EXTERNCTP^.VADDR:=IC-1;
46100 CODE.INFORMATION[CIX]:='E' END;
46200 GOTFILE := TRUE;
46300 FILETYPE := TYPTR;
46400 {Runtime checks if appropriate}
46500 (* 204 - don't check for CLOSE *)
46600 if runtmcheck and check
46700 then begin
46800 macro4(200B%MOVE\,hac,regc,filtst); {File test word}
46900 macro3(302B%CAIE\,hac,314157B); {True if file is open}
47000 support(fileuninitialized); {Not open}
47100 end;
47200 {Now see if there is an arg}
47300 IF SY <> RPARENT
47400 THEN BEGIN
47500 IF SY = COMMA
47600 THEN INSYMBOL
47700 ELSE ERROR(158);
47800 {Note that this is guaranteed not to change REGC unless it sees an
47900 expression, in which case it advances to 3. We can't have two
48000 advances (i.e. due to the EXPRESSION above and this one), since
48100 this is done only if the one above saw a file, which can't have
48200 advanced REGC}
48300 EXPRESSION(FSYS OR [COMMA,RPARENT,COLON],ONFIXEDREGC);
48400 GOTARG := TRUE
48500 END
48600 END;
48700 {Now we are done processing a file arg}
48800 IF NOT GOTFILE {If expression wasn't a file, use it as arg}
48900 THEN GOTARG := TRUE
49000 END;
49100 {End of IF RPARENT}
49200 {At this point REGC = 2 unless what we saw was an expr (which a file
49300 can't be), in which case REGC = 3 and it is loaded}
49400 IF NOT GOTFILE
49500 THEN WITH DEFAULTFILE^ DO
49600 {If we didn't get a file above, here is the code to do it}
49700 BEGIN
49800 (* 177 - fix AC *)
49900 MACRO3R(201B%MOVEI\,FILEREGC,VADDR);
50000 IF NOT GOTARG
50100 THEN WITH GATTR DO
50200 BEGIN
50300 KIND := VARBL; DPLMT := 0; INDEXR:=REGC;
50400 INDBIT:=0; VRELBYTE := NO;
50500 END;
50600 IF (VLEV=0) AND (NOT MAIN)
50700 THEN BEGIN VADDR:=IC-1; CODE.INFORMATION[CIX]:='E' END;
50800 FILETYPE := IDTYPE;
50900 (* 204 - don't check for CLOSE *)
51000 if runtmcheck and check
51100 then begin
51200 (* 207 - more bad AC's *)
51300 macro4(200B%MOVE\,hac,fileregc,filtst); {File test word}
51400 macro3(302B%CAIE\,hac,314157B); {True if file is open}
51500 support(fileuninitialized); {Not open}
51600 end;
51700 END;
51800 {If we saw an arg, REGC is exactly like it would have been with a
51900 simple INCREMENTREGC; EXPRESSION; which is the whole point.
52000 That is,it is 2 unless an expression was seen, in which case the
52100 expression is loaded into 3. If we didn't see an expression, then
52200 REGC is guaranteed to be 2. Very shady...}
52300 END %GETFILENAME\ ;
52400
52500 PROCEDURE VARIABLE(FSYS: SETOFSYS);
52600 VAR
52700 LCP: CTP;
52800 BEGIN
52900 IF SY = IDENT
53000 THEN
53100 BEGIN
53200 SEARCHID([VARS,FIELD],LCP); INSYMBOL
53300 END
53400 ELSE
53500 BEGIN
53600 ERROR(209); LCP := UVARPTR
53700 END;
53800 SELECTOR(FSYS,LCP)
53900 END %VARIABLE\ ;
54000 (* 22 - add GETFN - common non-defaulting file name scanner *)
54100 (* 73 - add ,COLON since used in NEW *)
54200 (* 175 - internal files *)
54300 PROCEDURE GETFN(TEST:BOOLEAN);
54400 BEGIN
54500 VARIABLE(FSYS OR [RPARENT,COLON,COMMA]);
54600 LOADADDRESS;
54700 IF GATTR.TYPTR#NIL
54800 THEN IF GATTR.TYPTR^.FORM#FILES
54900 THEN ERROR(212)
55000 (* 217 - complex file expressions *)
55100 ELSE IF GATTR.EXTERNCTP <> NIL
55200 THEN BEGIN GATTR.EXTERNCTP^.VADDR:=IC-1;
55300 CODE.INFORMATION[CIX]:='E' END;
55400 (* 175 - internal files *)
55500 if test and runtmcheck
55600 then begin
55700 macro4(200B%MOVE\,hac,regc,filtst); {File test word}
55800 macro3(302B%CAIE\,hac,314157B); {Magic value if it is open}
55900 support(fileuninitialized); {Not open}
56000 end;
56100 END;
56200
56300 (* 14 - SEVERAL CHANGES IN THIS PROC TO ADD NEW RUNTIMES AND ADD OPTIONAL XBLOCK ARG *)
56400 PROCEDURE GETPUTRESETREWRITE;
56500 VAR
56600 (* 172 - new options string *)
56700 LMAX,LMIN: INTEGER;
56800 (* 173 - internal files *)
56900 LATTR: ATTR;
57000 ADR : SUPPORTS ;
57100 DEFAULT : ARRAY [1..6] OF BOOLEAN;
57200 I,J : INTEGER;
57300
57400 PROCEDURE GETSTRINGADDRESS ;
57500
57600 VAR LMAX,LMIN: INTEGER;
57700 (* 61 - allow flags for gtjfn in tops20 *)
57800 flagbits: packed record case Boolean of
57900 true: (dum:0..777777B;usetty:Boolean;wildok:Boolean);
58000 false: (dum2:0..777777B; rh:0..777777B)
58100 end;
58200 BEGIN
58300 IF SY=COMMA
58400 THEN
58500 BEGIN
58600 INSYMBOL;
58700 EXPRESSION(FSYS OR [COMMA,RPARENT,COLON],ONFIXEDREGC);
58800 WITH GATTR DO
58900 IF TYPTR#NIL
59000 THEN
59100 WITH TYPTR^ DO
59200 IF(FORM=ARRAYS) AND ARRAYPF
59300 THEN
59400 IF COMPTYPES(AELTYPE,CHARPTR)
59500 THEN
59600 BEGIN
59700 (* 15 - CHANGE DUE TO SLIGHTLY DIFFERENT LOGIC IN MAIN PROC *)
59800 DEFAULT[I] := FALSE;
59900 I:=I+1;DEFAULT[I]:=FALSE;
60000 LOADADDRESS;
60100 GETBOUNDS(INXTYPE,LMIN,LMAX);
60200 LMAX := LMAX-LMIN+1;
60300 INCREMENTREGC;
60400 MACRO3(201B%MOVEI\,REGC,LMAX);
60500 END
60600 ELSE ERROR(212)
60700 ELSE ERROR(212);
60800 (* 61 - implement extra syntax for tops20 *)
60900 (* 144 - allow it for tops10, too *)
61000 if (sy=colon)
61100 then begin
61200 insymbol;
61300 flagbits.rh := 0;
61400 while sy in [relop,addop,mulop] do
61500 begin
61600 if op = leop (* @ *)
61700 then flagbits.usetty := true
61800 else if (op = mul) and (not tops10)
61900 then flagbits.wildok := true
62000 else error(158);
62100 insymbol
62200 end;
62300 macro3(505b%hrli\,regc-1,flagbits.rh);
62400 end;
62500 END;
62600 END ;
62700
62800 BEGIN
62900 VARIABLE( FSYS OR [RPARENT,COMMA] ) ;
63000 LOADADDRESS ;
63100 (* 173 - internal files *)
63200 LATTR := GATTR;
63300 IF GATTR.TYPTR # NIL
63400 THEN
63500 IF GATTR.TYPTR^.FORM # FILES
63600 THEN ERRANDSKIP(458,FSYS OR [RPARENT])
63700 ELSE
63800 BEGIN
63900 (* 217 - file expressions *)
64000 IF GATTR.EXTERNCTP <> NIL
64100 THEN
64200 BEGIN
64300 GATTR.EXTERNCTP^.VADDR:= IC-1;
64400 CODE.INFORMATION[CIX] := 'E'
64500 END;
64600 IF (LKEY>=5) AND (LKEY#28)
64700 THEN
64800 BEGIN
64900 FOR I := 1 TO 6 DO DEFAULT[I] := TRUE;
65000 I := 1;
65100 GETSTRINGADDRESS % OF FILENAME \ ;
65200 (* 15 - ADD NEW PARAMETERS AND ALLOW OMITTING BLOCK *)
65300 WHILE NOT DEFAULT[I] AND (SY=COMMA) DO
65400 BEGIN
65500 I := I+1;
65600 INSYMBOL;
65700 (* 172 - ADD OPTION STRING AS 3RD ARG *)
65800 IF I = 3
65900 THEN BEGIN
66000 EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
66100 WITH GATTR DO
66200 IF TYPTR#NIL
66300 THEN WITH TYPTR^ DO
66400 IF(FORM=ARRAYS) AND ARRAYPF
66500 THEN IF COMPTYPES(AELTYPE,CHARPTR)
66600 THEN BEGIN
66700 DEFAULT[I] := FALSE;
66800 LOADADDRESS;
66900 GETBOUNDS(INXTYPE,LMIN,LMAX);
67000 LMAX := LMAX-LMIN+1;
67100 MACRO3(505B%HRLI\,REGC,LMAX);
67200 END
67300 ELSE ERROR(212) {not CHAR array}
67400 ELSE BEGIN {not packed array}
67500 LOAD(GATTR); DEFAULT[I] := FALSE
67600 END
67700 END {I=3}
67800 (* 57 - ONLY TOPS10 HAS XBLOCK ARG *)
67900 ELSE IF (NOT TOPS10) OR (I # 4) OR ((SY=INTCONST)AND(VAL.IVAL=0))
68000 THEN BEGIN
68100 EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
68200 IF GATTR.TYPTR#NIL
68300 THEN
68400 BEGIN
68500 LOAD(GATTR); DEFAULT[I] := FALSE;
68600 (* 77 - allow sets, since they are elegant for specifying bits *)
68700 if gattr.typtr^.form = power
68800 then regc := regc-1;
68900 END
69000 END
69100 ELSE BEGIN
69200 VARIABLE(FSYS OR[COMMA,RPARENT]);
69300 IF GATTR.TYPTR # NIL
69400 (* 26 - allow record as lookup block *)
69500 THEN IF NOT (GATTR.TYPTR^.FORM IN [ARRAYS,RECORDS])
69600 THEN ERROR(264)
69700 ELSE IF GATTR.TYPTR^.SIZE<5
69800 THEN ERROR(265)
69900 ELSE BEGIN LOADADDRESS; DEFAULT[I]:=FALSE END
70000 ELSE ERROR(458)
70100 END;
70200 END;
70300 FOR I := 1 TO 6 DO
70400 IF DEFAULT[I]
70500 THEN
70600 BEGIN
70700 INCREMENTREGC;
70800 IF I=6
70900 THEN MACRO3(474B%SETO\,REGC,0)
71000 ELSE MACRO3(201B%MOVEI\,REGC,0)
71100 END;
71200 END;
71300 (* 173 - internal files *)
71400 if lkey in [5,6,29,36] {openning}
71500 then begin
71600 if lattr.typtr <> nil
71700 then if lattr.typtr^.form = files
71800 then if comptypes(lattr.typtr^.filtype,charptr)
71900 {In AC1, put size of component, or 0 if text file}
72000 then macro3(201B%movei\,tac,0)
72100 else macro3(201B%movei\,tac,
72200 {Normally we would have to type filtype^ for nil, but if it is nil, the
72300 comptypes above will succeed, and this code will never happen.}
72400 lattr.typtr^.filtype^.size)
72500 end
72600 (* 204 - don't validty check for DISMISS *)
72700 (* 205 - fix AC for RENAME *)
72800 else if runtmcheck and (lkey <> 28)
72900 then begin
73000 macro4(200B%MOVE\,hac,regin+1,filtst);{File test word}
73100 macro3(302B%CAIE\,hac,314157B); {Magic value if open}
73200 support(fileuninitialized); {Not open}
73300 end;
73400 CASE LKEY OF
73500 2: ADR:= GETLINE ;
73600 4: ADR:= PUTLINE ;
73700 5: ADR:= RESETFILE ;
73800 6: ADR:= REWRITEFILE;
73900 27:ADR:=NAMEFILE;
74000 28:ADR:=DISFILE;
74100 29:ADR:=UPFILE;
74200 36:ADR:=APFILE
74300 END ;
74400 SUPPORT(ADR) ;
74500 END ;
74600 END;
74700
74800 (* 10 - ADD SETSTRING, TO ALLOW I/O TO STRINGS *)
74900 (* 13 - CODE MODIFIED TO ALLOW 4TH ARG, LIMIT *)
75000 (* 51 - allow any file type, any packed array *)
75100 PROCEDURE SETSTRING;
75200 VAR
75300 LREGC:ACRANGE;
75400 LMIN,LMAX:ADDRRANGE;
75500 ARRAY1,OFFSET,FILEP,LIMIT:ATTR;
75600 NOOFF,NOLIM: BOOLEAN;
75700
75800 BEGIN
75900 LREGC := REGC; NOOFF := FALSE; NOLIM:=FALSE;
76000 (* 175 - if not inited, do it *)
76100 GETFN(FALSE);
76200 {If the file block is not legal yet, call routine to make it so}
76300 macro4(200B%MOVE\,hac,regc,filtst); {File test word}
76400 macro3(302B%CAIE\,hac,314157B); {Magic value if it is open}
76500 support(initfileblock);
76600 FILEP := GATTR;
76700 IF SY = COMMA
76800 THEN INSYMBOL
76900 ELSE ERROR(158);
77000 VARIABLE(FSYS OR [RPARENT,COMMA]);
77100 LOADADDRESS;
77200 WITH GATTR DO
77300 BEGIN
77400 KIND := EXPR; REG := INDEXR;
77500 IF TYPTR # NIL
77600 THEN WITH TYPTR^ DO
77700 IF FORM # ARRAYS
77800 THEN ERROR(458)
77900 ELSE IF FILEP.TYPTR#NIL
78000 THEN IF NOT ARRAYPF
78100 THEN ERROR(458)
78200 END;
78300 ARRAY1 := GATTR;
78400 IF SY = RPARENT
78500 THEN NOOFF := TRUE
78600 ELSE IF SY = COMMA
78700 THEN BEGIN
78800 INSYMBOL;
78900 EXPRESSION(FSYS OR [RPARENT,COMMA],ONREGC);
79000 IF GATTR.TYPTR # NIL
79100 THEN IF GATTR.TYPTR^.FORM # SCALAR
79200 THEN ERROR(458)
79300 ELSE IF NOT COMPTYPES(ARRAY1.TYPTR^.INXTYPE,GATTR.TYPTR)
79400 THEN ERROR(458);
79500 OFFSET := GATTR;
79600 IF OFFSET.KIND = EXPR
79700 THEN INCREMENTREGC
79800 END
79900 ELSE ERROR(158);
80000 IF SY = RPARENT
80100 THEN NOLIM := TRUE
80200 ELSE IF SY = COMMA
80300 THEN BEGIN
80400 INSYMBOL;
80500 EXPRESSION(FSYS OR [RPARENT],ONREGC);
80600 IF GATTR.TYPTR # NIL
80700 THEN IF GATTR.TYPTR^.FORM # SCALAR
80800 THEN ERROR(458)
80900 ELSE IF NOT COMPTYPES(ARRAY1.TYPTR^.INXTYPE,GATTR.TYPTR)
81000 THEN ERROR(458);
81100 LIMIT := GATTR;
81200 IF LIMIT.KIND = EXPR
81300 THEN INCREMENTREGC
81400 END
81500 ELSE ERROR(158);
81600 IF NOT ERRORFLAG
81700 THEN BEGIN
81800 GETBOUNDS(ARRAY1.TYPTR^.INXTYPE,LMIN,LMAX);
81900 LMAX := LMAX - LMIN;
82000 IF NOT NOLIM
82100 THEN BEGIN
82200 IF LIMIT.KIND # EXPR
82300 THEN BEGIN LOAD(LIMIT); INCREMENTREGC END;
82400 WITH LIMIT DO
82500 BEGIN
82600 IF LMIN > 0
82700 THEN MACRO3(275B%SUBI\,REG,LMIN)
82800 ELSE IF LMIN < 0
82900 THEN MACRO3(271B%ADDI\,REG,-LMIN);
83000 IF RUNTMCHECK
83100 THEN BEGIN
83200 MACRO3(307B%CAIG\,REG,LMAX);
83300 MACRO3(305B%CAIGE\,REG,0);
83400 SUPPORT(INDEXERROR)
83500 END;
83600 END;
83700 END;
83800 IF NOT NOOFF
83900 THEN BEGIN
84000 IF OFFSET.KIND # EXPR
84100 THEN BEGIN LOAD(OFFSET); INCREMENTREGC END;
84200 WITH OFFSET DO
84300 BEGIN
84400 IF LMIN > 0
84500 THEN MACRO3(275B%SUBI\,REG,LMIN)
84600 ELSE IF LMIN < 0
84700 THEN MACRO3(271B%ADDI\,REG,-LMIN);
84800 IF RUNTMCHECK
84900 THEN BEGIN
85000 MACRO3(301B%CAIL\,REG,0);
85100 MACRO3(303B%CAILE\,REG,LMAX+1);
85200 SUPPORT(INDEXERROR)
85300 END;
85400 END;
85500 INCREMENTREGC;
85600 IF NOLIM
85700 THEN MACRO4(211B%MOVNI\,REGC,OFFSET.REG,-LMAX-1)
85800 ELSE BEGIN
85900 MACRO4(201B%MOVEI\,REGC,LIMIT.REG,1);
86000 MACRO4(275B%SUBI\,REGC,OFFSET.REG,0);
86100 IF RUNTMCHECK
86200 THEN BEGIN
86300 MACRO3(305B%CAIGE\,REGC,0);
86400 SUPPORT(INDEXERROR)
86500 END
86600 END;
86700 MACRO4(552B%HRRZM\,REGC,FILEP.INDEXR,FILBFH+2);
86800 MACRO3R(200B%MOVE\,REGC,ARRAY1.TYPTR^.ARRAYBPADDR);
86900 MACRO3(621B%TLZ\,REGC,17B);
87000 MACRO3(231B%IDIVI\,OFFSET.REG,BITMAX DIV ARRAY1.TYPTR^.AELTYPE^.BITSIZE);
87100 MACRO3(270B%ADD\,ARRAY1.REG,OFFSET.REG);
87200 MACRO3(540B%HRR\,REGC,ARRAY1.REG);
87300 MACRO3(303B%CAILE\,OFFSET.REG+1,0);
87400 MACRO3(133B%IBP\,0,REGC);
87500 MACRO3R(367B%SOJG\,OFFSET.REG+1,IC-1);
87600 MACRO4(202B%MOVEM\,REGC,FILEP.INDEXR,FILBFH+1)
87700 END
87800 ELSE BEGIN
87900 INCREMENTREGC;
88000 IF NOLIM
88100 THEN MACRO3(201B%MOVEI\,REGC,LMAX+1)
88200 ELSE MACRO4(201B%MOVEI\,REGC,LIMIT.REG,1);
88300 MACRO4(202B%MOVEM\,REGC,FILEP.INDEXR,FILBFH+2);
88400 MACRO3R(200B%MOVE\,REGC,ARRAY1.TYPTR^.ARRAYBPADDR);
88500 MACRO3(621B%TLZ\,REGC,17B);
88600 MACRO3(540B%HRR\,REGC,ARRAY1.REG);
88700 MACRO4(202B%MOVEM\,REGC,FILEP.INDEXR,FILBFH+1)
88800 END;
88900 IF NOLIM
89000 THEN MACRO3(505B%HRLI\,REGC,LMIN+LMAX+400001B)
89100 ELSE MACRO4(505B%HRLI\,REGC,LIMIT.REG,LMIN+400001B);
89200 (* 60 - DON'T PUT IN LH(0) FOR TOPS-20. "FILBFH" IS FREE *)
89300 (* 143 - Tops10 now like Tops20 *)
89400 IF TOPS10
89500 THEN MACRO4(556B%HLRZM\,REGC,FILEP.INDEXR,FILBLL)
89600 ELSE MACRO4(556B%HLRZM\,REGC,FILEP.INDEXR,FILBFH);
89700 (* 43 - setzm to avoid blocked or dump mode I/O *)
89800 (* 60 - kludge needed only for tops10 *)
89900 (* 143 - tops10 now like tops20 *)
90000 CASE LKEY OF
90100 (* 60 - TOPS20 USES RUNTIME TO INIT *)
90200 (* 143 - so does Tops10 *)
90300 22: SUPPORT(RESETSTRING);
90400 23: SUPPORT(REWRITESTRING)
90500 END;
90600 END;
90700 REGC := LREGC
90800 END;
90900
91000 (* 57 - ADD SET20STRING FOR 20 STRSET,STRWRITE *)
91100 (* 60 - on further thought, use normal one *)
91200
91300 PROCEDURE GETINDEX;
91400 VAR LREGC:ACRANGE;
91500 FILEP:ATTR;
91600 BEGIN
91700 LREGC := REGC;
91800 (* 175 *)
91900 GETFN(TRUE);
92000 FILEP := GATTR;
92100 IF SY = COMMA
92200 THEN INSYMBOL
92300 ELSE ERROR(158);
92400 VARIABLE(FSYS OR [RPARENT]);
92500 LOADADDRESS;
92600 WITH GATTR DO
92700 BEGIN
92800 IF TYPTR # NIL
92900 THEN WITH TYPTR^ DO
93000 IF (FORM # SCALAR) AND (FORM # SUBRANGE)
93100 THEN ERROR(458)
93200 END;
93300 IF NOT ERRORFLAG
93400 THEN BEGIN
93500 INCREMENTREGC;
93600 WITH FILEP DO
93700 BEGIN
93800 (* 60 - TOPS20 HAS MAGIC NO. IN DIFFERENT PLACE *)
93900 (* 143 - tops10 now the same *)
94000 IF TOPS10
94100 THEN MACRO4(200B%MOVE\,REGC,INDEXR,FILBLL)
94200 ELSE MACRO4(200B%MOVE\,REGC,INDEXR,FILBFH);
94300 MACRO3(620B%TRZ\,REGC,400000B);
94400 MACRO4(274B%SUB\,REGC,INDEXR,FILBFH+2);
94500 MACRO4(202B%MOVEM\,REGC,GATTR.INDEXR,0);
94600 END
94700 END;
94800 REGC := LREGC
94900 END;
00100
00200 PROCEDURE READREADLN;
00300 VAR
00400 (* 14 ADD READING OF STRING *)
00500 (* 171 read into packed objects, ALLOW READ OF RECORDS *)
00600 LADDR : SUPPORTS; LMIN,LMAX:INTEGER; LATTR:ATTR;
00700 READREC: BOOLEAN; LREGC: ACRANGE;
00800 {This procedure is complicated by a number of special cases. The first is
00900 the question of whether the file is text or binary. The code for a binary
01000 file is more or less completely different. (Note also that only READLN
01100 is not legal for a binary file.) The second question is whether the
01200 address is passed to the runtimes or whether they return a value. For
01300 binary files we must pass the address of the variable to be filled, since
01400 it can be arbitrarily big. Similarly for strings. For simple values,
01500 the runtimes return the value in AC 3, and we must do a store. This is
01600 to allow for storing into packed objects (what kind of address could be
01700 pass for that?) We do LOADADDRESS for binary files and strings, and
01800 for simple objects we do STORE afterwards.}
01900 BEGIN
02000 (* 33 - ALLOW GETFILENAME WITH NON-TEXT FILES *)
02100 (* 171 - PREDECL FILES ARE GLOBAL, ALSO ALLOW READ OF RECORD *)
02200 IF LKEY = 7 {read?}
02300 THEN GETFILENAME(INFILE,FALSE,THISFILE,GOTARG,TRUE) {might be binary}
02400 ELSE GETFILENAME(INFILE,TRUE,THISFILE,GOTARG,TRUE); {must be text}
02500 IF (LKEY = 7) AND NOT GOTARG
02600 THEN ERROR(554); {READ must have args}
02700 READREC := FALSE; {now see if a binary file}
02800 IF LKEY = 7
02900 THEN IF NOT COMPTYPES(CHARPTR,THISFILE^.FILTYPE)
03000 THEN READREC := TRUE;
03100 LREGC := REGC;
03200 IF GOTARG
03300 THEN
03400 LOOP
03500 (* 14 ADD READING OF STRING *)
03600 (* 171 read into packed objects *)
03700 LATTR := GATTR;
03800 (* 31 - INITIALIZE LADDR IN CASE OF ERROR - PREVENT ILL MEM REF *)
03900 IF READREC
04000 THEN BEGIN {separate code for binary files}
04100 LADDR := READRECORD;
04200 IF GATTR.TYPTR#NIL
04300 THEN IF NOT COMPTYPES(THISFILE^.FILTYPE,GATTR.TYPTR)
04400 THEN ERROR(260);
04500 LOADADDRESS
04600 END
04700 ELSE BEGIN {Here is the code for TEXT files}
04800 LADDR := READCHARACTER;
04900 IF GATTR.TYPTR#NIL
05000 THEN
05100 IF GATTR.TYPTR^.FORM<=SUBRANGE
05200 THEN
05300 IF COMPTYPES(INTPTR,GATTR.TYPTR)
05400 THEN
05500 LADDR := READINTEGER
05600 ELSE
05700 IF COMPTYPES(REALPTR,GATTR.TYPTR)
05800 THEN
05900 LADDR := READREAL
06000 ELSE
06100 IF COMPTYPES(CHARPTR,GATTR.TYPTR)
06200 THEN
06300 LADDR := READCHARACTER
06400 ELSE ERROR(169)
06500 ELSE WITH GATTR.TYPTR^ DO
06600 IF FORM = ARRAYS
06700 THEN IF COMPTYPES(CHARPTR,AELTYPE)
06800 THEN
06900 BEGIN
07000 (* 171 - read into packed objects *)
07100 LOADADDRESS; {of array}
07200 GETBOUNDS(INXTYPE,LMIN,LMAX);
07300 INCREMENTREGC;
07400 MACRO3(201B%MOVEI\,REGC,LMAX-LMIN+1);
07500 IF ARRAYPF
07600 THEN LADDR := READPACKEDSTRING
07700 ELSE LADDR := READSTRING;
07800 IF SY = COLON
07900 THEN BEGIN
08000 INSYMBOL;
08100 (* 76 - allow set of break characters *)
08200 VARIABLE(FSYS OR [COMMA,RPARENT,COLON]);
08300 LOADADDRESS;
08400 IF NOT COMPTYPES(INTPTR,GATTR.TYPTR)
08500 THEN ERROR(458);
08600 END
08700 else begin
08800 incrementregc;
08900 MACRO3(201B%MOVEI\,REGC,0);
09000 end;
09100 if sy = colon
09200 then begin
09300 insymbol;
09400 expression(fsys or [comma,rparent],onfixedregc);
09500 if gattr.typtr#nil
09600 then if (gattr.typtr^.form = power)
09700 then if comptypes(gattr.typtr^.elset, charptr)
09800 then begin
09900 load(gattr);
10000 regc := regc-2;
10100 end
10200 else error(458)
10300 else error(458)
10400 end
10500 else macro3(403B%SETZB\,regc+1,regc+2);
10600 END
10700 ELSE ERROR(458)
10800 ELSE ERROR(458);
10900 END; {of TEXT file case}
11000 (* 171 - read into packed objects *)
11100 REGC := LREGC;
11200 if not (readrec or (laddr in [readstring,readpackedstring]))
11300 then begin
11400 {This is for reading single words, which may go into packed structures.
11500 Note that we have to redo the ac allocation because the read routine
11600 will return a value in AC 3, which quite likely is used as INDEXR or
11700 BPADDR. Since we are pushing the active AC's anyway, we might as well
11800 pop them back into a different place.}
11900 incrementregc; {place that read will return the value}
12000 if (lattr.indexr > regin) and (lattr.indexr <= 10B)
12100 then begin
12200 macro3(261B%PUSH\,topp,lattr.indexr);
12300 incrementregc;
12400 lattr.indexr := regc; {Place to put this value afterwards}
12500 end;
12600 if (lattr.packfg = packk) and (lattr.bpaddr > regin)
12700 and (lattr.bpaddr <= 10B)
12800 then begin
12900 macro3(261B%PUSH\,topp,lattr.bpaddr);
13000 incrementregc;
13100 lattr.bpaddr := regc;
13200 end;
13300 regc := lregc; {restore regc}
13400 support(laddr);
13500 if (lattr.packfg = packk) and (lattr.bpaddr > regin)
13600 and (lattr.bpaddr <= 10B)
13700 then macro3(262B%POP\,topp,lattr.bpaddr);
13800 if (lattr.indexr > regin) and (lattr.indexr <= 10B)
13900 then macro3(262B%POP\,topp,lattr.indexr);
14000 fetchbasis(lattr); {Now do the store}
14100 store(regc+1,lattr)
14200 end
14300 else SUPPORT(LADDR);
14400 EXIT IF SY # COMMA;
14500 INSYMBOL;
14600 VARIABLE(FSYS OR [COMMA,COLON,RPARENT]);
14700 END;
14800 IF LKEY = 8
14900 THEN SUPPORT(GETLINE)
15000 END %READREADLN\ ;
15100
15200 (* 42 - move breakin to close *)
15300 (* 43 - add putx *)
15400 procedure putx;
15500 begin
15600 (* 175 *)
15700 getfn(true);
15800 (* 61 - add delete *)
15900 case lkey of
16000 37: support(putxfile);
16100 41: support(delfile)
16200 end;
16300 end;
16400
16500 PROCEDURE BREAK;
16600 BEGIN
16700 (* 26 - allow non-text files *)
16800 (* 171 - PREDECL FILES ARE SPECIAL *)
16900 GETFILENAME(OUTFILE,FALSE,THISFILE,GOTARG,TRUE);
17000 IF GOTARG THEN ERROR(554);
17100 SUPPORT(BREAKOUTPUT) ;
17200 END ;
17300
17400 (* 10 - ADD CLOSE *)
17500 (* 15 - AND ALLOW OPT. PARAM FOR CLOSE BITS *)
17600 (* 42 - move breakin here, to allow param to suppress get *)
17700 PROCEDURE CLOSE;
17800 BEGIN
17900 (* 26 - allow non-text files *)
18000 (* 61 - rclose for tops20 *)
18100 if (lkey = 25) or (lkey = 42)
18200 (* 171 - PREDECL FILES ARE SPECIAL *)
18300 (* 204 - don't validity check CLOSE and RCLOSE *)
18400 THEN GETFILENAME(OUTFILE,FALSE,THISFILE,GOTARG,FALSE)
18500 else getfilename(INFILE,false,THISFILE,GOTARG,FALSE);
18600 IF GOTARG
18700 THEN LOAD(GATTR)
18800 ELSE BEGIN
18900 INCREMENTREGC;
19000 MACRO3(201B%MOVEI\,REGC,0)
19100 END;
19200 (* 45 - add NEXTBLOCK *)
19300 (* 61 - add RCLOSE *)
19400 case lkey of
19500 25: support(closefile);
19600 34: support(breakinput);
19700 39: support(nextblockf);
19800 42: support(relfile)
19900 end;
20000 END;
20100
20200 (* 14 - ADD DUMP MODE STUFF *)
20300 (* 42 - allow variable size *)
20400 PROCEDURE DUMP;
20500 VAR FILEP:ATTR; s:integer;
20600 BEGIN
20700 (* 175 *)
20800 GETFN(TRUE);
20900 FILEP:=GATTR;
21000 IF SY=COMMA
21100 THEN INSYMBOL
21200 ELSE ERROR(158);
21300 EXPRESSION(FSYS OR[COMMA,RPARENT],ONFIXEDREGC);
21400 LOADADDRESS;
21500 if gattr.typtr#nil
21600 then s:=gattr.typtr^.size;
21700 if sy=comma
21800 then
21900 begin
22000 insymbol;
22100 expression(fsys or [rparent],onfixedregc);
22200 if comptypes(intptr,gattr.typtr)
22300 then load(gattr)
22400 else error(458);
22500 if runtmcheck
22600 then begin
22700 macro3(303b%caile\,regc,s);
22800 support(indexerror)
22900 end
23000 end
23100 else
23200 begin
23300 INCREMENTREGC;
23400 MACRO3(201B%MOVEI\,REGC,GATTR.TYPTR^.SIZE)
23500 end;
23600 IF LKEY=30
23700 THEN SUPPORT(READDUMP)
23800 ELSE SUPPORT(WRITEDUMP)
23900 END;
24000
24100 PROCEDURE USET;
24200 VAR FILEP:ATTR;
24300 BEGIN
24400 (* 175 *)
24500 GETFN(TRUE);
24600 FILEP:=GATTR;
24700 IF SY = COMMA
24800 THEN INSYMBOL
24900 ELSE ERROR(158);
25000 (* 43 - new optional arg for useti *)
25100 EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
25200 LOAD(GATTR);
25300 IF GATTR.TYPTR=NIL
25400 THEN ERROR(458)
25500 ELSE IF GATTR.TYPTR#INTPTR
25600 THEN ERROR(458);
25700 (* 44 - add SETPOS and SKIP *)
25800 IF LKEY # 33
25900 (* 43 - new optional arg for useti *)
26000 then begin
26100 if sy=comma
26200 then begin
26300 insymbol;
26400 expression(fsys or [rparent],onfixedregc);
26500 load(gattr);
26600 end
26700 else begin
26800 incrementregc;
26900 macro3(201b%movei\,regc,0)
27000 end;
27100 case lkey of
27200 32:support(setin);
27300 38:support(setposf)
27400 end
27500 end
27600 ELSE SUPPORT(SETOUT)
27700 END;
27800
27900 PROCEDURE WRITEWRITELN;
28000 VAR
28100 LSP: STP; DEFAULT,REALFORMAT,WRITEOCT: BOOLEAN; LSIZE,LMIN,LMAX: INTEGER; LADDR: SUPPORTS;
28200 (* 171 - write records *)
28300 writerec: Boolean;
28400 BEGIN
28500 (* 171 - PREDECL FILES ARE GLOBAL, ALSO ALLOW READ OF RECORD *)
28600 {First scan file name and see if binary file}
28700 IF LKEY = 10 {WRITE?}
28800 THEN GETFILENAME(OUTFILE,FALSE,THISFILE,GOTARG,TRUE) {Yes, might be binary}
28900 ELSE GETFILENAME(OUTFILE,TRUE,THISFILE,GOTARG,TRUE); {No, WRITELN not legal for binary files}
29000 IF (LKEY = 10) AND NOT GOTARG
29100 THEN ERROR(554);
29200 WRITEREC := FALSE;
29300 IF LKEY = 10 {Now see if it was a binary file}
29400 THEN IF NOT COMPTYPES(CHARPTR,THISFILE^.FILTYPE)
29500 THEN WRITEREC := TRUE;
29600 IF GOTARG
29700 THEN
29800 LOOP
29900 (* 22 - INITIALIZE LADDR IN CASE OF ERRORS. PREVENTS ILL MEM REF *)
30000 (* 206 - moved initialization below *)
30100 LSP := GATTR.TYPTR; LSIZE := LGTH; WRITEOCT := FALSE;
30200 IF LSP # NIL
30300 THEN
30400 (* 206 - make non-text files work for constants *)
30500 {Note that the values of LADDR set here are used only for binary files.
30600 LADDR is reset below for text files. Only in case of error will these
30700 values remain for a text file, and in that case having them prevents
30800 an ill mem ref}
30900 IF LSP^.FORM <= POWER
31000 THEN BEGIN LOAD(GATTR); LADDR := WRITESCALAR END
31100 ELSE
31200 BEGIN
31300 IF (GATTR.KIND = VARBL)
31400 AND
31500 (GATTR.INDEXR = TOPP)
31600 THEN ERROR(458);
31700 LOADADDRESS;
31800 LADDR := WRITERECORD;
31900 END;
32000 (* 206 - make non-text files work for constants *)
32100 IF WRITEREC
32200 THEN BEGIN {For binary files, make sure of type match}
32300 IF GATTR.TYPTR#NIL
32400 THEN IF NOT COMPTYPES(THISFILE^.FILTYPE,GATTR.TYPTR)
32500 THEN ERROR(260);
32600 END {end binary}
32700 ELSE BEGIN
32800 IF SY = COLON
32900 THEN
33000 BEGIN
33100 INSYMBOL; EXPRESSION(FSYS OR [COMMA,COLON,RPARENT],ONFIXEDREGC);
33200 IF GATTR.TYPTR # NIL
33300 THEN
33400 IF GATTR.TYPTR # INTPTR
33500 THEN ERROR(458);
33600 LOAD(GATTR); DEFAULT := FALSE;
33700 END
33800 ELSE
33900 BEGIN
34000 DEFAULT := TRUE; INCREMENTREGC %RESERVE REGISTER FOR DEFAULT VALUE\
34100 END ;
34200 IF LSP = INTPTR
34300 THEN
34400 BEGIN
34500 LADDR := WRITEINTEGER ; LSIZE := 12
34600 END;
34700 IF SY = COLON
34800 THEN
34900 BEGIN
35000 INSYMBOL;
35100 IF (SY = IDENT) AND ((ID='O ') OR (ID='H '))
35200 THEN
35300 BEGIN
35400 IF NOT COMPTYPES(LSP,INTPTR)
35500 THEN ERROR(262);
35600 IF ID = 'O '
35700 THEN LADDR := WRITEOCTAL
35800 ELSE
35900 BEGIN
36000 LADDR := WRITEHEXADECIMAL; LSIZE := 11
36100 END;
36200 INSYMBOL
36300 END
36400 ELSE
36500 BEGIN
36600 EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
36700 IF GATTR.TYPTR # NIL
36800 THEN
36900 IF GATTR.TYPTR # INTPTR
37000 THEN ERROR(458);
37100 IF LSP # REALPTR
37200 THEN ERROR(258);
37300 LOAD(GATTR); REALFORMAT := FALSE
37400 END
37500 END
37600 ELSE REALFORMAT := TRUE;
37700 IF LSP = INTPTR
37800 THEN GOTO 1;
37900 IF LSP = CHARPTR
38000 THEN
38100 BEGIN
38200 LSIZE := 1; LADDR := WRITECHARACTER
38300 END
38400 ELSE
38500 IF LSP = REALPTR
38600 THEN
38700 BEGIN
38800 LSIZE := 16; LADDR := WRITEREAL;
38900 IF REALFORMAT
39000 THEN MACRO3(201B%MOVEI\,REGIN+4,123456B);
39100 END
39200 ELSE
39300 IF LSP = BOOLPTR
39400 THEN
39500 BEGIN
39600 LSIZE := 6; LADDR := WRITEBOOLEAN
39700 END
39800 ELSE
39900 IF LSP # NIL
40000 THEN
40100 BEGIN
40200 IF LSP^.FORM = SCALAR
40300 THEN ERROR(169)
40400 ELSE
40500 IF STRING(LSP)
40600 THEN
40700 BEGIN
40800 IF LSP^.INXTYPE#NIL
40900 THEN
41000 BEGIN
41100 GETBOUNDS(LSP^.INXTYPE,LMIN,LMAX);
41200 LSIZE := LMAX-LMIN+1;
41300 END;
41400 MACRO3(201B%MOVEI\,REGIN+4,LSIZE);
41500 IF LSP^.ARRAYPF
41600 THEN LADDR := WRITEPACKEDSTRING
41700 ELSE LADDR := WRITESTRING ;
41800 END
41900 ELSE ERROR(458)
42000 END;
42100 1:
42200 IF DEFAULT
42300 THEN MACRO3(201B%MOVEI\,REGIN+3,LSIZE);
42400 END; {of IF WRITEREC}
42500 SUPPORT(LADDR);
42600 REGC :=REGIN + 1;
42700 EXIT IF SY # COMMA;
42800 INSYMBOL;
42900 (* 206 - allow constants for records *)
43000 EXPRESSION(FSYS OR [COMMA,COLON,RPARENT],ONFIXEDREGC);
43100 END;
43200 IF LKEY = 11
43300 THEN SUPPORT(PUTLINE) ;
43400 END %WRITE\ ;
43500
43600 (* 6 - PACK and UNPACK have been rewritten to be as described in Jensen and Wirth *)
43700 PROCEDURE PACK;
43800
43900 % PACK(A,I,Z) MEANS:
44000 FOR L := LMIN(Z) TO LMAX(Z) DO Z[L] := A[L-LMIN(Z)+I] \
44100
44200 VAR
44300 ARRAY1,OFFSET1,ARRAY2,OFFSET2: ATTR;
44400 LADDR,START,STOP,LMIN1,LMAX1,LMIN2,LMAX2: ADDRRANGE;
44500 LREGC: ACRANGE;
44600
44700 BEGIN
44800 LREGC := REGC; START := 0;
44900 VARIABLE(FSYS OR [COMMA,RPARENT]);
45000 LOADADDRESS;
45100 WITH GATTR DO
45200 BEGIN
45300 KIND := EXPR; REG := INDEXR;
45400 (* 135 prevent ill mem ref if not a variable *)
45500 IF TYPTR = NIL
45600 THEN TYPTR := UARRTYP
45700 ELSE WITH TYPTR^ DO
45800 IF FORM # ARRAYS
45900 THEN ERROR(458)
46000 ELSE
46100 IF ARRAYPF
46200 THEN ERROR(458)
46300 END;
46400 ARRAY1 := GATTR;
46500 IF SY = COMMA
46600 THEN INSYMBOL
46700 ELSE ERROR(158);
46800 EXPRESSION(FSYS OR [COMMA,RPARENT],ONREGC);
46900 IF GATTR.TYPTR # NIL
47000 THEN
47100 IF GATTR.TYPTR^.FORM # SCALAR
47200 THEN ERROR(458)
47300 ELSE
47400 IF NOT COMPTYPES(ARRAY1.TYPTR^.INXTYPE,GATTR.TYPTR)
47500 THEN ERROR(458);
47600 OFFSET1 := GATTR;
47700 IF SY = COMMA
47800 THEN INSYMBOL
47900 ELSE ERROR(158);
48000 VARIABLE(FSYS OR [RPARENT]);
48100 LOADADDRESS;
48200 WITH GATTR DO
48300 BEGIN
48400 KIND := EXPR; REG := INDEXR;
48500 IF TYPTR # NIL
48600 THEN WITH TYPTR^ DO
48700 IF FORM # ARRAYS
48800 THEN ERROR(458)
48900 ELSE
49000 IF NOT ARRAYPF
49100 OR
49200 NOT (COMPTYPES(AELTYPE,ARRAY1.TYPTR^.AELTYPE)
49300 AND
49400 COMPTYPES(INXTYPE,ARRAY1.TYPTR^.INXTYPE))
49500 THEN ERROR(458)
49600 END;
49700 ARRAY2 := GATTR;
49800
49900 IF NOT ERRORFLAG
50000 THEN
50100 BEGIN
50200 GETBOUNDS(ARRAY1.TYPTR^.INXTYPE,LMIN1,LMAX1); LMAX1 := LMAX1 - LMIN1;
50300 GETBOUNDS(ARRAY2.TYPTR^.INXTYPE,LMIN2,LMAX2); LMAX2 := LMAX2 - LMIN2;
50400 WITH OFFSET2 DO %MAKE OFFSET2 A CONST = LMAX2+1 \
50500 BEGIN
50600 TYPTR := INTPTR;
50700 KIND := CST;
50800 CVAL.IVAL := LMAX2 + 1
50900 END;
51000 IF (OFFSET1.KIND = CST)
51100 THEN
51200 BEGIN
51300 STOP := OFFSET2.CVAL.IVAL;
51400 START := OFFSET1.CVAL.IVAL - LMIN1;
51500 IF (START < 0) OR (START > (LMAX1+1-STOP))
51600 THEN ERROR(263);
51700 MACRO3(505B%HRLI\,ARRAY1.REG,-STOP);
51800 END
51900 ELSE
52000 BEGIN
52100 LOAD(OFFSET2);
52200 WITH OFFSET2 DO
52300 MACRO3(210B%MOVN\,REG,REG);
52400 LOAD(OFFSET1);
52500 WITH OFFSET1 DO
52600 BEGIN
52700 IF LMIN1 > 0
52800 THEN MACRO3(275B%SUBI\,REG,LMIN1)
52900 ELSE
53000 IF LMIN1 < 0
53100 THEN MACRO3(271B%ADDI\,REG,-LMIN1);
53200 IF RUNTMCHECK
53300 THEN
53400 BEGIN
53500 MACRO3(301B%CAIL\,REG,0);
53600 MACRO4(303B%CAILE\,REG,OFFSET2.REG,LMAX1+1);
53700 SUPPORT(INDEXERROR)
53800 END;
53900 MACRO3(270B%ADD\,ARRAY1.REG,REG);
54000 MACRO4(505B%HRLI\,ARRAY1.REG,OFFSET2.REG,0)
54100 END
54200 END;
54300 INCREMENTREGC;
54400 MACRO3(540B%HRR\,TAC,ARRAY2.REG);
54500 MACRO3R(200B%MOVE\,REGC,ARRAY2.TYPTR^.ARRAYBPADDR);
54600 LADDR := IC;
54700 MACRO4(200B%MOVE\,HAC,ARRAY1.REG,START);
54800 MACRO3(136B%IDPB\,HAC,REGC);
54900 MACRO3R(253B%AOBJN\,ARRAY1.REG,LADDR)
55000 END;
55100 REGC := LREGC
55200 END;
55300
55400 PROCEDURE UNPACK;
55500
55600 % UNPACK(Z,A,I) MEANS:
55700 FOR L := LMIN(Z) TO LMAX(Z) DO A[L-LMIN(Z)+I] := Z[L] \
55800
55900 VAR
56000 ARRAY1,OFFSET1,ARRAY2,OFFSET2: ATTR;
56100 LADDR,START,STOP,LMIN1,LMAX1,LMIN2,LMAX2: ADDRRANGE;
56200 LREGC: ACRANGE;
56300
56400 BEGIN
56500 LREGC := REGC; START := 0;
56600 VARIABLE(FSYS OR [COMMA,RPARENT]);
56700 LOADADDRESS;
56800 WITH GATTR DO
56900 BEGIN
57000 KIND := EXPR; REG := INDEXR;
57100 (* 135 - prevent ill mem ref if not a variable *)
57200 IF TYPTR = NIL
57300 THEN TYPTR := UARRTYP
57400 ELSE WITH TYPTR^ DO
57500 IF FORM # ARRAYS
57600 THEN ERROR(458)
57700 ELSE
57800 IF NOT ARRAYPF
57900 THEN ERROR(458)
58000 END;
58100 ARRAY1 := GATTR;
58200 IF SY = COMMA
58300 THEN INSYMBOL
58400 ELSE ERROR(158);
58500 VARIABLE(FSYS OR [COMMA,RPARENT]);
58600 LOADADDRESS;
58700 WITH GATTR DO
58800 BEGIN
58900 KIND := EXPR; REG := INDEXR;
59000 (* 135 - prevent ill mem ref if not a variable *)
59100 IF TYPTR = NIL
59200 THEN TYPTR := UARRTYP
59300 ELSE WITH TYPTR^ DO
59400 IF FORM # ARRAYS
59500 THEN ERROR(458)
59600 ELSE
59700 IF ARRAYPF
59800 OR
59900 NOT (COMPTYPES(AELTYPE,ARRAY1.TYPTR^.AELTYPE)
60000 AND
60100 COMPTYPES(INXTYPE,ARRAY1.TYPTR^.INXTYPE))
60200 THEN ERROR(458)
60300 END;
60400 ARRAY2 := GATTR;
60500 IF SY = COMMA
60600 THEN INSYMBOL
60700 ELSE ERROR(158);
60800 EXPRESSION(FSYS OR [RPARENT],ONREGC);
60900 IF GATTR.TYPTR # NIL
61000 THEN
61100 IF GATTR.TYPTR^.FORM # SCALAR
61200 THEN ERROR(458)
61300 ELSE
61400 IF NOT COMPTYPES(ARRAY2.TYPTR^.INXTYPE,GATTR.TYPTR)
61500 THEN ERROR(458);
61600 OFFSET2 := GATTR;
61700
61800 IF NOT ERRORFLAG
61900 THEN
62000 BEGIN
62100 GETBOUNDS(ARRAY1.TYPTR^.INXTYPE,LMIN1,LMAX1); LMAX1 := LMAX1 - LMIN1;
62200 GETBOUNDS(ARRAY2.TYPTR^.INXTYPE,LMIN2,LMAX2); LMAX2 := LMAX2 - LMIN2;
62300 WITH OFFSET1 DO %MAKE OFFSET1 A CONST = LMAX1+1 \
62400 BEGIN
62500 TYPTR := INTPTR;
62600 KIND := CST;
62700 CVAL.IVAL := LMAX1 + 1
62800 END;
62900 IF (OFFSET2.KIND = CST)
63000 THEN
63100 BEGIN
63200 STOP := OFFSET1.CVAL.IVAL;
63300 START := OFFSET2.CVAL.IVAL - LMIN2;
63400 IF (START < 0) OR (START > (LMAX2+1-STOP))
63500 THEN ERROR(263);
63600 MACRO3(505B%HRLI\,ARRAY2.REG,-STOP);
63700 END
63800 ELSE
63900 BEGIN
64000 LOAD(OFFSET1);
64100 WITH OFFSET1 DO
64200 MACRO3(210B%MOVN\,REG,REG);
64300 LOAD(OFFSET2);
64400 WITH OFFSET2 DO
64500 BEGIN
64600 IF LMIN2 > 0
64700 THEN MACRO3(275B%SUBI\,REG,LMIN2)
64800 ELSE
64900 IF LMIN2 < 0
65000 THEN MACRO3(271B%ADDI\,REG,-LMIN2);
65100 IF RUNTMCHECK
65200 THEN
65300 BEGIN
65400 MACRO3(301B%CAIL\,REG,0);
65500 MACRO4(303B%CAILE\,REG,OFFSET1.REG,LMAX2+1);
65600 SUPPORT(INDEXERROR)
65700 END;
65800 MACRO3(270B%ADD\,ARRAY2.REG,REG);
65900 MACRO4(505B%HRLI\,ARRAY2.REG,OFFSET1.REG,0)
66000 END
66100 END;
66200 INCREMENTREGC;
66300 MACRO3(540B%HRR\,TAC,ARRAY1.REG);
66400 MACRO3R(200B%MOVE\,REGC,ARRAY1.TYPTR^.ARRAYBPADDR);
66500 LADDR := IC;
66600 MACRO3(134B%ILDB\,HAC,REGC);
66700 MACRO4(202B%MOVEM\,HAC,ARRAY2.REG,START);
66800 MACRO3R(253B%AOBJN\,ARRAY2.REG,LADDR)
66900 END;
67000 REGC := LREGC
67100 END;
67200
67300
67400 PROCEDURE NEW;
67500 CONST
67600 TAGFMAX=5;
67700 VAR
67800 (* 42 - move GET and PUT here *)
67900 (* 47 - add GETX and RECSIZE - no other comments in body *)
68000 adr:supports; sizereg:acrange;
68100 LSP,LSP1: STP; VARTS,LMIN,LMAX: INTEGER;
68200 FIRSTLOAD:BOOLEAN;
68300 LSIZE,LSZ: ADDRRANGE; LVAL: VALU;
68400 LATTR: ATTR; I,TAGFC: INTEGER;
68500 TAGFSAV: ARRAY[0..TAGFMAX] OF RECORD
68600 TAGFVAL: INTEGER;
68700 TAGFADDR: ADDRRANGE;
68800 LPACKKIND:PACKKIND;
68900 (* 21 - KEEP FROM STORING TAG VALUE IF NO PLACE TO PUT IT *)
69000 TAGWITHID:BOOLEAN
69100 END;
69200 BEGIN
69300 FOR I:=0 TO TAGFMAX DO TAGFSAV[I].TAGWITHID := FALSE;
69400 (* 42 - move GET and PUT in here *)
69500 (* 73 - restructure to use GETFN for file names, to allow extern files *)
69600 (* 152 - DISPOSE *)
69700 (* 153 - repair AC usage in DISPOSE *)
69800 if lkey = 44 {dispose}
69900 then begin
70000 incrementregc; incrementregc;
70100 sizereg := regc;
70200 variable(fsys or [comma,colon,rparent]);
70300 lattr := gattr; {We have to use a local copy so that
70400 if AC1 is loaded here, that fact is
70500 not saved for the store later.}
70600 fetchbasis(lattr);
70700 with lattr do {modelled after loadaddress}
70800 macro(vrelbyte,200B%MOVE\,sizereg-1,indbit,indexr,dplmt);
70900 end
71000 (* 162 - fix RECSIZE *)
71100 else if lkey in [14,35]
71200 then begin (* all except file names *)
71300 incrementregc; sizereg := regc ;
71400 VARIABLE(FSYS OR [COMMA,COLON,RPARENT]);
71500 end
71600 (* 175 - validate files for get and put stuff, but not for RECSIZE,
71700 which seems OK even if the file isn't open yet *)
71800 else begin getfn(lkey in [1,3,40]); sizereg := regin+2 end;
71900 LSP := NIL; VARTS := 0; LSIZE := 0; TAGFC := -1;
72000 LATTR := GATTR;
72100 IF GATTR.TYPTR # NIL
72200 THEN
72300 WITH GATTR.TYPTR^ DO
72400 (* 42 - move GET and PUT in here *)
72500 (* 152 - dispose *)
72600 (* 162 - fix RECSIZE *)
72700 if (lkey in [14,35,44]) and (form=pointer) or
72800 (lkey in [1,3,15,40]) and (form=files)
72900 THEN
73000 BEGIN %WARNING: This code depends upon fact that ELTYPE and FILTYPE are in the same place\
73100 IF ELTYPE # NIL
73200 THEN
73300 BEGIN
73400 LSIZE := ELTYPE^.SIZE;
73500 IF ELTYPE^.FORM = RECORDS
73600 THEN
73700 BEGIN
73800 LSP := ELTYPE^.RECVAR;
73900 END
74000 ELSE
74100 IF ELTYPE^.FORM = ARRAYS
74200 THEN LSP := ELTYPE
74300 END
74400 END
74500 ELSE ERROR(458);
74600 WHILE SY = COMMA DO
74700 BEGIN
74800 INSYMBOL; CONSTANT(FSYS OR [COMMA,COLON,RPARENT],LSP1,LVAL);
74900 VARTS := VARTS + 1;
75000 %CHECK TO INSERTADDR HERE: IS CONSTANT IN TAGFIELDTYPE RANGE\
75100 IF LSP = NIL
75200 THEN ERROR(408)
75300 ELSE
75400 IF STRING(LSP1) OR (LSP1=REALPTR)
75500 THEN ERROR(460)
75600 ELSE
75700 BEGIN
75800 TAGFC := TAGFC + 1;
75900 IF TAGFC > TAGFMAX
76000 THEN
76100 BEGIN
76200 ERROR(409);TAGFC := TAGFMAX; GOTO 1
76300 END;
76400 IF LSP^.FORM = TAGFWITHID
76500 THEN
76600 BEGIN
76700 IF LSP^.TAGFIELDP # NIL
76800 THEN
76900 IF COMPTYPES(LSP^.TAGFIELDP^.IDTYPE,LSP1)
77000 THEN
77100 WITH TAGFSAV[TAGFC],LSP^.TAGFIELDP^ DO
77200 BEGIN
77300 TAGFVAL := LVAL.IVAL;
77400 TAGFADDR:= FLDADDR;
77500 LPACKKIND:= PACKF;
77600 (* 21 - KEEP FROM STORING TAG VALUE INTO NON-EXISTENT FIELD *)
77700 TAGWITHID:=TRUE
77800 END
77900 ELSE
78000 BEGIN
78100 ERROR(458);GOTO 1
78200 END
78300 END
78400 ELSE
78500 IF LSP^.FORM=TAGFWITHOUTID
00100 THEN
00200 BEGIN
00300 IF NOT COMPTYPES(LSP^.TAGFIELDTYPE,LSP1)
00400 THEN
00500 BEGIN
00600 ERROR(458); GOTO 1
00700 END
00800 END
00900 ELSE
01000 BEGIN
01100 ERROR(358);GOTO 1
01200 END;
01300 LSP1 := LSP^.FSTVAR;
01400 WHILE LSP1 # NIL DO
01500 WITH LSP1^ DO
01600 IF VARVAL.IVAL = LVAL.IVAL
01700 THEN
01800 BEGIN
01900 LSIZE :=SIZE; LSP := SUBVAR; GOTO 1
02000 END
02100 ELSE LSP1:=NXTVAR;
02200 LSIZE := LSP^.SIZE; LSP := NIL
02300 END;
02400 1:
02500 END %WHILE\ ;
02600 IF SY = COLON
02700 THEN
02800 BEGIN
02900 INSYMBOL;
03000 EXPRESSION(FSYS OR [RPARENT],ONREGC);
03100 IF LSP = NIL
03200 THEN ERROR(408)
03300 ELSE
03400 IF LSP^.FORM # ARRAYS
03500 THEN ERROR(259)
03600 ELSE
03700 BEGIN
03800 IF NOT COMPTYPES(GATTR.TYPTR,LSP^.INXTYPE)
03900 THEN
04000 ERROR(458);
04100 LSZ := 1; LMIN := 1;
04200 IF LSP^.INXTYPE # NIL
04300 THEN
04400 GETBOUNDS(LSP^.INXTYPE,LMIN,LMAX);
04500 IF LSP^.AELTYPE # NIL
04600 THEN LSZ := LSP^.AELTYPE^.SIZE;
04700 LOAD(GATTR);
04800 (* 47 - add bounds checking *)
04900 if runtmcheck
05000 then begin
05100 macro3(301B%cail\,regc,lmin);
05200 macro3(303B%caile\,regc,lmax);
05300 support(indexerror)
05400 end;
05500 IF LSZ # 1
05600 THEN
05700 MACRO3(221B%IMULI\,REGC,LSZ);
05800 IF LSP^.ARRAYPF
05900 THEN
06000 BEGIN
06100 (* 30 - added BITMAX DIV, per Nagel's instructions *)
06200 (* 47 - repair calculation, and adjust for LMIN *)
06300 lsz := bitmax div lsp^.aeltype^.bitsize-1-(lmin-1);
06400 if lsz > 0
06500 then macro3(271B%addi\,regc,lsz)
06600 else if lsz < 0
06700 then macro3(275B%subi\,regc,-lsz);
06800 INCREMENTREGC; REGC := REGC - 1;
06900 %FOR TESTING BECAUSE IDIV WORKS ON AC+1 TOO\
07000 MACRO3(231B%IDIVI\,REGC,BITMAX DIV LSP^.AELTYPE^.BITSIZE);
07100 LSZ := LSIZE - LSP^.SIZE;
07200 END
07300 ELSE
07400 LSZ := LSIZE - LSP^.SIZE - LSZ*(LMIN - 1);
07500 (* 42 - change for GET and PUT *)
07600 MACRO4(201B%MOVEI\,SIZEREG,REGC,LSZ);
07700 END
07800 END
07900 ELSE MACRO3(201B%MOVEI\,SIZEREG,LSIZE);
08000 (* 24 - DON'T ZERO CORE UNLESS CHECKING *)
08100 (* 25 - USE /ZERO NOW INSTEAD *)
08200 (* 27 - add NEWZ *)
08300 (* 42 - move get and put in here *)
08400 if lattr.typtr # nil
08500 then begin
08600 case lkey of
08700 1:if comptypes(lattr.typtr^.filtype,charptr)
08800 then adr := getcharacter
08900 else adr := getfile;
09000 3:adr := putfile;
09100 14:if zero
09200 then adr := clearalloc
09300 else adr := allocate;
09400 15:with gattr do
09500 begin typtr:=intptr; reg:=sizereg;kind:=expr;regc:=sizereg end;
09600 35:adr := clearallocate;
09700 40:if comptypes(lattr.typtr^.filtype,charptr)
09800 then error(458)
09900 else adr:=getxf;
10000 (* 173 - internal files *)
10100 44:if lattr.typtr^.eltype <> nil
10200 then if lattr.typtr^.eltype^.hasfile
10300 then adr := withfiledeallocate
10400 else adr := deallocate
10500 else adr := deallocate
10600 end;
10700 {Perhaps this is premature optimization, but NEW and DISPOSE do not save any
10800 ac's. Hence any that are active here have to be saved by the caller. Since
10900 only ac's 1 to 6 are used by the NEW and DISPOSE, we save only things <= 6:
11000 any WITH ac's <= 6 (a fairly rare case)
11100 lattr.indexr, if it is <= 6. This is used in cases such as
11200 new(a^.b^.c)
11300 to save information needed to get to C again after the call.
11400 ac 1 sometimes contains the display pointer for a higher-level block.
11500 However by gerrymandering LATTR, we force this to be recomputed after
11600 the call by FETCHBASIS, so it is not saved.
11700 }
11800 (* 154 - don't clobber With AC's *)
11900 if (lkey in [14,35,44]) and (regcmax < 6)
12000 then for i := 0 to withix do
12100 with display[top-i] do
12200 if (cindr#0) and (cindr <= 6)
12300 then macro4(202B%MOVEM\,cindr,basis,clc);
12400 (* 153 - save AC's *)
12500 (* 154 - don't need to save WITH acs *)
12600 (* 171 - more AC saving *)
12700 if (lkey in [14,35,44])
12800 then begin
12900 if (lattr.indexr > regin) and (lattr.indexr <= 6)
13000 then macro3(261B%PUSH\,topp,lattr.indexr);
13100 if (lattr.packfg = packk) and (lattr.bpaddr > regin)
13200 and (lattr.bpaddr <= 6)
13300 then macro3(261B%PUSH\,topp,lattr.bpaddr);
13400 support(adr);
13500 if (lattr.packfg = packk) and (lattr.bpaddr > regin)
13600 and (lattr.bpaddr <= 6)
13700 then macro3(262B%POP\,topp,lattr.bpaddr);
13800 if (lattr.indexr > regin) and (lattr.indexr <= 6)
13900 then macro3(262B%POP\,topp,lattr.indexr);
14000 end
14100 else if lkey#15
14200 then support(adr);
14300 (* 154 - restore WITH ac's *)
14400 if (lkey in [14,35,44]) and (regcmax < 6)
14500 then for i := 0 to withix do
14600 with display[top-i] do
14700 if (cindr#0) and (cindr <= 6)
14800 then macro4(200B%MOVE\,cindr,basis,clc);
14900 end;
15000 if (lkey=14)or(lkey=35)
15100 then begin
15200 REGC := REGIN+1;
15300 FIRSTLOAD := TRUE;
15400 FOR I := 0 TO TAGFC DO
15500 WITH TAGFSAV[I] DO
15600 (* 21 - KEEP FROM STORING TAG VALUE INTO NON-EXISTENT FIELD *)
15700 IF TAGWITHID THEN
15800 BEGIN
15900 MACRO3(201B%MOVEI\,HAC,TAGFVAL);
16000 CASE LPACKKIND OF
16100 NOTPACK: MACRO4(202B%MOVEM\,HAC,REGC,TAGFADDR);
16200 HWORDR:MACRO4(542B%HRRM\,HAC,REGC,TAGFADDR);
16300 HWORDL:MACRO4(506B%HRLM\,HAC,REGC,TAGFADDR);
16400 PACKK :
16500 BEGIN
16600 IF FIRSTLOAD
16700 THEN
16800 BEGIN
16900 MACRO3(200B%MOVE\,TAC,REGC);
17000 FIRSTLOAD := FALSE
17100 END;
17200 MACRO3R(137B%DPB\,HAC,TAGFADDR)
17300 END
17400 END%CASE\
17500 END;
17600 STORE(REGC,LATTR)
17700 (* 42 - move GET and PUT in here *)
17800 end
17900 (* 152 - DISPOSE *)
18000 (* 153 - make reg usage safer *)
18100 else if lkey=44
18200 then begin
18300 incrementregc;
18400 macro3(201B%MOVEI\,regc,377777B%nil\);
18500 store(regc,lattr)
18600 end
18700 END %NEW\ ;
18800
18900 (* 46 - major reorganization to handle all arg formats *)
19000 PROCEDURE CALLI;
19100 type argform=(bareac,xwd,twowords,oneword);
19200 VAR LSP:STP; LVAL,acval:VALU;
19300 LH,RH,BOOL,RESUL:ATTR;
19400 arg:argform;
19500 BEGIN
19600 arg := xwd; %default format\
19700 CONSTANT(FSYS OR [RPARENT,COMMA],LSP,LVAL);
19800 IF NOT(COMPTYPES(INTPTR,LSP))
19900 THEN ERROR(458);
20000 IF SY = COMMA
20100 THEN INSYMBOL
20200 ELSE ERROR(158);
20300 if sy=comma %,,word\
20400 then begin
20500 insymbol;
20600 arg := oneword;
20700 expression(fsys or [rparent,comma],onregc);
20800 load(gattr);
20900 lh := gattr
21000 end
21100 else if sy=colon %:ac\
21200 then begin
21300 arg := bareac;
21400 insymbol;
21500 constant(fsys or [rparent,comma],lsp,acval);
21600 if not(comptypes(intptr,lsp))
21700 then error(458)
21800 end
21900 else begin %lh,rh or w1:w2\
22000 EXPRESSION(FSYS OR [RPARENT,COMMA,COLON],ONREGC);
22100 LOAD(GATTR);
22200 LH := GATTR;
22300 IF SY = COMMA
22400 THEN INSYMBOL
22500 else if sy=colon
22600 then begin arg:=twowords; insymbol end
22700 else error(158);
22800 EXPRESSION(FSYS OR [RPARENT,COMMA],ONREGC);
22900 IF GATTR.TYPTR # NIL
23000 THEN IF (GATTR.TYPTR^.FORM <= POWER) or (arg=twowords)
23100 THEN LOAD(GATTR)
23200 ELSE BEGIN
23300 LOADADDRESS;
23400 GATTR.KIND:=EXPR;
23500 GATTR.REG:=GATTR.INDEXR
23600 END;
23700 RH := GATTR;
23800 end %of lh,rh and w1:w2\;
23900 IF SY = COMMA
24000 THEN INSYMBOL
24100 ELSE ERROR(158);
24200 VARIABLE(FSYS OR [RPARENT,COMMA]);
24300 IF GATTR.TYPTR = NIL
24400 THEN ERROR(458)
24500 ELSE IF NOT(GATTR.TYPTR^.FORM IN [SUBRANGE,SCALAR])
24600 THEN ERROR(458)
24700 ELSE LOADADDRESS;
24800 RESUL:=GATTR;
24900 IF SY = COMMA
25000 THEN INSYMBOL
25100 ELSE ERROR(158);
25200 VARIABLE(FSYS OR [RPARENT]);
25300 IF NOT COMPTYPES(BOOLPTR,GATTR.TYPTR)
25400 THEN ERROR(158)
25500 ELSE LOADADDRESS;
25600 BOOL := GATTR;
25700 IF NOT ERRORFLAG
25800 THEN BEGIN
25900 case arg of
26000 bareac: regc := acval.ival;
26100 xwd: begin regc := rh.reg; macro3(504B%hrl\,rh.reg,lh.reg) end;
26200 oneword: regc := lh.reg;
26300 twowords: begin
26400 regc := lh.reg;
26500 if (regc+1) # rh.reg
26600 then macro3(200B%move\,regc+1,rh.reg)
26700 end
26800 end %case\;
26900 macro3(201B%movei\,tac,1);
27000 macro4(202B%movem\,tac,bool.indexr,0);
27100 MACRO3(047B%CALLI\,REGC,LVAL.IVAL);
27200 MACRO4(402B%SETZM\,0,BOOL.INDEXR,0);
27300 MACRO4(202B%MOVEM\,REGC,RESUL.INDEXR,0)
27400 END
27500 END;
27600
27700 (* 61 - tops20 system version *)
27800 procedure jsys;
27900 var
28000 lval:valu; lsp:stp; jsysnum,numrets,i:integer;
28100 retsave:attr; saveret,ercal,done1: Boolean;
28200 realregc:acrange;
28300 (* 133 - add variable to allow saving stuff in display *)
28400 savelc:addrrange;
28500 procedure loadarg;
28600 (* Handles input args for jsys:
28700 simple vars - use their values
28800 sets - use LH word only
28900 files - use jfn word
29000 packed arrays - make byte ptr to it
29100 other - make pointer to it
29200 *)
29300 begin
29400 expression (fsys or [rparent,comma,semicolon,colon],onfixedregc);
29500 if gattr.typtr # nil
29600 then if (gattr.typtr^.form < power)
29700 then load(gattr)
29800 else if (gattr.typtr^.form = power)
29900 then begin
30000 (* 77 - can't treat as integer. have to load both words and throw away 2nd *)
30100 load(gattr);
30200 regc := regc-1;
30300 end
30400 else if (gattr.typtr^.form = files)
30500 then begin
30600 loadaddress;
30700 (* 217 - file expressions *)
30800 if gattr.externctp <> nil
30900 then begin gattr.externctp^.vaddr := ic-1;
31000 code.information[cix] := 'E' end;
31100 macro4(200b%move\,regc,regc,filjfn)
31200 end
31300 else if (gattr.typtr^.form = arrays) and gattr.typtr^.arraypf
31400 then begin
31500 loadaddress;
31600 macro3r(500b%hll\,regc,gattr.typtr^.arraybpaddr);
31700 macro3(621b%tlz\,regc,17b)
31800 end
31900 else loadaddress
32000 end;
32100 procedure storearg;
32200 (* stores results of jsys. As above, but error for
32300 anything bigger than a word *)
32400 begin
32500 variable(fsys or [rparent,comma]);
32600 if gattr.typtr # nil
32700 then if (gattr.typtr^.form < power)
32800 then store(realregc,gattr)
32900 else if (gattr.typtr^.form = power)
33000 then begin
33100 gattr.typtr := intptr;
33200 store(realregc,gattr)
33300 end
33400 else if (gattr.typtr^.form = files)
33500 then begin
33600 loadaddress; {addr of file now in REGC}
33700 (* 217 - file expressions *)
33800 if gattr.externctp <> nil
33900 then begin gattr.externctp^.vaddr:=ic-1;
34000 code.information[cix] := 'E' end;
34100 (* 173 - internal files *)
34200 {We have to compile code to see if the file is initialized. If not,
34300 call INITB. to do so. INITB. needs the file in AC 2. Note that
34400 the AC use here is such that REGC is always above 2, so the only
34500 reason for 2 not to be free is that realregc is using it. This is
34600 certainly not the best possible code, but at this point I am going
34700 for the last code in the compiler to implement it.}
34800 macro3(250b%exch\,2,regc);
34900 macro4(200b%move\,0,2,filtst);
35000 macro3(302b%caie\,0,314157B);
35100 support(initfileblock);
35200 if realregc = 2
35300 then macro4(202b%movem\,regc,2,filjfn)
35400 else macro4(202b%movem\,realregc,2,filjfn)
35500 end
35600 else error(458)
35700 end;
35800 begin (* jsys *)
35900 ercal := false; saveret := false; numrets := 0; done1 := false;
36000 constant(fsys or [rparent,comma,semicolon],lsp,lval);
36100 jsysnum := lval.ival;
36200 if not comptypes (intptr, lsp)
36300 then error(458);
36400 if sy = comma
36500 then begin (* return spec *)
36600 insymbol;
36700 constant(fsys or [rparent,comma,semicolon],lsp,lval);
36800 if lval.ival < 0
36900 then ercal := true;
37000 numrets := abs(lval.ival);
37100 if not comptypes (intptr, lsp)
37200 then error(458);
37300 if sy = comma
37400 then begin (* return var *)
37500 insymbol;
37600 variable(fsys or [rparent,semicolon]);
37700 if comptypes (intptr,gattr.typtr)
37800 then begin saveret := true; retsave := gattr end
37900 else error (459)
38000 end
38100 end; (* return spec *)
38200 if sy = semicolon
38300 then begin (* prolog *)
38400 insymbol;
38500 regc := 1;
38600 if sy # semicolon
38700 then loop (* non-empty prolog *)
38800 loadarg;
38900 if sy = colon
39000 then begin
39100 insymbol;
39200 realregc := regc;
39300 loadarg;
39400 macro3(504b%hrl\,realregc,realregc);
39500 macro3(540b%hrr\,realregc,regc);
39600 regc := realregc
39700 end;
39800 if not done1
39900 then begin
40000 (* 133 - save in display instead of PUSH P, *)
40100 {Here we prepared a place on the display to store the value}
40200 savelc := lc;
40300 lc := lc+1;
40400 if lc > lcmax
40500 then lcmax := lc;
40600 macro4(202B%movem\,2,basis,savelc);
40700 done1 := true;
40800 regc := 1
40900 end;
41000 exit if sy # comma;
41100 insymbol
41200 end (* non-empty prolog *)
41300 end; (* prolog *)
41400 (* main call *)
41500 if done1
41600 (* 133 - save in display instead of POP P, *)
41700 then begin
41800 macro4(200B%move\,1,basis,savelc);
41900 lc := savelc
42000 end;
42100 if saveret
42200 then macro3(201b%movei\,0,numrets+1);
42300 macro3(104b%jsys\,0,jsysnum);
42400 if ercal
42500 then begin
42600 macro3r(320b%jump\,16b,ic+numrets);
42700 numrets := numrets -1
42800 end;
42900 for i := 1 to numrets do
43000 if saveret then
43100 macro3(275b%subi\,0,1)
43200 else macro3(255b%jfcl\,0,0);
43300 if sy = semicolon (* if epilog, save reg a over store *)
43400 then begin
43500 (* 133 - use display instead of stack to save *)
43600 {find a place in the display to save ac 2}
43700 savelc := lc;
43800 lc := lc + 1;
43900 if lc > lcmax
44000 then lcmax := lc;
44100 macro4(202B%movem\,2,basis,savelc);
44200 macro3(200b%move\,2,1);
44300 done1 := true
44400 end
44500 else done1 := false;
44600 if saveret
44700 then store(0,retsave);
44800 if sy = semicolon
44900 then begin (* epilog *)
45000 realregc := 1;
45100 repeat
45200 insymbol;
45300 regc := 4; (* so temp ac's start at 5 *)
45400 realregc := realregc + 1;
45500 if realregc > 4
45600 then error(458);
45700 storearg;
45800 if done1
45900 then begin
46000 (* 133 - use display instead of stack to store ac 2 *)
46100 macro4(200B%move\,2,basis,savelc);
46200 lc := savelc;
46300 realregc := 1;
46400 done1 := false
46500 end
46600 until sy # comma
46700 end (* epilog *)
46800 end; (* jsys *)
46900
47000 PROCEDURE MARK;
47100 BEGIN
47200 VARIABLE(FSYS OR [RPARENT]);
47300 IF COMPTYPES(INTPTR,GATTR.TYPTR)
47400 THEN
47500 (* 12 - REWRITE FOR NEW DYNAMIC MEMORY *)
47600 (* 122 - retrofit KA code *)
47700 (* 132 - separate KA10 into NOVM and KACPU *)
47800 if novm
47900 then begin
48000 loadaddress;
48100 macro4(202B%movem\,newreg,gattr.indexr,0)
48200 end
48300 else
48400 BEGIN
48500 LOADADDRESS;
48600 INCREMENTREGC;
48700 MACRO3R(200B%MOVE\,REGC,LSTNEW);
48800 LSTNEW:=IC-1; %GLOBAL FIXUP\
48900 MACRO4(202B%MOVEM\,REGC,GATTR.INDEXR,0)
49000 END
49100 ELSE ERROR(459)
49200 END %MARK\ ;
49300
49400 PROCEDURE RELEASE;
49500 BEGIN
49600 EXPRESSION(FSYS OR [RPARENT],ONREGC);
49700 IF GATTR.TYPTR = INTPTR
49800 THEN
49900 BEGIN
50000 (* 12 - RECODE FOR NEW DYNAMIC MEMORY *)
50100 LOAD(GATTR);
50200 (* 122 - retrofit for KA *)
50300 (* 132 - separate KA10 into NOVM and KACPU *)
50400 if novm
50500 then macro3(200B%move\,newreg,regc)
50600 ELSE BEGIN
50700 MACRO3R(202B%MOVEM\,REGC,LSTNEW);
50800 LSTNEW := IC-1; % GLOBAL FIXUP \
50900 end
51000 END
51100 ELSE ERROR(458)
51200 END %RELEASE\ ;
51300
51400 PROCEDURE GETLINENR;
51500 BEGIN
51600 (* 33 - ALLOW GETFILENAME WITH NON-TEXT *)
51700 (* 171 - PREDECL FILES ARE SPECIAL *)
51800 GETFILENAME(INFILE,TRUE,THISFILE,GOTARG,TRUE);
51900 IF NOT GOTARG
52000 THEN ERROR(554);
52100 IF GATTR.KIND <> VARBL
52200 THEN ERROR(458)
52300 ELSE IF GATTR.TYPTR # NIL
52400 THEN
52500 IF COMPTYPES(CHARPTR,GATTR.TYPTR^.AELTYPE) AND (GATTR.TYPTR^.FORM = ARRAYS)
52600 THEN
52700 BEGIN
52800 MACRO4(200B%MOVE\,REGC,REGC,FILLNR); STORE(REGC,GATTR)
52900 END
53000 ELSE ERROR(458);
53100 END;
53200
53300 PROCEDURE GETINTEGERFILENAME(DEFAULTNAME : ALFA);
53400 VAR
53500 LCP : CTP; LID : ALFA;
53600 BEGIN
53700 LID := ID;
53800 ID := DEFAULTNAME; SEARCHID([VARS],LCP);
53900 SELECTOR(FSYS OR FACBEGSYS OR [COMMA], LCP); LOADADDRESS;
54000 WITH LCP^, IDTYPE^ DO
54100 IF (FORM = FILES) AND (VLEV = 0) AND (NOT MAIN)
54200 THEN
54300 BEGIN
54400 VADDR:= IC-1; CODE.INFORMATION[CIX] := 'E'
54500 END;
54600 ID := LID
54700 END;
54800
54900 PROCEDURE PUT8BITSTOTTY;
55000 BEGIN
55100 EXPRESSION(FSYS OR [RPARENT],ONREGC) ;
55200 LOAD(GATTR);
55300 MACRO3(051B%TTCALL\,15B%IONEOU\,GATTR.REG)
55400 END %PUT8BITSTOTTY\ ;
55500
55600 PROCEDURE PAGE;
55700 BEGIN
55800 (* 33 - ALLOW GETFILENAME WITH NON-TEXT *)
55900 (* 171 - PREDECL FILES ARE SPECIAL *)
56000 GETFILENAME(OUTFILE,TRUE,THISFILE,GOTARG,TRUE);
56100 IF GOTARG
56200 THEN ERROR(554);
56300 SUPPORT(PUTPAGE)
56400 END;
56500 (* 63 - support for tops-20 time and runtime *)
56600 procedure jsysf(jsysnum,hireg:integer);
56700 var i:integer;
56800 begin
56900 if hireg > regc
57000 then hireg := regc;
57100 for i := 2 to hireg do
57200 macro3(261B%push\,topp,i);
57300 if jsysnum = 15B
57400 then macro3(211B%movni\,1,5);
57500 macro3(104B%jsys\,0,jsysnum);
57600 with gattr do
57700 begin
57800 incrementregc; typtr := intptr; reg := regc; kind := expr;
57900 macro3(200B%move\,regc,1)
58000 end;
58100 for i := hireg downto 2 do
58200 macro3(262B%pop\,topp,i)
58300 end;
58400
58500
58600 PROCEDURE RUNTIME;
58700 BEGIN
58800 (* 63 - TOPS20 *)
58900 IF TOPS10
59000 THEN WITH GATTR DO
59100 BEGIN
59200 INCREMENTREGC; TYPTR := INTPTR; REG := REGC; KIND := EXPR;
59300 MACRO3(047B,REGC,30B%PJOB-UUO\);
59400 MACRO3(047B,REGC,27B%RUNTIM-UUO\)
59500 END
59600 ELSE JSYSF(15B%RUNTM\,3)
59700 END;
59800
59900 PROCEDURE ABS;
60000 BEGIN
60100 WITH GATTR DO
60200 IF (TYPTR = INTPTR) OR (TYPTR = REALPTR)
60300 THEN
60400 WITH CODE.INSTRUCTION[CIX] DO
60500 IF INSTR = 200B%MOVE\
60600 THEN INSTR := 214B%MOVM\
60700 ELSE MACRO3(214B%MOVM\,REG,REG)
60800 ELSE
60900 BEGIN
61000 ERROR(459); TYPTR:= INTPTR
61100 END
61200 END %ABS\ ;
61300
61400 PROCEDURE TIME;
61500 BEGIN
61600 (* 63 - TOPS20 *)
61700 WITH GATTR DO
61800 BEGIN
61900 INCREMENTREGC; TYPTR := INTPTR; REG := REGC; KIND := EXPR;
62000 if tops10
62100 then MACRO3(047B,REGC,23B%MSTIME-UUO\)
62200 else begin
62300 support(getdaytime);
62400 macro3(262B%POP\,17B,regc)
62500 end
62600 END
62700 END;
62800
62900 PROCEDURE SQR;
63000 BEGIN
63100 WITH GATTR DO
63200 IF TYPTR = INTPTR
63300 THEN MACRO3(220B%IMUL\,REG,REG)
63400 ELSE
63500 IF TYPTR = REALPTR
63600 THEN MACRO3(164B%FMPR\,REG,REG)
63700 ELSE
63800 BEGIN
63900 ERROR(459); TYPTR := INTPTR
64000 END
64100 END %SQR\ ;
64200
64300 PROCEDURE TRUNC;
64400 VAR INSTRUC:1..777;
64500 BEGIN
64600 IF LKEY = 5
64700 THEN INSTRUC := 122B%FIX\
64800 ELSE INSTRUC := 126B%FIXR\;
64900 IF GATTR.TYPTR # REALPTR
65000 THEN ERROR(459)
65100 ELSE
65200 (* 2 - hard code TRUNC using KI-10 op code *)
65300 (* 10 - ADD ROUND *)
65400 (* 101 - fix bad code generation for fix and fixr *)
65500 (* 122 - put back KA code *)
65600 (* 132 - separate KA10 into NOVM and KACPU *)
65700 if kacpu
65800 then begin
65900 if lkey=5
66000 then macro3(551B%hrrzi\,tac,gattr.reg)
66100 else macro3(561B%hrroi\,tac,gattr.reg);
66200 support(convertrealtointeger);
66300 end
66400 ELSE WITH CODE.INSTRUCTION[CIX] DO
66500 IF (INSTR = 200B%MOVE\) AND (AC = GATTR.REG)
66600 THEN INSTR := INSTRUC
66700 ELSE MACRO3(INSTRUC,GATTR.REG,GATTR.REG);
66800 GATTR.TYPTR := INTPTR
66900 END %TRUNC\ ;
67000
67100 PROCEDURE ODD;
67200 BEGIN
67300 WITH GATTR DO
67400 BEGIN
67500 IF TYPTR # INTPTR
67600 THEN ERROR(459);
67700 MACRO3(405B%ANDI\,REG,1);
67800 TYPTR := BOOLPTR
67900 END
68000 END %ODD\ ;
68100
68200 PROCEDURE ORD;
68300 BEGIN
68400 IF GATTR.TYPTR # NIL
68500 THEN
68600 IF GATTR.TYPTR^.FORM >= POWER
68700 THEN ERROR(459);
68800 GATTR.TYPTR := INTPTR
68900 END %ORD\ ;
69000
69100 PROCEDURE CHR;
69200 BEGIN
69300 IF GATTR.TYPTR # INTPTR
69400 THEN ERROR(459);
69500 GATTR.TYPTR := CHARPTR
69600 END %CHR\ ;
69700
69800 PROCEDURE PREDSUCC;
69900 VAR
70000 LSTRPTR:STP; LATTR: ATTR;
70100 BEGIN
70200 IF GATTR.TYPTR # NIL
70300 THEN
70400 IF (GATTR.TYPTR^.FORM>SUBRANGE) OR (GATTR.TYPTR=REALPTR)
70500 THEN ERROR(459)
70600 ELSE
70700 IF RUNTMCHECK
70800 THEN
70900 BEGIN
71000 LSTRPTR:=GATTR.TYPTR;
71100 IF (LSTRPTR^.FORM=SUBRANGE) AND (LSTRPTR^.RANGETYPE #NIL)
71200 THEN LSTRPTR:=LSTRPTR^.RANGETYPE;
71300 IF LKEY=9
71400 THEN
71500 BEGIN
71600 IF LSTRPTR=INTPTR
71700 THEN
71800 BEGIN
71900 MACRO3R(255B%JFCL\,10B,IC+1);
72000 MACRO3(275B%SUBI\,REGC,1 );
72100 MACRO3R(255B%JFCL\,10B,IC+2);
72200 MACRO3(334B%SKIPA\,0,0 );
72300 SUPPORT(ERRORINASSIGNMENT)
72400 END
72500 ELSE% CHAR OR DECLARED \
72600 BEGIN
72700 MACRO3R(365B%SOJGE\,REGC,IC+2);
72800 SUPPORT(ERRORINASSIGNMENT)
72900 END
73000 END % LKEY = 9 \
73100 ELSE % LKEY = 10 \
73200 BEGIN
73300 IF LSTRPTR=INTPTR
73400 THEN
73500 BEGIN
73600 MACRO3R(255B%JFCL \,10B,IC+1);
73700 MACRO3(271B%ADDI \,REGC,1 );
73800 MACRO3R(255B%JFCL \,10B,IC+2);
73900 MACRO3(334B%SKIPA\,0,0 );
74000 SUPPORT(ERRORINASSIGNMENT)
74100 END
74200 ELSE %CHAR OR DECLARED\
74300 BEGIN
74400 WITH LATTR DO
74500 BEGIN
74600 TYPTR := LSTRPTR; KIND := CST; CVAL.IVAL := 0;
74700 IF LSTRPTR=CHARPTR
74800 THEN CVAL.IVAL := 177B
74900 ELSE
75000 IF LSTRPTR^.FCONST # NIL
75100 THEN CVAL.IVAL:=LSTRPTR^.FCONST^.VALUES.IVAL;
75200 MAKECODE(311B%CAML\,REGC,LATTR);
75300 SUPPORT(ERRORINASSIGNMENT);
75400 MACRO3(271B%ADDI \,REGC,1 );
75500 END
75600 END
75700 END % LKEY = 10 \;
75800 END % RUNTMCHECK \
75900 ELSE
76000 IF LKEY = 9
76100 THEN MACRO3(275B%SUBI\,REGC,1)
76200 ELSE MACRO3(271B%ADDI\,REGC,1)
76300 END %PREDSUCC\ ;
76400
76500 PROCEDURE EOFEOLN;
76600 BEGIN
76700 (* 33 - USE GETFILENAME, SO DEFAULTS TO INPUT *)
76800 (* 171 - PREDECL FILES ARE SPECIAL *)
76900 GETFILENAME(INFILE,FALSE,THISFILE,GOTARG,TRUE);
77000 IF GOTARG
77100 THEN ERROR(554);
77200 WITH GATTR DO
77300 BEGIN
77400 KIND := EXPR; REG := INDEXR;
77500 IF LKEY=11
77600 THEN
77700 BEGIN
77800 MACRO4(332B%SKIPE\,REG,REG,FILEOF) ;
77900 MACRO3(201B%MOVEI\,REG,1) ;
78000 END
78100 ELSE MACRO4(200B%MOVE\,REG,REG,FILEOL);
78200 TYPTR := BOOLPTR
78300 END
78400 END %EOF\ ;
78500
78600 PROCEDURE PROTECTION;
78700 (* FOR DETAILS SEE DEC-SYSTEM-10 MONITOR CALLS MANUAL, 3.2.4 *)
78800 BEGIN
78900 EXPRESSION ( FSYS OR [RPARENT], ONREGC );
79000 IF GATTR.TYPTR = BOOLPTR
79100 (* 63 - TOPS20 *)
79200 THEN IF TOPS10
79300 THEN
79400 BEGIN
79500 LOAD(GATTR);
79600 MACRO3(047B%CALLI\,REGC,36B%SETUWP\);
79700 MACRO3(254B%HALT\,4,0)
79800 END
79900 ELSE
80000 ELSE ERROR(458)
80100 END;
80200
80300 PROCEDURE CALLNONSTANDARD;
80400 VAR
80500 NXT,LNXT,LCP: CTP;
80600 LSP: STP;
80700 (* 33 - PROC PARAM.S*)
80800 PKIND,LKIND: IDKIND; LB: BOOLEAN;
80900 SAVECOUNT,P,I,NOFPAR: INTEGER;
81000 TOPPOFFSET,OFFSET,PARLIST,ACTUALPAR,FIRSTPAR,LLC: ADDRRANGE;
81100 LREGC: ACRANGE;
81200
81300 (* 111 - STRING, POINTER *)
81400 procedure paramfudge;
81500 var lmin,lmax:integer;
81600 (* This is used to handle special parameter types with
81700 reduced type checking, such as STRING, POINTER. They
81800 are always one of STRINGPTR, POINTERPTR, or POINTERREF.
81900 STRINGPTR is for STRING, the other two for POINTER.
82000 POINTERREF is for call by ref *)
82100 begin
82200 with gattr.typtr^ do
82300 if lsp=stringptr
82400 then if (form=arrays) and arraypf
82500 then if comptypes(aeltype,charptr)
82600 then begin (* STRING *)
82700 getbounds (gattr.typtr^.inxtype, lmin, lmax);
82800 loadaddress;
82900 incrementregc;
83000 macro3(201B%movei\,regc,lmax-lmin+1);
83100 end
83200 else error(503)
83300 else error(503)
83400 else if form=pointer {pointerptr or pointerref}
83500 then if eltype <> nil
83600 then begin (* POINTER *)
83700 (* 202 - fix up pointer by ref *)
83800 if lsp = pointerptr
83900 then load(gattr)
84000 else loadaddress;
84100 incrementregc;
84200 macro3(201B%movei\,regc,eltype^.size)
84300 end
84400 else (* bad type decl - already have error *)
84500 else error(503);
84600 gattr.typtr := lsp (* so comptypes later succeeds *)
84700 end;
84800
84900 BEGIN
85000 NOFPAR:= 0; TOPPOFFSET := 0; PARLIST := 0; ACTUALPAR := 0;
85100 WITH FCP^ DO
85200 BEGIN
85300 NXT := NEXT; LKIND := PFKIND;
85400 IF KLASS = FUNC
85500 THEN FIRSTPAR := 2
85600 ELSE FIRSTPAR := 1;
85700 (* 33 - PROC PARAM.S *)
85800 IF LKIND = ACTUAL
85900 THEN IF EXTERNDECL
86000 THEN LIBRARY[LANGUAGE].CALLED:= TRUE;
86100 SAVECOUNT := REGC - REGIN;
86200 IF SAVECOUNT > 0
86300 THEN
86400 BEGIN
86500 LLC := LC ;
86600 LC := LC + SAVECOUNT ;
86700 IF LC > LCMAX
86800 THEN LCMAX := LC ;
86900 IF SAVECOUNT > 3
87000 THEN
87100 BEGIN
87200 MACRO3(505B%HRLI\,TAC,2);
87300 MACRO4(541B%HRRI\,TAC,BASIS,LLC);
87400 MACRO4(251B%BLT\,TAC,BASIS,LLC+SAVECOUNT-1)
87500 END
87600 ELSE FOR I := 1 TO SAVECOUNT DO MACRO4(202B%MOVEM\,REGIN+I,BASIS,LLC+I-1)
87700 END;
87800 LREGC:= REGC;
87900 IF LKIND = FORMAL
88000 THEN REGC := REGIN
88100 ELSE IF LANGUAGE # PASCALSY
88200 THEN REGC:= PARREGCMAX
88300 ELSE REGC:= REGIN
88400 END;
88500 IF SY = LPARENT
88600 THEN
88700 BEGIN
88800 REPEAT
88900 LB := FALSE; %DECIDE WHETHER PROC/FUNC MUST BE PASSED\
89000 IF LKIND = ACTUAL
89100 THEN
89200 BEGIN
89300 IF NXT = NIL
89400 THEN ERROR(554)
89500 ELSE LB := NXT^.KLASS IN [PROC,FUNC]
89600 END
89700 (* 33 - PROC PARAM.S *)
89800 ELSE LB := FALSE;
89900 %FOR FORMAL PROC/FUNC LB IS FALSE AND EXPRESSION
90000 WILL BE CALLED, WHICH WILL ALLWAYS INTERPRET A PROC/FUNC ID
90100 AT ITS BEGINNING AS A CALL RATHER THAN A PARAMETER PASSING.
90200 IN THIS IMPLEMENTATION, PARAMETER PROCEDURES/FUNCTIONS
90300 ARE THEREFORE NOT ALLOWED TO HAVE PROCEDURE/FUNCTION
90400 PARAMETERS\
90500 INSYMBOL;
90600 IF LB
90700 THEN %PASS FUNCTION OR PROCEDURE\
90800 BEGIN
90900 IF SY # IDENT
91000 THEN
91100 ERRANDSKIP(209,FSYS OR [COMMA,RPARENT])
91200 ELSE
91300 BEGIN
91400 IF NXT^.KLASS = PROC
91500 THEN SEARCHID([PROC],LCP)
91600 ELSE
91700 BEGIN
91800 SEARCHID([FUNC],LCP);
91900 IF NOT COMPTYPES(LCP^.IDTYPE,NXT^.IDTYPE)
92000 THEN
92100 ERROR(555)
92200 END;
92300 INSYMBOL;
92400 IFERRSKIP(166,FSYS OR [COMMA,RPARENT])
92500 END;
92600 (* 33 - PROC PARAM.S *)
92700 WITH LCP^ DO
92800 IF (PFDECKIND = STANDARD) OR (PFKIND = ACTUAL) AND (LANGUAGE # PASCALSY)
92900 THEN ERROR (466)
93000 ELSE BEGIN
93100 INCREMENTREGC;
93200 (* 67 - fix proc param's *)
93300 if pflev > 1
93400 then p := level - pflev
93500 else p := 0;
93600 IF PFKIND = ACTUAL
93700 THEN BEGIN
93800 IF P = 0
93900 THEN MACRO3(514B%HRLZ\,REGC,BASIS)
94000 ELSE IF P=1
94100 THEN MACRO4(514B%HRLZ\,REGC,BASIS,-1)
94200 ELSE %P>1\
94300 BEGIN
94400 MACRO4(550B%HRRZ\,REGC,BASIS,-1);
94500 FOR I := 3 TO P DO MACRO4(550B%HRRZ\,REGC,REGC,-1);
94600 MACRO4(514B%HRLZ\,REGC,REGC,-1)
94700 END;
94800 IF PFADDR = 0
94900 THEN BEGIN
95000 (* 67 - fix typo: R in macro3r omitted *)
95100 MACRO3R(541B%HRRI\,REGC,LINKCHAIN[P]);
95200 LINKCHAIN[P] := IC - 1;
95300 IF EXTERNDECL
95400 THEN CODE.INFORMATION[CIX] := 'E'
95500 ELSE CODE.INFORMATION[CIX] := 'F'
95600 END
95700 ELSE MACRO3R(541B%HRRI\,REGC,PFADDR);
95800 END %OF PFKIND = ACTUAL \
95900 ELSE %PFKIND = FORMAL \
96000 IF P = 0
96100 THEN MACRO4(200B%MOVE\,REGC,BASIS,PFADDR)
96200 ELSE
96300 BEGIN
96400 MACRO4(200B%MOVE\,REGC,BASIS,-1);
96500 FOR I := 2 TO P DO MACRO4(200B%MOVE\,REGC,REGC,-1);
96600 MACRO4(200B%MOVE\,REGC,REGC,PFADDR)
96700 END
96800 END;
96900 END %IF LB\
97000 ELSE
97100 BEGIN
97200 EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
97300 IF GATTR.TYPTR # NIL
97400 THEN
97500 (* 33 - PROC PARAM.S *)
97600 BEGIN
97700 %NOTE : WE TREAT ALL PARAM'S OF A FORMAL PROC AS ACTUAL\
97800 IF (NXT # NIL) OR (LKIND = FORMAL)
97900 THEN
98000 BEGIN
98100 (*33 - PROC PARAM.S *)
98200 IF LKIND = FORMAL
98300 THEN BEGIN LSP := GATTR.TYPTR; PKIND := ACTUAL END
98400 ELSE BEGIN LSP := NXT^.IDTYPE; PKIND := NXT^.VKIND END;
98500 IF LSP # NIL
98600 THEN
98700 BEGIN
98800 (* 33 - PROC PARAM.S *)
98900 (* 161 - fix STRING,POINTER *)
99000 IF (PKIND = ACTUAL)
99100 THEN
99200 IF LSP^.SIZE <= 2
99300 THEN
99400 BEGIN
99500 (* 104 - more range checking for subrange things *)
99600 (* 202 - pointer by ref *)
99700 if (lsp = stringptr) or
99800 (lsp = pointerptr) or
99900 (lsp = pointerref)
00100 then paramfudge
00200 else if lsp^.form = subrange
00300 then loadsubrange(gattr,lsp)
00400 else load(gattr);
00500 IF COMPTYPES(REALPTR,LSP)
00600 AND (GATTR.TYPTR = INTPTR)
00700 THEN MAKEREAL(GATTR)
00800 END
00900 ELSE
01000 BEGIN
01100 LOADADDRESS;
01200 (* 33 - PROC PARAM.S *)
01300 IF (LKIND = ACTUAL) AND (FCP^.LANGUAGE # PASCALSY)
01400 THEN CODE.INSTRUCTION[CIX].INSTR := 505B%HRLI\
01500 END
01600 ELSE
01700 IF GATTR.KIND = VARBL
01800 THEN LOADADDRESS
01900 ELSE ERROR(463) ;
02000 (* 22 - ALLOW EXTERNAL FILE REFERENCES *)
02100 IF GATTR.TYPTR#NIL
02200 THEN IF GATTR.TYPTR^.FORM=FILES
02300 (* 217 - file expressions *)
02400 THEN IF GATTR.EXTERNCTP <> NIL
02500 THEN BEGIN GATTR.EXTERNCTP^.VADDR:=IC-1;
02600 CODE.INFORMATION[CIX]:='E' END;
02700 (* 64 - fix proc param's that don't fit in ac's *)
02800 IF NOT COMPTYPES(LSP,GATTR.TYPTR)
02900 THEN ERROR(503)
03000 END
03100 END
03200 END
03300 (* 33 - PROC PARAM.S *)
03400 END;
03500 IF REGC>PARREGCMAX
03600 THEN
03700 (* 33 - PROC PARAM.S *)
03800 (* NOTE: CURRENTLY WE PUNT IF ARG'S DON'T FIT IN AC'S IN FORMAL PROC*)
03900 (* 215 - keep from looping when NXT = NIL because of error *)
04000 IF NXT <> NIL
04100 THEN
04200 IF LKIND=FORMAL
04300 THEN ERROR(413)
04400 ELSE BEGIN
04500 IF TOPPOFFSET = 0
04600 THEN
04700 BEGIN
04800 LNXT := FCP^.NEXT ;
04900 IF FCP^.LANGUAGE = PASCALSY
05000 (* 62 - clean up offset *)
05100 then toppoffset := fcp^.poffset + 1
05200 ELSE
05300 BEGIN
05400 TOPPOFFSET := 1 + FIRSTPAR;
05500 REPEAT
05600 WITH LNXT^ DO
05700 BEGIN
05800 NOFPAR := NOFPAR +1;
05900 TOPPOFFSET := TOPPOFFSET + 1;
06000 IF VKIND = ACTUAL
06100 THEN TOPPOFFSET := TOPPOFFSET + IDTYPE^.SIZE;
06200 IF LKIND = ACTUAL
06300 THEN LNXT := NEXT
00100 END;
00200 UNTIL LNXT = NIL;
00300 PARLIST := 1 + FIRSTPAR;
00400 ACTUALPAR := PARLIST + NOFPAR
00500 END;
00600 (* 104 - TOPS20 DETECTION OF STACK OVERFLOW *)
00700 (* 115 - TENEX *)
00800 IF KLCPU AND NOT TOPS10
00900 THEN MACRO3(105B%ADJSP\,TOPP,TOPPOFFSET)
01000 ELSE MACRO3(271B%ADDI\,TOPP,TOPPOFFSET);
01100 (* 54 - keep track of how many loc's above stack are used *)
01200 stkoff := stkoff + toppoffset;
01300 if stkoff > stkoffmax
01400 then stkoffmax := stkoff
01500 END ;
01600 WITH NXT^ DO
01700 BEGIN
01800 IF FCP^.LANGUAGE = PASCALSY
01900 THEN
02000 (* 64 - fix parameter proc's that don't fit in ac's *)
02100 if klass # vars
02200 then macro4(202b%movem\,regc,topp,pfaddr+1-toppoffset)
02300 ELSE BEGIN
02400 (* 52 - if VAR, size is always 1 *)
02500 IF (VKIND=ACTUAL) AND (IDTYPE^.SIZE=2)
02600 THEN
02700 BEGIN
02800 MACRO4(202B%MOVEM\,REGC,TOPP,VADDR+2-TOPPOFFSET);
02900 REGC := REGC - 1
03000 END;
03100 (* 201 - zero size things *)
03200 IF (IDTYPE^.SIZE > 0) OR (VKIND <> ACTUAL)
03300 THEN MACRO4(202B%MOVEM\,REGC,TOPP,VADDR+1-TOPPOFFSET)
03400 END
03500 ELSE
03600 (* 64 - proc param's that don't fit in ac's *)
03700 if klass # vars
03800 then error(466)
03900 ELSE BEGIN
04000 IF VKIND = ACTUAL
04100 THEN
04200 BEGIN
04300 IF IDTYPE^.SIZE <= 2
04400 THEN
04500 BEGIN
04600 IF IDTYPE^.SIZE = 2
04700 THEN
04800 BEGIN
04900 MACRO4(202B%MOVEM\,REGC,TOPP,ACTUALPAR+1-TOPPOFFSET);
05000 REGC := REGC - 1
05100 END;
05200 (* 201 - zero size objects *)
05300 IF IDTYPE^.SIZE > 0
05400 THEN MACRO4(202B%MOVEM\,REGC,TOPP,ACTUALPAR-TOPPOFFSET);
05500 MACRO4(541B%HRRI\,REGC,TOPP,ACTUALPAR-TOPPOFFSET)
05600 END
05700 ELSE
05800 BEGIN
05900 MACRO4(541B%HRRI\,REGC,TOPP,ACTUALPAR-TOPPOFFSET);
06000 MACRO4(251B%BLT\,REGC,TOPP,ACTUALPAR+IDTYPE^.SIZE-1-TOPPOFFSET);
06100 (* 52 - BLT may change REGC, so reset it since used below *)
06200 MACRO4(541B%HRRI\,REGC,TOPP,ACTUALPAR-TOPPOFFSET)
06300 END;
06400 ACTUALPAR := ACTUALPAR + IDTYPE^.SIZE
06500 END;
06600 MACRO4(552B%HRRZM\,REGC,TOPP,PARLIST-TOPPOFFSET);
06700 PARLIST := PARLIST + 1
06800 END;
06900 REGC := PARREGCMAX
07000 END
07100 END;
07200 IF (LKIND = ACTUAL) AND (NXT # NIL)
07300 THEN NXT := NXT^.NEXT
07400 UNTIL SY # COMMA;
07500 IF SY = RPARENT
07600 THEN INSYMBOL
07700 ELSE ERROR(152)
07800 END %IF LPARENT\;
07900 FOR I := 0 TO WITHIX DO
08000 WITH DISPLAY[TOP-I] DO
08100 IF (CINDR#0) AND (CINDR#BASIS)
08200 THEN
08300 MACRO4(202B%MOVEM\,CINDR,BASIS,CLC);
08400 WITH FCP^ DO
08500 BEGIN
08600 (* 33 - PROC. PARAM.S *)
08700 IF LKIND = FORMAL
08800 THEN BEGIN END %TOPOFFSET=0 ALWAYS AT THE MOMENT\
08900 ELSE IF (LANGUAGE = PASCALSY) AND (TOPPOFFSET # 0)
09000 (* 54 - keep track of offsets above top of stack *)
09100 (* 62 - clean up offset *)
09200 THEN STKOFF := STKOFF - TOPPOFFSET
09300 ELSE IF (LANGUAGE # PASCALSY) AND (TOPPOFFSET = 0)
09400 THEN
09500 BEGIN
09600 TOPPOFFSET:= FIRSTPAR+2;
09700 (* 104 - TOPS20 ADJSP *)
09800 (* 115 - TENEX *)
09900 IF KLCPU AND NOT TOPS10
10000 THEN MACRO3(105B%ADJSP\,TOPP,TOPPOFFSET)
10100 ELSE MACRO3(271B%ADDI\,TOPP,TOPPOFFSET);
10200 (* 54 - keep track of how many loc's above stack are used *)
10300 STKOFF := STKOFF + TOPPOFFSET;
10400 IF STKOFF > STKOFFMAX
10500 THEN STKOFFMAX := STKOFF
10600 END;
10700 IF PFLEV > 1
10800 THEN P := LEVEL - PFLEV
10900 ELSE P:= 0;
11000 IF LKIND = ACTUAL
11100 THEN
11200 BEGIN
11300 IF NXT # NIL
11400 THEN ERROR(554);
11500 IF LANGUAGE # PASCALSY
11600 THEN
11700 BEGIN
11800 MACRO3(515B%HRLZI\,HAC,-NOFPAR);
11900 MACRO4(202B%MOVEM\,HAC,TOPP,FIRSTPAR-TOPPOFFSET);
12000 MACRO4(202B%MOVEM\,BASIS,TOPP,-TOPPOFFSET);
12100 MACRO4(201B%MOVEI\,BASIS,TOPP,FIRSTPAR-TOPPOFFSET+1);
12200 IF NOFPAR = 0
12300 THEN MACRO4(402B%SETZM\,0,TOPP,FIRSTPAR-TOPPOFFSET+1)
12400 END;
12500 IF PFADDR = 0
12600 THEN
12700 BEGIN
12800 MACRO3R(260B%PUSHJ\,TOPP,LINKCHAIN[P]); LINKCHAIN[P]:= IC-1;
12900 IF EXTERNDECL
13000 THEN CODE.INFORMATION[CIX] := 'E'
13100 ELSE CODE.INFORMATION[CIX] := 'F'
13200 END
13300 ELSE MACRO3R(260B%PUSHJ\,TOPP,PFADDR-P);
13400 (* 33 - PROC PARAM.S *)
13500 IF LANGUAGE # PASCALSY
13600 THEN
13700 BEGIN
13800 (* 104 - TOPS20 ADJSP *)
13900 IF KLCPU AND NOT TOPS10
14000 THEN MACRO3(105B%ADJSP\,TOPP,-TOPPOFFSET)
14100 ELSE MACRO3(275B%SUBI\,TOPP,TOPPOFFSET);
14200 (* 54 - keep track of how many loc's above stack are used *)
14300 STKOFF := STKOFF - TOPPOFFSET;
14400 IF KLASS = FUNC
14500 THEN
14600 BEGIN
14700 MACRO4(202B%MOVEM\,HAC,TOPP,2);
14800 IF IDTYPE^.SIZE = 2
14900 THEN MACRO4(202B%MOVEM\,TAC,TOPP,3)
15000 END;
15100 MACRO4(200B%MOVE\,BASIS,TOPP,0)
15200 END
15300 (* 33 - PROC PARAM.S *)
15400 END (* OF LKIND = ACTUAL *)
15500 ELSE
15600 BEGIN
15700 IF P = 0
15800 THEN BEGIN
15900 MACRO4(550B%HRRZ\,TAC,BASIS,PFADDR);
16000 MACRO4(544B%HLR\,BASIS,BASIS,PFADDR)
16100 END
16200 ELSE BEGIN
16300 MACRO4(550B%HRRZ\,TAC,BASIS,-1);
16400 FOR I := 2 TO P DO MACRO4(550B%HRRZ\,TAC,TAC,-1);
16500 MACRO4(544B%HLR\,BASIS,TAC,PFADDR);
16600 MACRO4(550B%HRRZ\,TAC,TAC,PFADDR)
16700 END;
16800 MACRO4(260B%PUSHJ\,TOPP,TAC,0)
16900 END
17000 END;
17100 FOR I := 0 TO WITHIX DO
17200 WITH DISPLAY[TOP-I] DO
17300 IF (CINDR#0) AND (CINDR#BASIS)
17400 THEN MACRO4(200B%MOVE\,CINDR,BASIS,CLC) ;
17500 IF SAVECOUNT > 0
17600 THEN
17700 BEGIN
17800 IF SAVECOUNT > 3
17900 THEN
18000 BEGIN
18100 MACRO4(505B%HRLI\,TAC,BASIS,LLC);
18200 MACRO3(541B%HRRI\,TAC,2);
18300 MACRO3(251B%BLT\,TAC,SAVECOUNT+1)
18400 END
18500 ELSE FOR I := 1 TO SAVECOUNT DO MACRO4(200B%MOVE\,REGIN+I,BASIS,LLC+I-1) ;
18600 LC := LLC
18700 END ;
18800 GATTR.TYPTR := FCP^.IDTYPE; REGC := LREGC
18900 END %CALLNONSTANDARD\ ;
19000
19100 BEGIN
19200 %CALL\
19300 IF FCP^.PFDECKIND = STANDARD
19400 THEN
19500 BEGIN
19600 LKEY := FCP^.KEY;
19700 IF FCP^.KLASS = PROC
19800 THEN
19900 BEGIN
20000 (* 26 - allow non-text files *)
20100 (* 61 - rclose *)
20200 IF NOT (LKEY IN [7,8,9,10,11,17,19,25,34,39,42] )
20300 THEN
20400 IF SY = LPARENT
20500 THEN INSYMBOL
20600 ELSE ERROR(153);
20700 (* 45 - APPEND, UPDATE, RENAME, use REG5 and REG6 *)
20800 IF (LKEY IN [5,6,7,8,10,11,27,29,36]) AND (REGCMAX <= 8)
20900 THEN ERROR(317);
21000 %REGISTER USED BY RUNTIME SUPPORT FREE OR NOT \
21100 CASE LKEY OF
21200 (* 42 - move GET and PUT to NEW *)
21300 2,4,
21400 (* 14 - NEW DUMP MODE I/O *)
21500 5,6,27,28,29,36: GETPUTRESETREWRITE;
21600 7,
21700 8:
21800 BEGIN
21900 READREADLN;
22000 IF NORIGHTPARENT
22100 THEN GOTO 9
22200 END;
22300 9:
22400 BEGIN
22500 BREAK;
22600 IF NORIGHTPARENT
22700 THEN GOTO 9
22800 END;
22900 10,
23000 11:
23100 BEGIN
23200 WRITEWRITELN;
23300 IF NORIGHTPARENT
23400 THEN GOTO 9
23500 END;
23600 12: PACK;
23700 13: UNPACK;
23800 (* 27 - add NEWZ *)
23900 (* 42 - move GET and PUT to NEW *)
24000 (* 152 - add DISPOSE *)
24100 1,3,14,35,40,44: NEW;
24200 15: MARK;
24300 16: RELEASE;
24400 17: GETLINENR;
24500 18: PUT8BITSTOTTY;
24600 19:
24700 BEGIN
24800 PAGE;
24900 IF NORIGHTPARENT
25000 THEN GOTO 9
25100 END;
25200 21: PROTECTION;
25300 (* 10 - ADD SETSTRING *)
25400 22,23: SETSTRING;
25500 24: GETINDEX;
25600 (* 26 - allow non-text files *)
25700 (* 42 - move breakin to close *)
25800 (* 61 - rclose *)
25900 25,34,39,42: BEGIN CLOSE;IF NORIGHTPARENT THEN GOTO 9 END;
26000 26:CALLI;
26100 (* 14 - NEW DUMP MODE I/O *)
26200 30,31:DUMP;
26300 32,33,38:USET;
26400 (* 61 - delete *)
26500 37,41:PUTX;
26600 (* 61 - tops20 system version *)
26700 43:JSYS
26800 END
26900 END
27000 ELSE
27100 BEGIN
27200 IF NOT (LKEY IN [1,2,11,12])
27300 THEN
27400 BEGIN
27500 IF SY = LPARENT
27600 THEN INSYMBOL
27700 ELSE ERROR(153);
27800 if lkey#15
27900 then EXPRESSION(FSYS OR [RPARENT],ONREGC);
28000 IF NOT (LKEY IN [7,8,11,12,15])
28100 THEN LOAD(GATTR)
28200 END;
28300 CASE LKEY OF
28400 1: RUNTIME;
28500 2: TIME;
28600 3: ABS;
28700 4: SQR;
28800 5,14: TRUNC;
28900 6: ODD;
29000 7: ORD;
29100 8: CHR;
29200 9,10: PREDSUCC;
29300 11,12: BEGIN EOFEOLN; IF NORIGHTPARENT THEN GOTO 9 END;
29400 15: NEW
29500 END;
29600 IF LKEY < 3
29700 THEN GOTO 9
29800 END;
29900 IF SY = RPARENT
30000 THEN INSYMBOL
30100 ELSE ERROR(152);
30200 9:
30300 END %STANDARD PROCEDURES AND FUNCTIONS\
30400 ELSE CALLNONSTANDARD
30500 END %CALL\ ;
30600
30700 PROCEDURE EXPRESSION;
30800 VAR
30900 LATTR: ATTR; LOP: OPERATOR; LSIZE: ADDRRANGE; LOFFSET: INTEGER; DEFAULT,NEEDSHIFT: BOOLEAN;
31000 BOOLREGC,TESTREGC:ACRANGE; LINSTR,LINSTR1: INSTRANGE; LREGC1,LREGC2: ACRANGE;
31100 SETINCLUSION : BOOLEAN; JMPADRIFALLEQUAL : INTEGER;
31200
31300 PROCEDURE CHANGEBOOL(VAR FINSTR: INSTRANGE);
31400 BEGIN
31500 IF (FINSTR>=311B) AND (FINSTR<=313B)
31600 THEN FINSTR := FINSTR+4 %CAML,CAME,CAMLE --> CAMGE,CAMN,CAMG\
31700 ELSE
31800 IF (FINSTR>=315B) AND (FINSTR<=317B)
31900 THEN FINSTR := FINSTR-4 %SAME IN THE OTHER WAY\;
32000 END;
32100
32200 PROCEDURE SEARCHCODE(FINSTR:INSTRANGE; FATTR: ATTR);
32300 PROCEDURE CHANGEOPERANDS(VAR FINSTR:INSTRANGE);
32400 BEGIN
32500 IF FINSTR=311B%CAML\
32600 THEN FINSTR := 317B%CAMG\
32700 ELSE
32800 IF FINSTR = 313B%CAMLE\
32900 THEN FINSTR := 315B%CAMGE\
33000 ELSE
33100 IF FINSTR=315B%CAMGE\
33200 THEN FINSTR := 313B%CAMLE\
33300 ELSE
33400 IF FINSTR = 317B%CAMG\
33500 THEN FINSTR := 311B%CAML\
33600 ELSE
33700 IF FINSTR = 420B%ANDCM\
33800 THEN FINSTR := 410B%ANDCA\
33900 ELSE
34000 IF FINSTR = 410B%ANDCA\
34100 THEN FINSTR := 420B%ANDCM\;
34200 END;
34300
34400 BEGIN
34500 WITH GATTR DO
34600 IF FATTR.KIND = EXPR
34700 THEN
34800 BEGIN
34900 MAKECODE(FINSTR,FATTR.REG,GATTR); REG := FATTR.REG
35000 END
35100 ELSE
35200 IF KIND = EXPR
35300 THEN
35400 BEGIN
35500 CHANGEOPERANDS(FINSTR); MAKECODE(FINSTR,REG,FATTR)
35600 END
35700 ELSE
35800 IF (KIND=VARBL) AND ((PACKFG#NOTPACK)
35900 OR (INDEXR>REGIN) AND (INDEXR<=REGCMAX) AND
36000 ((FATTR.INDEXR<=REGIN) OR (FATTR.INDEXR>REGCMAX)))
36100 THEN
36200 BEGIN
36300 LOAD(GATTR); CHANGEOPERANDS(FINSTR); MAKECODE(FINSTR,REG,FATTR)
36400 END
36500 ELSE
36600 BEGIN
36700 LOAD(FATTR); MAKECODE(FINSTR,FATTR.REG,GATTR); REG := FATTR.REG
36800 END;
36900 END;
37000
37100 PROCEDURE SIMPLEEXPRESSION(FSYS: SETOFSYS);
37200 VAR
37300 LATTR: ATTR; LOP: OPERATOR; SIGNED : BOOLEAN;
37400 (* 52 - new var needed to prevent clobbering CONST decl. *)
37500 NEWREALCSP: CSP;
37600
37700 PROCEDURE TERM(FSYS: SETOFSYS);
37800 VAR
37900 LATTR: ATTR; LOP: OPERATOR;
38000
38100 PROCEDURE FACTOR(FSYS: SETOFSYS);
38200 VAR
38300 LCP: CTP; LVP: CSP; VARPART: BOOLEAN;
38400 CSTPART: SET OF 0..71; LSP: STP;
38500 RANGEPART: BOOLEAN;LRMIN: INTEGER;
38600 BEGIN
38700 IF NOT (SY IN FACBEGSYS)
38800 THEN
38900 BEGIN
39000 ERRANDSKIP(173,FSYS OR FACBEGSYS);
39100 GATTR.TYPTR := NIL
39200 END;
39300 IF SY IN FACBEGSYS
39400 THEN
39500 BEGIN
39600 CASE SY OF
39700 %ID\ IDENT:
39800 BEGIN
39900 SEARCHID([KONST,VARS,FIELD,FUNC],LCP);
40000 INSYMBOL;
40100 IF LCP^.KLASS = FUNC
40200 THEN
40300 BEGIN
40400 CALL(FSYS,LCP);
40500 IF LCP^.PFDECKIND=DECLARED
40600 THEN
40700 BEGIN
40800 WITH LCP^,GATTR DO
40900 BEGIN
41000 TYPTR :=IDTYPE; KIND :=VARBL; PACKFG :=NOTPACK;
41100 VRELBYTE := NO;
41200 VLEVEL :=1; DPLMT :=2;
41300 INDEXR := TOPP; INDBIT :=0;
41400 IF TYPTR # NIL
41500 THEN
41600 IF TYPTR^.SIZE = 1
41700 THEN LOAD(GATTR)
41800 END
41900 END
42000 END
42100 ELSE
42200 IF LCP^.KLASS = KONST
42300 THEN
42400 WITH GATTR, LCP^ DO
42500 BEGIN
42600 TYPTR := IDTYPE; KIND := CST;
42700 CVAL := VALUES
42800 END
42900 ELSE
43000 SELECTOR(FSYS,LCP);
43100 IF GATTR.TYPTR # NIL
43200 THEN %ELIM. SUBR. TYPES TO\
43300 WITH GATTR, TYPTR^ DO %SIMPLIFY LATER TESTS\
43400 IF FORM = SUBRANGE
43500 THEN TYPTR := RANGETYPE
43600 END;
43700 %CST\ INTCONST:
43800 BEGIN
43900 WITH GATTR DO
44000 BEGIN
44100 TYPTR := INTPTR; KIND := CST;
44200 CVAL := VAL;
44300 END;
44400 INSYMBOL
44500 END;
44600 REALCONST:
44700 BEGIN
44800 WITH GATTR DO
44900 BEGIN
45000 TYPTR := REALPTR; KIND := CST;
45100 CVAL := VAL
45200 END;
45300 INSYMBOL
45400 END;
45500 STRINGCONST:
45600 BEGIN
45700 WITH GATTR DO
45800 BEGIN
45900 CONSTANT(FSYS,TYPTR,CVAL) ; KIND := CST ;
46000 END;
46100 END;
46200 %(\ LPARENT:
46300 BEGIN
46400 INSYMBOL; EXPRESSION(FSYS OR [RPARENT],ONREGC);
46500 IF SY = RPARENT
46600 THEN INSYMBOL
46700 ELSE ERROR(152)
46800 END;
46900 % NOT \ NOTSY:
47000 BEGIN
47100 INSYMBOL; FACTOR(FSYS);
47200 IF GATTR.TYPTR = BOOLPTR
47300 THEN
47400 BEGIN
47500 LOAD(GATTR); MACRO3(411B%ANDCAI\,REGC,1)
47600 END
47700 ELSE
47800 BEGIN
47900 ERROR(359); GATTR.TYPTR := NIL
48000 END;
48100 END;
48200 %[\ LBRACK:
48300 BEGIN
48400 INSYMBOL; CSTPART := [ ]; VARPART := FALSE;
48500 (* 110 - MOVED RANGEPART INITIALIZATION INSIDE LOOP *)
48600 NEWZ(LSP,POWER);
48700 WITH LSP^ DO
48800 BEGIN
48900 ELSET:=NIL; SIZE:= 2
49000 END;
49100 IF SY = RBRACK
49200 THEN
49300 BEGIN
49400 WITH GATTR DO
49500 BEGIN
49600 TYPTR:=LSP; KIND:=CST;
49700 NEWZ(LVP,PSET); LVP^.PVAL := CSTPART; CVAL.VALP := LVP
49800 END;
49900 INSYMBOL
50000 END
50100 ELSE
50200 BEGIN
50300 (* 110 - THIS ROUTINE LARGELY RECODED *)
50400 (* AC usage in the following is documented at the end. In order to provide
50500 any sanity at all, REGC has to be kept the same whatever the expression
50600 types found. Since an expression will advance REGC in most cases, we
50700 have to be sure it gets advanced in others. This means incrementregc
50800 for constants and LOAD otherwise. We don't LOAD constants because if
50900 the other half of the range is also constant we will just remember it
51000 as constant and not do a load at all. *)
51100 LOOP
51200 (* RANGEPART IS FLAG: 1ST EXPRESSION IS VARIABLE *)
51300 RANGEPART := FALSE;
51400 INCREMENTREGC; INCREMENTREGC; (* FIRST EXPR *)
51500 EXPRESSION(FSYS OR [COMMA,RBRACK,COLON],ONFIXEDREGC);
51600 IF GATTR.TYPTR # NIL
51700 THEN
51800 IF GATTR.TYPTR^.FORM # SCALAR
51900 THEN
52000 BEGIN
52100 ERROR(461); GATTR.TYPTR := NIL
52200 END
52300 ELSE
52400 IF COMPTYPES(LSP^.ELSET,GATTR.TYPTR)
52500 THEN
52600 BEGIN (* LOAD IF VAR, SAVE IN LRMIN IF CONST *)
52700 IF GATTR.KIND = CST
52800 THEN
52900 BEGIN (* FIRST EXPR IS CONST *)
53000 (* 127 - fix reversed AC's *)
53100 INCREMENTREGC;
53200 (* 137 - CHAR needs different test *)
53300 IF (GATTR.CVAL.IVAL<0)
53400 OR (GATTR.CVAL.IVAL>BASEMAX) AND (GATTR.TYPTR<>CHARPTR)
53500 OR (GATTR.CVAL.IVAL>CHARMAX) AND (GATTR.TYPTR=CHARPTR)
53600 THEN BEGIN ERROR(352) ; GATTR.CVAL.IVAL := 0 END;
53700 IF GATTR.TYPTR=CHARPTR
53800 THEN
53900 (* 7 - TREAT LOWER CASE AS UPPER IN SETS *)
54000 (* 105 - improve lower case mapping in sets *)
54100 GATTR.CVAL.IVAL := SETMAP[GATTR.CVAL.IVAL];
54200 LRMIN := GATTR.CVAL.IVAL;
54300 END
54400 ELSE
54500 BEGIN (* FIRST EXPR IS NOT A CONSTANT *)
54600 RANGEPART := TRUE; (* SIGNAL VARIABLE *)
54700 LOAD(GATTR);
54800 (* 112 - range check sets *)
54900 if runtmcheck
55000 then begin
55100 (* 137 - different range check for char *)
55200 if gattr.typtr = charptr
55300 then macro3(307B%caig\,regc,charmax)
55400 else macro3(307B%caig\,regc,basemax);
55500 macro3(305B%caige\,regc,0);
55600 support(errorinassignment)
55700 end;
55800 IF GATTR.TYPTR = CHARPTR
55900 THEN BEGIN
56000 (* 105 - improve lower case mapping in sets *)
56100 macro4r(200B%MOVE\,regc,regc,setmapchain);
56200 code.information[cix] := 'E';
56300 setmapchain := ic-1;
56400 END;
56500 END;
56600 IF SY <> COLON
56700 THEN (* ONLY ONE EXPR *)
56800 IF NOT RANGEPART
56900 THEN (* CONSTANT *)
57000 BEGIN
57100 CSTPART := CSTPART OR [LRMIN];
57200 (* 127 - fixed reversed AC's *)
57300 REGC := REGC - 3;
57400 END
57500 ELSE (* ONE VARIABLE *)
57600 BEGIN
57700 IF GATTR.TYPTR = CHARPTR
57800 THEN CODE.INSTRUCTION[CIX].INSTR := 210B%MOVN\
57900 ELSE MACRO3(210B%MOVN\,REGC,REGC);
58000 REGC := REGC - 1;
58100 MACRO3(515B%HRLZI\,REGC-1,400000B);
58200 MACRO3(400B%SETZ\,REGC,0);
58300 (* 105 - more improvements for lower case mapping *)
58400 MACRO4(246B%LSHC\,REGC-1,REGC+1,0);
58500 IF VARPART
58600 THEN
58700 BEGIN
58800 MACRO3(434B%IOR\,REGC-3,REGC-1);
58900 MACRO3(434B%IOR\,REGC-2,REGC);
59000 REGC := REGC-2;
59100 END
59200 ELSE VARPART := TRUE;
59300 GATTR.KIND := EXPR; GATTR.REG := REGC
59400 END
59500 ELSE (* RANGE *)
59600 BEGIN
59700 INSYMBOL;
59800 EXPRESSION(FSYS OR [COMMA,RBRACK],ONFIXEDREGC);
59900 IF GATTR.TYPTR <> NIL (* 2ND EXPR *)
60000 THEN
60100 IF GATTR.TYPTR^.FORM <> SCALAR
60200 THEN BEGIN
60300 ERROR(461);
60400 GATTR.TYPTR := NIL
60500 END
60600 ELSE
60700 IF COMPTYPES(LSP^.ELSET,GATTR.TYPTR)
60800 THEN
60900 BEGIN
61000 IF GATTR.KIND = CST
61100 THEN BEGIN
61200 (* 137 - different test for CHAR, fix AC mess *)
61300 INCREMENTREGC;
61400 IF (GATTR.CVAL.IVAL < 0)
61500 OR (GATTR.CVAL.IVAL > BASEMAX) AND (GATTR.TYPTR<>CHARPTR)
61600 OR (GATTR.CVAL.IVAL > CHARMAX) AND (GATTR.TYPTR=CHARPTR)
61700 THEN BEGIN ERROR(352); GATTR.CVAL.IVAL := 0 END;
61800 IF GATTR.TYPTR = CHARPTR
61900 THEN GATTR.CVAL.IVAL := SETMAP[GATTR.CVAL.IVAL]
62000 END
62100 (* 137 - more AC confusion *)
62200 ELSE LOAD(GATTR);
62300 IF (GATTR.KIND = CST) AND (NOT RANGEPART)
62400 THEN (* CONSTANT RANGE *)
62500 BEGIN
62600 WHILE(LRMIN <= GATTR.CVAL.IVAL) DO
62700 BEGIN
62800 CSTPART := CSTPART OR [LRMIN];
62900 LRMIN := LRMIN+1
63000 END;
63100 (* 127 - fix reversed AC's *)
63200 (* 137 - once again *)
63300 REGC := REGC - 4
63400 END
63500 ELSE
63600 BEGIN (* VARIABLE LIMITS ON RANGE *)
63700 IF NOT RANGEPART (* FIRST PART IS CONSTANT *)
63800 THEN
63900 BEGIN (* SO NOT IN AC YET *)
64000 (* 127 - fix reversed AC's *)
64100 (* 137 - once again *)
64200 MACRO3(201B%MOVEI\,REGC-1,LRMIN)
64300 END;
64400 if gattr.kind = cst (* same for second *)
64500 then macro3(201B%movei\,regc,gattr.cval.ival);
64600 (* 112 - range check sets *)
64700 (* 137 - different test needed for CHAR *)
64800 if (gattr.kind <> cst) and runtmcheck
64900 then begin
65000 if gattr.typtr = charptr
65100 then macro3(307B%caig\,regc,charmax)
65200 else macro3(307B%caig\,regc,basemax);
65300 macro3(305B%caige\,regc,0);
65400 support(errorinassignment);
65500 end;
65600 IF (GATTR.TYPTR=CHARPTR) AND (GATTR.KIND <> CST)
65700 THEN BEGIN
65800 (* 105 - improve lower case mapping in sets *)
65900 macro4r(200B%MOVE\,regc,regc,setmapchain);
66000 code.information[cix] := 'E';
66100 setmapchain := ic-1;
66200 END;
66300 (* HERE IS WHAT IS IN THE AC'S:
66400 REGC - RH LIMIT
66500 REGC-1 - LH LIMIT
66600 REGC-2 - DOUBLE WORD OF BITS
66700 REGC-3 "
66800 *)
66900 MACRO3(477B%SETOB\,REGC-3,REGC-2);
67000 MACRO4(246B%LSHC\,REGC-3,REGC-1,0);
67100 MACRO3(275B%SUBI\,REGC,71);
67200 MACRO3(210B%MOVN\,REGC,REGC);
67300 MACRO3(270B%ADD\,REGC-1,REGC);
67400 MACRO3(210B%MOVN\,REGC-1,REGC-1);
67500 MACRO4(246B%LSHC\,REGC-3,REGC-1,0);
67600 MACRO4(246B%LSHC\,REGC-3,REGC,0);
67700 REGC := REGC -2;
67800 IF VARPART
67900 THEN
68000 BEGIN
68100 MACRO3(434B%IOR\,REGC-3,REGC-1);
68200 MACRO3(434B%IOR\,REGC-2,REGC);
68300 REGC := REGC-2;
68400 END
68500 ELSE VARPART := TRUE;
68600 GATTR.KIND := EXPR; GATTR.REG := REGC
68700 END
68800 END
68900 END;
00100 LSP^.ELSET := GATTR.TYPTR;
00200 GATTR.TYPTR :=LSP
00300 END
00400 ELSE ERROR(360);
00500 EXIT IF NOT(SY IN [COMMA]);
00600 INSYMBOL
00700 END;
00800 IF SY = RBRACK
00900 THEN INSYMBOL
01000 ELSE ERROR(155);
01100 IF VARPART
01200 THEN
01300 BEGIN
01400 IF CSTPART # [ ]
01500 THEN
01600 BEGIN
01700 (* 34 - BUG FIX FROM HAMBURG - NEEDED FOR PROGSTAT *)
01800 NEW(LVP,PSET);LVP^.PVAL := CSTPART;
01900 GATTR.KIND:=CST; GATTR.CVAL.VALP := LVP;
02000 MAKECODE(434B%IOR\,REGC,GATTR)
02100 END
02200 END
02300 ELSE
02400 BEGIN
02500 NEWZ(LVP,PSET); LVP^.PVAL := CSTPART; GATTR.CVAL.VALP := LVP
02600 END
02700 END;
02800 END
02900 END %CASE\ ;
03000 IFERRSKIP(166,FSYS)
03100 END;
03200 %IF SY IN FACBEGSYS\
03300 END %FACTOR\ ;
03400
03500 BEGIN
03600 %TERM\
03700 FACTOR(FSYS OR [MULOP]);
03800 WHILE SY = MULOP DO
03900 BEGIN
04000 IF OP IN [RDIV,IDIV,IMOD]
04100 THEN LOAD(GATTR); %BECAUSE OPERANDS ARE NOT
04200 ALLOWED TO BE CHOSEN\
04300 LATTR := GATTR; LOP := OP;
04400 INSYMBOL; FACTOR(FSYS OR [MULOP]);
04500 IF (LATTR.TYPTR # NIL) AND (GATTR.TYPTR # NIL)
04600 THEN
04700 CASE LOP OF
04800 %*\ MUL:
04900 IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
05000 THEN SEARCHCODE(220B%IMUL\,LATTR)
05100 (* 21 - * with sets is and *)
05200 ELSE IF (LATTR.TYPTR^.FORM=POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
05300 THEN SEARCHCODE(404B%AND\,LATTR)
05400 ELSE
05500 BEGIN
05600 MAKEREAL(LATTR);
05700 IF (LATTR.TYPTR = REALPTR)
05800 AND (GATTR.TYPTR = REALPTR)
05900 THEN SEARCHCODE(164B%FMPR\,LATTR)
06000 ELSE
06100 BEGIN
06200 ERROR(311); GATTR.TYPTR := NIL
06300 END
06400 END;
06500 %/\ RDIV:
06600 BEGIN
06700 MAKEREAL(LATTR);
06800 IF (LATTR.TYPTR = REALPTR)
06900 AND (GATTR.TYPTR = REALPTR)
07000 THEN SEARCHCODE(174B%FDVR\,LATTR)
07100 ELSE
07200 BEGIN
07300 ERROR(311); GATTR.TYPTR := NIL
07400 END
07500 END;
07600 %DIV\ IDIV:
07700 IF (LATTR.TYPTR = INTPTR)
07800 AND (GATTR.TYPTR = INTPTR)
07900 THEN SEARCHCODE(230B%IDIV\,LATTR)
08000 ELSE
08100 BEGIN
08200 ERROR(311); GATTR.TYPTR := NIL
08300 END;
08400 %MOD\ IMOD:
08500 IF (LATTR.TYPTR = INTPTR)
08600 AND (GATTR.TYPTR = INTPTR)
08700 THEN
08800 BEGIN
08900 SEARCHCODE(230B%IDIV\,LATTR);GATTR.REG := GATTR.REG+1
09000 END
09100 ELSE
09200 BEGIN
09300 ERROR(311); GATTR.TYPTR := NIL
09400 END;
09500 % AND \ ANDOP:
09600 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
09700 AND ( (LATTR.TYPTR^.FORM = POWER) OR (GATTR.TYPTR = BOOLPTR) )
09800 THEN SEARCHCODE(404B%AND\,LATTR)
09900 ELSE
10000 BEGIN
10100 ERROR(311); GATTR.TYPTR := NIL
10200 END
10300 END %CASE\
10400 ELSE GATTR.TYPTR := NIL;
10500 REGC:=GATTR.REG
10600 END %WHILE\
10700 END %TERM\ ;
10800
10900 BEGIN
11000 %SIMPLEEXPRESSION\
11100 SIGNED := FALSE;
11200 IF (SY = ADDOP) AND (OP IN [PLUS,MINUS])
11300 THEN
11400 BEGIN
11500 SIGNED := OP = MINUS; INSYMBOL
11600 END;
11700 TERM(FSYS OR [ADDOP]);
11800 IF SIGNED
11900 THEN WITH GATTR DO
12000 IF TYPTR # NIL
12100 THEN
12200 IF (TYPTR = INTPTR) OR (TYPTR = REALPTR)
12300 THEN
12400 IF KIND = CST
12500 THEN
12600 IF TYPTR = INTPTR
12700 THEN CVAL.IVAL := - CVAL.IVAL
12800 (* 52 - have to put negated value in new place, since old one might be a CONST declaration used elsewhere *)
12900 ELSE
13000 BEGIN
13100 NEW(NEWREALCSP);
13200 NEWREALCSP^.CCLASS := REEL;
13300 NEWREALCSP^.RVAL := -CVAL.VALP^.RVAL;
13400 CVAL.VALP := NEWREALCSP
13500 END
13600 ELSE
13700 BEGIN
13800 LOAD(GATTR) ;
13900 WITH CODE, INSTRUCTION[CIX] DO
14000 IF INSTR=200B%MOVE\
14100 THEN INSTR := 210B%MOVN\
14200 ELSE MACRO3(210B%MOVN\,GATTR.REG,GATTR.REG)
14300 END
14400 ELSE
14500 BEGIN
14600 ERROR(311) ; GATTR.TYPTR := NIL
14700 END ;
14800 WHILE SY = ADDOP DO
14900 BEGIN
15000 IF OP=MINUS
15100 THEN LOAD(GATTR); %BECAUSE OPD MAY NOT BE CHOSEN\
15200 LATTR := GATTR; LOP := OP;
15300 INSYMBOL; TERM(FSYS OR [ADDOP]);
15400 IF (LATTR.TYPTR # NIL) AND (GATTR.TYPTR # NIL)
15500 THEN
15600 CASE LOP OF
15700 %+\ PLUS:
15800 IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
15900 THEN
16000 SEARCHCODE(270B%ADD\,LATTR)
16100 (* 21 - ALLOW + AS SET UNION *)
16200 ELSE IF(LATTR.TYPTR^.FORM=POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
16300 THEN SEARCHCODE(434B%IOR\,LATTR)
16400 ELSE
16500 BEGIN
16600 MAKEREAL(LATTR);
16700 IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR)
16800 THEN SEARCHCODE(144B%FADR\,LATTR)
16900 ELSE
17000 BEGIN
17100 ERROR(311); GATTR.TYPTR := NIL
17200 END
17300 END;
17400 %-\ MINUS:
17500 IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
17600 THEN
17700 SEARCHCODE(274B%SUB\,LATTR)
17800 (* 21 - ALLOW - AS SET DIFFERENCE *)
17900 ELSE IF (LATTR.TYPTR^.FORM = POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
18000 THEN SEARCHCODE(420B%ANDCM\,LATTR)
18100 ELSE
18200 BEGIN
18300 MAKEREAL(LATTR);
18400 IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR)
18500 THEN SEARCHCODE(154B%FSBR\,LATTR)
18600 ELSE
18700 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
18800 AND (LATTR.TYPTR^.FORM = POWER)
18900 THEN SEARCHCODE(420B%ANDCM\,LATTR)
19000 ELSE
19100 BEGIN
19200 ERROR(311); GATTR.TYPTR := NIL
19300 END
19400 END;
19500 % OR \ OROP:
19600 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
19700 AND ( (GATTR.TYPTR = BOOLPTR) OR (LATTR.TYPTR^.FORM = POWER) )
19800 THEN SEARCHCODE(434B%IOR\,LATTR)
19900 ELSE
20000 BEGIN
20100 ERROR(311); GATTR.TYPTR := NIL
20200 END
20300 END %CASE\
20400 ELSE GATTR.TYPTR := NIL;
20500 REGC:=GATTR.REG
20600 END %WHILE\
20700 END %SIMPLEEXPRESSION\ ;
20800
20900 BEGIN
21000 %EXPRESSION\
21100 TESTREGC := REGC+1;
21200 SIMPLEEXPRESSION(FSYS OR [RELOP]);
21300 IF SY = RELOP
21400 THEN
21500 BEGIN
21600 IF FVALUE IN [ONREGC,ONFIXEDREGC]
21700 THEN
21800 BEGIN
21900 INCREMENTREGC; MACRO3(201B%MOVEI\,REGC,1); BOOLREGC := REGC
22000 END;
22100 IF GATTR.TYPTR # NIL
22200 THEN
22300 (* 24 - STRING IS ONLY STRUCTURE ALLOWED *)
22400 IF STRING(GATTR.TYPTR)
22500 THEN LOADADDRESS; LREGC1 := REGC;
22600 LATTR := GATTR; LOP := OP;
22700 IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC < BOOLREGC)
22800 THEN REGC := BOOLREGC;
22900 INSYMBOL; SIMPLEEXPRESSION(FSYS);
23000 IF GATTR.TYPTR # NIL
23100 THEN
23200 (* 24 - STRING IS ONLY STRUCTURE ALLOWED *)
23300 IF STRING(GATTR.TYPTR)
23400 THEN LOADADDRESS; LREGC2 := REGC;
23500 IF (LATTR.TYPTR # NIL) AND (GATTR.TYPTR # NIL)
23600 THEN
23700 BEGIN
23800 IF LOP = INOP
23900 THEN
24000 IF GATTR.TYPTR^.FORM = POWER
24100 THEN
24200 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR^.ELSET)
24300 THEN
24400 BEGIN
24500 LOAD(LATTR);
24600 IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC < BOOLREGC)
24700 THEN REGC := BOOLREGC;
24800 LOAD(GATTR); REGC := GATTR.REG - 1;
24900 IF LATTR.TYPTR=CHARPTR
25000 THEN
25100 (* 7 - TREAT LOWER CASE AS UPPER IN SETS *)
25200 BEGIN
25300 (* 105 - improve lower case mapping in sets *)
25400 macro4r(200B%move\,lattr.reg,lattr.reg,setmapchain);
25500 code.information[cix] := 'E';
25600 setmapchain := ic-1;
25700 END;
25800 MACRO4(246B%LSHC\,REGC,LATTR.REG,0);
25900 IF FVALUE = TRUEJMP
26000 THEN LINSTR := 305B%CAIGE\
26100 ELSE LINSTR := 301B%CAIL\;
26200 MACRO3(LINSTR,REGC,0);
26300 END
26400 ELSE
26500 BEGIN
26600 ERROR(260); GATTR.TYPTR := NIL
26700 END
26800 ELSE
26900 BEGIN
27000 ERROR(213); GATTR.TYPTR := NIL
27100 END
27200 ELSE
27300 BEGIN
27400 IF LATTR.TYPTR # GATTR.TYPTR
27500 THEN
27600 MAKEREAL(LATTR);
27700 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
27800 THEN
27900 BEGIN
28000 LSIZE := LATTR.TYPTR^.SIZE;
28100 CASE LATTR.TYPTR^.FORM OF
28200 POINTER:
28300 IF LOP IN [LTOP,LEOP,GTOP,GEOP]
28400 THEN ERROR (312);
28500 POWER:
28600 IF LOP IN [LTOP,GTOP]
28700 THEN ERROR(313);
28800 ARRAYS:
28900 IF NOT STRING(LATTR.TYPTR)
29000 (* 24 - STRING IS ONLY STRUCT. ALLOWED *)
29100 THEN ERROR(312);
29200 RECORDS,
29300 FILES:
29400 ERROR(314)
29500 END;
29600 WITH LATTR.TYPTR^ DO
29700 BEGIN
29800 DEFAULT := TRUE; LOFFSET := 3; SETINCLUSION := FALSE;
29900 CASE LOP OF
30000 LTOP:
30100 BEGIN
30200 LINSTR := 311B%CAML\; LINSTR1 := 313B
30300 END;
30400 LEOP:
30500 IF FORM = POWER
30600 THEN
30700 BEGIN
30800 SEARCHCODE(420B%ANDCM\,LATTR);
30900 SETINCLUSION := TRUE
31000 END
31100 ELSE
31200 BEGIN
31300 LINSTR := 313B%CAMLE\; LINSTR1 := 313B
31400 END;
31500 GTOP:
31600 BEGIN
31700 LINSTR := 317B%CAMG\; LINSTR1 := 315B
31800 END;
31900 GEOP:
32000 IF FORM = POWER
32100 THEN
32200 BEGIN
32300 SEARCHCODE(410B%ANDCA\,LATTR);
32400 SETINCLUSION := TRUE
32500 END
32600 ELSE
32700 BEGIN
32800 LINSTR := 315B%CAMGE\; LINSTR1 := 315B
32900 END;
33000 NEOP:
33100 BEGIN
33200 LINSTR := 316B%CAMN\;DEFAULT := FALSE
33300 END;
33400 EQOP:
33500 BEGIN
33600 LINSTR := 312B%CAME\; DEFAULT := FALSE; LOFFSET := 2
33700 END
33800 END;
33900 IF FVALUE = TRUEJMP
34000 THEN CHANGEBOOL(LINSTR);
34100 (* 24 - STRING IS ONLY STRUCTURE *)
34200 IF FORM#ARRAYS THEN BEGIN
34300 IF SIZE = 1
34400 THEN SEARCHCODE(LINSTR,LATTR)
34500 ELSE
34600 IF SETINCLUSION
34700 THEN
34800 BEGIN
34900 MACRO3(336B%SKIPN\,0,GATTR.REG);
35000 MACRO3(332B%SKIPE\,0,GATTR.REG-1);
35100 IF FVALUE = TRUEJMP
35200 THEN
35300 MACRO3R(254B%JRST\,0,IC+2)
35400 END
35500 ELSE
35600 BEGIN
35700 LOAD(LATTR);
35800 IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC<BOOLREGC)
35900 THEN
36000 REGC := BOOLREGC;
36100 LOAD(GATTR);
36200 IF DEFAULT
36300 THEN
36400 BEGIN
36500 MACRO3(LINSTR1,LATTR.REG-1,GATTR.REG-1);
36600 MACRO3R(254B%JRST\,0,IC+4) %FALSE\
36700 END;
36800 MACRO3(312B%CAME\,LATTR.REG-1,GATTR.REG-1);
36900 MACRO3R(254B%JRST\,0,IC+LOFFSET);
37000 MACRO3(LINSTR,LATTR.REG,GATTR.REG)
37100 END
37200 END
37300 ELSE
37400 (* 24 - THIS CODE IS NOW ONLY FOR STRINGS *)
37500 BEGIN (*STRING*)
37600 GETBOUNDS(INXTYPE,LOFFSET,LSIZE);
37700 LSIZE:=LSIZE-LOFFSET+1;
37800 (* 40 - fix this code for unpacked strings, too *)
37900 if arraypf
38000 then begin
38100 LOFFSET:=(LSIZE MOD 5)*700B;
38200 LSIZE:=LSIZE DIV 5;
38300 end
38400 else loffset:=0;
38500 IF (LSIZE=0) AND (LOFFSET=0)
38600 THEN MACRO3(403B%SETZB\,TAC,HAC)
38700 ELSE IF (LSIZE=0)
38800 THEN BEGIN
38900 MACRO3(505B%HRLI\,LREGC1,LOFFSET+440000B);
39000 MACRO3(505B%HRLI\,LREGC2,LOFFSET+440000B);
39100 MACRO3(134B%ILDB\,TAC,LREGC1);
39200 MACRO3(134B%ILDB\,HAC,LREGC2)
39300 END
39400 ELSE
39500 BEGIN
39600 (* 40 - fix for nonpacked arrays *)
39700 if arraypf
39800 then begin
39900 MACRO3(505B%HRLI\,LREGC1,444300B);
40000 MACRO3(505B%HRLI\,LREGC2,444300B);
40100 end
40200 else begin
40300 macro3(505b%hrli\,lregc1,444400b);
40400 macro3(505b%hrli\,lregc2,444400b)
40500 end;
40600 INCREMENTREGC;
40700 IF LSIZE > 1
40800 THEN MACRO3(201B%MOVEI\,REGC,LSIZE);
40900 MACRO3(134B%ILDB\,TAC,LREGC1);
41000 MACRO3(134B%ILDB\,HAC,LREGC2);
41100 IF (LOFFSET=0)
41200 THEN BEGIN
41300 IF LSIZE>1
41400 THEN BEGIN
41500 MACRO3(316B%CAMN\,TAC,HAC);
41600 MACRO3R(367B%SOJG\,REGC,IC-3)
41700 END
41800 END
41900 ELSE %OFFSET NOT 0\ BEGIN
42000 MACRO3(312B%CAME\,TAC,HAC);
42100 IF LSIZE>1
42200 THEN BEGIN
42300 MACRO3R(254B%JRST\,0,IC+6);
42400 MACRO3R(367B%SOJG\,REGC,IC-4)
42500 END
42600 ELSE MACRO3R(254B%JRST\,0,IC+5);
42700 MACRO3(505B%HRLI\,LREGC1,LOFFSET);
42800 MACRO3(505B%HRLI\,LREGC2,LOFFSET);
42900 MACRO3(134B%ILDB\,TAC,LREGC1);
43000 MACRO3(134B%ILDB\,HAC,LREGC2)
43100 END;
43200 REGC:=REGC-1
43300 END;
43400 MACRO3(LINSTR,TAC,HAC);
43500 REGC:=REGC-2
43600 END
43700 END
43800 END
43900 ELSE ERROR(260)
44000 END;
44100 IF FVALUE IN [ONREGC,ONFIXEDREGC]
44200 THEN
44300 BEGIN
44400 MACRO3(400B%SETZ\,BOOLREGC,0); REGC := BOOLREGC
44500 END
44600 ELSE MACRO3(254B%JRST\,0,0);
44700 END;
44800 %(IF LATTR.TYPTR#NIL) AND (GATTR.TYPTR#NIL) THEN \
44900 GATTR.TYPTR := BOOLPTR; GATTR.KIND := EXPR; GATTR.REG := REGC
45000 END %SY = RELOP\
45100 ELSE
45200 IF FVALUE IN [TRUEJMP,FALSEJMP]
45300 THEN
45400 BEGIN
45500 LOAD(GATTR);
45600 IF GATTR.TYPTR#BOOLPTR
45700 THEN ERROR (359);
45800 IF FVALUE = TRUEJMP
45900 THEN LINSTR := 326B%JUMPN\
46000 ELSE LINSTR := 322B%JUMPE\;
46100 MACRO3(LINSTR,GATTR.REG,0)
46200 END
46300 ELSE
46400 IF GATTR.KIND=EXPR
46500 THEN REGC := GATTR.REG;
46600 IF GATTR.TYPTR # NIL
46700 THEN
46800 WITH GATTR,TYPTR^ DO
46900 (* 141 - fix bollixed AC allocation in complex array calculations *)
47000 (* 143 - fixed code below for Tops-10 packed arrays *)
47100 {Warning to modifiers: the following code depends upon the register
47200 allocation in MAKECODE for the case where opcode=MOVE, and in
47300 LOADADDRESS. Please be sure to keep them consistent!}
47400 {Onfixedregc means we are in a context where the result has to go in
47500 a particular AC. So if we had a complex calculation that ended up
47600 with it in a higher AC, we have to move it down. That is for
47700 KIND=EXPR. For KIND=CST or VARBL (the only other cases), we have
47800 to make sure REGC was not changed, as the caller will expect that.
47900 It could be changed by an array with a complex subscript calculation.
48000 Note that we in the case KIND=VARBL we may leave AC's set up with
48100 info needed to access arrays (in the fieldS INDEXR and/or BPADDR).
48200 So in that case this amounts to second-guessing LOAD and MAKECODE
48300 to make sure that whichever place the result will be loaded
48400 (usually INDEXR or BPADDR) is pointing to the fixed AC.}
48500
48600 IF FVALUE = ONFIXEDREGC
48700 THEN
48800 BEGIN
48900 IF KIND=EXPR
49000 THEN BEGIN
49100 IF SIZE = 2
49200 THEN TESTREGC := TESTREGC + 1;
49300 IF TESTREGC # REGC
49400 THEN BEGIN
49500 IF SIZE = 2
49600 THEN MACRO3(200B%MOVE\,TESTREGC-1,REGC-1);
49700 MACRO3(200B%MOVE\,TESTREGC,REGC);
49800 REG := TESTREGC; REGC := TESTREGC;
49900 END
50000 END
50100 ELSE IF KIND=VARBL
50200 THEN BEGIN
50300 IF (PACKFG = PACKK) AND (BPADDR>REGIN) AND (BPADDR<=REGCMAX)
50400 THEN IF (INDEXR <= REGIN) OR (BPADDR<INDEXR)
50500 THEN IF BPADDR<> TESTREGC
50600 THEN BEGIN
50700 MACRO3(200B%MOVE\,TESTREGC,BPADDR);
50800 BPADDR := TESTREGC
50900 END
51000 ELSE
51100 ELSE IF INDEXR<>TESTREGC
51200 THEN BEGIN
51300 MACRO3(200B%MOVE\,TESTREGC,INDEXR);
51400 INDEXR := TESTREGC
51500 END
51600 ELSE
51700 ELSE IF (INDEXR>REGIN) AND (INDEXR<=REGCMAX) AND (INDEXR<>TESTREGC)
51800 THEN BEGIN
51900 MACRO3(200B%MOVE\,TESTREGC,INDEXR);
52000 INDEXR := TESTREGC
52100 END;
52200 REGC := TESTREGC - 1;
52300 END
52400 ELSE REGC := TESTREGC-1
52500 END
52600 END %EXPRESSION\ ;
52700
52800 PROCEDURE ASSIGNMENT(FCP: CTP);
52900 VAR
53000 LATTR,SLATTR: ATTR;
53100 SRMIN,SRMAX: INTEGER;
53200
53300 PROCEDURE STOREGLOBALS ;
53400 TYPE
53500 WANDELFORM = (PTRW,INTW,REELW,PSETW,STRGW,INSTW) ;
53600 VAR
53700 WANDEL : RECORD
53800 CASE KW : WANDELFORM OF
53900 PTRW: (WPTR :GTP %TO ALLOW NIL\) ;
54000 INTW: (WINT : INTEGER ; WINT1 : INTEGER %TO PICK UP SECOND WORD OF SET\) ;
54100 REELW: (WREEL: REAL) ;
54200 PSETW: (WSET : SET OF 0..71) ;
54300 STRGW: (WSTRG: CHARWORD) ;
54400 INSTW: (WINST: PDP10INSTR)
54500 END ;
54600 I,J : INTEGER ;
54700 PROCEDURE STOREWORD ;
54800 BEGIN
54900 CIX := CIX + 1 ;
55000 IF CIX > CIXMAX
55100 THEN
55200 BEGIN
55300 CIX := 0 ; ERRORWITHTEXT(356,'INITPROCD.')
55400 END ;
55500 WITH CGLOBPTR^ DO
55600 BEGIN
55700 CODE.INSTRUCTION[CIX] := WANDEL.WINST ;
55800 LASTGLOB := LASTGLOB + 1 ;
55900 END ;
56000 END ;
56100 PROCEDURE GETNEWGLOBPTR ;
56200 VAR
56300 LGLOBPTR : GTP ;
56400 BEGIN
56500 NEWZ(LGLOBPTR) ;
56600 WITH LGLOBPTR^ DO
56700 BEGIN
56800 NEXTGLOBPTR := NIL ;
56900 FIRSTGLOB := 0 ;
57000 END ;
57100 IF CGLOBPTR # NIL
57200 THEN CGLOBPTR^.NEXTGLOBPTR := LGLOBPTR ;
57300 CGLOBPTR := LGLOBPTR ;
57400 END;
57500 BEGIN
57600 %STOREGLOBALS\
57700 IF FGLOBPTR = NIL
57800 THEN
57900 BEGIN
58000 GETNEWGLOBPTR ;
58100 FGLOBPTR := CGLOBPTR ;
58200
58300 END
58400 ELSE
58500 IF LATTR.DPLMT # CGLOBPTR^.LASTGLOB + 1
58600 THEN GETNEWGLOBPTR ;
58700 WITH WANDEL,CGLOBPTR^,GATTR,CVAL DO
00100 BEGIN
00200 IF FIRSTGLOB = 0
00300 THEN
00400 BEGIN
00500 FIRSTGLOB := LATTR.DPLMT ;
00600 LASTGLOB := FIRSTGLOB - 1 ;
00700 FCIX := CIX + 1 ;
00800 END ;
00900 CASE TYPTR^.FORM OF
01000 SCALAR,
01100 SUBRANGE:
01200 BEGIN
01300 (* 174 30-Sep-80 Andy Hisgen, CMU, Problems with xreal:=xinteger,
01400 and with subranges.
01500 The lines below used to read --
01600 IF TYPTR = REALPTR
01700 THEN
01800 IF LATTR.TYPTR=INTPTR
01900 THEN WREEL := IVAL
02000 ELSE WREEL := VALP^.RVAL
02100 ELSE WINT := IVAL ;
02200 Unfortunately, that was testing to see if the RightHandSide (GATTR) was
02300 a real, and if so doing weird things. For example, that let the
02400 assignment "x:=2", where x is a real, go thru, but without doing
02500 any conversion, thus x contained the bit pattern for the integer 2.
02600 The problem here seems to have been that the roles of LATTR and
02700 GATTR got reversed in the coder's mind. Below, we have reversed
02800 them back.
02900 A second unrelated problem was that subrange checking was not
03000 being done. In the code below, we now handle this.
03100 *)
03200 IF lattr.typtr = realptr
03300 THEN
03400 IF gattr.typtr = intptr
03500 THEN WREEL := IVAL
03600 ELSE WREEL := VALP^.RVAL
03700 ELSE BEGIN (*left isn't real*)
03800 IF lattr.typtr^.form = subrange
03900 THEN
04000 BEGIN (*left is subrange*)
04100 getBounds(lattr.typtr,srmin,srmax);
04200 IF NOT( (srmin <= ival) AND
04300 (ival <= srmax) )
04400 THEN error(367);
04500 END; (*left is subrange*)
04600 WINT := IVAL;
04700 END; (*left isn't real*)
04800 (*30-Sep-80 end of changes for xreal:=integer and for subranges*)
04900
05000 STOREWORD ;
05100 END ;
05200 POINTER:
05300 BEGIN
05400 WPTR := NIL ; STOREWORD
05500 END ;
05600 POWER :
05700 BEGIN
05800 WSET := VALP^.PVAL ; STOREWORD ;
05900 WINT := WINT1 %GET SECOND WORD OF SET\ ;
06000 STOREWORD ;
06100 END ;
06200 ARRAYS : WITH VALP^,WANDEL DO
06300 BEGIN
06400 J := 0; WINT := 0;
06500 FOR I := 1 TO SLGTH DO
06600 BEGIN
06700 J := J + 1;
06800 WSTRG[J] := SVAL[I];
06900 IF J=5
07000 THEN
07100 BEGIN
07200 J := 0;
07300 STOREWORD; WINT := 0
07400 END
07500 END;
07600 IF J#0
07700 THEN STOREWORD
07800 END;
07900
08000 RECORDS,
08100 FILES : ERROR(411)
08200 END %CASE\ ;
08300 END % WITH \ ;
08400 END % STOREGLOBALS \ ;
08500
08600 BEGIN
08700 %ASSIGNMENT\
08800 SELECTOR(FSYS OR [BECOMES],FCP);
08900 IF SY = BECOMES
09000 THEN
09100 BEGIN
09200 LATTR := GATTR;
09300 INSYMBOL;
09400 EXPRESSION(FSYS,ONREGC);
09500 IF (LATTR.TYPTR # NIL) AND (GATTR.TYPTR # NIL)
09600 THEN
09700 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) OR
09800 (REALPTR=LATTR.TYPTR) AND (GATTR.TYPTR=INTPTR)
09900 THEN
10000 IF INITGLOBALS
10100 THEN
10200 IF GATTR.KIND = CST
10300 THEN STOREGLOBALS
10400 ELSE ERROR(504)
10500 ELSE
10600 IF (GATTR.KIND=CST) AND (GATTR.CVAL.IVAL=0)
10700 AND (LATTR.PACKFG=NOTPACK)
10800 THEN
10900 BEGIN
11000 FETCHBASIS(LATTR);
11100 WITH LATTR DO
11200 BEGIN
11300 (* 104 - check subranges *)
11400 if lattr.typtr^.form = subrange
11500 then begin
11600 getbounds(lattr.typtr,srmin,srmax);
11700 if (0 < srmin) or (0 > srmax)
11800 then error(367)
11900 end;
12000 MACRO(VRELBYTE,402B%SETZM\,0,INDBIT,INDEXR,DPLMT)
12100 END
12200 END
12300 ELSE
12400 CASE LATTR.TYPTR^.FORM OF
12500 SCALAR,
12600 POINTER,
12700 POWER:
12800 BEGIN
12900 LOAD(GATTR);
13000 IF COMPTYPES(REALPTR,LATTR.TYPTR) AND (GATTR.TYPTR=INTPTR)
13100 THEN
13200 MAKEREAL(GATTR);
13300 STORE(GATTR.REG,LATTR)
13400 END;
13500 SUBRANGE:
13600 BEGIN
13700 (* 104 - moved code into procedure for use elsewhere *)
13800 loadsubrange(gattr,lattr.typtr);
13900 STORE(GATTR.REG,LATTR)
14000 END;
14100
14200 ARRAYS,
14300 RECORDS:
14400 (* 201 - zero size objects *)
14500 IF GATTR.TYPTR^.SIZE = 0
14600 THEN
14700 ELSE IF GATTR.TYPTR^.SIZE = 1
14800 THEN
14900 BEGIN
15000 LOAD(GATTR) ; STORE(GATTR.REG,LATTR)
15100 END
15200 ELSE WITH LATTR DO
15300 BEGIN
15400 LOADADDRESS ;
15500 CODE.INSTRUCTION[CIX].INSTR := 505B%HRLI\ ;
15600 FETCHBASIS(LATTR);
15700 MACRO(VRELBYTE,541B%HRRI\,REGC,INDBIT,INDEXR,DPLMT) ;
15800 IF INDBIT=0
15900 THEN MACRO5(VRELBYTE,251B%BLT \,REGC,INDEXR,DPLMT+TYPTR^.SIZE-1)
16000 ELSE
16100 BEGIN
16200 INCREMENTREGC ;
16300 MACRO3(200B%MOVE\,REGC,REGC-1);
16400 MACRO4(251B%BLT \,REGC,REGC-1,TYPTR^.SIZE-1)
16500 END;
16600 END;
16700 FILES: ERROR(361)
16800 END
16900 ELSE ERROR(260)
17000 END %SY = BECOMES\
17100 ELSE ERROR(159);
17200 END %ASSIGNMENT\ ;
17300
17400 PROCEDURE GOTOSTATEMENT;
17500 VAR
17600 (* 64 - non-local gotos *)
17700 (* 65 - remove exit labels *)
17800 I,J,JJ:INTEGER; lcp:ctp;
17900 BEGIN
18000 IF SY = INTCONST
18100 THEN
18200 BEGIN
18300 prterr := false;
18400 searchid([labelt],lcp);
18500 prterr := true;
18600 if lcp # nil
18700 then with lcp^ do
18800 (* See if the goto is out of the current block. If so, handle
18900 specially, since we have to restore the basis and topp. Except
19000 for the global level, we recover the basis by tracing the static
19100 links. Then we arranged for topp's RH to be stored in the LH
19200 of word 0 of the display. Global labels are odd because the
19300 static link will be 0. So the global topp and basis are stored
19400 in special variables. *)
19500 (* 173 - As of this edit, we have to call GOTOC. in order to
19600 close files in the blocks exited. In order to prevent problems
19700 if we are interrupted while this is happening, we can't really
19800 change BASIS or TOPP until after the files are closed, else we
19900 might be trying to close a file whose control block is above TOPP.
20000 So we REGC is the new BASIS and REGC+1 is the new TOPP *)
20100 if scope # level
20200 then begin
20300 incrementregc;
20400 if scope = 1
20500 then begin
20600 macro3r(200B%move\,regc,globbasis);
20700 macro3r(200B%move\,regc+1,globtopp)
20800 end
20900 else begin
21000 macro4(504B%hrl\,regc,basis,-1);
21100 macro3(544B%hlr\,regc,regc);
21200 for i := scope to level - 2 do
21300 macro4(507B%hrls\,regc,regc,-1);
21400 macro4(544B%hlr\,regc+1,regc,0);
21500 macro3(504B%hrl\,regc+1,regc+1);
21600 end;
21700 (* 75 - following was macro3 due to typo *)
21800 macro3r(201B%movei\,regc+2,gotochain);
21900 gotochain := ic-1;
22000 code.information[cix] := 'F';
22100 nonlocgoto := true;
22200 support(exitgoto);
22300 goto 2
22400 end;
22500 FOR I:=1 TO LIX DO
22600 BEGIN
22700 WITH LABELS[I] DO
22800 IF LABSVAL = VAL.IVAL
22900 THEN
23000 BEGIN
23100 MACRO3R(254B%JRST\,0,LABSADDR);
23200 GOTO 2
23300 END
23400 END;
23500 MACRO3(254B%JRST\,0,0);
23600 FOR I:=1 TO JIX DO
23700 BEGIN
23800 WITH GOTOS[I] DO
23900 IF GOTOVAL = VAL.IVAL
24000 THEN
24100 BEGIN
24200 J:= CODE.INSTRUCTION[GOTOADDR].ADDRESS;
24300 JJ:= GOTOADDR;
24400 WHILE J#0 DO
24500 BEGIN
24600 JJ:=J;
24700 J:= CODE.INSTRUCTION[J].ADDRESS
24800 END;
24900 INSERTADDR(NO,JJ,CIX);
25000 GOTO 2
25100 END
25200 END;
25300 FOR I:=1 TO JIX DO
25400 BEGIN
25500 WITH GOTOS[I] DO
25600 IF GOTOVAL = -1
25700 THEN
25800 BEGIN
25900 GOTOVAL:=VAL.IVAL;
26000 GOTOADDR:=CIX;
26100 GOTO 2
26200 END
26300 END;
26400 JIX :=JIX+1;
26500 IF JIX > LABMAX
26600 THEN
26700 BEGIN
26800 ERROR(362);
26900 JIX := LABMAX
27000 END;
27100 WITH GOTOS[JIX] DO
27200 BEGIN
27300 GOTOVAL := VAL.IVAL;
27400 GOTOADDR:=CIX
27500 END;
27600 2:
27700 INSYMBOL
27800 END
27900 ELSE ERROR(255)
28000 END %GOTOSTATEMENT\ ;
28100
28200 PROCEDURE COMPOUNDSTATEMENT;
28300 BEGIN
28400 LOOP
28500 REPEAT
28600 STATEMENT(FSYS,STATENDS)
28700 UNTIL NOT (SY IN STATBEGSYS);
28800 EXIT IF SY # SEMICOLON;
28900 INSYMBOL
29000 END;
29100 IF SY = ENDSY
29200 THEN INSYMBOL
29300 ELSE ERROR(163)
29400 END %COMPOUNDSTATEMENET\ ;
29500
29600 PROCEDURE IFSTATEMENT;
29700 VAR
29800 LCIX1,LCIX2: CODERANGE;
29900 BEGIN
30000 EXPRESSION(FSYS OR [THENSY],FALSEJMP);
30100 LCIX1 := CIX;
30200 IF SY = THENSY
30300 THEN INSYMBOL
30400 ELSE ERROR(164);
30500 STATEMENT(FSYS OR [ELSESY],STATENDS OR [ELSESY]);
30600 IF SY = ELSESY
30700 THEN
30800 BEGIN
30900 MACRO3(254B%JRST\,0,0); LCIX2 := CIX;
31000 INSERTADDR(RIGHT,LCIX1,IC);
31100 INSYMBOL; STATEMENT(FSYS,STATENDS);
31200 INSERTADDR(RIGHT,LCIX2,IC)
31300 END
31400 ELSE INSERTADDR(RIGHT,LCIX1,IC)
31500 END %IFSTATEMENT\ ;
31600
31700 PROCEDURE CASESTATEMENT;
31800 TYPE
31900 CIP = ^CASEINFO;
32000 CASEINFO = PACKED
32100 RECORD
32200 NEXT: CIP;
32300 CSSTART: ADDRRANGE;
32400 CSEND: CODERANGE;
32500 CSLAB: INTEGER
32600 END;
32700 VAR
32800 LSP,LSP1: STP; FSTPTR,LPT1,LPT2,LPT3,OTHERSPTR: CIP; LVAL: VALU;
32900 LIC,LADDR,JUMPADDR: ADDRRANGE; LCIX: CODERANGE; LMIN,LMAX: INTEGER;
33000
33100 PROCEDURE INSERTBOUND(FCIX:CODERANGE;FIC: ADDRRANGE;BOUND:INTEGER);
33200 VAR
33300 LCIX1:CODERANGE; LIC1: ADDRRANGE;
33400 LATTR:ATTR;
33500 BEGIN
33600 IF BOUND>=0
33700 THEN INSERTADDR(NO,FCIX,BOUND)
33800 ELSE
33900 BEGIN
34000 LCIX1:=CIX; LIC1 := IC;
34100 CIX:=FCIX; IC := FIC;
34200 WITH LATTR DO
34300 BEGIN
34400 KIND:=CST;
34500 CVAL.IVAL:=BOUND;
34600 TYPTR:=NIL
34700 END;
34800 DEPCST(INT,LATTR);
34900 CIX:=LCIX1; IC:= LIC1;
35000 WITH CODE.INSTRUCTION[FCIX] DO
35100 INSTR:=INSTR+10B %CAILE-->CAMLE, CAIL-->CAML\
35200 END
35300 END;
35400
35500 BEGIN
35600 OTHERSPTR:=NIL;
35700 EXPRESSION(FSYS OR [OFSY,COMMA,COLON],ONREGC);
35800 LOAD(GATTR);
35900 MACRO3(301B%CAIL\,REGC,0);%<<<---------- LMIN IS INSERTED HERE\
36000 MACRO3(303B%CAILE\,REGC,0);%<<<--------- LMAX IS INSERTED HERE\
36100 MACRO3(254B%JRST\,0,0);%<<<------------- START OF "OTHERS" IS INSERTED HERE\
36200 MACRO(NO,254B%JRST\,0,1,REGC,0);%<<<---- START OF JUMP TABLE IS INSERTED HERE\
36300 LCIX := CIX; LIC := IC;
36400 LSP := GATTR.TYPTR;
36500 IF LSP # NIL
36600 THEN
36700 IF (LSP^.FORM # SCALAR) OR (LSP = REALPTR)
36800 THEN
36900 BEGIN
37000 ERROR(315); LSP := NIL
37100 END;
37200 IF SY = OFSY
37300 THEN INSYMBOL
37400 ELSE ERROR(160);
37500 (* 65 - allow extra semicolon *)
37600 while sy=semicolon do
37700 insymbol;
37800 FSTPTR := NIL; LPT3 := NIL;
37900 LOOP
38000 LOOP
38100 CONSTANT(FSYS OR [COMMA,COLON],LSP1,LVAL);
38200 IF LSP # NIL
38300 THEN
38400 IF COMPTYPES(LSP,LSP1)
38500 THEN
38600 BEGIN
38700 LPT1 := FSTPTR; LPT2 := NIL;
38800 IF ABS(LVAL.IVAL) > HWCSTMAX
38900 THEN ERROR(316);
39000 WHILE LPT1 # NIL DO
39100 WITH LPT1^ DO
39200 BEGIN
39300 IF CSLAB <= LVAL.IVAL
39400 THEN
39500 BEGIN
39600 IF CSLAB = LVAL.IVAL
39700 THEN ERROR(261);
39800 GOTO 1
39900 END;
40000 LPT2 := LPT1; LPT1 := NEXT
40100 END;
40200 1:
40300 NEWZ(LPT3);
40400 WITH LPT3^ DO
40500 BEGIN
40600 NEXT := LPT1; CSLAB := LVAL.IVAL;
40700 CSSTART := IC; CSEND := 0
40800 END;
40900 IF LPT2 = NIL
41000 THEN FSTPTR := LPT3
41100 ELSE LPT2^.NEXT := LPT3
41200 END
41300 ELSE ERROR(505);
41400 EXIT IF SY # COMMA;
41500 INSYMBOL
41600 END;
41700 IF SY = COLON
41800 THEN INSYMBOL
41900 ELSE ERROR(151);
42000 REPEAT
42100 STATEMENT(FSYS,STATENDS)
42200 UNTIL NOT (SY IN STATBEGSYS);
42300 IF LPT3 # NIL
42400 THEN
42500 BEGIN
42600 MACRO3(254B%JRST\,0,0); LPT3^.CSEND := CIX
42700 END;
42800 (* 65 - allow extra semicolons *)
42900 while sy = semicolon
43000 do insymbol;
43100 exit if sy in (fsys or statends);
43200 IF SY=OTHERSSY
43300 THEN
43400 BEGIN
43500 INSYMBOL;
43600 IF SY=COLON
43700 THEN INSYMBOL
43800 ELSE ERROR(151);
43900 NEWZ(OTHERSPTR);
44000 WITH OTHERSPTR^ DO
44100 BEGIN
44200 CSSTART:=IC;
44300 REPEAT
44400 STATEMENT(FSYS,STATENDS)
44500 UNTIL NOT(SY IN STATBEGSYS);
44600 MACRO3(254B %JRST\,0,0);
44700 CSEND:=CIX;
44800 (* 65 - allow extra semicolons *)
44900 while sy=semicolon do
45000 insymbol;
45100 GOTO 2
45200 END
45300 END
45400 END;
45500 2:
45600 IF FSTPTR # NIL
45700 THEN
45800 BEGIN
45900 LMAX := FSTPTR^.CSLAB;
46000 %REVERSE POINTERS\
46100 LPT1 := FSTPTR; FSTPTR := NIL;
46200 REPEAT
46300 LPT2 := LPT1^.NEXT; LPT1^.NEXT := FSTPTR;
46400 FSTPTR := LPT1; LPT1 := LPT2
46500 UNTIL LPT1 = NIL;
46600 LMIN := FSTPTR^.CSLAB;
46700 INSERTBOUND(LCIX-2,LIC-2,LMAX);
46800 INSERTBOUND(LCIX-3,LIC-3,LMIN);
46900 (* 164 - Polish fixups to avoid problem with LOADER *)
47000 INSERTPOLISH(LIC-1,IC,-LMIN); {put IC-LMIN at LIC-1}
47100 IF LMAX - LMIN < CIXMAX-CIX
47200 THEN
47300 BEGIN
47400 LADDR := IC + LMAX - LMIN + 1;
47500 IF OTHERSPTR=NIL
47600 THEN JUMPADDR:=LADDR
47700 ELSE
47800 BEGIN
47900 INSERTADDR(RIGHT,OTHERSPTR^.CSEND,LADDR);
48000 JUMPADDR:=OTHERSPTR^.CSSTART
48100 END;
48200 INSERTADDR(RIGHT,LCIX-1,JUMPADDR);
48300 REPEAT
48400 WITH FSTPTR^ DO
48500 BEGIN
48600 WHILE CSLAB > LMIN DO
48700 BEGIN
48800 FULLWORD(RIGHT,0,JUMPADDR); LMIN := LMIN + 1
48900 END;
49000 FULLWORD(RIGHT,0,CSSTART);
49100 IF CSEND # 0
49200 THEN INSERTADDR(RIGHT,CSEND,LADDR);
49300 FSTPTR := NEXT; LMIN := LMIN + 1
49400 END
49500 UNTIL FSTPTR = NIL
49600 END
49700 ELSE ERROR(363)
49800 END;
49900 IF SY = ENDSY
50000 THEN INSYMBOL
50100 ELSE ERROR(163)
50200 END %CASESTATEMENT\ ;
50300
50400 PROCEDURE REPEATSTATEMENT;
50500 VAR
50600 LADDR: ADDRRANGE;
50700 BEGIN
50800 LADDR := IC;
50900 LOOP
51000 REPEAT
51100 STATEMENT(FSYS OR [UNTILSY],STATENDS OR [UNTILSY])
51200 UNTIL NOT (SY IN STATBEGSYS);
51300 EXIT IF SY # SEMICOLON;
51400 INSYMBOL
51500 END;
51600 IF SY = UNTILSY
51700 THEN
51800 BEGIN
51900 INSYMBOL; EXPRESSION(FSYS,FALSEJMP); INSERTADDR(RIGHT,CIX,LADDR);
52000 END
52100 ELSE ERROR(202)
52200 END %REPEATSTATEMENT\ ;
52300
52400 PROCEDURE WHILESTATEMENT;
52500 VAR
52600 LADDR: ADDRRANGE; LCIX: CODERANGE;
52700 BEGIN
52800 LADDR := IC;
52900 EXPRESSION(FSYS OR [DOSY],FALSEJMP);
53000 LCIX := CIX;
53100 IF SY = DOSY
53200 THEN INSYMBOL
53300 ELSE ERROR(161);
53400 STATEMENT(FSYS,STATENDS);
53500 MACRO3R(254B%JRST\,0,LADDR);
53600 INSERTADDR(RIGHT,LCIX,IC)
53700 END %WHILESTATEMENT\ ;
53800
53900 PROCEDURE FORSTATEMENT;
54000 VAR
54100 (* 104 - check subranges *)
54200 LATTR,SATTR: ATTR; LSP: STP; LSY: SYMBOL;
54300 LCIX: CODERANGE; LADDR,LDPLMT: ADDRRANGE; LINSTR: INSTRANGE;
54400 LREGC,LINDREG: ACRANGE; LINDBIT: IBRANGE; LRELBYTE: RELBYTE;
54500 ADDTOLC: INTEGER;
54600 BEGIN
54700 IF SY = IDENT
54800 THEN
54900 BEGIN
55000 SEARCHID([VARS],LCP);
55100 WITH LCP^, LATTR DO
00100 BEGIN
00200 TYPTR := IDTYPE; KIND := VARBL;
00300 IF VKIND = ACTUAL
00400 THEN
00500 BEGIN
00600 VLEVEL := VLEV;
00700 IF VLEV > 1
00800 THEN VRELBYTE := NO
00900 ELSE VRELBYTE := RIGHT;
01000 DPLMT := VADDR; INDEXR :=0; PACKFG := NOTPACK;
01100 INDBIT:=0
01200 END
01300 ELSE
01400 BEGIN
01500 ERROR(364); TYPTR := NIL
01600 END
01700 END;
01800 IF LATTR.TYPTR # NIL
01900 THEN
02000 IF COMPTYPES(REALPTR,LATTR.TYPTR) OR (LATTR.TYPTR^.FORM > SUBRANGE)
02100 THEN
02200 BEGIN
02300 ERROR(365); LATTR.TYPTR := NIL
02400 END;
02500 INSYMBOL
02600 END
02700 ELSE
02800 BEGIN
02900 ERRANDSKIP(209,FSYS OR [BECOMES,TOSY,DOWNTOSY,DOSY]);
03000 LATTR.TYPTR := NIL
03100 END;
03200 IF SY = BECOMES
03300 THEN
03400 BEGIN
03500 INSYMBOL; EXPRESSION(FSYS OR [TOSY,DOWNTOSY,DOSY],ONREGC);
03600 IF GATTR.TYPTR # NIL
03700 THEN
03800 IF GATTR.TYPTR^.FORM # SCALAR
03900 THEN ERROR(315)
04000 ELSE
04100 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
04200 (* 104 - range check subranges *)
04300 then begin
04400 if lattr.typtr # nil
04500 then if lattr.typtr^.form = subrange
04600 then loadsubrange(gattr,lattr.typtr)
04700 else load(gattr)
04800 end
04900 ELSE ERROR(556);
05000 LREGC := GATTR.REG
05100 END
05200 ELSE ERRANDSKIP(159,FSYS OR [TOSY,DOWNTOSY,DOSY]);
05300 IF SY IN [TOSY,DOWNTOSY]
05400 THEN
05500 BEGIN
05600 LSY := SY; INSYMBOL; EXPRESSION(FSYS OR [DOSY],ONREGC);
05700 IF GATTR.TYPTR # NIL
05800 THEN
05900 IF GATTR.TYPTR^.FORM # SCALAR
06000 THEN ERROR(315)
06100 ELSE
06200 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
06300 THEN
06400 BEGIN
06500 ADDTOLC := 0 ;
06600 WITH GATTR DO
06700 {This test checks for forms of upper bound that must be copied into a local
06800 variable. Originally, they tried to use variables in place instead of
06900 copying, to save the MOVE, MOVEM. The problem is that if the user changes
07000 the variable inside the loop, you have the wrong upper bound. We
07100 interpret the language spec as requiring the bound to be evaluated only
07200 once, at the start. The following test, commented out, was the original
07300 test, to see whether the object could be used in place for a CAMGE, or
07400 needed to be copied. Now we copy all variables, as just discussed.}
07500 {IF ( (KIND = VARBL) AND ( (VLEVEL > 1) AND (VLEVEL < LEVEL) OR
07600 (PACKFG # NOTPACK) OR (INDEXR > 0) AND (INDEXR <= REGCMAX) ) ) OR
07700 (KIND = EXPR) }
07800 IF (KIND = VARBL) OR (KIND = EXPR)
07900 THEN
08000 BEGIN
08100 (* 104 - add range checking for subrange types *)
08200 if lattr.typtr # nil
08300 then if lattr.typtr^.form = subrange
08400 then loadsubrange(gattr,lattr.typtr)
08500 else load(gattr);
08600 MACRO4(202B%MOVEM\,REGC,BASIS,LC); ADDTOLC := 1;
08700 KIND := VARBL ; INDBIT := 0 ; INDEXR := BASIS ; VLEVEL := 1;
08800 DPLMT := LC ; PACKFG := NOTPACK ; VRELBYTE := NO
08900 END
09000 else if lattr.typtr # nil
09100 then if (lattr.typtr^.form = subrange) and runtmcheck
09200 then begin
09300 (* must copy, since otherwise at end of loop
09400 makecode will think it is in an AC *)
09500 sattr := gattr;
09600 loadsubrange(sattr,lattr.typtr)
09700 end;
09800 FETCHBASIS(LATTR);
09900 WITH LATTR DO
10000 BEGIN
10100 IF (INDEXR>0) AND (INDEXR<=REGCMAX)
10200 THEN
10300 BEGIN
10400 MACRO(NO,201B%MOVEI\,INDEXR,INDBIT,INDEXR,DPLMT);
10500 LINDBIT := 1; LDPLMT := LC+ADDTOLC; LINDREG := BASIS ;
10600 MACRO4(202B%MOVEM\,INDEXR,BASIS,LDPLMT);
10700 ADDTOLC := ADDTOLC + 1 ;
10800 END
10900 ELSE
11000 BEGIN
11100 LINDBIT := INDBIT; LINDREG := INDEXR; LDPLMT := DPLMT
11200 END;
11300 LRELBYTE:= VRELBYTE
11400 END;
11500 MACRO(LRELBYTE,202B%MOVEM\,LREGC,LINDBIT,LINDREG,LDPLMT);
11600 IF LSY = TOSY
11700 THEN LINSTR := 313B%CAMLE\
11800 ELSE LINSTR := 315B%CAMGE\;
11900 LADDR := IC;
12000 MAKECODE(LINSTR,LREGC,GATTR) ;
12100 END
12200 ELSE ERROR(556)
12300 END
12400 ELSE ERRANDSKIP(251,FSYS OR [DOSY]);
12500 MACRO3(254B%JRST\,0,0); LCIX :=CIX;
12600 IF SY = DOSY
12700 THEN INSYMBOL
12800 ELSE ERROR(161);
12900 LC := LC + ADDTOLC;
13000 IF LC > LCMAX
13100 THEN LCMAX:=LC;
13200 STATEMENT(FSYS,STATENDS);
13300 LC := LC - ADDTOLC;
13400 IF LSY = TOSY
13500 THEN LINSTR := 350B%AOS\
13600 ELSE LINSTR := 370B%SOS\;
13700 MACRO(LRELBYTE,LINSTR,LREGC,LINDBIT,LINDREG,LDPLMT);
13800 MACRO3R(254B%JRST\,0,LADDR); INSERTADDR(RIGHT,LCIX,IC)
13900 END %FORSTATEMENT\ ;
14000
14100 PROCEDURE LOOPSTATEMENT;
14200 VAR
14300 LADDR: ADDRRANGE; LCIX: CODERANGE;
14400 BEGIN
14500 LADDR := IC;
14600 LOOP
14700 REPEAT
14800 STATEMENT(FSYS OR [EXITSY],STATENDS OR [EXITSY])
14900 UNTIL NOT (SY IN STATBEGSYS);
15000 EXIT IF SY # SEMICOLON;
15100 INSYMBOL
15200 END;
15300 IF SY = EXITSY
15400 THEN
15500 BEGIN
15600 INSYMBOL;
15700 IF SY = IFSY
15800 THEN
15900 BEGIN
16000 INSYMBOL; EXPRESSION(FSYS OR [SEMICOLON,ENDSY],TRUEJMP);
16100 END
16200 ELSE ERRANDSKIP(162,FSYS OR [SEMICOLON,ENDSY]);
16300 LCIX := CIX;
16400 LOOP
16500 REPEAT
16600 STATEMENT(FSYS,STATENDS)
16700 UNTIL NOT (SY IN STATBEGSYS);
16800 EXIT IF SY # SEMICOLON;
16900 INSYMBOL
17000 END;
17100 MACRO3R(254B%JRST\,0,LADDR); INSERTADDR(RIGHT,LCIX,IC)
17200 END
17300 ELSE ERROR(165);
17400 IF SY = ENDSY
17500 THEN INSYMBOL
17600 ELSE ERROR(163)
17700 END %LOOPSTATEMENT\ ;
17800
17900 PROCEDURE WITHSTATEMENT;
18000 VAR
18100 LCP: CTP; OLDLC: ADDRRANGE; LCNT1: DISPRANGE; OLDREGC: ACRANGE;
18200 BEGIN
18300 LCNT1 := 0; OLDREGC := REGCMAX; OLDLC := LC;
18400 LOOP
18500 IF SY = IDENT
18600 THEN
18700 BEGIN
18800 SEARCHID([VARS,FIELD],LCP); INSYMBOL
18900 END
19000 ELSE
19100 BEGIN
19200 ERROR(209); LCP := UVARPTR
19300 END;
19400 SELECTOR(FSYS OR [COMMA,DOSY],LCP);
19500 IF GATTR.TYPTR # NIL
19600 THEN
19700 IF GATTR.TYPTR^.FORM = RECORDS
19800 THEN
19900 IF TOP < DISPLIMIT
20000 THEN
20100 BEGIN
20200 TOP := TOP + 1; LCNT1 := LCNT1 + 1; WITHIX := WITHIX + 1;
20300 DISPLAY[TOP].FNAME := GATTR.TYPTR^.FSTFLD;
20400 WITH DISPLAY[TOP],GATTR DO
20500 BEGIN
20600 OCCUR := CREC;
20700 (* 5 - create block name for CREF *)
20800 BLKNAME := '.FIELDID. ';
20900 IF INDBIT = 1
21000 THEN GETPARADDR;
21100 FETCHBASIS(GATTR);
21200 IF (INDEXR#0) AND (INDEXR # BASIS)
21300 THEN
21400 BEGIN
21500 MACRO3(200B%MOVE\,REGCMAX,INDEXR);
21600 INDEXR := REGCMAX;
21700 REGCMAX := REGCMAX-1;
21800 IF REGCMAX<REGC
21900 THEN
22000 BEGIN
22100 ERROR(317);
22200 REGC := REGCMAX
22300 END
22400 END;
22500 CLEV := VLEVEL; CRELBYTE := VRELBYTE;
22600 CINDR := INDEXR; CINDB:=INDBIT;
22700 CDSPL := DPLMT;
22800 CLC := LC;
22900 IF (CINDR#0) AND (CINDR#BASIS)
23000 THEN
23100 BEGIN
23200 LC := LC + 1;
23300 IF LC>LCMAX
23400 THEN LCMAX := LC;
23500 END
23600 END
23700 END
23800 ELSE ERROR(404)
23900 ELSE ERROR(308);
24000 EXIT IF SY # COMMA;
24100 INSYMBOL
24200 END;
24300 IF SY = DOSY
24400 THEN INSYMBOL
24500 ELSE ERROR(161);
24600 STATEMENT(FSYS,STATENDS);
24700 REGCMAX:=OLDREGC;
24800 TOP := TOP - LCNT1; LC := OLDLC; WITHIX := WITHIX - LCNT1;
24900 END %WITHSTATEMENT\ ;
25000
25100 BEGIN
25200 %STATEMENT\
25300 IF SY = INTCONST
25400 THEN %LABEL\
25500 BEGIN
25600 (* 64 - non-loc gotos *)
25700 prterr := false;
25800 searchid([labelt],lcp);
25900 prterr := true;
26000 if lcp # nil
26100 then with lcp^ do
26200 if scope = level
26300 then labeladdress := ic;
26400 FOR IX:=1 TO LIX DO
26500 BEGIN
26600 WITH LABELS[IX] DO
26700 IF LABSVAL = VAL.IVAL
26800 THEN
26900 BEGIN
27000 ERROR(211);
27100 GOTO 1
27200 END
27300 END;
27400 LIX := LIX+1;
27500 IF LIX > LABMAX
27600 THEN
27700 BEGIN
27800 ERROR(362);
27900 LIX:=LABMAX
28000 END;
28100 WITH LABELS[LIX] DO
28200 BEGIN
28300 LABSVAL:=VAL.IVAL;
28400 LABSADDR:=IC
28500 END;
28600 FOR IX:=1 TO JIX DO
28700 BEGIN
28800 WITH GOTOS[IX] DO
28900 IF GOTOVAL = VAL.IVAL
29000 THEN
29100 BEGIN
29200 J:=CODE.INSTRUCTION[GOTOADDR].ADDRESS;
29300 INSERTADDR(RIGHT,GOTOADDR,IC);
29400 WHILE J#0 DO
29500 BEGIN
29600 GOTOADDR:=J;
29700 J:=CODE.INSTRUCTION[GOTOADDR].ADDRESS;
29800 INSERTADDR(RIGHT,GOTOADDR,IC)
29900 END;
30000 GOTOVAL:=-1;
30100 GOTO 1
30200 END
30300 END;
30400 1:
30500 INSYMBOL;
30600 IF SY = COLON
30700 THEN INSYMBOL
30800 ELSE ERROR(151)
30900 END;
31000 IF DEBUG AND NOT INITGLOBALS
31100 THEN PUTLINER;
31200 IF NOT (SY IN FSYS OR [IDENT])
31300 THEN ERRANDSKIP(166,FSYS);
31400 IF SY IN STATBEGSYS OR [IDENT]
31500 THEN
31600 BEGIN
31700 REGC:=REGIN ;
31800 IF INITGLOBALS AND (SY # IDENT)
31900 THEN ERROR(462)
32000 ELSE
32100 CASE SY OF
32200 IDENT:
32300 BEGIN
32400 SEARCHID([VARS,FIELD,FUNC,PROC],LCP); INSYMBOL;
32500 IF LCP^.KLASS = PROC
32600 THEN
32700 IF INITGLOBALS
32800 THEN ERROR(462)
32900 ELSE CALL(FSYS,LCP)
33000 ELSE ASSIGNMENT(LCP)
33100 END;
33200 BEGINSY:
33300 BEGIN
33400 INSYMBOL; COMPOUNDSTATEMENT
33500 END;
33600 GOTOSY:
33700 BEGIN
33800 INSYMBOL; GOTOSTATEMENT
33900 END;
34000 IFSY:
34100 BEGIN
34200 INSYMBOL; IFSTATEMENT
34300 END;
34400 CASESY:
34500 BEGIN
34600 INSYMBOL; CASESTATEMENT
34700 END;
34800 WHILESY:
34900 BEGIN
35000 INSYMBOL; WHILESTATEMENT
35100 END;
35200 REPEATSY:
35300 BEGIN
35400 INSYMBOL; REPEATSTATEMENT
35500 END;
35600 LOOPSY:
35700 BEGIN
35800 INSYMBOL; LOOPSTATEMENT
35900 END;
36000 FORSY:
36100 BEGIN
36200 INSYMBOL; FORSTATEMENT
36300 END;
36400 WITHSY:
36500 BEGIN
36600 INSYMBOL; WITHSTATEMENT
36700 END
36800 END;
36900 SKIPIFERR(STATENDS,506,FSYS)
37000 END;
37100 REGC := REGIN %RE-INITIALIZE REGISTER COUNTER TO AVOID OVERFLOW DURING SUBSEQUENT
37200 EXPRESSION EVALUATIONS IN REPEATSTATEMENT OR LOOPSTATEMENT \ ;
37300 END %STATEMENT\ ;
37400
37500 BEGIN
37600 %BODY\
37700 LIX:=0;JIX:=0;REGCMAX:=WITHIN;WITHIX := -1; FIRSTKONST := NIL;
37800 (* 164 - Polish fixups for CASE *)
37900 FIRSTPOL := NIL;
38000 IF NOT ENTRYDONE
38100 THEN
38200 BEGIN
38300 ENTRYDONE:= TRUE;
38400 WRITEMC(WRITEENTRY);
38500 WRITEMC(WRITENAME);
38600 WRITEMC(WRITEHISEG)
38700 END;
38800 CIX := -1 ;
38900 IF INITGLOBALS
39000 THEN
39100 BEGIN
39200 CGLOBPTR := NIL ;
39300 LOOP
39400 IF SY # ENDSY
39500 THEN STATEMENT([SEMICOLON,ENDSY],[SEMICOLON,ENDSY]) ;
39600 EXIT IF SY # SEMICOLON ;
39700 INSYMBOL
39800 END ;
39900 IF SY = ENDSY
40000 THEN INSYMBOL
40100 ELSE ERROR(163) ;
40200 WRITEMC(WRITEGLOBALS)
40300 END
40400 ELSE
40500 BEGIN
40600 %BODY PROPER\
40700 ENTERBODY;
40800 IF FPROCP # NIL
40900 (* 40 - fix print format *)
41000 THEN FPROCP^.PFADDR:= PFSTART
41100 ELSE LC:= 1;
41200 LCMAX:=LC;
41300 (* 54 - keep track of how many loc's above stack are used *)
41400 STKOFFMAX := 0;
41500 STKOFF := 0;
41600 IF MAIN OR (LEVEL > 1)
41700 THEN
41800 BEGIN
41900 LOOP
42000 REPEAT
42100 STATEMENT(FSYS OR [SEMICOLON,ENDSY],[SEMICOLON,ENDSY])
42200 UNTIL NOT (SY IN STATBEGSYS);
42300 EXIT IF SY # SEMICOLON;
42400 INSYMBOL
42500 END;
42600 IF SY = ENDSY
42700 THEN INSYMBOL
42800 ELSE ERROR(163);
42900 FOR IX:=1 TO JIX DO %TEST ON UNDEFINED LABELS\
43000 BEGIN
43100 WITH GOTOS[IX] DO
43200 IF GOTOVAL # -1
43300 THEN
43400 BEGIN
43500 ERROR(215);
43600 NEWZ(ERRMPTR1,D);
43700 WITH ERRMPTR1^ DO
43800 BEGIN
43900 NUMBER := 215; INTVAL := GOTOVAL; NEXT := ERRMPTR
44000 END;
44100 ERRMPTR := ERRMPTR1;
44200 END
44300 END
44400
44500 % WHILE FSTEXP # FEXP DO %TEST ON UNDEFINED EXIT LABELS\
44600
44700 END;
44800
44900 LEAVEBODY;
45000 IF MAIN OR (LEVEL > 1)
45100 (* 53 - allocate core for loc's above stack *)
45200 then
45300 begin
45400 (* 104 - check for overflow of address space *)
45500 if lcmax > 377777B (* else adjsp will see it negative *)
45600 then error(266);
45700 (* 62 - clean up stack offsets *)
45800 if fprocp # nil
45900 then insertaddr(no,insertsize,lcmax-fprocp^.poffset)
46000 else insertaddr(no,insertsize,lcmax); %below the stack\
46100 (* 57 - coralloc only needed for tops10 *)
46200 if tops10
46300 then insertaddr(no,coralloc,stkoffmax+40B); %above the stack\
46400 end;
46500 WRITEMC(WRITECODE);
46600 (* 40 - fix print format *)
46700 if fprocp # nil
46800 then writemc(writeblk);
46900 (* 64 - Polish fixups for CASE *)
47000 if firstpol # NIL
47100 then writemc(writepolish);
47200 IF FIRSTKONST # NIL
47300 THEN WRITEMC(WRITEINTERNALS)
47400 ELSE
47500 IF LOCALPFPTR # NIL
47600 THEN
47700 IF LOCALPFPTR^.PFLEV = LEVEL
47800 THEN WRITEMC(WRITEINTERNALS)
47900 (* 114 - ALWAYS WRITE INTERNALS IF REF TO NON-LOC GOTO *)
48000 ELSE IF LASTLABEL # NIL
48100 THEN IF LASTLABEL^.SCOPE = LEVEL
48200 THEN WRITEMC(WRITEINTERNALS)
48300 ELSE
48400 ELSE
48500 ELSE IF LASTLABEL # NIL
48600 THEN IF LASTLABEL^.SCOPE = LEVEL
48700 THEN WRITEMC(WRITEINTERNALS);
48800 IF LEVEL = 1
48900 THEN
49000 BEGIN
49100 WRITEMC(WRITESYMBOLS);
49200 WRITEMC(WRITELIBRARY);
49300 WRITEMC(WRITESTART);
49400 WRITEMC(WRITEEND)
49500 END
49600 END % BODY PROPER\
49700 END %BODY\ ;
49800
49900 (* 56 - PROCEDURES FOR FILE SWITCHING *)
50000 PROCEDURE OPENALT;
50100 BEGIN
50200 REQFILE := TRUE;
50300 (* 136 - listing format *)
50400 ORIGPAGECNT := PAGECNT; ORIGSUBPAGE := SUBPAGE; ORIGLINENR := LINENR;
50500 ORIGPAGE := PAGER; ORIGLINECNT := LINECNT; ORIGCH := CH;
50600 ENDSTUFF;
50700 PUSHF(INPUT,VAL.VALP^.SVAL,VAL.VALP^.SLGTH);
50800 (* 107 - error check openning of subfile *)
50900 if eof
51000 then begin (* nb: on the 20, analys does not show the file name in most cases *)
51100 (* 136 - LISTING FORMAT *)
51200 write('Failure to open INCLUDEd file: ',val.valp^.sval:val.valp^.slgth);
51300 NEWLINE;
51400 writeln(tty,'Failure to open INCLUDEd file: ',val.valp^.sval:val.valp^.slgth);
51500 analys(input); writeln(tty);
51600 rewrite(outputrel);
51700 (* 112 - clrbfi when error *)
51800 clribf;
51900 (* 123 - restore input so close gets done by pasxit *)
52000 close(input);
52100 popf(input);
52200 pasxit(input,output,outputrel)
52300 end;
52400 (* 136 - listing format *)
52500 PAGECNT := 1; SUBPAGE := 0; LINECNT := 1; CH := ' ';
52600 READLN; {because pushf does an interactive open}
52700 GETLINENR(LINENR);
52800 pagehead;
52900 WRITE(VAL.VALP^.SVAL:VAL.VALP^.SLGTH);
53000 newline; newline;
53100 BEGSTUFF
53200 END;
53300
53400 PROCEDURE CLOSEALT;
53500 BEGIN
53600 ENDSTUFF;
53700 POPF(INPUT);
53800 (* 136 - listing format *)
53900 PAGECNT := ORIGPAGECNT; SUBPAGE := ORIGSUBPAGE + 1;
54000 pagehead;
54100 write('Main file continued'); newline; newline;
54200 LINENR := ORIGLINENR; CH := ORIGCH;
54300 PAGER := ORIGPAGE; LINECNT := ORIGLINECNT;
54400 BEGSTUFF
54500 END;
54600
54700 PROCEDURE INCLUSION;
54800 BEGIN
54900 IF NOT (SY = STRINGCONST)
55000 THEN BEGIN ERROR(212); REQFILE := FALSE END
55100 ELSE BEGIN
55200 OPENALT;
55300 INSYMBOL
55400 END
55500 END;
55600
55700
55800 BEGIN
55900 %BLOCK\
56000 MARK(HEAPMARK);
56100 (* 24 - testpacked no longer needed *)
56200 (* 55 - ALL 55 PATCHES ARE FOR REQUIRE FILES - INITIALIZE REQFILE *)
56300 (* 65 - remove exit labels *)
56400 (* 125 - reqfile init moved *)
56500 (* 173 - internal files *)
56600 FILEINBLOCK[LEVEL] := FALSE;
56700 DP := TRUE; FORWPTR := NIL;
56800 REPEAT
56900 (* 23 - be sure LCPAR is set even when no VAR part *)
57000 LCPAR := LC;
57100 (* 56 - INCLUDE SYNTAX *)
57200 (* 126 - turn while into repeat for better to force check for BEGIN *)
57300 REPEAT
57400 (* 56 - SCAN REQUIRE FILE SYNTAX *)
57500 IF (SY=INCLUDESY) OR REQFILE
57600 THEN BEGIN
57700 INSYMBOL;
57800 INCLUSION;
57900 END;
58000 (* 55 - LABELS NOT LEGAL IN REQUIRE FILE *)
58100 IF (SY = LABELSY) AND NOT REQFILE
58200 THEN
58300 BEGIN
58400 INSYMBOL; LABELDECLARATION
58500 END;
58600 IF SY = CONSTSY
58700 THEN
58800 BEGIN
58900 INSYMBOL; CONSTANTDECLARATION
59000 END;
59100 IF SY = TYPESY
59200 THEN
59300 BEGIN
59400 INSYMBOL; TYPEDECLARATION
59500 END;
59600 (* 55 - NO VARIABLES OR INITPROC'S IN REQUIRE FILE *)
59700 IF NOT REQFILE THEN BEGIN
59800 LCPAR := LC;
59900 IF SY = VARSY
60000 THEN
60100 BEGIN
60200 INSYMBOL; VARIABLEDECLARATION
60300 END;
60400 (* 167 - resolve fwd type ref's *)
60500 {Note that FWDRESOLVE must be called after the VAR section because
60600 ^FOO in the VAR section is treated as a forward reference to FOO.
60700 We can't resolve this until after the end of the var section,
60800 since otherwise we might accept ^FOO where FOO is a type in an
60900 outer block, but a local variable in the current block. This seems
61000 to be illegal}
61100 FWDRESOLVE;
61200 (* 124 - detect initproc's when not at level 1 *)
61300 WHILE SY = INITPROCSY DO
61400 BEGIN
61500 IF LEVEL # 1
61600 THEN ERROR(557);
61700 INSYMBOL ;
61800 IF SY # SEMICOLON
61900 THEN ERRANDSKIP(156,[BEGINSY])
62000 ELSE INSYMBOL ;
62100 IF SY = BEGINSY
62200 THEN
62300 BEGIN
62400 MARK(GLOBMARK) ; INITGLOBALS := TRUE ;
62500 INSYMBOL ; BODY(FSYS OR [SEMICOLON,ENDSY]) ;
62600 IF SY = SEMICOLON
62700 THEN INSYMBOL
62800 ELSE ERROR(166) ;
62900 INITGLOBALS := FALSE ; RELEASE(GLOBMARK) ;
63000 END
63100 ELSE ERROR(201) ;
63200 END ;
63300 IF LEVEL=1
63400 THEN
63500 LCMAIN := LC;
63600 END;
63700 WHILE SY IN [PROCEDURESY,FUNCTIONSY] DO
63800 BEGIN
63900 LSY := SY; INSYMBOL; PROCEDUREDECLARATION(LSY)
64000 END;
64100 WHILE FORWPTR # NIL DO
64200 WITH FORWPTR^ DO
64300 BEGIN
64400 IF FORWDECL
64500 THEN ERRORWITHTEXT(465,NAME);
64600 FORWPTR := TESTFWDPTR
64700 END;
64800 (* 56 - REQ FILE ENDS IN PERIOD *)
64900 IF (MAIN OR (LEVEL > 1)) AND NOT REQFILE
65000 (* 126 - TWEAK ERROR RECOVER AGAIN *)
65100 THEN BEGIN IF SY # BEGINSY THEN ERROR(201) END
65200 (* 35 - fix error recovery, especially for /NOMAIN *)
65300 %This else is top level of /NOMAIN. If anything is here
65400 other than a period we have to turn on /MAIN, since otherwise
65500 BODY will refuse to scan anything.\
65600 ELSE IF SY # PERIOD
65700 THEN BEGIN
65800 ERROR(172);
65900 (* 56 - DON'T SET MAIN TO TRUE IN REQ FILE *)
66000 IF NOT REQFILE
66100 THEN MAIN := TRUE
66200 END;
66300 (* 55 - CLOSE REQFILE *)
66400 IF REQFILE
66500 THEN BEGIN
66600 (* 136 - listing format *)
66700 REQFILE := FALSE;
66800 CLOSEALT;
66900 INSYMBOL;
67000 IF SY = SEMICOLON
67100 THEN INSYMBOL
67200 ELSE IF SY = COMMA
67300 THEN REQFILE := TRUE
67400 ELSE
67500 ERROR(166);
67600 END;
67700 (* 126 - make it an UNTIL to force always check for BEGIN, etc. *)
67800 UNTIL NOT ( (SY IN BLOCKBEGSYS - [BEGINSY]) OR REQFILE);
67900 DP := FALSE;
68000 IF SY = BEGINSY
68100 THEN INSYMBOL;
68200 %ELSE ERROR(201) REDUNDANT HERE - MSG PRINTED ABOVE\
68300 BODY(FSYS OR [CASESY]);
68400 SKIPIFERR(LEAVEBLOCKSYS,166,FSYS)
00100 UNTIL SY IN LEAVEBLOCKSYS;
00200 RELEASE(HEAPMARK);
00300 END %BLOCK\ ;
00400
00500
00600
00700 PROCEDURE ENTERSTDTYPES;
00800 VAR
00900 LBTP: BTP; LSP: STP;
01000 BEGIN
01100 %TYPE UNDERLIEING:\
01200 %*****************\
01300
01400 NEWZ(INTPTR,SCALAR,STANDARD); %INTEGER\
01500 WITH INTPTR^ DO
01600 BEGIN
01700 SIZE := 1;BITSIZE := BITMAX; SELFSTP := NIL
01800 END;
01900 NEWZ(REALPTR,SCALAR,STANDARD); %REAL\
02000 WITH REALPTR^ DO
02100 BEGIN
02200 SIZE := 1;BITSIZE := BITMAX; SELFSTP := NIL
02300 END;
02400 NEWZ(CHARPTR,SCALAR,STANDARD); %CHAR\
02500 WITH CHARPTR^ DO
02600 BEGIN
02700 SIZE := 1;BITSIZE := 7; SELFSTP := NIL
02800 END;
02900 NEWZ(BOOLPTR,SCALAR,DECLARED); %BOOLEAN\
03000 WITH BOOLPTR^ DO
03100 BEGIN
03200 SIZE := 1;BITSIZE := 1; SELFSTP := NIL
03300 END;
03400 NEWZ(NILPTR,POINTER); %NIL\
03500 WITH NILPTR^ DO
03600 BEGIN
03700 ELTYPE := NIL; SIZE := 1; BITSIZE := 18; SELFSTP := NIL
03800 END;
03900 NEWZ(TEXTPTR,FILES); %TEXT\
04000 WITH TEXTPTR^ DO
04100 BEGIN
04200 FILTYPE := CHARPTR; SIZE := SIZEOFFILEBLOCK + 1; BITSIZE := BITMAX;
04300 FILEPF := FALSE; SELFSTP := NIL; HASFILE := TRUE;
04400 END;
04500 (* 15 - ALLOW "FILE" AS TYPE IN PROC DECL - ANY TYPE OF FILE *)
04600 NEWZ(ANYFILEPTR,FILES);
04700 WITH ANYFILEPTR^ DO
04800 BEGIN
04900 FILTYPE := NIL; SIZE := SIZEOFFILEBLOCK + 1; BITSIZE := BITMAX;
05000 FILEPF := FALSE; SELFSTP := NIL; HASFILE := TRUE;
05100 END;
05200 NEWZ(LSP,SUBRANGE);
05300 WITH LSP^ DO
05400 BEGIN
05500 RANGETYPE := INTPTR; MIN.IVAL := 1; MAX.IVAL := 9; SELFSTP := NIL
05600 END;
05700 NEWZ(DATEPTR,ARRAYS);
05800 WITH DATEPTR^ DO
05900 BEGIN
06000 ARRAYPF := TRUE; ARRAYBPADDR := 0;
06100 SELFSTP := NIL; AELTYPE := CHARPTR; INXTYPE := LSP;
06200 SIZE := 2; BITSIZE := 36
06300 END;
06400 NEWZ(LBTP,ARRAYY);
06500 WITH LBTP^, BYTE DO
06600 BEGIN
06700 SBITS := 7; PBITS := BITMAX; DUMMYBIT := 0;
06800 IBIT := 0; IREG := TAC; RELADDR := 0;
06900 LAST := LASTBTP; LASTBTP := LBTP; ARRAYSP := DATEPTR
07000 END;
07100 NEWZ(LSP,SUBRANGE);
07200 WITH LSP^ DO
07300 BEGIN
07400 RANGETYPE := INTPTR; MIN.IVAL := 1; MAX.IVAL := ALFALENG; SELFSTP := NIL
07500 END;
07600 NEWZ(ALFAPTR,ARRAYS);
07700 WITH ALFAPTR^ DO
07800 BEGIN
07900 ARRAYPF := TRUE; ARRAYBPADDR := 0;
08000 SELFSTP := NIL; AELTYPE := CHARPTR; INXTYPE := LSP;
08100 SIZE := 2; BITSIZE := 36
08200 END;
08300 (* 111 - STRING, POINTER *)
08400 NEWZ(STRINGPTR,ARRAYS);
08500 WITH STRINGPTR^ DO
08600 BEGIN
08700 ARRAYPF := TRUE; SELFSTP := NIL; AELTYPE := CHARPTR;
08800 (* 161 - fix string and pointer *)
08900 INXTYPE := NIL; SIZE := 2; BITSIZE := 36
09000 END;
09100 NEWZ(POINTERPTR,POINTER);
09200 WITH POINTERPTR^ DO
09300 BEGIN
09400 (* 161 - fix string and pointer *)
09500 ELTYPE := NIL; SIZE := 2; BITSIZE := 36; SELFSTP := NIL
09600 END;
09700 (* 202 - fix VAR POINTER *)
09800 NEWZ(POINTERREF,POINTER);
09900 (* 203 - had done pointerref^ := pointerptr^ - This copied too much *)
10000 WITH POINTERREF^ DO
10100 BEGIN
10200 (* 161 - fix string and pointer *)
10300 ELTYPE := NIL; SIZE := 2; BITSIZE := 36; SELFSTP := NIL
10400 END;
10500 NEWZ(LBTP,ARRAYY);
10600 WITH LBTP^, BYTE DO
10700 BEGIN
10800 SBITS := 7; PBITS := BITMAX; DUMMYBIT := 0;
10900 IBIT := 0; IREG := TAC; RELADDR := 0;
11000 LAST := LASTBTP; LASTBTP := LBTP; ARRAYSP := ALFAPTR
11100 END;
11200 END %ENTERSTDTYPES\ ;
11300
11400 PROCEDURE ENTERSTDNAMES;
11500 VAR
11600 CP,CP1: CTP; I,J: INTEGER; LFILEPTR :FTP ;
11700 BEGIN
11800 %NAME:\
11900 %*****\
12000
12100 NEWZ(CP,TYPES); %INTEGER\
12200 WITH CP^ DO
12300 BEGIN
12400 (* 116 - here and following: add next := nil for copyctp *)
12500 NAME := 'INTEGER '; IDTYPE := INTPTR; NEXT := NIL;
12600 END;
12700 ENTERID(CP);
12800 NEWZ(CP,TYPES); %REAL\
12900 WITH CP^ DO
13000 BEGIN
13100 NAME := 'REAL ';IDTYPE := REALPTR; NEXT := NIL;
13200 END;
13300 ENTERID(CP);
13400 NEWZ(CP, TYPES); %CHAR\
13500 WITH CP^ DO
13600 BEGIN
13700 NAME := 'CHAR '; IDTYPE := CHARPTR; NEXT := NIL;
13800 END;
13900 ENTERID(CP);
14000 NEWZ(CP,TYPES); %BOOLEAN\
14100 WITH CP^ DO
14200 BEGIN
14300 NAME := 'BOOLEAN '; IDTYPE := BOOLPTR; NEXT := NIL;
14400 END;
14500 ENTERID(CP);
14600 NEWZ(CP,TYPES); %TEXT\
14700 WITH CP^ DO
14800 BEGIN
14900 NAME := 'TEXT '; IDTYPE := TEXTPTR; NEXT := NIL;
15000 END;
15100 ENTERID(CP);
15200 NEWZ(CP,TYPES);
15300 WITH CP^ DO
15400 BEGIN
15500 NAME := 'ALFA '; IDTYPE := ALFAPTR; NEXT := NIL;
15600 END;
15700 ENTERID(CP);
15800 (* 111 - STRING, POINTER *)
15900 NEWZ(CP,PARAMS);
16000 WITH CP^ DO
16100 BEGIN
16200 NAME := 'STRING '; IDTYPE := STRINGPTR; NEXT := NIL;
16300 END;
16400 ENTERID(CP);
16500 NEWZ(CP,PARAMS);
16600 WITH CP^ DO
16700 BEGIN
16800 NAME := 'POINTER '; IDTYPE := POINTERPTR; NEXT := NIL;
16900 END;
17000 ENTERID(CP);
17100 NEWZ(CP,KONST); %NIL\
17200 WITH CP^ DO
17300 BEGIN
17400 NAME := 'NIL '; IDTYPE := NILPTR;
17500 NEXT := NIL; VALUES.IVAL := 377777B;
17600 END;
17700 ENTERID(CP);
17800 NEWZ(CP,KONST); %ALFALENG\
17900 WITH CP^ DO
18000 BEGIN
18100 NAME := 'ALFALENG '; IDTYPE := INTPTR;
18200 NEXT := NIL; VALUES.IVAL := 10;
18300 END;
18400 ENTERID(CP);
18500 (* 112 - maxint *)
18600 newz(cp,konst);
18700 with cp^ do
18800 begin
18900 name := 'MAXINT '; idtype := intptr;
19000 next := nil; values.ival := 377777777777B;
19100 end;
19200 enterid(cp);
19300 CP1 := NIL;
19400 FOR I := 1 TO 2 DO
19500 BEGIN
19600 NEWZ(CP,KONST); %FALSE,TRUE\
19700 WITH CP^ DO
19800 BEGIN
19900 NAME := NA[I]; IDTYPE := BOOLPTR;
20000 NEXT := CP1; VALUES.IVAL := I - 1;
20100 END;
20200 ENTERID(CP); CP1 := CP
20300 END;
20400 BOOLPTR^.FCONST := CP;
20500 FOR I := 3 TO 6 DO
20600 BEGIN
20700 NEWZ(CP,VARS); %INPUT,OUTPUT,TTY,TTYOUTPUT\
20800 (* 171 - treat files as special *)
20900 case i of
21000 3:infile := cp; 4:outfile := cp; 5:ttyfile := cp; 6:ttyoutfile := cp
21100 end;
21200 WITH CP^ DO
21300 BEGIN
21400 (* 173 - no channels any more *)
21500 NAME := NA[I]; IDTYPE := TEXTPTR; CHANNEL := I-2;
21600 VKIND := ACTUAL; NEXT := NIL; VLEV := 0;
21700 VADDR:= LC;
21800 LC := LC + 1 %BUFFERSIZE FOR TYPE CHAR\ + SIZEOFFILEBLOCK;
21900 NEWZ(LFILEPTR) ;
22000 WITH LFILEPTR^ DO
22100 BEGIN
22200 NEXTFTP := FILEPTR ;
22300 FILEIDENT := CP ;
22400 END ;
22500 FILEPTR := LFILEPTR ;
22600 END;
22700 ENTERID(CP)
22800 END;
22900 SFILEPTR := FILEPTR; %REMEMBER TOP OF STANDARD FILES\
23000 (* 16 - ADD DATA AT ENTRY *)
23100 CCLSW := LC; LC := LC+5;
23200 (* 66 - nonloc gotos *)
23300 globtopp := lc; lc:=lc+1; globbasis := lc; lc:=lc+1;
23400 (* 61 - allow us to distinguish tops10 and tops20 specific ftns *)
23500 if tops10
23600 then othermachine := t20name
23700 else othermachine := t10name;
23800
23900 % GET,GETLN,PUT,PUTLN,RESET,REWRITE,READ,READLN,
24000 WRITE,WRITELN,PACK,UNPACK,NEW,MARK,RELEASE,GETLINR,
24100 PUT8BITSTOTTY,PAGE\
24200
24300 FOR I := 7 TO 25 DO
24400 (* 61 - restrict tops10 and tops20 specific *)
24500 if machna[i] # othermachine then
24600 BEGIN
24700 NEWZ(CP,PROC,STANDARD);
24800 WITH CP^ DO
24900 BEGIN
25000 NAME := NA[I]; IDTYPE := NIL;
25100 NEXT := NIL; KEY := I - 6;
25200 END;
25300
25400 ENTERID(CP)
25500 END;
25600 (* 10 - ADD SETSTRING *)
25700 (* 14 - AND OTHERS *)
25800
25900 (* 27 - add NEWZ *)
26000 (* 61 - restrict tops10 and tops20 defn's *)
26100 (* 152 - DISPOSE *)
26200 FOR I := 54 TO 76 DO
26300 if machna[i] # othermachine then
26400 BEGIN
26500 NEWZ(CP,PROC,STANDARD);
26600 WITH CP^ DO
26700 BEGIN
26800 NAME := NA[I]; IDTYPE := NIL;
26900 NEXT := NIL; KEY := I - 32;
27000 END;
27100
27200 ENTERID(CP)
27300 END;
27400
27500 (* 44 - add curpos and its arg *)
27600 (* arg for CURPOS *)
27700 newz(cp1,vars);
27800 with cp1^ do
27900 begin
28000 name:=' ';idtype:=anyfileptr;
28100 vkind:=formal;next:=nil;vlev:=1;vaddr:=2
28200 end;
28300
28400 (* CURPOS *)
28500 (* 47 - more of this kind now *)
28600 (* 61 - tops10 and tops20 specific functions *)
28700 FOR I:=77 TO 79 DO
28800 if machna[i] # othermachine then
28900 begin
29000 newz(cp,func,declared,actual);
29100 with cp^ do
29200 begin
29300 name := na[i]; idtype:=intptr; next:=cp1; forwdecl:=false;
29400 externdecl := true; pflev:=0; pfaddr:=0; pfchain:=externpfptr;
29500 externpfptr:=cp; for j:=0 to maxlevel do linkchain[j]:=0; externalname:=na[i];
29600 language:=pascalsy
29700 end;
29800 enterid(cp);
29900 end;
30000
30100 NEWZ(CP,FUNC,DECLARED,ACTUAL);
30200 WITH CP^ DO
30300 BEGIN
30400 NAME := NA[26]; IDTYPE := DATEPTR; NEXT := NIL; FORWDECL := FALSE;
30500 EXTERNDECL := TRUE; PFLEV := 0; PFADDR := 0; PFCHAIN := EXTERNPFPTR;
30600 EXTERNPFPTR := CP; FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0; EXTERNALNAME := NA[26];
30700 LANGUAGE := FORTRANSY
30800 END;
30900 ENTERID(CP);
31000
31100 % RUNTIME,TIME,ABS,SQR,TRUNC,ODD,ORD,CHR,PRED,SUCC,EOF,EOLN \
31200
31300 FOR I := 27 TO 38 DO
31400 BEGIN
31500 NEWZ(CP,FUNC,STANDARD);
31600 WITH CP^ DO
31700 BEGIN
31800 NAME := NA[I]; IDTYPE := NIL;
31900 NEXT := NIL; KEY := I - 26;
32000 END;
32100 ENTERID(CP)
32200 END;
32300
32400 FOR I := 80 TO 81 DO
32500 BEGIN
32600 NEWZ(CP,FUNC,STANDARD);
32700 WITH CP^ DO
32800 BEGIN
32900 NAME := NA[I]; IDTYPE := NIL;
33000 NEXT := NIL; KEY := I - 66;
33100 END;
33200 ENTERID(CP)
33300 END;
33400 NEWZ(CP,VARS); %PARAMETER OF PREDECLARED FUNCTIONS\
33500 WITH CP^ DO
33600 BEGIN
33700 NAME := ' '; IDTYPE := REALPTR;
33800 VKIND := ACTUAL; NEXT := NIL; VLEV := 1; VADDR := 2
33900 END;
34000
34100 % SIN,COS,EXP,SQRT,ALOG,ATAN,ALOG10,
34200 SIND,COSD,SINH,COSH,TANH,ASIN,ACOS,RAN \
34300
34400 FOR I := 39 TO 53 DO
34500 BEGIN
34600 NEWZ(CP1,FUNC,DECLARED,ACTUAL);
34700 WITH CP1^ DO
34800 BEGIN
34900 NAME := NA[I]; IDTYPE := REALPTR; NEXT := CP;
35000 FORWDECL := FALSE; EXTERNDECL := TRUE; PFLEV := 0; PFADDR := 0;
35100 PFCHAIN:= EXTERNPFPTR; EXTERNPFPTR:= CP1; EXTERNALNAME := EXTNA[I];
35200 FOR J := 0 TO MAXLEVEL DO LINKCHAIN[J] := 0; LANGUAGE := EXTLANGUAGE[I]
35300 END;
35400 ENTERID(CP1)
35500 END;
35600 LCMAIN := LC;
35700 END %ENTERSTDNAMES\ ;
35800
35900 PROCEDURE ENTERUNDECL;
36000 VAR
36100 I: INTEGER;
36200 BEGIN
36300 NEWZ(UTYPPTR,TYPES);
36400 WITH UTYPPTR^ DO
36500 BEGIN
36600 NAME := ' '; IDTYPE := NIL; NEXT := NIL;
36700 END;
36800 NEWZ(UCSTPTR,KONST);
36900 WITH UCSTPTR^ DO
37000 BEGIN
37100 NAME := ' '; IDTYPE := NIL; NEXT := NIL;
37200 VALUES.IVAL := 0
37300 END;
37400 NEWZ(UVARPTR,VARS);
37500 WITH UVARPTR^ DO
37600 BEGIN
37700 NAME := ' '; IDTYPE := NIL; VKIND := ACTUAL;
37800 NEXT := NIL; VLEV := 0; VADDR := 0
37900 END;
38000 (* 135 - UARRPTR is needed as dummy to prevent ill mem ref in PACK/UNPACK *)
38100 NEWZ(UARRTYP,ARRAYS);
38200 WITH UARRTYP^ DO
38300 BEGIN
38400 ARRAYPF := FALSE; SELFSTP := NIL; AELTYPE := NIL;
38500 INXTYPE := NIL; SIZE := 777777B; BITSIZE := 36
38600 END;
38700 NEWZ(UFLDPTR,FIELD);
38800 WITH UFLDPTR^ DO
38900 BEGIN
39000 NAME := ' '; IDTYPE := NIL; NEXT := NIL; FLDADDR := 0;
39100 PACKF := NOTPACK
39200 END;
39300 NEWZ(UPRCPTR,PROC,DECLARED,ACTUAL);
39400 WITH UPRCPTR^ DO
39500 BEGIN
39600 NAME := ' '; IDTYPE := NIL; FORWDECL := FALSE;
39700 FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0;
39800 NEXT := NIL; EXTERNDECL := FALSE; PFLEV := 0; PFADDR := 0
39900 END;
40000 NEWZ(UFCTPTR,FUNC,DECLARED,ACTUAL);
40100 WITH UFCTPTR^ DO
40200 BEGIN
40300 NAME := ' '; IDTYPE := NIL; NEXT := NIL;
40400 FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0;
40500 FORWDECL := FALSE; EXTERNDECL := FALSE; PFLEV := 0; PFADDR := 0
40600 END;
40700 (* 64 - non-loc gotos *)
40800 newz(ulblptr,labelt);
40900 with ulblptr^ do
41000 begin
41100 name := ' '; idtype := nil; next := nil;
41200 scope := 0; gotochain := 0; labeladdress := 0;
41300 end;
41400 END %ENTERUNDECL\ ;
41500
41600 PROCEDURE ENTERDEBNAMES;
41700 VAR
41800 CP:CTP;
41900 BEGIN
42000 NEWZ(CP,PROC,STANDARD);
42100 WITH CP^ DO
42200 BEGIN
42300 NAME := 'PROTECTION';
42400 IDTYPE := NIL; NEXT := NIL; KEY:= 21
42500 END;
42600 ENTERID(CP);
42700 END;
42800
42900 (* 4 - replace file name scanner with call to SCAN *)
43000 (* 11 - new definition of PASPRM *)
43100 FUNCTION PASPRM(VAR I,O:TEXT;VAR R:INTFILE):RPGPT; EXTERN;
43200
43300 (* 104 - improved error detection in tops10 *)
43400 (* 107 - moved declaration of analys earlier *)
43500
43600 BEGIN
43700 %ENTER STANDARD NAMES AND STANDARD TYPES:\
43800 %****************************************\
43900
44000 (* 41 - make restartable *)
44100 reinit;
44200
44300 RTIME := RUNTIME; DAY := DATE;
44400 LEVEL := 0; TOP := 0;
44500 WITH DISPLAY[0] DO
44600 BEGIN
44700 (* 5 - create block name for CREF *)
44800 FNAME := NIL; OCCUR := BLCK; BLKNAME := '.PREDEFIN.';
44900 END;
45000 ENTERSTDTYPES; ENTERSTDNAMES; ENTERUNDECL; ENTERDEBNAMES;
45100
45200 TOP := 1; LEVEL := 1;
45300 WITH DISPLAY[1] DO
45400 BEGIN
45500 (* 5 - create block name for CREF *)
45600 FNAME := NIL; OCCUR := BLCK; BLKNAME := '.GLOBAL. ';
45700 END;
45800
45900 %OPEN COMPILER FILES\
46000 %*******************\
46100
46200 (* 4 - here we open the files that SCAN gave us *)
46300 REWRITE(TTYOUTPUT);
46400 SCANDATA := PASPRM(INPUT,OUTPUT,OUTPUTREL);
46500 WITH SCANDATA ^ DO
46600 BEGIN
46700 (* 33 - VERSION NO *)
46800 VERSION.WORD := VERVAL;
46900 (* I haven't figured out what to do about lookup blocks. Commented out for now *)
47000 (* 104 - fix error detection on tops10 *)
47100 if tops10
47200 then reset(input,'',true,lookblock,40000B,4000B) {tag for SOS}
47300 else reset(input,'',0,0,0,20B); {see EOL char's}
47400 if eof {tag for SOS}
47500 then begin
47600 analys(input);
47700 pasxit(input,output,outputrel);
47800 end;
47900 get(input); {tag for SOS}
48000 IF VERSION.WORD = 0 THEN VERSION.WORD := LOOKBLOCK[6];
48100 LOOKBLOCK[6] := VERSION.WORD;
48200 FOR I := 1 TO 5 DO LOOKBLOCK[I] := 0;
48300 REWRITE(OUTPUT,'',0,LOOKBLOCK); {tag for SOS}
48400 FOR I := 1 TO 5 DO LOOKBLOCK[I] := 0;
48500 REWRITE(OUTPUTREL,'',0,LOOKBLOCK); {tag for SOS}
48600 FILENAME := RELNAME;
48700 (* 34 - DON'T NEED ENTRY NOW *)
48800 IF FILENAME = ' '
48900 THEN FILENAME := '.NONAM '; %A BLANK ENTRY NAME IS BAD NEWS\
49000 LISTCODE := LSW;
49100 TTYINUSE := TSW;
49200 MAIN := MSW;
49300 RUNTMCHECK := CSW;
49400 (* 160 - compiler switch /ARITHCHECK *)
49500 ARITHCHECK := ASW;
49600 DEBUGSWITCH := DSW;
49700 CREF:=CRSW;
49800 DEBUG := DSW;
49900 RPGENTRY := RPGSW;
50000 (* 7 - ADD /HEAP SWITCH *)
50100 (* 12 - /heap no longer needed *)
50200 (* 24 - /HEAP AND /STACK NOW USED FOR START ADDR *)
50300
50400 HEAP := HEAPVAL;
50500 STACK := STACKVAL;
50600 (* 25 - /ZERO *)
50700 ZERO := ZSW
50800 END;
50900
51000 %WRITE HEADER\
51100 %************\
51200
51300 (* 136 - listing format *)
51400 pagehead;
51500 %NEW LINE FOR ERROR MESSAGES OR PROCEDURENAMES\
51600 GETNEXTLINE; %GETS FIRST LINENUMBER IF ANY\
51700 CH := ' '; INSYMBOL; RESETFLAG := FALSE;
51800 IF NOT MAIN
51900 THEN
52000 BEGIN
52100 LC := PROGRST; LCMAIN := LC;
52200 WHILE SFILEPTR # NIL DO
52300 WITH SFILEPTR^, FILEIDENT^ DO
52400 BEGIN
52500 VADDR:= 0; SFILEPTR:= NEXTFTP
52600 END;
52700 SFILEPTR := FILEPTR;
52800 END;
52900
53000 %COMPILE:\
53100 %********\
53200
53300 (* 5 - CREF *)
53400 IF CREF
53500 THEN WRITE(CHR(15B),CHR(10),'.GLOBAL. ');
53600
53700 FOR I := 1 TO CHCNTMAX DO ERRLINE[I] := ' '; RELBLOCK.COUNT:= 0;
53800 FOR SUPPORTIX := FIRSTSUPPORT TO LASTSUPPORT DO RNTS.LINK[SUPPORTIX] := 0;
53900
54000 (* 6 - allow PROGRAM statement *)
54100 PROGSTAT;
54200 (* 13 - PRINT HEADER NOW THAT HAD PROG STATEMENT SCANNED *)
54300 IF RPGENTRY
54400 THEN WRITELN(TTY,'PASCAL:',CHR(11B),FILENAME:6);
54500 (* 41 - Don't print header *)
54600 (* 26 - break not needed for TTY *)
54700 BLOCK(NIL,BLOCKBEGSYS OR STATBEGSYS-[CASESY],[PERIOD]);
54800
54900 (* 104 - detect programs that don't fit in address space *)
55000 (* 216 - settable highseg start *)
55100 if (highestcode > maxaddr) or (lcmain >= highstart)
55200 then error(266);
55300
55400 (* 5 - CREF *)
55500 IF CREF
55600 THEN WRITE(CHR(16B),CHR(10),'.GLOBAL. ');
55700
55800 (* 16 - EOF *)
55900 ENDOFLINE(TRUE);
56000 (* 5 - CREF *)
56100 if cref and not eof(input)
56200 then write(chr(177B),'A'); %balances <ro>B from ENDOFLINE\
56300 (* 136 - LISTING FORMAT *)
56400 NEWLINE ; NEWLINE ;
56500 IF NOT ERRORFLAG
56600 THEN
56700 BEGIN
56800 (* 4 - Make us look normal if called by COMPIL *)
56900 WRITE('No ') ; IF NOT RPGENTRY THEN WRITE(TTY,'No ')
57000 END
57100 ELSE WRITE(TTY,'?');
57200 (* 136 - LISTING FORMAT *)
57300 WRITE('error detected') ; NEWLINE;
57400 IF (NOT RPGENTRY) OR ERRORFLAG
57500 THEN
57600 (* 26 - break not needed for TTY *)
57700 WRITELN(TTY,'error detected');
57800 IF ERRORFLAG
57900 (* 112 - clrbfi when error *)
58000 THEN BEGIN
58100 REWRITE(OUTPUTREL);
58200 clribf;
58300 end
58400 ELSE IF NOT RPGENTRY THEN
00100 BEGIN
00200 (* 136 - LISTING FORMAT *)
00300 WRITELN(TTY); NEWLINE;
00400 (* 216 - allow start of high seg other than 400000 *)
00500 I := (HIGHESTCODE - HIGHSTART + 1023) DIV 1024;
00600 WRITELN(TTY,'Highseg: ',I:3,'K'); WRITELN('Highseg: ',I:3,'K');
00700 I := (LCMAIN + 1023) DIV 1024;
00800 WRITELN(TTY,'Lowseg : ',I:3,'K'); WRITELN('Lowseg : ',I:3,'K');
00900 END;
01000 (* 4 - Make us look normal if called by COMPIL *)
01100 IF NOT RPGENTRY THEN BEGIN
01200 RTIME := RUNTIME - RTIME;
01300 WRITE(TTY,'Runtime: ',(RTIME DIV 60000):3,':');
01400 RTIME := RTIME MOD 60000;
01500 WRITE(TTY,(RTIME DIV 1000):2,'.');
01600 RTIME := RTIME MOD 1000;
01700 WRITELN(TTY,RTIME:3)
01800 (* 4 - get back to SCAN if appropriate *)
01900 END;
02000 PASXIT(INPUT,OUTPUT,OUTPUTREL)
02100 END.