Trailing-Edge
-
PDP-10 Archives
-
decuslib10-07
-
43,50433/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:001200000214B\
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
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 *)
41400
41500 CONST
41600 HEADER = 'PASCAL %12(214)';
41700
41800 DISPLIMIT = 20; MAXLEVEL = 8;
41900 STRGLGTH = 120; BITMAX = 36;
42000 (* 43 - longer file block for new runtimes *)
42100 SIZEOFFILEBLOCK=43B ; {plus size of component}
42200 OFFSET=40B; %FUER SETVERARBEITUNG DER ASCIICHARACTER\
42300 CHCNTMAX = 132; %MAXIMUM OF CHARACTERS IN ONE LINE\
42400 LEFT = 2;RIGHT = 1;BOTH = 3;NO = 0;
42500
42600 %KONSTANTEN VON BODY: \
42700 %*********************\
42800
42900 (* move cixmax to param file *)
43000 HWCSTMAX = 377777B; LABMAX = 20;
43100 (* 2 - increase default stack space *)
43200 (* 7 - stackandheap now set by switch *)
43300 (* 137 - fix set constructor for CHAR *)
43400 MAXERR = 4; BASEMAX = 71; CHARMAX = 177B;
43500
43600 %ADDRESSES:
43700 **********\
43800
43900 HAC=0; %HILFSREGISTER\
44000 TAC=1; %HILFSREGISTER AUCH FUER BYTEPOINTER\
44100 REGIN=1; %INITIALISE REGC\
44200 PARREGCMAX=6; %HIGHEST REGISTER USED FOR PARAMETERS\
44300 WITHIN=12; %FIRST REGISTER FOR WITHSTACK\
44400 NEWREG=13; %LAST PLACE OF NEW-STACK\
44500 BASIS=14; %BASIS ADDRESS STACK\
44600 TOPP=15; %FIRST FREE PLACE IN DATASTACK\
44700 PROGRST = 145B; %LOC 140B..144B RESERVED FOR DEBUG-PROGR.\
44800 HIGHSTART=400000B;
44900 MAXADDR=777777B;
45000
45100
45200
45300
45400
45500 TYPE
45600 %DESCRIBING:\
45700 %***********\
45800
45900
46000 %BASIC SYMBOLS\
46100 %*************\
46200
46300 SYMBOL = (IDENT,INTCONST,REALCONST,STRINGCONST,NOTSY,MULOP,ADDOP,RELOP,
46400 LPARENT,RPARENT,LBRACK,RBRACK,COMMA,SEMICOLON,PERIOD,ARROW,
46500 COLON,BECOMES,LABELSY,CONSTSY,TYPESY,VARSY,VALUESY,FUNCTIONSY,
46600 (* 6 - add PROGRAM statement *)
46700 (* 56 - ADD INCLUDE *)
46800 PROCEDURESY,SETSY,PACKEDSY,ARRAYSY,RECORDSY,FILESY,FORWARDSY,PROGRAMSY,INCLUDESY,
46900 BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITHSY,LOOPSY,
47000 GOTOSY,EXITSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY,
47100 EXTERNSY,PASCALSY,FORTRANSY,ALGOLSY,COBOLSY,
47200 THENSY,OTHERSY,INITPROCSY,OTHERSSY);
47300
47400 OPERATOR = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,LTOP,LEOP,GEOP,GTOP,
47500 NEOP,EQOP,INOP,NOOP);
47600
47700 SETOFSYS = SET OF SYMBOL;
47800
47900 (* 23 - check for bad pointer *)
48000 (* 24 - ONLY CLEAR NEW WHEN TYPECHECKING *)
48100 (* 104 - new tops10 stackoverflow *)
48200 (* 152 - DISPOSE *)
48300 SUPPORTS = (FIRSTSUPPORT,STACKOVERFLOW,DEBSTACK,BADPOINT,ALLOCATE,CLEARALLOC,DEALLOCATE,
48400 (* 173 - internal files *)
48500 WITHFILEDEALLOCATE,
48600 (* 43 - add PUTX *)
48700 (* 64 - non-loc goto *)
48800 EXITGOTO,EXITPROGRAM,GETLINE,GETFILE,PUTLINE,PUTFILE,PUTXFILE,
48900 (* 57 - Add strset and strwrite external routines *)
49000 RESETFILE,REWRITEFILE,RESETSTRING,REWRITESTRING,GETCHARACTER,PUTPAGE,ERRORINASSIGNMENT,
49100 (* 173 - internal files *)
49200 FILEUNINITIALIZED,INITFILEBLOCK,
49300 WRITEPACKEDSTRING,WRITESTRING,WRITEBOOLEAN,READCHARACTER,READINTEGER,READREAL,
49400 (* 171 - RECORD READ/WRITE *)
49500 (* 206 - extend for constants *)
49600 READRECORD,WRITERECORD,WRITESCALAR,
49700 BREAKOUTPUT,OPENTTY,INITIALIZEDEBUG,ENTERDEBUG,INDEXERROR,WRITEOCTAL,WRITEINTEGER,WRITEREAL,
49800 (* 10 add CLOSE *)
49900 WRITEHEXADECIMAL,WRITECHARACTER,CONVERTINTEGERTOREAL,
50000 (* 14 and lots more *)
50100 (* 33 - PROGRAM statement *)
50200 CONVERTREALTOINTEGER,CLOSEFILE,READSTRING,READPACKEDSTRING,READFILENAME,
50300 NAMEFILE,DISFILE,UPFILE,APFILE,READDUMP,WRITEDUMP,SETIN,SETOUT,BREAKINPUT,
50400 (* 74 - tops20 routines *)
50500 SETPOSF,CURPOSF,NEXTBLOCKF,SPACELEFTF,GETXF,DELFILE,RELFILE,INITMEM,INITFILES,
50600 (* 163 - tops20 TIME function *)
50700 GETDAYTIME,LASTSUPPORT);
50800
50900 %CONSTANTS\
51000 %*********\
51100
51200 CSTCLASS = (INT,REEL,PSET,STRD,STRG);
51300 CSP = ^ CONSTNT;
51400 (* 55 - add require files *)
51500 STRGARR = PACKED ARRAY[1..STRGLGTH] OF CHAR;
51600 CONSTNT = RECORD
51700 SELFCSP: CSP; NOCODE: BOOLEAN;
51800 CASE CCLASS: CSTCLASS OF
51900 INT : (INTVAL: INTEGER; INTVAL1:INTEGER %TO ACCESS SECOND WORD OF PVAL\ );
52000 REEL: (RVAL: REAL);
52100 PSET: (PVAL: SET OF 0..71);
52200 STRD,
52300 STRG: (SLGTH: 0..STRGLGTH;
58500 ARRAYY : (ARRAYSP: STP)
58600 END;
58700 GLOBPTR = RECORD
58800 NEXTGLOBPTR: GTP ;
58900 FIRSTGLOB,
59000 LASTGLOB : ADDRRANGE ;
59100 FCIX : CODERANGE
59200 END ;
59300
59400 FILBLCK = PACKED RECORD
59500 NEXTFTP : FTP ;
59600 FILEIDENT : CTP
59700 END ;
59800
59900 %NAMES\
60000 %*****\
60100
60200 (* 64 - non-loc goto *)
60300 (* 111 - STRING, POINTER *)
60400 (* PARAMS is a special kind of TYPES. It is used only for
60500 predeclared identifiers describing kludgey types that are
60600 valid only in procedure parameter lists. *)
60700 IDCLASS = (TYPES,KONST,VARS,FIELD,PROC,FUNC,LABELT,PARAMS);
60800 SETOFIDS = SET OF IDCLASS;
60900 IDKIND = (ACTUAL,FORMAL);
61000 PACKKIND = (NOTPACK,PACKK,HWORDR,HWORDL);
61100 CHARWORD = PACKED ARRAY [1..5] OF CHAR;
61200 %ALFA = PACKED ARRAY [1..ALFALENG] OF CHAR;\
61300
61400 IDENTIFIER = PACKED RECORD
61500 NAME: ALFA;
61600 LLINK, RLINK: CTP;
61700 IDTYPE: STP; NEXT: CTP;
61800 SELFCTP: CTP; NOCODE: BOOLEAN;
61900 CASE KLASS: IDCLASS OF
62000 KONST: (VALUES: VALU);
62100 VARS: (VKIND: IDKIND; VLEV: LEVRANGE;
62200 CHANNEL: ACRANGE; VDUMMY: 0..31; VADDR: ADDRRANGE);
62300 FIELD: (PACKF: PACKKIND; FDUMMY: 0..7777B;
62400 FLDADDR: ADDRRANGE);
62500 %IF PACKF=PACKK THEN FLDADDR CONTAINS THE
62600 ABSOLUTE ADDRESS OF THE CORRESPONDING BYTEPOINTER
62700 -----> ENTERBODY\
62800 PROC,
62900 FUNC: (PFCHAIN: CTP; CASE PFDECKIND: DECLKIND OF
63000 STANDARD: (KEY: 1..44);
63100 DECLARED: (PFLEV: LEVRANGE; PFADDR: ADDRRANGE;
63200 CASE PFKIND: IDKIND OF
63300 ACTUAL: (FORWDECL: BOOLEAN; TESTFWDPTR: CTP;
63400 EXTERNDECL: BOOLEAN; LANGUAGE: SYMBOL;
63500 EXTERNALNAME: ALFA;
63600 LINKCHAIN: PACKED ARRAY[LEVRANGE] OF ADDRRANGE;
63700 (* 62 - clean of stack offsets *)
63800 POFFSET:ADDRRANGE)));
63900 (* 66 - non-local goto's *)
64000 LABELT: (SCOPE:LEVRANGE;NONLOCGOTO:BOOLEAN;
64100 GOTOCHAIN:ADDRRANGE;LABELADDRESS:ADDRRANGE)
64200 END;
64300
64400
64500 DISPRANGE = 0..DISPLIMIT;
64600 WHERE = (BLCK,CREC);
64700 (* 61 - new type to separate tops10 and tops20 ftns *)
64800 machine = (okname,t10name,t20name);
64900
65000 %RELOCATION\
65100 %**********\
65200
65300 RELBYTE = 0..3B %(NO,RIGHT,LEFT,BOTH)\;
65400
65500 RELWORD = PACKED ARRAY[0..17] OF RELBYTE;
65600
65700 %EXPRESSIONS\
65800 %***********\
65900
66000 ATTRKIND = (CST,VARBL,EXPR);
66100
66200 ATTR = RECORD
66300 TYPTR: STP;
66400 CASE KIND: ATTRKIND OF
66500 CST: (CVAL: VALU);
66600 VARBL: (PACKFG: PACKKIND; INDEXR: ACRANGE; INDBIT: IBRANGE;
66700 VLEVEL: LEVRANGE; BPADDR,DPLMT: ADDRRANGE; VRELBYTE: RELBYTE; SUBKIND: STP);
66800 EXPR: (REG:ACRANGE)
66900 END;
67000
67100 TESTP = ^ TESTPOINTER;
67200 TESTPOINTER = PACKED RECORD
67300 ELT1,ELT2: STP;
67400 LASTTESTP: TESTP
67500 END;
67600
67700 (* 65 - remove exit labels *)
67800
67900 %TYPES FROM BODY \
68000 %****************\
68100
68200 (* 13 - ADD WRITEBLOCK FOR DDT SYMBOLS *)
68300 WRITEFORM = (WRITEENTRY,WRITENAME,WRITEHISEG,WRITEGLOBALS,WRITECODE,WRITEINTERNALS,
68400 (* 164 - add Polish fixups *)
68500 WRITEPOLISH,WRITELIBRARY,
68600 (* 173 - remove writefileblock *)
68700 WRITESYMBOLS,WRITEBLK,WRITESTART,WRITEEND);
68800
68900 UPDATEFORM = (C,D);
69000 ETP = ^ ERRORUPDATE;
69100 ERRORUPDATE = PACKED RECORD
69200 NUMBER: INTEGER;
69300 NEXT: ETP;
69400 CASE FORM: UPDATEFORM OF
69500 C: (STRING: ALFA);
69600 D: (INTVAL: INTEGER)
69700 END;
69800
69900 KSP = ^ KONSTREC;
70000 KONSTREC = PACKED RECORD
70100 (* 72 - two fixup chains for 2 word consts *)
70200 ADDR, ADDR1, KADDR: ADDRRANGE;
70300 CONSTPTR: CSP;
70400 NEXTKONST: KSP
70500 END;
70600 (* 164 - Polish fixups for CASE *)
70700 POLPT = ^ POLREC;
70800 {This record indicates a Polish fixup to be done at address WHERE in
70900 the code. The RH of WHERE is to get the BASE (assumed relocatable),
71000 adjusted by OFFSET (a constant). This is needed because the loader
71100 assumes that any address < 400000B is in the lowseg. So to get the
71200 virtual start of the CASE statement branch table we need to use
71300 this to adjust the physical start of the table by the first case
71400 index}
71500 POLREC = PACKED RECORD
71600 WHERE: ADDRRANGE;
71700 BASE: ADDRRANGE;
71800 OFFSET: INTEGER;
71900 NEXTPOL: POLPT
72000 END;
72100
72200 PDP10INSTR = PACKED RECORD
72300 INSTR : INSTRANGE ;
72400 AC : ACRANGE;
72500 INDBIT : IBRANGE;
72600 INXREG : ACRANGE;
72700 ADDRESS : ADDRRANGE
72800 END ;
72900
73000 HALFS = PACKED RECORD
73100 LEFTHALF: ADDRRANGE;
73200 RIGHTHALF: ADDRRANGE
73300 END;
73400
73500 PAGEELEM = PACKED RECORD
73600 WORD1: PDP10INSTR;
73700 LHALF: ADDRRANGE; RHALF: ADDRRANGE
73800 END;
73900 DEBENTRY = RECORD
74000 (* 36 - ALLOW MULTIPLE MODULES *)
74100 NEXTDEB: INTEGER; %WILL BE PTR TO NEXT ENTRY\
74200 LASTPAGEELEM: PAGEELEM;
74300 (* 103 - fix global id tree *)
74400 GLOBALIDTREE: CTP;
74500 STANDARDIDTREE: CTP;
74600 INTPOINT: STP;
74700 REALPOINT: STP;
74800 CHARPOINT: STP;
74900 MODNAME: ALFA;
75000 (* 155 - add source information *)
75100 SOURCE: PACKED ARRAY[1..167]OF CHAR;
75200 END;
75300
75400 (* 4 - add data structure for SCAN to return *)
75500 (* 11 - modify structure and add type for the REL file *)
75600 INTFILE = FILE OF INTEGER;
75700 RPGDATA = RECORD
75800 (* 7 - add /HEAP switch *)
75900 RELNAME:ALFA;
76000 (* 24 - allow user to set first loc of stack and heap *)
76100 STACKVAL:INTEGER;
76200 HEAPVAL:INTEGER;
76300 (* 33 - version no. *)
76400 VERVAL:INTEGER;
76500 (* 25 - add /ZERO *)
76600 (* 160 - add /ARITHCHECK *)
76700 ASW,ZSW,LSW,TSW,MSW,CSW,DSW,CRSW,RPGSW:BOOLEAN
76800 END;
76900 RPGPT = ^ RPGDATA;
77000 (* 33 - PROGRAM statement *)
77100 (* 61 - allow +* in tops20 *)
77200 PROGFILE = PACKED RECORD
77300 FILID:ALFA;
77400 NEXT:^PROGFILE;
77500 (* 64 - INPUT:/ *)
77600 wild,newgen,oldfile,interact,seeeol:Boolean
77700 END;
77800 (* 157 - See if we need INITTTY *)
77900 PROGFILEPT = ^ PROGFILE;
78000
78100 %------------------------------------------------------------------------------\
78200
78300
78400 VAR
78500 %RETURNED BY SOURCE PROGRAM SCANNER INSYMBOL:\
78600 %********************************************\
78700
78800 SY: SYMBOL; %LAST SYMBOL\
78900 OP: OPERATOR; %CLASSIFICATION OF LAST SYMBOL\
79000 VAL: VALU; %VALUE OF LAST CONSTANT\
79100 LGTH: INTEGER; %LENGTH OF LAST STRING CONSTANT\
79200 ID: ALFA; %LAST IDENTIFIER (POSSIBLY TRUNCATED)\
79300 CH: CHAR; %LAST CHARACTER\
79400
79500
79600 %COUNTERS:\
79700 %*********\
79800
79900 RTIME,
80000 I: INTEGER;
80100 SUPPORTIX: SUPPORTS;
80200 LANGUAGEIX: SYMBOL;
80300 CHCNT: 0..132; %CHARACTER COUNTER\
80400 CODEEND, %FIRST LOCATION NOT USED FOR INSTRUCTIONS\
80500 LCMAIN,
80600 (* 5 - some new variables for CREF *)
80700 LC,IC,BEGLC,BEGIC: ADDRRANGE; %DATA LOCATION AND INSTRUCTION COUNTER\
80800 (* 176 - new vars for unterminated comment *)
80900 comment_page, comment_line: integer;
81000
81100 %SWITCHES:\
81200 %*********\
81300
81400 (* 25 - ADD /ZERO *)
81500 ZERO, %ON TO INITIALIZE LOCAL VAR'S\
81600 (* 4 - variable for COMPIL linkage *)
81700 RPGENTRY, %ON IF CALLED CALLED BY COMPIL\
81800 (* 5 - new variables for CREF *)
81900 CREF, %ON IF CREF LISTING BEING MADE\
82000 DP,BEGDP, %DECLARATION PART\
82100 RESETFLAG, %TO IGNORE SWITCHES WHICH MUST NOT BE RESET\
82200 PRTERR, %TO ALLOW FORWARD REFERENCES IN POINTER TYPE
82300 DECLARATION BY SUPPRESSING ERROR MESSAGE\
82400 MAIN, %IF FALSE COMPILER PRODUCES EXTERNAL PROCEDURE OR FUNCTION\
82500 doinitTTY, %TTYOPEN needed\
82600 TTYINUSE, %no longer used ?\
82700 TTYSEEEOL, %TTY:# in program state\
82800 DEBUG, %ENABLE DEBUGGING\
82900 DEBUGSWITCH, %INSERT DEBUGINFORMATION\
83000 LISTCODE, %LIST MACRO CODE\
83100 INITGLOBALS, %INITIALIZE GLOBAL VARIABLES\
83200 LOADNOPTR, %TRUE IF NO POINTERVARIABLE SHALL BE LOADED\
83300 (* 157 - separate control for arith overflow *)
83400 ARITHCHECK, %SWITCH FOR DETECTING ARITH ERRORS\
83500 RUNTMCHECK: BOOLEAN; %SWITCH FOR RUNTIME-TESTS\
83600 (* 24 - ALLOW USER TO SET FIRST LOC OF STACK AND HEAP *)
83700 STACK,HEAP: ADDRRANGE; %FIRST ADDR OF STACK AND HEAP\
83800 (* 12 - stackandheap no longer needed *)
83900 (* 33 - VERSION NO. *)
84000 version:packed record %version no. for output\
84100 case boolean of
84200 true:(word:integer);
84300 false:(who:0..7B;major:0..777B;minor:0..77B;edit:0..777777B)
84400 end;
84500
84600
84700 %POINTERS:\
84800 %*********\
84900
85000 LOCALPFPTR, EXTERNPFPTR: CTP; %PTRS TO LOCAL/EXTERNAL PROC/FUNC-CHAIN\
85100 (* 111 - STRING, POINTER *)
85200 (* 202 - POINTER by ref *)
85300 INTPTR,REALPTR,CHARPTR,ANYFILEPTR,STRINGPTR,POINTERPTR,POINTERREF,
85400 BOOLPTR,NILPTR,TEXTPTR: STP; %POINTERS TO ENTRIES OF STANDARD IDS\
85500 (* 135 - ill mem ref in PACK, UNPACK *)
85600 UARRTYP:STP;
85700 UTYPPTR,UCSTPTR,UVARPTR,
85800 UFLDPTR,UPRCPTR,UFCTPTR, %POINTERS TO ENTRIES FOR UNDECLARED IDS\
85900 (* 64 - non-loc goto *)
86000 ulblptr,
86100 FWPTR: CTP; %HEAD OF CHAIN OF FORW DECL TYPE IDS\
86200 ERRMPTR,ERRMPTR1: ETP; %TO CHAIN ERROR-UPDATES\
86300 (* 65 - remove exit labels *)
86400 LASTBTP: BTP; %HEAD OF BYTEPOINTERTABLE\
86500 SFILEPTR,
86600 FILEPTR: FTP;
86700 FIRSTKONST: KSP;
86800 (* 164 - Polish fixups for CASE *)
86900 FIRSTPOL: POLPT;
87000 ALFAPTR, DATEPTR: STP;
87100 FGLOBPTR,CGLOBPTR : GTP ; %POINTER TO FIRST AND CURRENT GLOBAL INITIALISATION RECORD\
87200 GLOBTESTP : TESTP ; %POINTER TO LAST PAIR OF POINTERTYPES\
87300 (* 4 - Here is the main structure for the SCAN linkage *)
87400 SCANDATA : RPGPT ; %DATA FROM SCAN OF FILE NAMES\
87500 (* 33 - PROGRAM STATEMENT *)
87600 NPROGFILE, %NEW FILE NAME\
87700 LPROGFILE, %LAST FILE NAME IN LIST\
87800 FPROGFILE:PROGFILEPT; %FIRST FILE NAME IN LIST\
87900 (* 64 - non-loc goto *)
88000 lastlabel:ctp;
88100 (* 171 - treat file names as special *)
88200 infile,outfile,ttyfile,ttyoutfile:ctp; {Pointers to ID's for
88300 INPUT, OUTPUT, TTY, TTYOUT}
88400
88500 %BOOKKEEPING OF DECLARATION LEVELS:\
88600 %**********************************\
88700
88800 (* 5 - new variable for CREF *)
88900 LEVEL,BEGLEVEL: LEVRANGE; %CURRENT STATIC LEVEL\
89000 DISX, %LEVEL OF LAST ID SEARCHED BY SEARCHID\
89100 TOP: DISPRANGE; %TOP OF DISPLAY\
89200
89300 DISPLAY: %WHERE: MEANS:\
89400 ARRAY[DISPRANGE] OF
89500 PACKED RECORD
89600 %=BLCK: ID IS VARIABLE ID\
89700 (* 5 - new variable for CREF *)
89800 BLKNAME: ALFA; %NAME OF BLOCK\
89900 FNAME: CTP; %=CREC: ID IS FIELD ID IN RECORD WITH\
90000 CASE OCCUR: WHERE OF % CONSTANT ADDRESS\
90100 CREC: (CLEV: LEVRANGE; %=VREC: ID IS FIELD ID IN RECORD WITH\
90200 CINDR: ACRANGE; % VARIABLE ADDRESS\
90300 CINDB: IBRANGE;
90400 CRELBYTE: RELBYTE;
90500 CDSPL,
90600 CLC : ADDRRANGE)
90700 END;
90800
90900
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 ';
EDURE %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 IC := HIGHSTART; %START OF HIGHSEGMENT\
45300 LC := PROGRST; %START OF LOWSEGMENT AVAILABLE TO PROGRAM\
45400 (* 136 - listing format *)
45500 CHCNT := 0; LINECNT := 1; PAGECNT := 1; SUBPAGE := 0;
45600 LASTLINE := -1; LASTPAGE := 0;
45700 (* 12 - initialize new variables for dynamic core *)
45800 LIBIX := 0; ERRINX := 0; LSTNEW := 0; NEWBND := 0;
45900 END %INITSCALARS\ ;
46000
46100 INITPROCEDURE %INITSETS\ ;
46200 BEGIN
46300 DIGITS := ['0'..'9'];
46400 LETTERS := ['A'..'Z'];
46500 HEXADIGITS := ['0'..'9','A'..'F'];
46600 LETTERSORDIGITS := [ '0'..'9','A'..'Z'];
46700 LETTERSDIGITSORLEFTARROW := ['0'..'9','A'..'Z','_'];
46800 LANGUAGESYS := [FORTRANSY,ALGOLSY,COBOLSY,PASCALSY];
46900 CONSTBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT];
47000 SIMPTYPEBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT] ;
47100 TYPEBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,ARROW,PACKEDSY,ARRAYSY,RECORDSY,SETSY,FILESY] ;
47200 TYPEDELS := [ARRAYSY,RECORDSY,SETSY,FILESY];
47300 (* 56 - add require files *)
47400 BLOCKBEGSYS := [INCLUDESY,LABELSY,CONSTSY,TYPESY,VARSY,INITPROCSY,PROCEDURESY,FUNCTIONSY,BEGINSY];
47500 SELECTSYS := [ARROW,PERIOD,LBRACK];
47600 FACBEGSYS := [INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,LBRACK,NOTSY];
47700 STATBEGSYS := [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,LOOPSY,FORSY,WITHSY,CASESY]
47800 END %INITSETS\ ;
47900
48000 INITPROCEDURE %RESWORDS\ ;
48100 BEGIN
48200 RW[ 1] := 'IF '; RW[ 2] := 'DO '; RW[ 3] := 'OF ';
48300 RW[ 4] := 'TO '; RW[ 5] := 'IN '; RW[ 6] := 'OR ';
48400 RW[ 7] := 'END '; RW[ 8] := 'FOR '; RW[ 9] := 'VAR ';
48500 RW[10] := 'DIV '; RW[11] := 'MOD '; RW[12] := 'SET ';
48600 RW[13] := 'AND '; RW[14] := 'NOT '; RW[15] := 'THEN ';
48700 RW[16] := 'ELSE '; RW[17] := 'WITH '; RW[18] := 'GOTO ';
48800 RW[19] := 'LOOP '; RW[20] := 'CASE '; RW[21] := 'TYPE ';
48900 RW[22] := 'FILE '; RW[23] := 'EXIT '; RW[24] := 'BEGIN ';
49000 RW[25] := 'UNTIL '; RW[26] := 'WHILE '; RW[27] := 'ARRAY ';
49100 RW[28] := 'CONST '; RW[29] := 'LABEL '; RW[30] := 'ALGOL ';
49200 RW[31] := 'COBOL '; RW[32] := 'EXTERN '; RW[33] := 'PASCAL ';
49300 RW[34] := 'RECORD '; RW[35] := 'DOWNTO '; RW[36] := 'PACKED ';
49400 RW[37] := 'OTHERS '; RW[38] := 'REPEAT '; RW[39] := 'FORTRAN ';
49500 (* 6 - add PROGRAM statement *)
49600 (* 56 - ADD INCLUDE *)
49700 RW[40] := 'FORWARD '; RW[41] := 'PROGRAM '; RW[42] := 'INCLUDE ';
49800 RW[43] := 'FUNCTION '; RW[44] := 'PROCEDURE ';
49900 RW[45] := 'INITPROCED';
50000 FRW[1] := 1; FRW[2] := 1; FRW[3] := 7; FRW[4] := 15; FRW[5] := 24;
50100 FRW[6] := 32; FRW[7] := 39; FRW[8] := 43; FRW[9] := 44; FRW[10] := 45;
50200 FRW[11] := 46;
50300 END %RESWORDS\ ;
50400
50500 INITPROCEDURE %SYMBOLS\ ;
50600 BEGIN
50700 RSY[1] := IFSY; RSY[2] := DOSY; RSY[3] := OFSY; RSY[4] := TOSY;
50800 RSY[5] := RELOP; RSY[6] := ADDOP; RSY[7] := ENDSY; RSY[8] := FORSY;
50900 RSY[9] := VARSY; RSY[10] := MULOP; RSY[11] := MULOP; RSY[12] := SETSY;
51000 RSY[13] := MULOP; RSY[14] := NOTSY; RSY[15] := THENSY;
51100 RSY[16] := ELSESY; RSY[17] := WITHSY; RSY[18] := GOTOSY;
51200 RSY[19] := LOOPSY; RSY[20] := CASESY; RSY[21] := TYPESY;
51300 RSY[22] := FILESY; RSY[23] := EXITSY; RSY[24] := BEGINSY;
51400 RSY[25] := UNTILSY; RSY[26] := WHILESY; RSY[27] := ARRAYSY;
51500 RSY[28] := CONSTSY; RSY[29] := LABELSY;
51600 RSY[30] := ALGOLSY; RSY[31] := COBOLSY;
51700 RSY[32] := EXTERNSY; RSY[33] := PASCALSY; RSY[34] := FORTRANSY;
51800 RSY[34] := RECORDSY; RSY[35]:= DOWNTOSY; RSY[36] := PACKEDSY;
51900 RSY[37] := OTHERSSY; RSY[38]:= REPEATSY; RSY[39] := FORTRANSY;
52000 (* 6 - add PROGRAM statement *)
52100 (* 56 - ADD INCLUDE *)
52200 RSY[40] := FORWARDSY; RSY[41] := PROGRAMSY; RSY[42] := INCLUDESY; RSY[43] := FUNCTIONSY;
52300 RSY[44] := PROCEDURESY; RSY[45] := INITPROCSY;
52400
52500 SSY['A'] := OTHERSY; SSY['B'] := OTHERSY; SSY['C'] := OTHERSY;
52600 SSY['D'] := OTHERSY; SSY['E'] := OTHERSY; SSY['F'] := OTHERSY;
52700 SSY['G'] := OTHERSY; SSY['H'] := OTHERSY; SSY['I'] := OTHERSY;
52800 SSY['J'] := OTHERSY; SSY['K'] := OTHERSY; SSY['L'] := OTHERSY;
52900 SSY['M'] := OTHERSY; SSY['N'] := OTHERSY; SSY['O'] := OTHERSY;
53000 SSY['P'] := OTHERSY; SSY['Q'] := OTHERSY; SSY['R'] := OTHERSY;
53100 SSY['S'] := OTHERSY; SSY['T'] := OTHERSY; SSY['U'] := OTHERSY;
53200 SSY['V'] := OTHERSY; SSY['W'] := OTHERSY; SSY['X'] := OTHERSY;
53300 SSY['Y'] := OTHERSY; SSY['Z'] := OTHERSY; SSY['0'] := OTHERSY;
53400 SSY['1'] := OTHERSY; SSY['2'] := OTHERSY; SSY['3'] := OTHERSY;
53500 SSY['4'] := OTHERSY; SSY['5'] := OTHERSY; SSY['6'] := OTHERSY;
53600 SSY['7'] := OTHERSY; SSY['8'] := OTHERSY; SSY['9'] := OTHERSY;
53700 SSY['_'] := OTHERSY;
53800 SSY['+'] := ADDOP; SSY['-'] := ADDOP; SSY['*'] := MULOP;
53900 SSY['/'] := MULOP; SSY['('] := LPARENT; SSY[')'] := RPARENT;
54000 SSY['$'] := OTHERSY; SSY['='] := RELOP; SSY[' '] := OTHERSY;
54100 SSY[','] := COMMA; SSY['.'] := PERIOD; SSY[''''] := OTHERSY;
54200 SSY['['] := LBRACK; SSY[']'] := RBRACK; SSY[':'] := COLON;
54300 SSY['#'] := RELOP; SSY['%'] := OTHERSY; SSY['!'] := ADDOP;
54400 SSY['&'] := MULOP; SSY['^'] := ARROW; SSY['\'] := OTHERSY;
54500 SSY['<'] := RELOP; SSY['>'] := RELOP; SSY['@'] := RELOP;
54600 SSY['"'] := RELOP; SSY['?'] := NOTSY; SSY[';'] := SEMICOLON;
54700 END %SYMBOLS\ ;
54800
54900 INITPROCEDURE %OPERATORS\ ;
55000 BEGIN
55100 ROP[ 1] := NOOP; ROP[ 2] := NOOP; ROP[ 3] := NOOP; ROP[ 4] := NOOP;
55200 ROP[ 5] := INOP; ROP[ 6] := OROP; ROP[ 7] := NOOP; ROP[ 8] := NOOP;
55300 ROP[ 9] := NOOP; ROP[10] := IDIV; ROP[11] := IMOD; ROP[12] := NOOP;
55400 ROP[13] :=ANDOP; ROP[14] := NOOP; ROP[15] := NOOP; ROP[16] := NOOP;
55500 ROP[17] := NOOP; ROP[18] := NOOP; ROP[19] := NOOP; ROP[20] := NOOP;
55600 ROP[21] := NOOP; ROP[22] := NOOP; ROP[23] := NOOP; ROP[24] := NOOP;
55700 ROP[25] := NOOP; ROP[26] := NOOP; ROP[27] := NOOP; ROP[28] := NOOP;
55800 ROP[29] := NOOP; ROP[30] := NOOP; ROP[31] := NOOP; ROP[32] := NOOP;
55900 ROP[33] := NOOP; ROP[34] := NOOP; ROP[35] := NOOP; ROP[36] := NOOP;
56000 ROP[37] := NOOP; ROP[38] := NOOP; ROP[39] := NOOP; ROP[40] := NOOP;
56100 (* 6 - add PROGRAM statement *)
56200 (* 56 - ADD INCLUDE *)
56300 ROP[41] := NOOP; ROP[42] := NOOP; ROP[43] := NOOP; ROP[44] := NOOP; ROP[45] := NOOP;
56400
56500 SOP['+'] := PLUS; SOP['-'] := MINUS; SOP['*'] := MUL; SOP['/'] := RDIV;
56600 SOP['='] := EQOP; SOP['#'] := NEOP; SOP['!'] := OROP; SOP['&'] := ANDOP;
56700 SOP['<'] := LTOP; SOP['>'] := GTOP; SOP['@'] := LEOP; SOP['"'] := GEOP;
56800 SOP[' '] := NOOP; SOP['$'] := NOOP; SOP['%'] := NOOP; SOP['('] := NOOP;
56900 SOP[')'] := NOOP; SOP[','] := NOOP; SOP['.'] := NOOP; SOP['0'] := NOOP;
57000 SOP['1'] := NOOP; SOP['2'] := NOOP; SOP['3'] := NOOP; SOP['4'] := NOOP;
57100 SOP['5'] := NOOP; SOP['6'] := NOOP; SOP['7'] := NOOP; SOP['8'] := NOOP;
57200 SOP['9'] := NOOP; SOP[':'] := NOOP; SOP[';'] := NOOP; SOP['?'] := NOOP;
57300 SOP['A'] := NOOP; SOP['B'] := NOOP; SOP['C'] := NOOP; SOP['D'] := NOOP;
57400 SOP['E'] := NOOP; SOP['F'] := NOOP; SOP['G'] := NOOP; SOP['H'] := NOOP;
57500 SOP['I'] := NOOP; SOP['J'] := NOOP; SOP['K'] := NOOP; SOP['L'] := NOOP;
57600 SOP['M'] := NOOP; SOP['N'] := NOOP; SOP['O'] := NOOP; SOP['P'] := NOOP;
57700 SOP['Q'] := NOOP; SOP['R'] := NOOP; SOP['S'] := NOOP; SOP['T'] := NOOP;
57800 SOP['U'] := NOOP; SOP['V'] := NOOP; SOP['W'] := NOOP; SOP['X'] := NOOP;
57900 SOP['Y'] := NOOP; SOP['Z'] := NOOP; SOP['['] := NOOP; SOP['\'] := NOOP;
58000 SOP[']'] := NOOP; SOP['^'] := NOOP; SOP['_'] := NOOP; SOP[''''] := NOOP;
58100 END %OPERATORS\ ;
58200
58300 INITPROCEDURE %RECORDSIZES\;
58400 BEGIN
58500 IDRECSIZE[TYPES] := 5;
58600 IDRECSIZE[KONST] := 6;
58700 IDRECSIZE[VARS] := 6;
58800 IDRECSIZE[FIELD] := 6;
58900 IDRECSIZE[PROC] := 5;
59000 IDRECSIZE[FUNC] := 8;
59100 (* 116 - define size of the new types for copyctp *)
59200 IDRECSIZE[PARAMS] := 5;
59300 IDRECSIZE[LABELT] := 6;
59400 STRECSIZE[SCALAR] := 2;
59500 STRECSIZE[SUBRANGE]:=4;
59600 STRECSIZE[POINTER]:= 2;
59700 STRECSIZE[POWER] := 2;
59800 STRECSIZE[ARRAYS] := 3;
59900 STRECSIZE[RECORDS]:= 3;
60000 STRECSIZE[FILES] := 2;
60100 STRECSIZE[TAGFWITHID]:=3;
60200 STRECSIZE[TAGFWITHOUTID] := 3;
60300 STRECSIZE[VARIANT] :=4
60400 END;
60500
60600 INITPROCEDURE %ERRORMESSAGES\ ;
60700 BEGIN
60800 ERRMESS15[ 1] := '":" expected ';
60900 ERRMESS15[ 2] := '")" expected ';
61000 ERRMESS15[ 3] := '"(" expected ';
61100 ERRMESS15[ 4] := '"[" expected ';
61200 ERRMESS15[ 5] := '"]" expected ';
61300 ERRMESS15[ 6] := '";" expected ';
61400 ERRMESS15[ 7] := '"=" expected ';
61500 ERRMESS15[ 8] := '"," expected ';
61600 ERRMESS15[ 9] := '":=" expected ';
61700 ERRMESS15[10] := '"OF" expected ';
61800 ERRMESS15[11] := '"DO" expected ';
61900 ERRMESS15[12] := '"IF" expected ';
62000 ERRMESS15[13] := '"END" expected ';
62100 ERRMESS15[14] := '"THEN" expected';
62200 ERRMESS15[15] := '"EXIT" expected';
62300 ERRMESS15[16] := 'Illegal symbol ';
62400 ERRMESS15[17] := 'No sign allowed';
62500 ERRMESS15[18] := 'Number expected';
62600 ERRMESS15[19] := 'Not implemented';
62700 ERRMESS15[20] := 'Error in type ';
62800 (* 35 - new error - no longer need old one, so we replaced*)
62900 ERRMESS15[21] := 'Compiler error ';
63000 ERRMESS15[22] := '"." expected ';
63100 ERRMESS15[23] := 'Error in factor';
63200 ERRMESS15[24] := 'Too many digits';
63300
63400 ERRMESS20[ 1] := '"BEGIN" expected ';
63500 ERRMESS20[ 2] := '"UNTIL" expected ';
63600 ERRMESS20[ 3] := 'Error in options ';
63700 ERRMESS20[ 4] := 'Constant too large ';
63800 ERRMESS20[ 5] := 'Digit must follow ';
63900 ERRMESS20[ 6] := 'Exponent too large ';
64000 ERRMESS20[ 7] := 'Constant expected ';
64100 ERRMESS20[ 8] := 'Simple type expected';
64200 ERRMESS20[ 9] := 'Identifier expected ';
64300 ERRMESS20[10] := 'Realtype not allowed';
64400 ERRMESS20[11] := 'Multidefined label ';
64500 ERRMESS20[12] := 'Filename expected ';
64600 ERRMESS20[13] := 'Set type expected ';
64700 ERRMESS20[14] := 'Undeclared exitlabel';
64800 ERRMESS20[15] := 'Undeclared label ';
64900 (* 6 - add error msg for illegal character *)
65000 ERRMESS20[16] := 'Illegal character ';
65100
65200 ERRMESS25[ 1] := '"TO"/"DOWNTO" expected ';
65300 ERRMESS25[ 2] := '8 OR 9 in octal number ';
65400 ERRMESS25[ 3] := 'Identifier not declared ';
65500 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-controlvar tandard 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 IC := HIGHSTART; %START OF HIGHSEGMENT\
20900 LC := PROGRST; %START OF LOWSEGMENT AVAILABLE TO PROGRAM\
21000 (* 136 - listing format *)
21100 CHCNT := 0; LINECNT := 1; PAGECNT := 1; SUBPAGE := 0; CURLINE := 1;
21200 LASTLINE := -1; LASTPAGE := 0;
21300 (* 12 - initialize new variables for dynamic core *)
21400 LIBIX := 0; ERRINX := 0; LSTNEW := 0; NEWBND := 0;
21500 with pager.word1 do
21600 begin instr:=0;ac:=0;indbit:=0;inxreg:=0;address:=0 end;
21700 pager.lhalf := 0; pager.rhalf := 0;
21800 debugentry.lastpageelem := pager;
21900 laststop := 0; lastpager := 0;
22000 (* 103 - changed type for idtree's *)
22100 debugentry.standardidtree := nil;
22200 debugentry.globalidtree := nil;
22300 filename := ' ';
22400 LIBRARY[PASCALSY].INORDER := FALSE;
22500 LIBRARY[FORTRANSY].INORDER := FALSE;
22600 LIBRARY[ALGOLSY].INORDER := FALSE;
22700 LIBRARY[COBOLSY].INORDER := FALSE;
22800 LIBRARY[PASCALSY].CALLED := FALSE;
22900 LIBRARY[FORTRANSY].CALLED := FALSE;
23000 LIBRARY[ALGOLSY].CALLED := FALSE;
23100 LIBRARY[COBOLSY].CALLED := FALSE;
23200 (* 105 - map lower case better *)
23300 setmapchain := 0;
23400 end;
23500
23600 (* 136 - new listing format *)
23700
23800 procedure pagehead;
23900 begin
24000 page;
24100 write(header,' ',day,' ',scandata^.relname);
24200 if reqfile
24300 then write(' ****Included file****');
24400 write(' Page ',pagecnt:0);
24500 if subpage > 0
24600 then write('-',subpage:0);
24700 writeln;
24800 writeln;
24900 curline := 1;
25000 end;
25100
25200 procedure newline;
25300 begin
25400 writeln;
25500 curline := curline+1;
25600 if curline > 53
25700 then begin
25800 subpage := subpage + 1;
25900 pagehead;
26000 end
26100 end;
26200
26300 PROCEDURE NEWPAGER;
26400 BEGIN
26500 WITH PAGER, WORD1 DO
26600 BEGIN
26700 AC := PAGECNT DIV 16;
26800 INXREG := PAGECNT MOD 16; ADDRESS := LASTPAGER;
26900 LHALF := LASTLINE; RHALF := LASTSTOP;
27000 LASTLINE := -1
27100 END
27200 END;
27300
27400 (* 5 - reorganized printing somewhat for CREF *)
27500 (* The FILCOM is a bit misleading here, as global changes have been made *)
27600 PROCEDURE BEGOFLINE;
27700 BEGIN
27800 IF CREF THEN WRITE(CHR(177B),'A');
27900 IF CHCNT > CHCNTMAX THEN CHCNT := CHCNTMAX;
28000 IF LISTCODE
28100 THEN
28200 BEGIN
28300 (* 5 - more of the CREF change *)
28400 IF BEGDP
28500 THEN
28600 BEGIN
28700 WRITE(BEGLC:6:O);
28800 IF (BEGLC < PROGRST) OR (BEGLEVEL > 1)
28900 THEN WRITE(' ')
29000 ELSE WRITE('''')
29100 END
29200 ELSE WRITE(BEGIC:6:O,'''');
29300 WRITE(' ':2)
29400 END;
29500 IF LINENR='-----'
29600 THEN WRITE(LINECNT:5)
29700 ELSE WRITE(LINENR) ;
29800 WRITE(' ':3);
29900 END;
30000
30100 PROCEDURE WRITEBUFFER;
30200 BEGIN
30300 IF LISTCODE
30400 THEN
30500 BEGIN
30600 (* 5 - more CREF *)
30700 IF CREF THEN WRITE(CHR(177B),'B'); BEGOFLINE;
30800 (* 136 - listing format *)
30900 WRITE(BUFFER:CHCNT); FOR CHCNT := 1 TO 17 DO BUFFER[CHCNT] := ' '; CHCNT := 17;
31000 newline;
31100 END
31200 END;
31300
31400 PROCEDURE GETNEXTLINE;
31500 BEGIN
31600 LOOP
31700 GETLINENR(LINENR);
31800 EXIT IF INPUT^ # CHR(14B); %TEST END OF PAGE\
31900 IF DEBUG AND (LASTLINE > -1)
32000 THEN NEWPAGER;
32100 (* 136 - listing format *)
32200 PAGECNT := PAGECNT + 1; SUBPAGE := 0;
32300 pagehead;
32400 (* 137 - reset line to 1 on each page *)
32500 linecnt := 1;
32600 READLN; %TO OVERREAD SECOND CARRIAGE RETURN IN PAGE MARK\
32700 END;
32800 IF CREF
32900 THEN WRITE(CHR(177B),'B');
33000 BEGIC:=IC;BEGLC:=LC;BEGDP:=DP;BEGLEVEL:=LEVEL;
33100 END;
33200
33300 (* 56 - needed for file switch *)
33400 PROCEDURE BEGSTUFF;
33500 BEGIN
33600 IF CREF
33700 THEN WRITE(CHR(177B),'B');
33800 BEGIC:=IC;BEGLC:=LC;BEGDP:=DP;BEGLEVEL:=LEVEL;
33900 CHCNT:=0
34000 END;
34100
34200 (* 16 - DETECT UNEXPECTED EOF *)
34300 (* 41 - make restartable *)
34400 PROCEDURE PASXIT(VAR A,B,C:FILE); EXTERN;
34500 (* 55 - ADD PROC'S FOR REQUIRE FILES *)
34600 PROCEDURE PUSHF(VAR F:FILE;S:STRGARR;L:INTEGER); EXTERN;
34700 PROCEDURE POPF(VAR F:FILE); EXTERN;
34800 (* 107 - moved declaration of analys so can be used several places *)
34900 procedure analys(var f:file); extern;
35000 (* 112 - clrbfi when error detected *)
35100 procedure clribf; extern;
35200 (* 141 - better detection of number overflow *)
35300 function overflow:Boolean; extern;
35400 (* 155 - source file name *)
35500 procedure curname(var f:file;var s:string); extern;
35600
35700 (* 56 - SEPARATE OUT STUFF NEEDED FOR FILE SWITCH *)
35800 PROCEDURE ENDSTUFF;
35900 VAR
36000 I,K: INTEGER;
36100 BEGIN
36200 (* 5 - more CREF *)
36300 BEGOFLINE;
36400 (* 136 - listing format *)
36500 WRITE(BUFFER:CHCNT); NEWLINE;
36600 IF ERRORINLINE
36700 THEN %OUTPUT ERROR MESSAGES\
36800 BEGIN
36900 IF LISTCODE
37000 THEN K := 11
37100 ELSE K := 2;
37200 WRITE(' ':K,'***** '); LISTCODE := FALSE;
37300 IF LINENR = '-----'
37400 THEN WRITE(TTY,LINECNT:5)
37500 ELSE WRITE(TTY,LINENR);
37600 WRITELN(TTY,' ':3,BUFFER:CHCNT); WRITE(TTY,'P*',PAGECNT:3,'** ');
37700 (* 5 - more CREF *)
37800 FOR K:=1 TO CHCNT DO
37900 IF BUFFER[K] = CHR(11B)
38000 THEN ERRLINE[K] := CHR(11B);
38100 (* 136 - LISTING FORMAT *)
38200 WRITE(ERRLINE : CHCNT); WRITELN(TTY,ERRLINE : CHCNT); NEWLINE;
38300 FOR K := 1 TO ERRINX DO
38400 WITH ERRLIST[K] DO
38500 BEGIN
38600 WRITE(' ':15,ARW:1,'.',TIC,': '); WRITE(TTY,ARW:1,'.',TIC,': ');
38700 IF ERRMPTR # NIL
38800 THEN
38900 BEGIN
39000 ERRMPTR1 := ERRMPTR;
39100 WHILE ERRMPTR1 # NIL DO
39200 WITH ERRMPTR1^ DO
39300 BEGIN
39400 IF NMR = NUMBER
39500 THEN
39600 BEGIN
39700 CASE FORM OF
39800 C:
39900 BEGIN
40000 WRITE(STRING:10,' --> ');WRITE(TTY,STRING:10,' --> ')
40100 END;
40200 D:
40300 BEGIN
40400 WRITE(INTVAL:5,' --> ');WRITE(TTY,INTVAL:5,' --> ')
40500 END
40600 END;
40700 NUMBER := 0; ERRMPTR1 := NIL
40800 END
40900 ELSE ERRMPTR1 := NEXT
41000 END
41100 END;
41200 I := NMR MOD 50;
41300 CASE NMR DIV 50 OF
41400 3:
41500 BEGIN
41600 WRITE(ERRMESS15[I]); WRITE(TTY,ERRMESS15[I])
41700 END;
41800 4:
41900 BEGIN
42000 WRITE(ERRMESS20[I]); WRITE(TTY,ERRMESS20[I])
42100 END;
42200 5:
42300 BEGIN
42400 WRITE(ERRMESS25[I]); WRITE(TTY,ERRMESS25[I])
42500 END;
42600 6:
42700 BEGIN
42800 WRITE(ERRMESS30[I]); WRITE(TTY,ERRMESS30[I])
42900 END;
43000 7:
43100 BEGIN
43200 WRITE(ERRMESS35[I]); WRITE(TTY,ERRMESS35[I])
43300 END;
43400 8:
43500 BEGIN
43600 WRITE(ERRMESS40[I]); WRITE(TTY,ERRMESS40[I])
43700 END;
43800 9:
43900 BEGIN
44000 WRITE(ERRMESS45[I]); WRITE(TTY,ERRMESS45[I])
44100 END;
44200 10:
44300 BEGIN
44400 WRITE(ERRMESS50[I]); WRITE(TTY,ERRMESS50[I])
44500 END;
44600 11:
44700 BEGIN
44800 WRITE(ERRMESS55[I]); WRITE(TTY,ERRMESS55[I])
44900 END
45000 END;
45100 (* 136 - LISTING FORMAT *)
45200 newline; WRITELN(TTY)
45300 END;
45400 (* 26 - break not needed for TTY *)
45500 ERRINX := 0; ERRORINLINE := FALSE;
45600 FOR I := 1 TO CHCNT DO ERRLINE [I] := ' ';
45700 ERRMPTR := NIL
45800 END;
45900 (* 56 -SEPARATE OUT STUFF NEEDED FOR FILE SWITCH *)
46000 END;
46100
46200 PROCEDURE ENDOFLINE(OKEOF:BOOLEAN);
46300 BEGIN
46400 ENDSTUFF;
46500 (* 16 - DETECT UNEXPECTED EOF *)
46600 IF EOF(INPUT) AND NOT OKEOF
46700 THEN BEGIN
46800 (* 136 - LISTING FORMAT *)
46900 WRITE('Unexpected end of file'); NEWLINE;
47000 WRITELN(TTY,'? Unexpected end of file');
47100 (* 176 - error for unexpected EOF in a comment *)
47200 if comment_page <> 0 then (* we're in a comment *)
47300 begin
47400 write('Unterminated Comment at ',comment_page:0,
47500 '/',comment_line:0); NEWLINE;
47600 writeln(tty,'? Unterminated Comment at ',comment_page:0,
47700 '/',comment_line:0)
47800 end;
47900 (* 41 - make restartable *)
48000 (* 107 - abort creation of rel file on error *)
48100 rewrite(outputrel);
48200 (* 112 - clrbfi when error *)
48300 clribf;
48400 (* 125 - popf to be sure we get main file closed in reqfile *)
48500 if reqfile
48600 then begin
48700 close(input);
48800 popf(input)
48900 end;
49000 PASXIT(INPUT,OUTPUT,OUTPUTREL)
49100 END;
49200 READLN;
49300 (* 147 - move incr linecnt here so first line of new page is 1 *)
49400 LINECNT := LINECNT + 1;
49500 IF NOT EOF(INPUT)
49600 THEN GETNEXTLINE;
49700 (* 136 - listing format *)
49800 CHCNT := 0
49900 END %ENDOFLINE\ ;
50000
50100 PROCEDURE ERROR(FERRNR: INTEGER);
50200 VAR
50300 LPOS,LARW : INTEGER;
50400 BEGIN
50500 IF NOT FOLLOWERROR
50600 THEN
50700 BEGIN
50800 ERRORFLAG := TRUE ;
50900 IF ERRINX >= MAXERR
51000 THEN
51100 BEGIN
51200 ERRLIST[MAXERR].NMR := 410; ERRINX := MAXERR
51300 END
51400 ELSE
51500 BEGIN
51600 ERRINX := ERRINX + 1;
51700 WITH ERRLIST[ERRINX] DO BEGIN NMR := FERRNR; TIC := '^' END
51800 END;
51900 FOLLOWERROR := TRUE; ERRORINLINE := TRUE;
52000 IF (FERRNR # 215)
52100 AND (FERRNR # 356)
52200 AND (FERRNR # 405)
52300 AND (FERRNR # 464)
52400 THEN
52500 IF EOLN(INPUT)
52600 THEN ERRLINE [CHCNT] := '^'
52700 ELSE ERRLINE [CHCNT-1] := '^'
52800 ELSE ERRLIST[ERRINX].TIC := ' ';
52900 IF ERRINX > 1
53000 THEN
53100 WITH ERRLIST [ ERRINX-1] DO
53200 BEGIN
53300 LPOS := POS; LARW := ARW
53400 END;
53500 WITH ERRLIST [ERRINX] DO
53600 BEGIN
53700 POS := CHCNT;
53800 IF ERRINX = 1
53900 THEN ARW := 1
54000 ELSE
54100 IF LPOS = CHCNT
54200 THEN ARW := LARW
54300 ELSE ARW := LARW + 1
54400 END;
54500 END;
54600 END %ERROR\ ;
54700
54800 PROCEDURE ERRORWITHTEXT ( FERRNR: INTEGER; FTEXT: ALFA ) ;
54900 BEGIN
55000 ERROR(FERRNR); NEWZ(ERRMPTR1,C);
55100 WITH ERRMPTR1^ DO
55200 BEGIN
55300 NUMBER := FERRNR; STRING := FTEXT;
55400 NEXT := ERRMPTR
55500 END;
55600 ERRMPTR := ERRMPTR1
55700 END %ERROR WITH TEXT\ ;
55800
55900 PROCEDURE INSYMBOL;
56000 %READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS
56100 DESCRIPTION IN THE GLOBAL VARIABLES SY, OP, ID, VAL AND LGTH\
56200 (* 114 - prevent recursive comment scanning *)
56300 LABEL 2;
56400 CONST
56500 (* 210 - allow 9 digit hex numbers *)
56600 hexmax = 9;
56700 DIGMAX = 12; MAX8 = 37777777777B;
56800 TEST8 = 40000000000B;
56900 MIN8 = 400000000000B;
57000 (* 142 - better real number scanning *)
57100 MAX10 = 3435973836; {maximum number, sans last digit}
57200 MAX16 = 17777777777B;
57300 MAXEXP = 35;
57400 type
57500 (* 43 - allow 12 digit octal no. *)
57600 numconv=record case Boolean of
57700 true:(oct:packed array[1:digmax]of 0..7);
57800 false:(int:integer)
57900 end;
58000 (* 210 - allow 9 digit hex numbers *)
58100 hexconv=record case Boolean of
58200 true:(hex:packed array[1..hexmax] of 0..15);
58300 false:(int:integer)
58400 end;
58500 VAR
58600 (* 133 - make real numbers be read exactly *)
58700 I,K,ASCALE,SCALE,EXP,IVAL: INTEGER;
58800 RVAL,R,FAC: REAL; STRINGTOOLONG,SIGN: BOOLEAN;
58900 DIGIT: ARRAY [1..DIGMAX] OF 0..9;
59000 STRING: ARRAY [1..STRGLGTH] OF CHAR;
59100 LVP: CSP;
59200 (* 43 - allow 12 digit octal no. *)
59300 nc:numconv;
59400 (* 210 - allow 9 digit hex numbers *)
59500 hc:hexconv;
59600
59700 PROCEDURE NEXTCH;
59800 BEGIN
59900 IF EOLN(INPUT)
60000 THEN CH := ' '
60100 ELSE
60200 BEGIN
60300 %READ(CH);\ CH := INPUT^; GET(INPUT); %THIS CHANGE SAVES 3 INSTRUCTIONS AT RUN-TIME\
60400 CHCNT := CHCNT + 1;
60500 IF CHCNT <= CHCNTMAX
60600 THEN BUFFER[CHCNT] := CH
60700 (* 3 - map lower case to upper. Need separate NEXTCH for strings now,
60800 since we don't do mapping there. *)
60900 END;
61000 (* 105 - improve lower case mapping *)
61100 ch := chr(charmap[ord(ch)]);
61200 END;
61300
61400 PROCEDURE NEXTSTRCH;
61500 BEGIN
61600 IF EOLN(INPUT)
61700 THEN CH := ' '
61800 ELSE
61900 BEGIN
62000 CH := INPUT^; GET(INPUT);
62100 CHCNT := CHCNT + 1;
62200 IF CHCNT <= CHCNTMAX
62300 THEN BUFFER[CHCNT] := CH
62400 END
62500 END;
62600
62700 PROCEDURE OPTIONS;
62800 VAR
62900 LCH : CHAR; LSWITCH : BOOLEAN;
63000 BEGIN
63100 REPEAT
63200 NEXTCH; LCH := CH;
63300 IF NOT (CH IN ['\','*'])
63400 THEN NEXTCH;
63500 IF NOT (CH IN ['+','-'])
63600 (* 24 - S AND H FOR STACK AND HEAP *)
63700 (* 33 - version *)
63800 THEN IF (LCH IN ['H','S','V']) AND (CH = ':')
63900 THEN BEGIN
64000 NEXTCH;
64100 INSYMBOL;
64200 IF SY # INTCONST
64300 THEN ERROR(203)
64400 (* 24 - S AND H FOR STACK AND HEAP *)
64500 ELSE BEGIN
64600 (* 33 - version *)
64700 IF LCH IN ['H','S']
64800 THEN BEGIN
64900 IF (VAL.IVAL MOD 1000B) = 0
65000 THEN VAL.IVAL := VAL.IVAL -1;
65100 VAL.IVAL := (VAL.IVAL DIV 1000B)*1000B + 777B;
65200 END;
65300 IF LCH = 'S'
65400 THEN STACK := VAL.IVAL
65500 (* 33 - version *)
65600 ELSE IF LCH = 'H'
65700 THEN HEAP := VAL.IVAL
65800 ELSE VERSION.WORD := VAL.IVAL
65900 END
66000 END
66100 ELSE ERROR(203)
66200 ELSE
66300 BEGIN
66400 LSWITCH := CH = '+';
66500 (* 157 - use CASE instead of IF nest *)
66600 CASE LCH OF
66700 'L': LISTCODE := LSWITCH;
66800 'T': IF RESETFLAG THEN TTYINUSE := LSWITCH;
66900 'M': IF RESETFLAG THEN MAIN := LSWITCH;
67000 'C': BEGIN RUNTMCHECK := LSWITCH; ARITHCHECK := LSWITCH END;
67100 'A': ARITHCHECK := LSWITCH;
67200 'Z': ZERO := LSWITCH;
67300 'D': BEGIN
67400 DEBUGSWITCH := LSWITCH;
67500 (* 36 - allow us to reset debug at beginning *)
67600 if resetflag
67700 then debug := lswitch
67800 else IF LSWITCH
67900 THEN DEBUG := TRUE
68000 END
68100 END
68200 END;
68300 IF EOLN(INPUT)
68400 (* 16 - EOF *)
68500 THEN ENDOFLINE(FALSE);
68600 IF NOT ((CH IN ['\','*']) OR (LCH = 'H'))
68700 THEN NEXTCH
68800 UNTIL CH # ','
68900 END %OPTIONS\ ;
69000
69100 (* 1 - reorganized a bit here, mainly to improve comment scanning *)
69200 PROCEDURE NEWCH;
69300 BEGIN
69400 (* 16 - EOF *)
69500 IF EOLN(INPUT) THEN ENDOFLINE(FALSE);
69600 NEXTCH
69700 END;
69800
69900 PROCEDURE SCANCOMMENT(STOPCH:CHAR);
70000 BEGIN
70100 (* 176 - error for unexpected EOF in a comment *)
70200 comment_page := pagecnt; { pagecnt had better not be 0 }
70300 comment_line := linecnt;
70400 NEWCH;
70500 IF CH='$' THEN OPTIONS;
70600 (* 105 - curly brackets are now comments *)
70700 if (stopch = '\') or (stopch = '}')
70800 then while ch # stopch do newch
70900 ELSE REPEAT WHILE CH#'*' DO NEWCH; NEXTCH UNTIL CH=STOPCH;
71000 (* 176 - error for unexpected EOF in a comment *)
71100 comment_page := 0;
71200 (* 114 - prevent deep recursion in comment scanning *)
71300 NEWCH;
71400 END;
71500
71600 BEGIN 2:
71700 %INSYMBOL\
71800 WHILE (CH = ' ') OR (ORD(CH) = 11B) DO
71900 BEGIN
72000 IF EOLN(INPUT)
72100 (* 16 - EOF *)
72200 THEN ENDOFLINE(FALSE);
72300 NEXTCH;
72400 END;
72500 (* 1 - code removed here for comments. Handled better elsewhere *)
72600 CASE CH OF
72700 'A','B','C','D','E','F','G','H','I',
72800 'J','K','L','M','N','O','P','Q','R',
72900 'S','T','U','V','W','X','Y','Z':
73000 BEGIN
73100 K := 0 ; ID := ' ';
73200 REPEAT
73300 IF K < ALFALENG
73400 THEN
73500 BEGIN
73600 K := K + 1; ID[K] := CH
73700 END ;
73800 NEXTCH
73900 UNTIL NOT (CH IN LETTERSDIGITSORLEFTARROW);
74000 FOR I := FRW[K] TO FRW[K+1] - 1 DO
74100 IF RW[I] = ID
74200 THEN
74300 BEGIN
74400 SY := RSY[I]; OP := ROP[I]; GOTO 1
74500 END;
74600 SY := IDENT; OP := NOOP;
74700 1:
74800 END;
74900 '0','1','2','3','4','5','6','7','8','9':
75000 BEGIN
75100 (* 141 - better way to check overflow *)
75200 if overflow then; {clear old errors}
75300 SY := INTCONST; OP := NOOP;
75400 (* 64 - non-loc goto *)
75500 id := ' ';
75600 I := 0;
75700 REPEAT
75800 I := I + 1;
75900 if i <= alfaleng
76000 then id[i] := ch;
76100 IF I <= DIGMAX
76200 (* 142 - better real scanning *)
76300 THEN DIGIT[I] := ORD(CH) - ORD('0');
76400 NEXTCH
76500 UNTIL NOT (CH IN DIGITS);
76600 IVAL := 0;
76700 IF CH = 'B'
76800 THEN
76900 BEGIN
77000 (* 43 - allow 12 digit octal no. *)
77100 (* 142 - better real number scanning *)
77200 if i > digmax
77300 then begin
77400 error(174);
77500 i := digmax
77600 end;
77700 nc.int:=0;
77800 FOR K := 1 TO I DO
77900 IF DIGIT[K] IN [8,9]
78000 THEN ERROR(252)
78100 else nc.oct[k+digmax-i]:=digit[k];
78200 val.ival := nc.int;
78300 NEXTCH
78400 END
78500 ELSE
78600 BEGIN
78700 (* 142 - better real number scanning *)
78800 scale := 0;
78900 FOR K := 1 TO I DO
79000 if scale > 0
79100 then scale := scale + 1
79200 else if ival < max10
79300 then ival := 10*ival + digit[k]
79400 else if (ival = max10) and (digit[k] <= 7)
79500 then ival := 10*ival + digit[k]
79600 else scale := scale + 1;
79700 IF CH = '.'
79800 THEN
79900 BEGIN
80000 NEXTCH;
80100 IF CH = '.'
80200 THEN CH := ':'
80300 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 if abs(i) <= 377777B
06700 then checksize := i
06800 else begin
06900 error(266);
07000 checksize := 0
07100 end
07200 end;
07300
07400 FUNCTION LOG2(FVAL: INTEGER): BITRANGE;
07500 VAR
07600 E: BITRANGE; H: INTEGER;
07700 BEGIN
07800 E :=0;
07900 H := 1;
08000 (* 135 - numbers > 200 000 000 000B didn't work. *)
08100 {There are two complicating issues here:
08200 1 - 200 000 000 000 is the highest power of 2, so the
08300 loop below goes forever for them
08400 2 - the caller has often added 1, thus making 377 777 777 777
08500 into 400 000 000 000, which is negative!!
08600 In both of these cases we want to return 35}
08700 IF (FVAL-1) >= 200000000000B
08800 THEN E := 35
08900 ELSE REPEAT
09000 E := E + 1; H := H * 2
09100 UNTIL FVAL <= H;
09200 LOG2 := E
09300 END %LOG2\;
09400
09500 PROCEDURE SIMPLETYPE(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE;
09600 VAR FBITSIZE: BITRANGE);
09700 VAR
09800 LSP,LSP1: STP; LCP,LCP1: CTP; TTOP: DISPRANGE;
09900 LCNT: INTEGER; LVALU: VALU; LBITSIZE: BITRANGE;
10000 BEGIN
10100 FSIZE := 1;
10200 SKIPIFERR(SIMPTYPEBEGSYS,208,FSYS);
10300 IF SY IN SIMPTYPEBEGSYS
10400 THEN
10500 BEGIN
10600 IF SY = LPARENT
10700 THEN
10800 BEGIN
10900 TTOP := TOP; %DECL. CONSTS LOCAL TO INNERMOST BLOCK\
11000 WHILE DISPLAY[TOP].OCCUR # BLCK DO TOP := TOP - 1;
11100 NEWZ(LSP,SCALAR,DECLARED);
11200 LSP^.SIZE := 1;
11300 LCP1 := NIL; LCNT := 0;
11400 REPEAT
11500 INSYMBOL;
11600 IF SY = IDENT
11700 THEN
11800 BEGIN
11900 NEWZ(LCP,KONST);
12000 WITH LCP^ DO
12100 BEGIN
12200 NAME := ID; IDTYPE := LSP; NEXT := LCP1;
12300 VALUES.IVAL := LCNT;
12400 END;
12500 ENTERID(LCP);
12600 LCNT := LCNT + 1;
12700 LCP1 := LCP; INSYMBOL
12800 END
12900 ELSE ERROR(209);
13000 IFERRSKIP(166,FSYS OR [COMMA,RPARENT])
13100 UNTIL SY # COMMA;
13200 TOP := TTOP;
13300 WITH LSP^ DO
13400 BEGIN
13500 SELFSTP := NIL; FCONST := LCP1; BITSIZE := LOG2(LCNT)
13600 END;
13700 IF SY = RPARENT
13800 THEN INSYMBOL
13900 ELSE ERROR(152)
14000 END
14100 ELSE
14200 BEGIN
14300 IF SY = IDENT
14400 THEN
14500 BEGIN
14600 SEARCHID([TYPES,KONST],LCP);
14700 INSYMBOL;
14800 IF LCP^.KLASS = KONST
14900 THEN
15000 BEGIN
15100 NEWZ(LSP,SUBRANGE);
15200 WITH LSP^, LCP^ DO
15300 BEGIN
15400 SELFSTP := NIL; RANGETYPE := IDTYPE;
15500 IF STRING(RANGETYPE)
15600 THEN
15700 BEGIN
15800 ERROR(303); RANGETYPE := NIL
15900 END;
16000 MIN := VALUES; SIZE := 1
16100 END;
16200 IF SY = COLON
16300 THEN INSYMBOL
16400 ELSE ERROR(151);
16500 CONSTANT(FSYS,LSP1,LVALU);
16600 WITH LSP^ DO
16700 BEGIN
16800 MAX := LVALU;
16900 IF MIN.IVAL<0
17000 THEN BITSIZE := BITMAX
17100 ELSE BITSIZE := LOG2(MAX.IVAL + 1);
17200 IF RANGETYPE # LSP1
17300 THEN ERROR(304)
17400 END;
17500 END
17600 ELSE
17700 BEGIN
17800 LSP := LCP^.IDTYPE;
17900 IF LSP # NIL
18000 THEN FSIZE := LSP^.SIZE;
18100 END
18200 END %SY = IDENT\
18300 ELSE
18400 BEGIN
18500 NEWZ(LSP,SUBRANGE);
18600 CONSTANT(FSYS OR [COLON],LSP1,LVALU);
18700 IF STRING(LSP1)
18800 THEN
18900 BEGIN
19000 ERROR(303); LSP1 := NIL
19100 END;
19200 WITH LSP^ DO
19300 BEGIN
19400 RANGETYPE := LSP1; MIN := LVALU; SIZE := 1
19500 END;
19600 IF SY = COLON
19700 THEN INSYMBOL
19800 ELSE ERROR(151);
19900 CONSTANT(FSYS,LSP1,LVALU);
20000 WITH LSP^ DO
20100 BEGIN
20200 SELFSTP := NIL; MAX := LVALU;
20300 IF MIN.IVAL<0
20400 THEN BITSIZE := BITMAX
20500 ELSE BITSIZE := LOG2(MAX.IVAL + 1);
20600 IF RANGETYPE # LSP1
20700 THEN ERROR(304)
20800 END
20900 END;
21000 IF LSP # NIL
21100 THEN
21200 WITH LSP^ DO
21300 IF FORM = SUBRANGE
21400 THEN
21500 IF RANGETYPE # NIL
21600 THEN
21700 IF RANGETYPE = REALPTR
21800 THEN
21900 (* 106 - make subranges of real illegal *)
22000 error(210)
22100 ELSE
22200 IF MIN.IVAL > MAX.IVAL
22300 THEN ERROR(451)
22400 END;
22500 FSP := LSP;
22600 IF LSP#NIL
22700 THEN FBITSIZE := LSP^.BITSIZE
22800 ELSE FBITSIZE := 0;
22900 IFERRSKIP(166,FSYS)
23000 END
23100 ELSE
23200 BEGIN
23300 FSP := NIL; FBITSIZE := 0
23400 END
23500 END %SIMPLETYPE\ ;
23600
23700 (* 173 - internal files *)
23800 PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FRECVAR: STP; VAR FFIRSTFIELD: CTP; VAR FHASFILE:BOOLEAN);
23900 VAR
24000 LHASFILE:BOOLEAN;
24100 LCP,LCP1,NXT,NXT1: CTP; LSP,LSP1,LSP2,LSP3,LSP4,TAGSP: STP;
24200 MINSIZE,MAXSIZE,LSIZE: ADDRRANGE; LVALU: VALU;
24300 LBITSIZE: BITRANGE;
24400 LBTP: BTP; MINBITCOUNT:INTEGER;
24500 LID : ALFA ;
24600
24700 PROCEDURE RECSECTION( VAR FCP: CTP; FSP: STP );
24800 BEGIN
24900 IF NOT PACKFLAG OR (LSIZE > 1) OR (LBITSIZE = 36)
25000 THEN
25100 BEGIN
25200 IF BITCOUNT > 0
25300 THEN
25400 BEGIN
25500 DISPL := DISPL + 1; BITCOUNT := 0
25600 END;
25700 WITH FCP^ DO
25800 BEGIN
25900 IDTYPE := FSP; FLDADDR := DISPL;
26000 PACKF := NOTPACK; FCP := NEXT;
26100 DISPL := DISPL + LSIZE
26200 END
26300 END
26400 ELSE %PACK RECORD-SECTION\
26500
26600 BEGIN
26700 BITCOUNT := BITCOUNT + LBITSIZE;
26800 IF BITCOUNT>BITMAX
26900 THEN
27000 BEGIN
27100 DISPL := DISPL + 1;
27200 BITCOUNT := LBITSIZE
27300 END;
27400 IF (LBITSIZE = 18) AND (BITCOUNT IN [18,36])
27500 THEN
27600 BEGIN
27700 WITH FCP^ DO
27800 BEGIN
27900 IDTYPE := FSP;
28000 FLDADDR := DISPL;
28100 IF BITCOUNT = 18
28200 THEN PACKF := HWORDL
28300 ELSE PACKF := HWORDR;
28400 FCP := NEXT
28500 END
28600 END
28700 ELSE
28800 BEGIN
28900 NEWZ(LBTP,RECORDD);
29000 WITH LBTP^.BYTE DO
29100 BEGIN
29200 SBITS := LBITSIZE;
29300 PBITS := BITMAX - BITCOUNT;
29400 RELADDR := DISPL;
29500 DUMMYBIT := 0;
29600 IBIT := 0;
29700 IREG := TAC
29800 END;
29900 WITH LBTP^ DO
30000 BEGIN
30100 LAST := LASTBTP; FIELDCP := FCP
30200 END;
30300 LASTBTP := LBTP;
30400 WITH FCP^ DO
30500 BEGIN
30600 IDTYPE := FSP;
30700 PACKF := PACKK;
30800 FCP := NEXT
30900 END
31000 END
31100 END
31200 END % RECSECTION \ ;
31300 BEGIN
31400 (* 173 - internal files *)
31500 (* 166 - In case of null record declaration, FRECVAR was getting junk.
31600 I don't understand the logic of this routine, but initializing
31700 it to NIL seems safe enough *)
31800 NXT1 := NIL; LSP := NIL; FRECVAR := NIL; FHASFILE := FALSE;
31900 (* 21 - Allow null fieldlist (added FSYS OR to next statement) *)
32000 (* 65 - allow extra semicolons *)
32100 while sy=semicolon do
32200 insymbol;
32300 SKIPIFERR(FSYS OR [IDENT,CASESY],452,FSYS);
32400 WHILE SY = IDENT DO
32500 BEGIN
32600 NXT := NXT1;
32700 LOOP
32800 IF SY = IDENT
32900 THEN
33000 BEGIN
33100 NEWZ(LCP,FIELD);
33200 WITH LCP^ DO
33300 BEGIN
33400 NAME := ID; IDTYPE := NIL; NEXT := NXT
33500 END;
33600 NXT := LCP;
33700 ENTERID(LCP);
33800 INSYMBOL
33900 END
34000 ELSE ERROR(209);
34100 SKIPIFERR([COMMA,COLON],166,FSYS OR [SEMICOLON,CASESY]);
34200 EXIT IF SY # COMMA;
34300 INSYMBOL
34400 END;
34500 IF SY = COLON
34600 THEN INSYMBOL
34700 ELSE ERROR(151);
34800 TYP(FSYS OR [CASESY,SEMICOLON],LSP,LSIZE,LBITSIZE);
34900 IF LSP # NIL
35000 THEN
35100 (* internal files *)
35200 IF (LSP^.FORM = FILES) OR LSP^.HASFILE
35300 THEN FHASFILE := TRUE;
35400 WHILE NXT # NXT1 DO RECSECTION(NXT,LSP); %RESERVES SPACE FOR ONE RECORDSECTION \
35500 NXT1 := LCP;
35600 (* 64 - allow null entry *)
35700 WHILE SY = SEMICOLON DO
35800 BEGIN
35900 INSYMBOL;
36000 SKIPIFERR(FSYS OR [IDENT,CASESY,SEMICOLON],452,FSYS)
36100 END
36200 END %WHILE\;
36300 NXT := NIL;
36400 WHILE NXT1 # NIL DO
36500 WITH NXT1^ DO
36600 BEGIN
36700 LCP := NEXT; NEXT := NXT; NXT := NXT1; NXT1 := LCP
36800 END;
36900 FFIRSTFIELD := NXT;
37000 IF SY = CASESY
37100 THEN
37200 BEGIN
37300 LCP:=NIL; %POSSIBILITY OF NO TAGFIELDIDENTIFIER\
37400 INSYMBOL;
37500 IF SY = IDENT
37600 THEN
37700 BEGIN
37800 LID := ID ;
37900 INSYMBOL ;
38000 IF (SY#COLON) AND (SY#OFSY)
38100 THEN
38200 BEGIN
38300 ERROR(151) ;
38400 ERRANDSKIP(160,FSYS OR [LPARENT])
38500 END
38600 ELSE
38700 BEGIN
38800 IF SY = COLON
38900 THEN
39000 BEGIN
39100 NEWZ(LSP,TAGFWITHID);
39200 NEWZ(LCP,FIELD) ;
39300 WITH LCP^ DO
39400 BEGIN
39500 NAME := LID ; IDTYPE := NIL ; NEXT := NIL
39600 END ;
39700 ENTERID(LCP) ;
39800 INSYMBOL ;
39900 IF SY # IDENT
40000 THEN
40100 BEGIN
40200 ERRANDSKIP(209,FSYS OR [LPARENT]) ; GOTO 1
40300 END
40400 ELSE
40500 BEGIN
40600 LID := ID ;
40700 INSYMBOL ;
40800 IF SY # OFSY
40900 THEN
41000 BEGIN
41100 ERRANDSKIP(160,FSYS OR [LPARENT]) ; GOTO 1
41200 END
41300 END
41400 END
41500 ELSE NEWZ(LSP,TAGFWITHOUTID) ;
41600 WITH LSP^ DO
41700 BEGIN
41800 SIZE:= 0 ; SELFSTP := NIL ;
41900 FSTVAR := NIL;
42000 IF FORM=TAGFWITHID
42100 THEN TAGFIELDP:=NIL
42200 ELSE TAGFIELDTYPE := NIL
42300 END;
42400 FRECVAR := LSP;
42500 ID := LID ;
42600 SEARCHID([TYPES],LCP1) ;
42700 TAGSP := LCP1^.IDTYPE;
42800 IF TAGSP # NIL
42900 THEN
43000 IF (TAGSP^.FORM <= SUBRANGE) OR STRING(TAGSP)
43100 THEN
43200 BEGIN
43300 IF COMPTYPES(REALPTR,TAGSP)
43400 THEN ERROR(210)
43500 ELSE
43600 IF STRING(TAGSP)
43700 THEN ERROR(169);
43800 WITH LSP^ DO
43900 BEGIN
44000 BITSIZE := TAGSP^.BITSIZE;
44100 IF FORM = TAGFWITHID
44200 THEN TAGFIELDP := LCP
44300 ELSE TAGFIELDTYPE := TAGSP;
44400 END;
44500 IF LCP # NIL
44600 THEN
44700 BEGIN
44800 LBITSIZE :=TAGSP^.BITSIZE;
44900 LSIZE := TAGSP^.SIZE;
45000 RECSECTION(LCP,TAGSP); %RESERVES SPACE FOR THE TAGFIELD \
45100 IF BITCOUNT > 0
45200 (* 104 - check structure sizes *)
45300 THEN LSP^.SIZE:=CHECKSIZE(DISPL + 1)
45400 ELSE LSP^.SIZE:= CHECKSIZE(DISPL);
45500 END
45600 END
45700 ELSE ERROR(402);
45800
45900 INSYMBOL;
46000 END
46100 END
46200 (* 150 - fix ill mem ref trying to follow tagsp if not set *)
46300 ELSE BEGIN TAGSP := NIL; ERRANDSKIP(209,FSYS OR [LPARENT]) END ;
46400 1:
46500 LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL; MINBITCOUNT:=BITCOUNT;
46600 (* 65 - allow extra semicolons *)
46700 while sy=semicolon do
46800 insymbol;
46900 LOOP
47000 LSP2 := NIL;
47100 LOOP
47200 CONSTANT(FSYS OR [COMMA,COLON,LPARENT],LSP3,LVALU);
47300 IF NOT COMPTYPES(TAGSP,LSP3)
47400 THEN ERROR(305);
47500 NEWZ(LSP3,VARIANT);
47600 WITH LSP3^ DO
47700 BEGIN
47800 NXTVAR := LSP1; SUBVAR := LSP2; VARVAL := LVALU;
47900 BITSIZE := LSP^.BITSIZE; SELFSTP := NIL
48000 END;
48100 LSP1 := LSP3; LSP2 := LSP3;
48200 EXIT IF SY # COMMA;
48300 INSYMBOL;
48400 END;
48500 IF SY = COLON
48600 THEN INSYMBOL
48700 ELSE ERROR(151);
48800 IF SY = LPARENT
48900 THEN INSYMBOL
49000 ELSE ERROR(153);
49100 (* 173 - internal files *)
49200 FIELDLIST(FSYS OR [RPARENT,SEMICOLON],LSP2,LCP,LHASFILE);
49300 FHASFILE := FHASFILE OR LHASFILE;
49400 IF DISPL > MAXSIZE
49500 THEN MAXSIZE := DISPL;
49600 WHILE LSP3 # NIL DO
49700 BEGIN
49800 LSP4 := LSP3^.SUBVAR; LSP3^.SUBVAR := LSP2; LSP3^.FIRSTFIELD := LCP;
49900 (* 20 - deleted if bitcount>0 use displ+1 - done in fieldlist *)
50000 (* 104 - check structure sizes *)
50100 LSP3^.SIZE := CHECKSIZE(DISPL) ;
50200 LSP3 := LSP4
50300 END;
50400 IF SY = RPARENT
50500 THEN
50600 BEGIN
50700 INSYMBOL;
50800 IFERRSKIP(166,FSYS OR [SEMICOLON])
50900 END
51000 ELSE ERROR(152);
51100 (* 65 - allow extra semicolons *)
51200 while sy=semicolon
51300 do insymbol;
51400 exit if sy in fsys;
51500 DISPL := MINSIZE;
51600 BITCOUNT:=MINBITCOUNT; %RESTAURATION \
51700 END;
51800 DISPL := MAXSIZE;
51900 LSP^.FSTVAR := LSP1;
52000 END %IF SY = CASESY\
52100 ELSE
52200 IF LSP # NIL
52300 THEN
52400 IF LSP^.FORM = ARRAYS
52500 THEN FRECVAR := LSP
52600 ELSE FRECVAR := NIL;
52700 (* 20 - fix packed records - from CMU *)
52800 IF BITCOUNT > 0 THEN
52900 BEGIN DISPL:=DISPL+1; BITCOUNT := 0 END
53000 END %FIELDLIST\ ;
53100
53200 BEGIN
53300 %TYP\
53400 (* 173 - internal files *)
53500 FHASFILE := FALSE;
53600 SKIPIFERR(TYPEBEGSYS,170,FSYS);
53700 PACKFLAG := FALSE;
53800 IF SY IN TYPEBEGSYS
53900 THEN
54000 BEGIN
54100 IF SY IN SIMPTYPEBEGSYS
54200 THEN SIMPLETYPE(FSYS,FSP,FSIZE,FBITSIZE)
54300 ELSE
54400 %^\
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 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 LASTFILE: CTP;
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 THEN HEAP := 377777B;
33300 MACRO3(201B%MOVEI\,BASIS,HEAP); %LSTNEW_377777\
33400 MACRO3R(202B%MOVEM\,BASIS,LSTNEW); %WILL GET GLOBAL FIXUP\
33500 LSTNEW := IC-1;
33600 MACRO3(201B%MOVEI\,BASIS,HEAP+1); %NEWBND_400000\
33700 MACRO3R(202B%MOVEM\,BASIS,NEWBND); %GLOBAL FIXUP\
33800 NEWBND := IC-1;
33900 IF STACK#0
34000 THEN MACRO3(201B%MOVEI\,BASIS,STACK)
34100 ELSE MACRO3(550B%HRRZ\,BASIS,115B); %BASIS_.JBHRL\
34200 MACRO3(306B%CAIN\,BASIS,0); %IF NO HISEG\
34300 MACRO3(201B%MOVEI\,BASIS,377777B); %START STACK 400000\
34400 MACRO3(200B%MOVE\,NEWREG,BASIS); %NEWREG=HIGHEST ALLOC\
34500 MACRO3(271B%ADDI\,BASIS,1); %BASIS=NEXT TO USE\
34600 MACRO4(505B%HRLI\,BASIS,BASIS,0);
34700 MACRO4(541B%HRRI\,TOPP,BASIS,0); %GETS FIXED UP\
34800 INSERTSIZE:= CIX;
34900 (* 104 - KEEP LH=RH FOR TOPS20 ADJSP *)
35000 MACRO3(504B%HRL\,TOPP,TOPP);
35100 (* 66 - nonloc goto's *)
35200 macro3r(202B%movem\,basis,globbasis);
35300 macro3r(202B%movem\,topp,globtopp);
35400 (* 17 - LEAVE .JBFF ALONE, SINCE BUFFER HEADERS POINT INTO FREE AREA *)
35500 (* 57 - LIMIT UUO'S AND CORE ALLOC TO TOPS-10 VERSION *)
35600 IF TOPS10 THEN BEGIN
35700 (* 122 - seem not to need to save .jbff any more *)
35800 { MACRO3(550B%HRRZ\,1,121B); %.JBFF\
35900 MACRO3(506B%HRLM\,1,120B); %TO LH(.JBSA)\
36000 } MACRO3(047B,0,0%RESET-UUO\); %.JBFF=.JBSA\
36100 (* 74 - new init stuff for tops10 under emulator *)
36200 support(initmem);
36300 (* 53 - figure out later how many loc's above stack we need *)
36400 (* 130 - leave in dummy CAI in KA version so there is some place for the CORALLOC fixup to go *)
36500 MACRO4(300B%CAI\,NEWREG,TOPP,0); CORALLOC := CIX; %Will be fixed up later\
36600 (* 122 - already get core in initmem for KA *)
36700 (* 132 - separate KA10 into novm and kacpu *)
36800 if not novm
36900 THEN SUPPORT(STACKOVERFLOW); % GET CORE FOR STACK\
37000 (* 34 - TRAP ARITH EXCEPTIONS WHEN CHECKING *)
37100 IF ARITHCHECK
37200 THEN BEGIN
37300 MACRO3(201B%MOVEI\,1,110B); %TRAP ALL ARITH. EXCEPTIONS\
37400 MACRO3(047B%CALLI\,1,16B); %APRENB - TURN ON APR SYS\
37500 END;
37600 (* 57 - INIT ALL IN RUNTIMES FOR NON-TOPS10 *)
37700 END
37800 ELSE MACRO3(201B%MOVEI\,2,ORD(ARITHCHECK));
37900 (* 50 - reinit file ctl. blocks *)
38000 support(initfiles);
38100 doinitTTY := false;
38200 LFILEPTR := SFILEPTR ;
38300 REGC := REGIN + 1 ;
38400 (* 33 - PROGRAM *)
38500 (* 50 - changed logic to only open INPUT and OUTPUT if in pgm state *)
38600 LPROGFILE := FPROGFILE;
38700 WHILE LPROGFILE # NIL DO
38800 BEGIN
38900 PRTERR := FALSE; OLDID := ID; ID := LPROGFILE^.FILID;
39000 SEARCHID([VARS],LCP);
39100 PRTERR := TRUE; ID := OLDID;
39200 IF LCP = NIL
39300 THEN ERRORWITHTEXT(508,LPROGFILE^.FILID)
39400 ELSE
39500 WITH LCP^ DO
39600 BEGIN
39700 IF IDTYPE#NIL THEN IF IDTYPE^.FORM#FILES
39800 THEN ERRORWITHTEXT(509,LPROGFILE^.FILID);
39900 MACRO3R(201B%MOVEI\,REGC,VADDR);
40000 IF (VLEV = 0) AND (NOT MAIN)
40100 THEN BEGIN
40200 VADDR := IC -1;
40300 CODE.INFORMATION[CIX] := 'E'
40400 END;
40500 ALFACONSTANT(LPROGFILE^.FILID);
40600 MACRO3(551B%HRRZI\,REGC+1,0);DEPCST(STRG,GATTR);
40700 (* 61 - set up flags for gtjfn *)
40800 i := 60023b; %mandatory flags for gtjfn\
40900 if lprogfile^.wild
41000 then i := i + 100B;
41100 if lprogfile^.newgen
41200 then i := i + 400000B;
41300 if lprogfile^.oldfile
41400 then i := i + 100000B;
41500 macro3(505B%hrli\,regc+1,i);
41600 (* 172 - end of line proc *)
41700 if lcp = ttyfile
41800 then ttyseeeol := lprogfile^.seeeol;
41900 if not ((lcp = ttyfile) or (lcp = ttyoutfile))
42000 then SUPPORT(READFILENAME)
42100 END;
42200 (* 171 - handle input and output as special - many changes to lcp = in/outfile *)
42300 if (lcp = infile)
42400 and not lprogfile^.interact
42500 then doinitTTY := true;
42600 if (lcp = infile) or (lcp = outfile)
42700 then begin
42800 macro3(201B%movei\,regc-1,0); {AC1=0 for text file}
42900 macro3(403B%setzb\,regc+1,regc+2);
43000 macro3(403B%setzb\,regc+3,regc+4);
43100 (* 64 - input:/ *)
43200 (* 157 - always open INPUT interactive - do GET below *)
43300 if lcp = infile
43400 then macro3(201B%movei\,regc+3,1);
43500 macro3(403B%setzb\,regc+5,regc+6);
43600 (* 172 - new eoln handling *)
43700 if (lcp = infile) and lprogfile^.seeeol
43800 then if tops10
43900 then macro3(201B%movei\,regc+5,40000B)
44000 else macro3(201B%movei\,regc+6,20B);
44100 if lcp = infile
44200 then support(resetfile)
44300 else support(rewritefile)
44400 end;
44500 LPROGFILE := LPROGFILE^.NEXT
44600 END;
44700 (* 15 - ZERO ALL ARGS TO OPEN *)
44800 TTYINUSE := TTYINUSE OR DEBUG;
44900 WHILE LFILEPTR # NIL DO
45000 WITH LFILEPTR^ , FILEIDENT^ DO
45100 (* 50 - only open TTY here, as INPUT and OUTPUT done above *)
45200 begin
45300 if (fileident = ttyfile) or (fileident = ttyoutfile)
45400 then
45500 BEGIN
45600 MACRO3R(201B%MOVEI\,REGC,VADDR) ;
45700 macro3(201B%movei\,regc-1,0); {0=text file}
45800 (* 202 - fix illegal option *)
45900 macro3(403B%setzb\,regc+1,regc+2);
46000 macro3(403B%setzb\,regc+3,regc+4);
46100 (* 172 - new EOL *)
46200 macro3(403B%setzb\,regc+5,regc+6);
46300 if (fileident = ttyfile) and ttyseeeol
46400 then if tops10
46500 then macro3(201B%movei\,regc+5,40000B)
46600 else macro3(201B%movei\,regc+6,20B);
46700 (* 36 - allow debugging non-main modules *)
46800 IF fileident = ttyfile
46900 THEN
47000 SUPPORT(RESETFILE)
47100 ELSE
47200 SUPPORT(REWRITEFILE) ;
47300 end;
47400 (* 3 - Removed OPENTTY because of RUNTIM changes *)
47500 LFILEPTR := NEXTFTP ;
47600 END ;
47700 if doinitTTY
47800 then support(opentty);
47900 macro3(200b%move\,tac,74b); %get .jbddt\
48000 macro3(602b%trne\,tac,777777b); %if zero RH\
48100 macro3(603b%tlne\,tac,777777b); %or non-0 LH\
48200 macro3r(254b%jrst\,0,mainstart); %isn't PASDDT\
48300 macro4(260b%pushj\,topp,tac,-2); %init pt. is start-2\
48400 MACRO3R(254B%JRST\,0,MAINSTART);
48500 END;
48600 END;
48700 CODEEND := IC;
48800 LKSP:= FIRSTKONST;
48900 WHILE LKSP # NIL DO
49000 WITH LKSP^,CONSTPTR^ DO
49100 BEGIN
49200 KADDR:= IC;
49300 CASE CCLASS OF
49400 INT,
49500 REEL: IC := IC + 1 ;
49600 PSET: IC := IC + 2 ;
49700 STRD,
49800 STRG: IC := IC + (SLGTH+4) DIV 5
49900 END ;
50000 %CASE\
50100 LKSP := NEXTKONST
50200 END %WITH , WHILE\;
50300 IF DEBUGSWITCH
50400 THEN
50500 BEGIN
50600 IF (LEVEL > 1) AND ( DISPLAY[TOP].FNAME # NIL )
50700 THEN INSERTADDR(RIGHT,IDTREE,IC)
50800 END
50900 ELSE
51000 IF LEVEL = 1
51100 THEN HIGHESTCODE := IC
51200 END%LEAVEBODY\;
51300
51400 PROCEDURE FETCHBASIS(VAR FATTR: ATTR);
51500 VAR
51600 P,Q: INTEGER;
51700 BEGIN
51800 WITH FATTR DO
51900 IF VLEVEL>1
52000 THEN
52100 BEGIN
52200 P := LEVEL - VLEVEL;
52300 IF P=0
52400 THEN
52500 IF INDEXR=0
52600 THEN INDEXR := BASIS
52700 ELSE MACRO3(270B%ADD\,INDEXR,BASIS)
52800 ELSE
52900 BEGIN
53000 MACRO4(540B%HRR\,TAC,BASIS,-1);
53100 FOR Q := P DOWNTO 2 DO
53200 MACRO4(540B%HRR\,TAC,TAC,-1);
53300 IF INDEXR=0
53400 THEN INDEXR := TAC
53500 ELSE MACRO3(270B%ADD\,INDEXR,TAC)
53600 END;
53700 VLEVEL:=1 %DA IN WITHSTATEMENT DIE MOEGLICHKEIT BESTEHT,
53800 DASS ES 2-MAL DURCH FETCHBASIS LAEUFT\
53900 END
54000 END;
54100 %FETCHBASIS\
54200
54300 PROCEDURE GETPARADDR;
54400 BEGIN
54500 FETCHBASIS(GATTR);
54600 WITH GATTR DO
54700 BEGIN
54800 INCREMENTREGC;
54900 MACRO5(VRELBYTE,200B%MOVE\,REGC,INDEXR,DPLMT);
55000 INDEXR := REGC; VRELBYTE:= NO;
55100 INDBIT := 0; VLEVEL := 1; DPLMT := 0;
55200 END
55300 END;
55400
55500 {Warning to future modifiers: At the end of EXPRESSION, there is code that
55600 second-guesses the register allocation in this procedure. If you change
55700 the register allocation here, please look at that code.}
55800 PROCEDURE MAKECODE(FINSTR: INSTRANGE; FAC: ACRANGE; VAR FATTR: ATTR);
55900 VAR
56000 LINSTR: INSTRANGE; LREGC: ACRANGE;
56100 BEGIN
56200 WITH FATTR DO
56300 IF TYPTR#NIL
56400 THEN
56500 BEGIN
56600 CASE KIND OF
56700 CST:
56800 IF TYPTR=REALPTR
56900 THEN
57000 BEGIN
57100 MACRO3(FINSTR,FAC,0); DEPCST(REEL,FATTR)
57200 END
57300 ELSE
57400 IF TYPTR^.FORM=SCALAR
57500 THEN
57600 WITH CVAL DO
57700 IF ((IVAL >= 0) AND (IVAL <= MAXADDR))
57800 OR
57900 (* 50 - correct code for 400000,,0 *)
58000 ((ABS(IVAL) <= HWCSTMAX+1) AND (IVAL # 400000000000B)
58100 AND
58200 ((FINSTR = 200B%MOVE\) OR (IVAL >= 0)))
58300 THEN
58400 BEGIN
58500 IF FINSTR=200B%MOVE\
58600 THEN
58700 IF IVAL < 0
58800 THEN FINSTR := 571B%HRREI\
58900 ELSE FINSTR := 551B%HRRZI\
59000 ELSE
59100 IF (FINSTR>=311B) AND (FINSTR <= 317B)
59200 THEN FINSTR := FINSTR - 10B %E.G. CAML --> CAIL\
59300 ELSE FINSTR := FINSTR+1;
59400 MACRO3(FINSTR,FAC,IVAL);
59500 END
59600 ELSE
59700 BEGIN
59800 MACRO3(FINSTR,FAC,0); DEPCST(INT,FATTR)
59900 END
60000 ELSE
60100 IF TYPTR=NILPTR
60200 THEN
60300 BEGIN
60400 IF FINSTR=200B%MOVE\
60500 THEN FINSTR := 571B%HRREI\
60600 ELSE
60700 IF (FINSTR>=311B) AND (FINSTR<=317B)
60800 THEN FINSTR := FINSTR-10B
60900 ELSE FINSTR := FINSTR+1;
61000 MACRO3(FINSTR,FAC,377777B);
61100 END
61200 ELSE
61300 IF TYPTR^.FORM=POWER
61400 THEN
61500 BEGIN
61600 MACRO3(FINSTR,FAC,0); MACRO3(FINSTR,FAC-1,0); DEPCST(PSET,FATTR);
61700 END
61800 ELSE
61900 IF TYPTR^.FORM=ARRAYS
62000 THEN
62100 IF TYPTR^.SIZE = 1
62200 THEN
62300 BEGIN
62400 MACRO3(FINSTR,FAC,0); DEPCST(STRG,FATTR)
62500 END
62600 ELSE
62700 IF TYPTR^.SIZE = 2
62800 THEN
62900 BEGIN
63000 FATTR.CVAL.VALP^.CCLASS := STRD;
63100 MACRO3(FINSTR,FAC,0); MACRO3(FINSTR,FAC-1,0); DEPCST(STRD,FATTR);
63200 END;
63300 VARBL:
63400 BEGIN
63500 FETCHBASIS(FATTR); LREGC := FAC;
63600 IF (INDEXR>REGIN) INCREMENTREGC ;
70700 MAKECODE(200B%MOVE\,REGC,FATTR);REGC := REG
70800 END;
70900 END;
71000 %LOAD\
71100
71200 (* 104 - common procedure for improved range check on subranges *)
71300 procedure loadsubrange(var gattr:attr;lsp:stp);
71400 var slattr:attr; srmin,srmax:integer;
71500 begin
71600 GETBOUNDS(LSP,SRMIN,SRMAX);
71700 IF (GATTR.KIND=CST)
71800 THEN
71900 IF (GATTR.CVAL.IVAL >= SRMIN) AND (GATTR.CVAL.IVAL <=SRMAX)
72000 THEN LOAD (GATTR)
72100 ELSE ERROR (367)
72200 ELSE
72300 BEGIN
72400 IF RUNTMCHECK AND (( GATTR.KIND#VARBL) OR (GATTR.SUBKIND # LSP))
72500 THEN
72600 BEGIN
72700 LOAD (GATTR);
72800 WITH SLATTR DO
72900 BEGIN
73000 TYPTR:=INTPTR;
73100 KIND :=CST;
73200 CVAL.IVAL:=SRMAX
73300 END;
73400 MAKECODE(317B%CAMG\,REGC,SLATTR);
73500 SLATTR.KIND:=CST;
73600 SLATTR.CVAL.IVAL:=SRMIN;
73700 MAKECODE(315B%CAMGE\,REGC,SLATTR);
73800 SUPPORT(ERRORINASSIGNMENT)
73900 END
74000 ELSE LOAD (GATTR);
74100 END
74200 end;
74300
74400 PROCEDURE STORE(FAC: ACRANGE; VAR FATTR: ATTR);
74500 VAR
74600 LATTR: ATTR;
74700 BEGIN
74800 LATTR := FATTR;
74900 WITH LATTR DO
75000 IF TYPTR # NIL
75100 THEN
75200 BEGIN
75300 FETCHBASIS(LATTR);
75400 CASE PACKFG OF
75500 NOTPACK:
75600 BEGIN
75700 IF TYPTR^.SIZE = 2
75800 THEN
75900 BEGIN
76000 MACRO5(VRELBYTE,202B%MOVEM\,FAC,INDEXR,DPLMT+1); FAC := FAC-1
76100 END;
76200 MACRO(VRELBYTE,202B%MOVEM\,FAC,INDBIT,INDEXR,DPLMT)
76300 END;
76400 PACKK:
76500 BEGIN
76600 MACRO5(VRELBYTE,201B%MOVEI\,TAC,INDEXR,DPLMT);
76700 MACRO3R(137B%DPB\,FAC,BPADDR);
76800 END;
76900 HWORDL: MACRO5(VRELBYTE,506B%HRLM\,FAC,INDEXR,DPLMT);
77000 HWORDR: MACRO5(VRELBYTE,542B%HRRM\,FAC,INDEXR,DPLMT)
77100 END %CASE\ ;
77200 END %WITH\ ;
77300 END %STORE\ ;
77400
77500 {Warning to future modifiers: At the end of EXPRESSION, there is code that
77600 second-guesses the register allocation in this procedure. If you change
77700 the register allocation here, please look at that code.}
77800 PROCEDURE LOADADDRESS;
77900 BEGIN
78000 INCREMENTREGC ;
78100 BEGIN
78200 WITH GATTR DO
78300 IF TYPTR # NIL
78400 THEN
78500 BEGIN
78600 CASE KIND OF
78700 CST:
78800 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 WRITEPAIR(NO,400000B,400000B);
44000 END
44100 END %CASE\
44200 END %MCVARIOUS\ ;
44300
44400 PROCEDURE MCSYMBOLS;
44500 VAR
44600 ENTRYFOUND: BOOLEAN; POLHEADERDONE:Boolean; chan:integer;
44700 BEGIN
44800 %MCSYMBOLS\
44900 WRITEHEADER('ENTRYPOINT(S) ');
45000 WRITEBLOCKST(2);
45100 SAVELISTCODE := LISTCODE;
45200 LISTCODE := FALSE;
45300 FOR SWITCHFLAG := 1B TO 2B DO
45400 BEGIN
45500 IF MAIN
45600 THEN
45700 BEGIN
45800 WRITEIDENTIFIER(SWITCHFLAG,FILENAME);
45900 WRITEPAIR(RIGHT,0,STARTADDR)
46000 END
46100 ELSE
46200 BEGIN
46300 (* 34 - LOOK FOR FTN=FILENAME ONLY IF NOT SPEC. IN PROGRAM STATE. *)
46400 CHECKER := LOCALPFPTR;
46500 IF FPROGFILE=NIL
46600 THEN ENTRYFOUND := FALSE
46700 ELSE ENTRYFOUND := TRUE;
46800 WHILE CHECKER # NIL DO
46900 WITH CHECKER^ DO
47000 BEGIN
47100 IF PFADDR # 0
47200 THEN
47300 BEGIN
47400 IF NOT ENTRYFOUND
47500 (* 34 - USING FILENAME FOR ENTRY NOW *)
47600 THEN ENTRYFOUND := FILENAME = NAME;
47700 WRITEIDENTIFIER(SWITCHFLAG,NAME);
47800 WRITEPAIR(RIGHT,0,PFADDR);
47900 IF PFCHAIN = NIL
48000 THEN
48100 IF NOT ENTRYFOUND
48200 THEN
48300 BEGIN
48400 (* 34 - USING FILENAME FOR ENTRY NOW *)
48500 WRITEIDENTIFIER(SWITCHFLAG,FILENAME);
48600 WRITEPAIR(RIGHT,0,PFADDR)
48700 END
48800 END;
48900 CHECKER:= PFCHAIN
49000 END
49100 END;
49200 LISTCODE := SAVELISTCODE; LIC := 0
49300 END;
49400 IF MAIN
49500 THEN
49600 BEGIN
49700 SWITCHFLAG:= 1B; WRITEHEADER('GLOBAL SYMBOLS ');
49800 (* 16 - ADD CCL SWITCH *)
49900 WRITEIDENTIFIER(SWITCHFLAG,'%CCLSW ');
50000 WRITEPAIR(RIGHT,0,CCLSW);
50100 WRITEIDENTIFIER(SWITCHFLAG,'%RNNAM ');
50200 WRITEPAIR(RIGHT,0,CCLSW+1);
50300 WRITEIDENTIFIER(SWITCHFLAG,'%RNPPN ');
50400 WRITEPAIR(RIGHT,0,CCLSW+2);
50500 WRITEIDENTIFIER(SWITCHFLAG,'%RNDEV ');
50600 WRITEPAIR(RIGHT,0,CCLSW+3);
50700 END
50800 ELSE
50900 BEGIN
51000 SWITCHFLAG:= 14B; WRITEHEADER('GLOBAL REQUESTS')
51100 END;
51200 FILEPTR := SFILEPTR;
51300 WHILE FILEPTR # NIL DO
51400 WITH FILEPTR^, FILEIDENT^ DO
51500 BEGIN
51600 IF VADDR # 0
51700 THEN
51800 BEGIN
51900 WRITEIDENTIFIER(SWITCHFLAG,NAME);
52000 WRITEPAIR(RIGHT,0,VADDR)
52100 END;
52200 FILEPTR:= NEXTFTP
52300 END;
52400 IF MAIN
52500 THEN WRITEHEADER('GLOBAL REQUESTS');
52600 CHECKER:= EXTERNPFPTR;
52700 WHILE CHECKER # NIL DO
52800 WITH CHECKER^ DO
52900 BEGIN
53000 IF LINKCHAIN[0] # 0
53100 THEN
53200 BEGIN
53300 IF PFLEV = 0
53400 THEN WRITEIDENTIFIER(14B,EXTERNALNAME)
53500 ELSE WRITEIDENTIFIER(14B,NAME);
53600 WRITEPAIR(RIGHT,0,LINKCHAIN[0])
53700 END;
53800 CHECKER:= PFCHAIN
53900 END;
54000 (* 12 - ADD EXTERNAL REF TO RUNTIMES FOR DYNAMIC CORE ALLOC *)
54100 IF LSTNEW # 0
54200 THEN BEGIN
54300 WRITEIDENTIFIER(14B,'LSTNEW ');
54400 WRITEPAIR(RIGHT,0,LSTNEW); % GLOBAL FIXUP TO INIT. CODE\
54500 END;
54600 IF NEWBND # 0
54700 THEN BEGIN
54800 WRITEIDENTIFIER(14B,'NEWBND ');
54900 WRITEPAIR(RIGHT,0,NEWBND); % DITTO \
55000 END;
55100 (* 105 - improve lower case mapping in sets *)
55200 if setmapchain # 0
55300 then begin
55400 writeidentifier (14B,'.STCHM ');
55500 writepair (right,0,setmapchain)
55600 end;
55700 FOR SUPPORTIX:= SUCC(FIRSTSUPPORT) TO PRED(LASTSUPPORT) DO
55800 IF RNTS.LINK[SUPPORTIX] # 0
55900 THEN
56000 BEGIN
56100 WRITEIDENTIFIER(14B,RNTS.NAME[SUPPORTIX]);
56200 WRITEPAIR(RIGHT,0,RNTS.LINK[SUPPORTIX])
56300 END;
56400 (* 36 - 141 is now set up elsewhere *)
56500 {In non-main modules, if there are references to TTY^, etc., a
56600 Polish fixup may be needed to resolve them.}
56700 polheaderdone := false;
56800 FILEPTR := SFILEPTR;
56900 IF NOT MAIN THEN WHILE FILEPTR # NIL DO
57000 WITH FILEPTR^, FILEIDENT^ DO
57100 begin
57200 if chantab[channel] <> 0
57300 then begin
57400 if not polheaderdone
57500 then begin
57600 writeheader('SYMBOLIC POLISH');
57700 polheaderdone := true;
57800 end;
57900 {A Polish fixup block looks like this:
58000 type 11
58100 operator,,2 2 means next word is global req - that is operand
58200 operand1
58300 0,,operand2 0 means next half word is operand
58400 -1,,place to put -1 means put in RH of result addr
58500 }
58600 writeblockst(11B);
58700 writepair(no,3,2); {add}
58800 writeidentifier(0,name);
58900 writepair(no,0,filcmp);
59000 writepair(right,777777B,chantab[channel]);
59100 putrelcode;
59200 end;
59300 FILEPTR:= NEXTFTP
59400 END;
59500 if polheaderdone and cref and listcode then NEWLINE;
59600 END %MCSYMBOLS\ ;
59700
59800 PROCEDURE MCLIBRARY;
59900 BEGIN
60000 %MCLIBRARY\
60100 WRITEHEADER('LINK LIBRARIES ');
60200 WRITEBLOCKST(15);
60300 FOR L := 1 TO 2 DO
60400 BEGIN
60500 FOR I := 1 TO LIBIX DO
60600 WITH LIBRARY[LIBORDER[I]] DO
60700 IF CALLED
60800 THEN WITH WANDLUNG DO
60900 BEGIN
61000 FOR J := 1 TO 6 DO WSIXBIT[J] := ORD(NAME[J]) - 40B;
61100 WRITEIDENTIFIER(6B,NAME);
61200 WRITEPAIR(NO,PROJNR,PROGNR);
61300 FOR J := 1 TO 6 DO WSIXBIT[J] := ORD(DEVICE[J]) - 40B;
61400 WRITEIDENTIFIER(6B,DEVICE); LIC := LIC + 1
61500 END;
61600 I := 1;
61700 (* 40 - load PASLIB first *)
61800 for languageix := pascalsy to fortransy do
61900 WITH LIBRARY[LANGUAGEIX] DO
62000 BEGIN
62100 CALLED := (NOT INORDER AND CALLED) OR (LANGUAGEIX = PASCALSY);
62200 LIBORDER[I] := LANGUAGEIX; I := I + 1
62300 END;
62400 LIBIX := 2
62500 END;
62600 END %MCLIBRARY\;
62700
62800 BEGIN
62900 %WRITEMC\
63000 (* 121 - missing initialization - fix bollixed INITPROC's *)
63100 CODEARRAY := FALSE;
63200 IF NOT ERRORFLAG
63300 THEN
63400 BEGIN
63500 (* 5 - CREF *)
63600 IF CREF AND LISTCODE
63700 THEN WRITE(CHR(177B),'F');
63800 FOR I:=1 TO MAXSIZE DO RELEMPTY[I] := 0;
63900 WITH ICWANDEL DO
64000 BEGIN
64100 ICVAL := 0;
64200 CSP0 := ICCSP
64300 END;
64400 LLISTCODE := LISTCODE;
64500 CASE WRITEFLAG OF
64600 WRITEGLOBALS : MCGLOBALS; %LINK-ITEM 01B\
64700 WRITECODE : MCCODE; %LINK-ITEM 01B\
64800 WRITESYMBOLS : MCSYMBOLS; %LINK-ITEM 02B\
64900 WRITEBLK, %LINK-ITEM 02B\
65000 WRITEINTERNALS, %LINK-ITEM 10B\
65100 (* 164 - Polish fixups *)
65200 WRITEPOLISH, %LINK-ITEM 11B\
65300 WRITEENTRY, %LINK-ITEM 04B\
65400 WRITEEND, %LINK-ITEM 05B\
65500 WRITESTART, %LINK-ITEM 07B\
65600 WRITEHISEG, %LINK-ITEM 03B\
65700 WRITENAME : MCVARIOUS; %LINK-ITEM 06B\
65800 WRITELIBRARY : MCLIBRARY %LINK-ITEM 17B\
65900 END %CASE\;
66000 IF LISTCODE AND (WRITEFLAG > WRITEHISEG)
66100 (* 5 - CREF *)
66200 (* 136 - LISTING FORMAT *)
66300 THEN NEWLINE;
66400 IF CREF AND LISTCODE
66500 THEN WRITE(CHR(177B),'B')
66600 END %IF ERRORFLAG\
66700 ELSE
66800 IF WRITEFLAG = WRITECODE
66900 THEN LASTBTP := NIL
67000 END %WRITEMC\;
67100
67200 PROCEDURE STATEMENT(FSYS,STATENDS: SETOFSYS);
67300 TYPE
67400 VALUEKIND = (ONREGC,ONFIXEDREGC,TRUEJMP,FALSEJMP);
67500 VAR
67600 LCP: CTP; IX,J: INTEGER;
67700
67800 PROCEDURE EXPRESSION(FSYS: SETOFSYS; FVALUE:VALUEKIND); FORWARD;
67900
68000 PROCEDURE MAKEREAL(VAR FATTR: ATTR);
68100 BEGIN
68200 IF FATTR.TYPTR=INTPTR
68300 THEN
68400 BEGIN
68500 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 IF IDTYPE^.FORM = FILES
05400 THEN LASTFILE:= FCP
05500 ELSE LASTFILE:= NIL;
05600 IF VKIND=ACTUAL
05700 THEN INDBIT:=0
05800 ELSE INDBIT:=1
05900 END;
06000 FIELD:
06100 WITH DISPLAY[DISX] DO
06200 IF OCCUR = CREC
06300 THEN
06400 BEGIN
06500 VLEVEL := CLEV; PACKFG := PACKF; VRELBYTE:= CRELBYTE;
06600 IF PACKFG = PACKK
06700 THEN
06800 BEGIN
06900 BPADDR := FLDADDR;
07000 DPLMT := CDSPL
07100 END
07200 ELSE DPLMT := CDSPL+FLDADDR;
07300 INDEXR := CINDR; INDBIT:=CINDB
07400 END
07500 ELSE
07600 ERROR(171);
07700 FUNC:
07800 IF PFDECKIND = STANDARD
07900 THEN ERROR(502)
08000 ELSE
08100 IF PFLEV = 0
08200 THEN ERROR(502) %EXTERNAL FCT\
08300 ELSE
08400 IF PFKIND = FORMAL
08500 THEN ERROR(456)
08600 (* 31 - BE SURE WE'RE IN THE BODY OF THE FTN *)
08700 ELSE IF (LEVEL <= PFLEV) OR (DISPLAY[PFLEV+1].BLKNAME # NAME)
08800 THEN ERROR(412)
08900 ELSE
09000 BEGIN
09100 (* 166 - use pflev+1 for vlevel, to allow assignment from inner function *)
09200 VLEVEL := PFLEV + 1; VRELBYTE := NO;
09300 DPLMT := 1; %IMPL. RELAT. ADDR. OF FCT. RESULT\
09400 INDEXR :=0; INDBIT :=0
09500 END
09600 END;
09700 %CASE\
09800 END %WITH\;
09900 IFERRSKIP(166,SELECTSYS OR FSYS);
10000 WHILE SY IN SELECTSYS DO
10100 BEGIN
10200 (* 156 - error for selector on ftn name *)
10300 IF FCP^.KLASS = FUNC
10400 THEN ERROR(368);
10500 %[\
10600 IF SY = LBRACK
10700 THEN
10800 BEGIN
10900 IF GATTR.INDBIT = 1
11000 THEN GETPARADDR;
11100 OLDIC := GATTR.INDEXR;
11200 INDEXOFFSET := 0 ;
11300 LOOP
11400 LATTR := GATTR; INDEXVALUE := 0 ;
11500 WITH LATTR DO
11600 IF TYPTR # NIL
11700 THEN
11800 BEGIN
11900 IF TYPTR^.FORM # ARRAYS
12000 THEN
12100 BEGIN
12200 ERROR(307); TYPTR := NIL
12300 END;
12400 LSP := TYPTR
12500 END;
12600 INSYMBOL;
12700 EXPRESSION(FSYS OR [COMMA,RBRACK],ONREGC);
12800 IF GATTR.KIND#CST
12900 THEN LOAD(GATTR)
13000 ELSE INDEXVALUE := GATTR.CVAL.IVAL ;
13100 IF GATTR.TYPTR # NIL
13200 THEN
13300 IF GATTR.TYPTR^.FORM # SCALAR
13400 THEN ERROR(403);
13500 IF LATTR.TYPTR # NIL
13600 THEN
13700 WITH LATTR,TYPTR^ DO
13800 BEGIN
13900 IF COMPTYPES(INXTYPE,GATTR.TYPTR)
14000 THEN
14100 BEGIN
14200 IF INXTYPE # NIL
14300 THEN
14400 BEGIN
14500 GETBOUNDS(INXTYPE,LMIN,LMAX);
14600 IF GATTR.KIND = CST
14700 THEN
14800 IF (INDEXVALUE < LMIN) OR (INDEXVALUE > LMAX)
14900 THEN ERROR(263)
15000 END
15100 END
15200 ELSE ERROR(457);
15300 TYPTR := AELTYPE ;
15400 END ;
15500 EXIT IF SY # COMMA;
15600 WITH LATTR DO
15700 IF TYPTR#NIL
15800 THEN
15900 IF GATTR.KIND = CST
16000 THEN DPLMT := DPLMT +( INDEXVALUE - LMIN ) * TYPTR^.SIZE
16100 ELSE
16200 BEGIN
16300 SUBLOWBOUND;
16400 IF TYPTR^.SIZE > 1
16500 THEN MACRO3(221B%IMULI\,REGC,TYPTR^.SIZE);
16600 IF OLDIC = 0
16700 THEN OLDIC := REGC
16800 ELSE
16900 IF OLDIC > REGCMAX
17000 THEN
17100 BEGIN
17200 MACRO3(270B%ADD\,REGC,OLDIC);
17300 OLDIC := REGC
17400 END
17500 ELSE
17600 BEGIN
17700 MACRO3(270B%ADD\,OLDIC,REGC) ;
17800 REGC := REGC - 1
17900 END;
18000 INDEXR := OLDIC
18100 END ;
18200 GATTR := LATTR ;
18300 END;
18400 %LOOP\
18500 WITH LATTR DO
18600 IF TYPTR # NIL
18700 THEN
18800 BEGIN
18900 IF GATTR.KIND = CST
19000 THEN INDEXOFFSET := ( INDEXVALUE - LMIN ) * TYPTR^.SIZE
19100 ELSE
19200 BEGIN
19300 IF (TYPTR^.SIZE > 1) OR RUNTMCHECK
19400 THEN SUBLOWBOUND
19500 ELSE INDEXOFFSET := -LMIN;
19600 IF TYPTR^.SIZE > 1
19700 THEN MACRO3(221B%IMULI\,REGC,TYPTR^.SIZE);
19800 INDEXR := REGC ;
19900 END ;
20000 IF LSP^.ARRAYPF
20100 THEN
20200 BEGIN
20300 (* 102 - kl array code *)
20400 if not klcpu
20500 THEN INCREMENTREGC;
20600 IF INDEXR=OLDIC
20700 THEN
20800 BEGIN
20900 INCREMENTREGC; INDEXR := 0
21000 END;
21100 (* 102 - kl adjbp code *)
21200 if not klcpu then begin
21300 MACRO4(571B%HRREI\,REGC,INDEXR,INDEXOFFSET);
21400 INCREMENTREGC; %TEST FOR IDIVI-INSTRUCTION\
21500 REGC := REGC-1; INDEXOFFSET := 0;
21600 MACRO3R(200B%MOVE\,REGC-1,LSP^.ARRAYBPADDR);
21700 MACRO3(231B%IDIVI\,REGC,BITMAX DIV LSP^.AELTYPE^.BITSIZE);
21800 MACRO3(133B%IBP\,0,REGC-1);
21900 MACRO3R(365B%SOJGE\,REGC+1,IC-1);
22000 BPADDR := REGC-1; PACKFG := PACKK; INDEXR := REGC;
22100 (* 102 - kl adjbp code *)
22200 end
22300 else begin (* kl code*)
22400 macro4(571B%hrrei\,regc,indexr,indexoffset+1);
22500 macro3r(133B%adjbp\,regc,lsp^.arraybpaddr);
22600 bpaddr := regc; packfg := packk; indexr := 0;
22700 indexoffset := 0;
22800 end;
22900 END;
23000 DPLMT := DPLMT + INDEXOFFSET ;
23100 KIND := VARBL ;
23200 IF ( OLDIC # INDEXR ) AND ( OLDIC # 0 )
23300 THEN
23400 BEGIN
23500 (* 102 - new packed array code *)
23600 if indexr = 0
23700 then indexr := oldic
23800 ELSE IF OLDIC > REGCMAX
23900 THEN MACRO3(270B%ADD\,INDEXR,OLDIC)
24000 ELSE
24100 BEGIN
24200 MACRO3(270B%ADD\,OLDIC,INDEXR);
24300 REGC := REGC - 1;
24400 INDEXR := OLDIC
24500 END
24600 END
24700 END %WITH.. IF TYPTR # NIL\ ;
24800 GATTR := LATTR ;
24900 IF SY = RBRACK
25000 THEN INSYMBOL
25100 ELSE ERROR(155)
25200 END %IF SY = LBRACK\
25300 ELSE
25400 %.\
25500 IF SY = PERIOD
25600 THEN
25700 BEGIN
25800 WITH GATTR DO
25900 BEGIN
26000 IF TYPTR # NIL
26100 THEN
26200 IF TYPTR^.FORM # RECORDS
26300 THEN
26400 BEGIN
26500 ERROR(308); TYPTR := NIL
26600 END;
26700 IF INDBIT=1
26800 THEN GETPARADDR;
26900 INSYMBOL;
27000 IF SY = IDENT
27100 THEN
27200 BEGIN
27300 IF TYPTR # NIL
27400 THEN
27500 BEGIN
27600 SEARCHSECTION(TYPTR^.FSTFLD,LCP);
27700 (* 5 - CREF *)
27800 IF CREF
27900 THEN WRITE(CHR(1B),CHR(21),ID,' .FIELDID. ');
28000 IF LCP = NIL
28100 THEN
28200 BEGIN
28300 ERROR(309); TYPTR := NIL
28400 END
28500 ELSE
28600 WITH LCP^ DO
28700 BEGIN
28800 TYPTR := IDTYPE;PACKFG := PACKF;
28900 IF PACKFG = PACKK
29000 THEN
29100 BPADDR := FLDADDR
29200 ELSE
29300 DPLMT := DPLMT + FLDADDR;
29400 END
29500 END;
29600 INSYMBOL
29700 END %SY = IDENT\
29800 ELSE ERROR(209)
29900 END %WITH GATTR\
30000 END %IF SY = PERIOD\
30100 ELSE
30200 %^\
30300 BEGIN
30400 IF GATTR.TYPTR # NIL
30500 THEN
30600 WITH GATTR,TYPTR^ DO
30700 (* 173 - changes for internal files, since we can't assume FILPTR is set up *)
30800 IF FORM = FILES
30900 THEN BEGIN
31000 TYPTR := FILTYPE;
31100 {What we are trying to do here is to generate code like
31200 MOVEI 2,INPUT+FILCMP
31300 In the usual case, we just do a loadaddress on the file, after add
31400 filcmp to the displacement. There are two cases where this won't
31500 work:
31600 - when the address is an external reference, since it then
31700 becomes an address in a fixup chain, and can't have FILCMP
31800 added to it at compile time. Thus we have a separate
31900 fixup chain stored in CHANTAB which the loader will add
32000 FILCMP to after fixing up.
32100 - when the thing is indirect, since we have to add the displacemtn
32200 after doing the indirection. The only solution there is
32300 an ADDI, as far as I can see.
32400 Hamburg used to just do a LOAD, which works because at INPUT there
32500 is a pointer to INPUT+FILCMP. I can't do that because if the
32600 FCB isn't initialized that will be garbage, and I need the real
32700 address to do the validity check}
32800 WITH FCP^ DO
32900 IF (VLEV = 0) AND (NOT MAIN)
33000 THEN BEGIN
33100 INCREMENTREGC;
33200 MACRO3R(201B%MOVEI\,REGC,CHANTAB[CHANNEL]);
33300 CHANTAB[CHANNEL] := IC-1;
33400 CODE.INFORMATION[CIX] := 'E';
33500 WITH GATTR DO
33600 BEGIN
33700 KIND := VARBL; DPLMT := 0; INDEXR:=REGC;
33800 INDBIT:=0; VRELBYTE := NO
33900 END
34000 END
34100 (* 200 - fix addressing *)
34200 ELSE IF INDBIT = 0
34300 THEN BEGIN
34400 DPLMT := DPLMT + FILCMP;
34500 LOADADDRESS;
34600 END
34700 ELSE BEGIN
34800 LOADADDRESS;
34900 MACRO3(271B%ADDI\,REGC,FILCMP)
35000 END;
35100 IF RUNTMCHECK
35200 THEN BEGIN
35300 {See if the file is open. A magic value of 314157 is left in FILTST if so }
35400 MACRO4(200B%MOVE\,HAC,REGC,FILTST-FILCMP);
35500 MACRO3(302B%CAIE\,HAC,314157B);
35600 SUPPORT(FILEUNINITIALIZED)
35700 END
35800 END
35900 ELSE IF FORM = POINTER
36000 THEN
36100 BEGIN
36200 TYPTR := ELTYPE;
36300 IF TYPTR # NIL
36400 THEN WITH GATTR DO
36500 BEGIN
36600 LOADNOPTR := FALSE;
36700 LOAD(GATTR); LOADNOPTR := TRUE;
36800 (* 23 - check for bad pointer *)
36900 (* 26 - but not for file *)
37000 IF RUNTMCHECK
37100 THEN BEGIN
37200 MACRO3(302B%CAIE\,REG,0);
37300 MACRO3(306B%CAIN\,REG,377777B);
37400 SUPPORT(BADPOINT)
37500 END;
37600 INDEXR := REG; DPLMT := 0; INDBIT:=0;
37700 PACKFG := NOTPACK; KIND := VARBL;
37800 VRELBYTE:= NO
37900 END
38000 END
38100 ELSE ERROR(407);
38200 INSYMBOL
38300 END;
38400 IFERRSKIP(166,FSYS OR SELECTSYS)
38500 END;
38600 %WHILE\
38700 WITH GATTR DO
38800 IF TYPTR#NIL
38900 THEN
39000 IF TYPTR^.SIZE = 2
39100 THEN
39200 BEGIN
39300 IF INDBIT = 1
39400 THEN GETPARADDR;
39500 IF (INDEXR>REGIN) AND (INDEXR<=REGCMAX)
39600 THEN INCREMENTREGC
39700 END
39800 END %SELECTOR\ ;
39900
40000 PROCEDURE CALL(FSYS: SETOFSYS; FCP: CTP);
40100 VAR
40200 (* 10 - ALLOW MORE RUNTIMES *)
40300 LKEY: 1..44;
40400 LFOLLOWERROR, NORIGHTPARENT : BOOLEAN;
40500
40600 (* 33 - allow use with non-TEXT files *)
40700 (* 171 - allow read/write of records *)
40800 (* 173 - completely new getfilename *)
40900 (* 204 - don't check validty of file to be closed *)
41000 PROCEDURE GETFILENAME(DEFAULTFILE:CTP;TEXTPROC:BOOLEAN;
41100 VAR FILETYPE:STP;VAR GOTARG:BOOLEAN;CHECK:BOOLEAN);
41200 VAR
41300 (* 177 - fix AC *)
41400 GOTFILE : BOOLEAN; FILEREGC: ACRANGE;
41500 {When we are finished we will have loaded a file into REGC, and parsed
41600 the next parameter if there is one, using EXPRESSION with REGC incremented}
41700 BEGIN
41800 INCREMENTREGC; {by default we will load into 3}
41900 FILEREGC := REGC; {but file goes into 2, which this still is}
42000 {REGC = 2}
42100 GOTARG := FALSE; NORIGHTPARENT := TRUE; GOTFILE := FALSE;
42200 IF SY = LPARENT
42300 THEN BEGIN
42400 NORIGHTPARENT := FALSE;
42500 INSYMBOL;
42600 EXPRESSION(FSYS OR [COMMA,RPARENT,COLON],ONFIXEDREGC);
42700 {REGC = 3 if expression (file can't be), 2 otherwise}
42800 GOTFILE := FALSE;
42900 {We have an expression, see if it is a legal file. If so, load it into
43000 REGC (note: no incrementregc first) and do a few tests. We have to do
43100 our own loading mostly to avoid the INCREMENTREGC done by LOADADDRESS}
43200 WITH GATTR DO
43300 IF TYPTR <> NIL
43400 THEN WITH TYPTR^ DO
43500 IF FORM = FILES
43600 THEN BEGIN
43700 IF TEXTPROC
43800 THEN IF NOT (COMPTYPES(FILTYPE,CHARPTR))
43900 THEN ERROR(366);
44000 {Yes, it is a legal file. Now load it}
44100 {If TTY that is supposed to be mapped to TTYOUTPUT, handle that}
44200 IF (LASTFILE = TTYFILE) AND (DEFAULTFILE = OUTFILE)
44300 THEN BEGIN
44400 LASTFILE := TTYOUTFILE;
44500 MACRO3R(201B%MOVEI\,REGC,TTYOUTFILE^.VADDR);
44600 END
44700 ELSE BEGIN
44800 FETCHBASIS(GATTR);
44900 MACRO(VRELBYTE,201B%MOVEI\,REGC,INDBIT,INDEXR,DPLMT);
45000 END;
45100 KIND := VARBL; DPLMT := 0; INDEXR:=REGC;
45200 INDBIT:=0; VRELBYTE := NO;
45300 WITH LASTFILE^ DO
45400 IF (VLEV=0) AND (NOT MAIN)
45500 THEN BEGIN VADDR:=IC-1; CODE.INFORMATION[CIX]:='E' END;
45600 GOTFILE := TRUE;
45700 FILETYPE := TYPTR;
45800 {Runtime checks if appropriate}
45900 (* 204 - don't check for CLOSE *)
46000 if runtmcheck and check
46100 then begin
46200 macro4(200B%MOVE\,hac,regc,filtst); {File test word}
46300 macro3(302B%CAIE\,hac,314157B); {True if file is open}
46400 support(fileuninitialized); {Not open}
46500 end;
46600 {Now see if there is an arg}
46700 IF SY <> RPARENT
46800 THEN BEGIN
46900 IF SY = COMMA
47000 THEN INSYMBOL
47100 ELSE ERROR(158);
47200 {Note that this is guaranteed not to change REGC unless it sees an
47300 expression, in which case it advances to 3. We can't have two
47400 advances (i.e. due to the EXPRESSION above and this one), since
47500 this is done only if the one above saw a file, which can't have
47600 advanced REGC}
47700 EXPRESSION(FSYS OR [COMMA,RPARENT,COLON],ONFIXEDREGC);
47800 GOTARG := TRUE
47900 END
48000 END;
48100 {Now we are done processing a file arg}
48200 IF NOT GOTFILE {If expression wasn't a file, use it as arg}
48300 THEN GOTARG := TRUE
48400 END;
48500 {End of IF RPARENT}
48600 {At this point REGC = 2 unless what we saw was an expr (which a file
48700 can't be), in which case REGC = 3 and it is loaded}
48800 IF NOT GOTFILE
48900 THEN WITH DEFAULTFILE^ DO
49000 {If we didn't get a file above, here is the code to do it}
49100 BEGIN
49200 (* 177 - fix AC *)
49300 MACRO3R(201B%MOVEI\,FILEREGC,VADDR);
49400 IF NOT GOTARG
49500 THEN WITH GATTR DO
49600 BEGIN
49700 KIND := VARBL; DPLMT := 0; INDEXR:=REGC;
49800 INDBIT:=0; VRELBYTE := NO;
49900 END;
50000 IF (VLEV=0) AND (NOT MAIN)
50100 THEN BEGIN VADDR:=IC-1; CODE.INFORMATION[CIX]:='E' END;
50200 FILETYPE := IDTYPE;
50300 (* 204 - don't check for CLOSE *)
50400 if runtmcheck and check
50500 then begin
50600 (* 207 - more bad AC's *)
50700 macro4(200B%MOVE\,hac,fileregc,filtst); {File test word}
50800 macro3(302B%CAIE\,hac,314157B); {True if file is open}
50900 support(fileuninitialized); {Not open}
51000 end;
51100 END;
51200 {If we saw an arg, REGC is exactly like it would have been with a
51300 simple INCREMENTREGC; EXPRESSION; which is the whole point.
51400 That is,it is 2 unless an expression was seen, in which case the
51500 expression is loaded into 3. If we didn't see an expression, then
51600 REGC is guaranteed to be 2. Very shady...}
51700 END %GETFILENAME\ ;
51800
51900 PROCEDURE VARIABLE(FSYS: SETOFSYS);
52000 VAR
52100 LCP: CTP;
52200 BEGIN
52300 IF SY = IDENT
52400 THEN
52500 BEGIN
52600 SEARCHID([VARS,FIELD],LCP); INSYMBOL
52700 END
52800 ELSE
52900 BEGIN
53000 ERROR(209); LCP := UVARPTR
53100 END;
53200 SELECTOR(FSYS,LCP)
53300 END %VARIABLE\ ;
53400 (* 22 - add GETFN - common non-defaulting file name scanner *)
53500 (* 73 - add ,COLON since used in NEW *)
53600 (* 175 - internal files *)
53700 PROCEDURE GETFN(TEST:BOOLEAN);
53800 BEGIN
53900 VARIABLE(FSYS OR [RPARENT,COLON,COMMA]);
54000 LOADADDRESS;
54100 IF GATTR.TYPTR#NIL
54200 THEN IF GATTR.TYPTR^.FORM#FILES
54300 THEN ERROR(212)
54400 ELSE WITH LASTFILE^ DO
54500 IF (VLEV=0) AND (NOT MAIN)
54600 THEN BEGIN VADDR:=IC-1; CODE.INFORMATION[CIX]:='E' END;
54700 (* 175 - internal files *)
54800 if test and runtmcheck
54900 then begin
55000 macro4(200B%MOVE\,hac,regc,filtst); {File test word}
55100 macro3(302B%CAIE\,hac,314157B); {Magic value if it is open}
55200 support(fileuninitialized); {Not open}
55300 end;
55400 END;
55500
55600 (* 14 - SEVERAL CHANGES IN THIS PROC TO ADD NEW RUNTIMES AND ADD OPTIONAL XBLOCK ARG *)
55700 PROCEDURE GETPUTRESETREWRITE;
55800 VAR
55900 (* 172 - new options string *)
56000 LMAX,LMIN: INTEGER;
56100 (* 173 - internal files *)
56200 LATTR: ATTR;
56300 ADR : SUPPORTS ;
56400 DEFAULT : ARRAY [1..6] OF BOOLEAN;
56500 I,J : INTEGER;
56600
56700 PROCEDURE GETSTRINGADDRESS ;
56800
56900 VAR LMAX,LMIN: INTEGER;
57000 (* 61 - allow flags for gtjfn in tops20 *)
57100 flagbits: packed record case Boolean of
57200 true: (dum:0..777777B;usetty:Boolean;wildok:Boolean);
57300 false: (dum2:0..777777B; rh:0..777777B)
57400 end;
57500 BEGIN
57600 IF SY=COMMA
57700 THEN
57800 BEGIN
57900 INSYMBOL;
58000 EXPRESSION(FSYS OR [COMMA,RPARENT,COLON],ONFIXEDREGC);
58100 WITH GATTR DO
58200 IF TYPTR#NIL
58300 THEN
58400 WITH TYPTR^ DO
58500 IF(FORM=ARRAYS) AND ARRAYPF
58600 THEN
58700 IF COMPTYPES(AELTYPE,CHARPTR)
58800 THEN
58900 BEGIN
59000 (* 15 - CHANGE DUE TO SLIGHTLY DIFFERENT LOGIC IN MAIN PROC *)
59100 DEFAULT[I] := FALSE;
59200 I:=I+1;DEFAULT[I]:=FALSE;
59300 LOADADDRESS;
59400 GETBOUNDS(INXTYPE,LMIN,LMAX);
59500 LMAX := LMAX-LMIN+1;
59600 INCREMENTREGC;
59700 MACRO3(201B%MOVEI\,REGC,LMAX);
59800 END
59900 ELSE ERROR(212)
60000 ELSE ERROR(212);
60100 (* 61 - implement extra syntax for tops20 *)
60200 (* 144 - allow it for tops10, too *)
60300 if (sy=colon)
60400 then begin
60500 insymbol;
60600 flagbits.rh := 0;
60700 while sy in [relop,addop,mulop] do
60800 begin
60900 if op = leop (* @ *)
61000 then flagbits.usetty := true
61100 else if (op = mul) and (not tops10)
61200 then flagbits.wildok := true
61300 else error(158);
61400 insymbol
61500 end;
61600 macro3(505b%hrli\,regc-1,flagbits.rh);
61700 end;
61800 END;
61900 END ;
62000
62100 BEGIN
62200 VARIABLE( FSYS OR [RPARENT,COMMA] ) ;
62300 LOADADDRESS ;
62400 (* 173 - internal files *)
62500 LATTR := GATTR;
62600 IF GATTR.TYPTR # NIL
62700 THEN
62800 IF GATTR.TYPTR^.FORM # FILES
62900 THEN ERRANDSKIP(458,FSYS OR [RPARENT])
63000 ELSE
63100 BEGIN
63200 WITH LASTFILE^ DO
63300 IF (VLEV = 0) AND (NOT MAIN)
63400 THEN
63500 BEGIN
63600 VADDR:= IC-1; CODE.INFORMATION[CIX] := 'E'
63700 END;
63800 IF (LKEY>=5) AND (LKEY#28)
63900 THEN
64000 BEGIN
64100 FOR I := 1 TO 6 DO DEFAULT[I] := TRUE;
64200 I := 1;
64300 GETSTRINGADDRESS % OF FILENAME \ ;
64400 (* 15 - ADD NEW PARAMETERS AND ALLOW OMITTING BLOCK *)
64500 WHILE NOT DEFAULT[I] AND (SY=COMMA) DO
64600 BEGIN
64700 I := I+1;
64800 INSYMBOL;
64900 (* 172 - ADD OPTION STRING AS 3RD ARG *)
65000 IF I = 3
65100 THEN BEGIN
65200 EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
65300 WITH GATTR DO
65400 IF TYPTR#NIL
65500 THEN WITH TYPTR^ DO
65600 IF(FORM=ARRAYS) AND ARRAYPF
65700 THEN IF COMPTYPES(AELTYPE,CHARPTR)
65800 THEN BEGIN
65900 DEFAULT[I] := FALSE;
66000 LOADADDRESS;
66100 GETBOUNDS(INXTYPE,LMIN,LMAX);
66200 LMAX := LMAX-LMIN+1;
66300 MACRO3(505B%HRLI\,REGC,LMAX);
66400 END
66500 ELSE ERROR(212) {not CHAR array}
66600 ELSE BEGIN {not packed array}
66700 LOAD(GATTR); DEFAULT[I] := FALSE
66800 END
66900 END {I=3}
67000 (* 57 - ONLY TOPS10 HAS XBLOCK ARG *)
67100 ELSE IF (NOT TOPS10) OR (I # 4) OR ((SY=INTCONST)AND(VAL.IVAL=0))
67200 THEN BEGIN
67300 EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
67400 IF GATTR.TYPTR#NIL
67500 THEN
67600 BEGIN
67700 LOAD(GATTR); DEFAULT[I] := FALSE;
67800 (* 77 - allow sets, since they are elegant for specifying bits *)
67900 if gattr.typtr^.form = power
68000 then regc := regc-1;
68100 END
68200 END
68300 ELSE BEGIN
68400 VARIABLE(FSYS OR[COMMA,RPARENT]);
68500 IF GATTR.TYPTR # NIL
68600 (* 26 - allow record as lookup block *)
68700 THEN IF NOT (GATTR.TYPTR^.FORM IN [ARRAYS,RECORDS])
68800 THEN ERROR(264)
68900 ELSE IF GATTR.TYPTR^.SIZE<5
69000 THEN ERROR(265)
69100 ELSE BEGIN LOADADDRESS; DEFAULT[I]:=FALSE END
69200 ELSE ERROR(458)
69300 END;
69400 END;
69500 FOR I := 1 TO 6 DO
69600 IF DEFAULT[I]
69700 THEN
69800 BEGIN
69900 INCREMENTREGC;
70000 IF I=6
70100 THEN MACRO3(474B%SETO\,REGC,0)
70200 ELSE MACRO3(201B%MOVEI\,REGC,0)
70300 END;
70400 END;
70500 (* 173 - internal files *)
70600 if lkey in [5,6,29,36] {openning}
70700 then begin
70800 if lattr.typtr <> nil
70900 then if lattr.typtr^.form = files
71000 then if comptypes(lattr.typtr^.filtype,charptr)
71100 {In AC1, put size of component, or 0 if text file}
71200 then macro3(201B%movei\,tac,0)
71300 else macro3(201B%movei\,tac,
71400 {Normally we would have to type filtype^ for nil, but if it is nil, the
71500 comptypes above will succeed, and this code will never happen.}
71600 lattr.typtr^.filtype^.size)
71700 end
71800 (* 204 - don't validty check for DISMISS *)
71900 (* 205 - fix AC for RENAME *)
72000 else if runtmcheck and (lkey <> 28)
72100 then begin
72200 macro4(200B%MOVE\,hac,regin+1,filtst);{File test word}
72300 macro3(302B%CAIE\,hac,314157B); {Magic value if open}
72400 support(fileuninitialized); {Not open}
72500 end;
72600 CASE LKEY OF
72700 2: ADR:= GETLINE ;
72800 4: ADR:= PUTLINE ;
72900 5: ADR:= RESETFILE ;
73000 6: ADR:= REWRITEFILE;
73100 27:ADR:=NAMEFILE;
73200 28:ADR:=DISFILE;
73300 29:ADR:=UPFILE;
73400 36:ADR:=APFILE
73500 END ;
73600 SUPPORT(ADR) ;
73700 END ;
73800 END;
73900
74000 (* 10 - ADD SETSTRING, TO ALLOW I/O TO STRINGS *)
74100 (* 13 - CODE MODIFIED TO ALLOW 4TH ARG, LIMIT *)
74200 (* 51 - allow any file type, any packed array *)
74300 PROCEDURE SETSTRING;
74400 VAR
74500 LREGC:ACRANGE;
74600 LMIN,LMAX:ADDRRANGE;
74700 ARRAY1,OFFSET,FILEP,LIMIT:ATTR;
74800 NOOFF,NOLIM: BOOLEAN;
74900
75000 BEGIN
75100 LREGC := REGC; NOOFF := FALSE; NOLIM:=FALSE;
75200 (* 175 - if not inited, do it *)
75300 GETFN(FALSE);
75400 {If the file block is not legal yet, call routine to make it so}
75500 macro4(200B%MOVE\,hac,regc,filtst); {File test word}
75600 macro3(302B%CAIE\,hac,314157B); {Magic value if it is open}
75700 support(initfileblock);
75800 FILEP := GATTR;
75900 IF SY = COMMA
76000 THEN INSYMBOL
76100 ELSE ERROR(158);
76200 VARIABLE(FSYS OR [RPARENT,COMMA]);
76300 LOADADDRESS;
76400 WITH GATTR DO
76500 BEGIN
76600 KIND := EXPR; REG := INDEXR;
76700 IF TYPTR # NIL
76800 THEN WITH TYPTR^ DO
76900 IF FORM # ARRAYS
77000 THEN ERROR(458)
77100 ELSE IF FILEP.TYPTR#NIL
77200 THEN IF NOT ARRAYPF
77300 THEN ERROR(458)
77400 END;
77500 ARRAY1 := GATTR;
77600 IF SY = RPARENT
77700 THEN NOOFF := TRUE
77800 ELSE IF SY = COMMA
77900 THEN BEGIN
78000 INSYMBOL;
78100 EXPRESSION(FSYS OR [RPARENT,COMMA],ONREGC);
78200 IF GATTR.TYPTR # NIL
78300 THEN IF GATTR.TYPTR^.FORM # SCALAR
78400 THEN ERROR(458)
78500 ELSE IF NOT COMPTYPES(ARRAY1.TYPTR^.INXTYPE,GATTR.TYPTR)
78600 THEN ERROR(458);
78700 OFFSET := GATTR;
78800 IF OFFSET.KIND = EXPR
78900 THEN INCREMENTREGC
79000 END
79100 ELSE ERROR(158);
79200 IF SY = RPARENT
79300 THEN NOLIM := TRUE
79400 ELSE IF SY = COMMA
79500 THEN BEGIN
79600 INSYMBOL;
79700 EXPRESSION(FSYS OR [RPARENT],ONREGC);
79800 IF GATTR.TYPTR # NIL
79900 THEN IF GATTR.TYPTR^.FORM # SCALAR
80000 THEN ERROR(458)
80100 ELSE IF NOT COMPTYPES(ARRAY1.TYPTR^.INXTYPE,GATTR.TYPTR)
80200 THEN ERROR(458);
80300 LIMIT := GATTR;
80400 IF LIMIT.KIND = EXPR
80500 THEN INCREMENTREGC
80600 END
80700 ELSE ERROR(158);
80800 IF NOT ERRORFLAG
80900 THEN BEGIN
81000 GETBOUNDS(ARRAY1.TYPTR^.INXTYPE,LMIN,LMAX);
81100 LMAX := LMAX - LMIN;
81200 IF NOT NOLIM
81300 THEN BEGIN
81400 IF LIMIT.KIND # EXPR
81500 THEN BEGIN LOAD(LIMIT); INCREMENTREGC END;
81600 WITH LIMIT DO
81700 BEGIN
81800 IF LMIN > 0
81900 THEN MACRO3(275B%SUBI\,REG,LMIN)
82000 ELSE IF LMIN < 0
82100 THEN MACRO3(271B%ADDI\,REG,-LMIN);
82200 IF RUNTMCHECK
82300 THEN BEGIN
82400 MACRO3(307B%CAIG\,REG,LMAX);
82500 MACRO3(305B%CAIGE\,REG,0);
82600 SUPPORT(INDEXERROR)
82700 END;
82800 END;
82900 END;
83000 IF NOT NOOFF
83100 THEN BEGIN
83200 IF OFFSET.KIND # EXPR
83300 THEN BEGIN LOAD(OFFSET); INCREMENTREGC END;
83400 WITH OFFSET DO
83500 BEGIN
83600 IF LMIN > 0
83700 THEN MACRO3(275B%SUBI\,REG,LMIN)
83800 ELSE IF LMIN < 0
83900 THEN MACRO3(271B%ADDI\,REG,-LMIN);
84000 IF RUNTMCHECK
84100 THEN BEGIN
84200 MACRO3(301B%CAIL\,REG,0);
84300 MACRO3(303B%CAILE\,REG,LMAX+1);
84400 SUPPORT(INDEXERROR)
84500 END;
84600 END;
84700 INCREMENTREGC;
84800 IF NOLIM
84900 THEN MACRO4(211B%MOVNI\,REGC,OFFSET.REG,-LMAX-1)
85000 ELSE BEGIN
85100 MACRO4(201B%MOVEI\,REGC,LIMIT.REG,1);
85200 MACRO4(275B%SUBI\,REGC,OFFSET.REG,0);
85300 IF RUNTMCHECK
85400 THEN BEGIN
85500 MACRO3(305B%CAIGE\,REGC,0);
85600 SUPPORT(INDEXERROR)
85700 END
85800 END;
85900 MACRO4(552B%HRRZM\,REGC,FILEP.INDEXR,FILBFH+2);
86000 MACRO3R(200B%MOVE\,REGC,ARRAY1.TYPTR^.ARRAYBPADDR);
86100 MACRO3(621B%TLZ\,REGC,17B);
86200 MACRO3(231B%IDIVI\,OFFSET.REG,BITMAX DIV ARRAY1.TYPTR^.AELTYPE^.BITSIZE);
86300 MACRO3(270B%ADD\,ARRAY1.REG,OFFSET.REG);
86400 MACRO3(540B%HRR\,REGC,ARRAY1.REG);
86500 MACRO3(303B%CAILE\,OFFSET.REG+1,0);
86600 MACRO3(133B%IBP\,0,REGC);
86700 MACRO3R(367B%SOJG\,OFFSET.REG+1,IC-1);
86800 MACRO4(202B%MOVEM\,REGC,FILEP.INDEXR,FILBFH+1)
86900 END
87000 ELSE BEGIN
87100 INCREMENTREGC;
87200 IF NOLIM
87300 THEN MACRO3(201B%MOVEI\,REGC,LMAX+1)
87400 ELSE MACRO4(201B%MOVEI\,REGC,LIMIT.REG,1);
87500 MACRO4(202B%MOVEM\,REGC,FILEP.INDEXR,FILBFH+2);
87600 MACRO3R(200B%MOVE\,REGC,ARRAY1.TYPTR^.ARRAYBPADDR);
87700 MACRO3(621B%TLZ\,REGC,17B);
87800 MACRO3(540B%HRR\,REGC,ARRAY1.REG);
87900 MACRO4(202B%MOVEM\,REGC,FILEP.INDEXR,FILBFH+1)
88000 END;
88100 IF NOLIM
88200 THEN MACRO3(505B%HRLI\,REGC,LMIN+LMAX+400001B)
88300 ELSE MACRO4(505B%HRLI\,REGC,LIMIT.REG,LMIN+400001B);
88400 (* 60 - DON'T PUT IN LH(0) FOR TOPS-20. "FILBFH" IS FREE *)
88500 (* 143 - Tops10 now like Tops20 *)
88600 IF TOPS10
88700 THEN MACRO4(556B%HLRZM\,REGC,FILEP.INDEXR,FILBLL)
88800 ELSE MACRO4(556B%HLRZM\,REGC,FILEP.INDEXR,FILBFH);
88900 (* 43 - setzm to avoid blocked or dump mode I/O *)
89000 (* 60 - kludge needed only for tops10 *)
89100 (* 143 - tops10 now like tops20 *)
89200 CASE LKEY OF
89300 (* 60 - TOPS20 USES RUNTIME TO INIT *)
89400 (* 143 - so does Tops10 *)
89500 22: SUPPORT(RESETSTRING);
89600 23: SUPPORT(REWRITESTRING)
89700 END;
89800 END;
89900 REGC := LREGC
90000 END;
90100
90200 (* 57 - ADD SET20STRING FOR 20 STRSET,STRWRITE *)
90300 (* 60 - on further thought, use normal one *)
90400
90500 PROCEDURE GETINDEX;
90600 VAR LREGC:ACRANGE;
90700 FILEP:ATTR;
90800 BEGIN
90900 LREGC := REGC;
91000 (* 175 *)
91100 GETFN(TRUE);
91200 FILEP := GATTR;
91300 IF SY = COMMA
91400 THEN INSYMBOL
91500 ELSE ERROR(158);
91600 VARIABLE(FSYS OR [RPARENT]);
91700 LOADADDRESS;
91800 WITH GATTR DO
91900 BEGIN
92000 IF TYPTR # NIL
92100 THEN WITH TYPTR^ DO
92200 IF (FORM # SCALAR) AND (FORM # SUBRANGE)
92300 THEN ERROR(458)
92400 END;
92500 IF NOT ERRORFLAG
92600 THEN BEGIN
92700 INCREMENTREGC;
92800 WITH FILEP DO
92900 BEGIN
93000 (* 60 - TOPS20 HAS MAGIC NO. IN DIFFERENT PLACE *)
93100 (* 143 - tops10 now the same *)
93200 IF TOPS10
93300 THEN MACRO4(200B%MOVE\,REGC,INDEXR,FILBLL)
93400 ELSE MACRO4(200B%MOVE\,REGC,INDEXR,FILBFH);
93500 MACRO3(620B%TRZ\,REGC,400000B);
93600 MACRO4(274B%SUB\,REGC,INDEXR,FILBFH+2);
93700 MACRO4(202B%MOVEM\,REGC,GATTR.INDEXR,0);
93800 END
93900 END;
94000 REGC := LREGC
94100 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 with lastfile^ do
30800 if (vlev = 0) and (not main)
30900 then begin vaddr := ic-1; code.information[cix] := 'E' end;
31000 macro4(200b%move\,regc,regc,filjfn)
31100 end
31200 else if (gattr.typtr^.form = arrays) and gattr.typtr^.arraypf
31300 then begin
31400 loadaddress;
31500 macro3r(500b%hll\,regc,gattr.typtr^.arraybpaddr);
31600 macro3(621b%tlz\,regc,17b)
31700 end
31800 else loadaddress
31900 end;
32000 procedure storearg;
32100 (* stores results of jsys. As above, but error for
32200 anything bigger than a word *)
32300 begin
32400 variable(fsys or [rparent,comma]);
32500 if gattr.typtr # nil
32600 then if (gattr.typtr^.form < power)
32700 then store(realregc,gattr)
32800 else if (gattr.typtr^.form = power)
32900 then begin
33000 gattr.typtr := intptr;
33100 store(realregc,gattr)
33200 end
33300 else if (gattr.typtr^.form = files)
33400 then begin
33500 loadaddress; {addr of file now in REGC}
33600 with lastfile^ do
33700 if (vlev = 0) and (not main)
33800 then begin vaddr:=ic-1; code.information[cix] := 'E' end;
33900 (* 173 - internal files *)
34000 {We have to compile code to see if the file is initialized. If not,
34100 call INITB. to do so. INITB. needs the file in AC 2. Note that
34200 the AC use here is such that REGC is always above 2, so the only
34300 reason for 2 not to be free is that realregc is using it. This is
34400 certainly not the best possible code, but at this point I am going
34500 for the last code in the compiler to implement it.}
34600 macro3(250b%exch\,2,regc);
34700 macro4(200b%move\,0,2,filtst);
34800 macro3(302b%caie\,0,314157B);
34900 support(initfileblock);
35000 if realregc = 2
35100 then macro4(202b%movem\,regc,2,filjfn)
35200 else macro4(202b%movem\,realregc,2,filjfn)
35300 end
35400 else error(458)
35500 end;
35600 begin (* jsys *)
35700 ercal := false; saveret := false; numrets := 0; done1 := false;
35800 constant(fsys or [rparent,comma,semicolon],lsp,lval);
35900 jsysnum := lval.ival;
36000 if not comptypes (intptr, lsp)
36100 then error(458);
36200 if sy = comma
36300 then begin (* return spec *)
36400 insymbol;
36500 constant(fsys or [rparent,comma,semicolon],lsp,lval);
36600 if lval.ival < 0
36700 then ercal := true;
36800 numrets := abs(lval.ival);
36900 if not comptypes (intptr, lsp)
37000 then error(458);
37100 if sy = comma
37200 then begin (* return var *)
37300 insymbol;
37400 variable(fsys or [rparent,semicolon]);
37500 if comptypes (intptr,gattr.typtr)
37600 then begin saveret := true; retsave := gattr end
37700 else error (459)
37800 end
37900 end; (* return spec *)
38000 if sy = semicolon
38100 then begin (* prolog *)
38200 insymbol;
38300 regc := 1;
38400 if sy # semicolon
38500 then loop (* non-empty prolog *)
38600 loadarg;
38700 if sy = colon
38800 then begin
38900 insymbol;
39000 realregc := regc;
39100 loadarg;
39200 macro3(504b%hrl\,realregc,realregc);
39300 macro3(540b%hrr\,realregc,regc);
39400 regc := realregc
39500 end;
39600 if not done1
39700 then begin
39800 (* 133 - save in display instead of PUSH P, *)
39900 {Here we prepared a place on the display to store the value}
40000 savelc := lc;
40100 lc := lc+1;
40200 if lc > lcmax
40300 then lcmax := lc;
40400 macro4(202B%movem\,2,basis,savelc);
40500 done1 := true;
40600 regc := 1
40700 end;
40800 exit if sy # comma;
40900 insymbol
41000 end (* non-empty prolog *)
41100 end; (* prolog *)
41200 (* main call *)
41300 if done1
41400 (* 133 - save in display instead of POP P, *)
41500 then begin
41600 macro4(200B%move\,1,basis,savelc);
41700 lc := savelc
41800 end;
41900 if saveret
42000 then macro3(201b%movei\,0,numrets+1);
42100 macro3(104b%jsys\,0,jsysnum);
42200 if ercal
42300 then begin
42400 macro3r(320b%jump\,16b,ic+numrets);
42500 numrets := numrets -1
42600 end;
42700 for i := 1 to numrets do
42800 if saveret then
42900 macro3(275b%subi\,0,1)
43000 else macro3(255b%jfcl\,0,0);
43100 if sy = semicolon (* if epilog, save reg a over store *)
43200 then begin
43300 (* 133 - use display instead of stack to save *)
43400 {find a place in the display to save ac 2}
43500 savelc := lc;
43600 lc := lc + 1;
43700 if lc > lcmax
43800 then lcmax := lc;
43900 macro4(202B%movem\,2,basis,savelc);
44000 macro3(200b%move\,2,1);
44100 done1 := true
44200 end
44300 else done1 := false;
44400 if saveret
44500 then store(0,retsave);
44600 if sy = semicolon
44700 then begin (* epilog *)
44800 realregc := 1;
44900 repeat
45000 insymbol;
45100 regc := 4; (* so temp ac's start at 5 *)
45200 realregc := realregc + 1;
45300 if realregc > 4
45400 then error(458);
45500 storearg;
45600 if done1
45700 then begin
45800 (* 133 - use display instead of stack to store ac 2 *)
45900 macro4(200B%move\,2,basis,savelc);
46000 lc := savelc;
46100 realregc := 1;
46200 done1 := false
46300 end
46400 until sy # comma
46500 end (* epilog *)
46600 end; (* jsys *)
46700
46800 PROCEDURE MARK;
46900 BEGIN
47000 VARIABLE(FSYS OR [RPARENT]);
47100 IF COMPTYPES(INTPTR,GATTR.TYPTR)
47200 THEN
47300 (* 12 - REWRITE FOR NEW DYNAMIC MEMORY *)
47400 (* 122 - retrofit KA code *)
47500 (* 132 - separate KA10 into NOVM and KACPU *)
47600 if novm
47700 then begin
47800 loadaddress;
47900 macro4(202B%movem\,newreg,gattr.indexr,0)
48000 end
48100 else
48200 BEGIN
48300 LOADADDRESS;
48400 INCREMENTREGC;
48500 MACRO3R(200B%MOVE\,REGC,LSTNEW);
48600 LSTNEW:=IC-1; %GLOBAL FIXUP\
48700 MACRO4(202B%MOVEM\,REGC,GATTR.INDEXR,0)
48800 END
48900 ELSE ERROR(459)
49000 END %MARK\ ;
49100
49200 PROCEDURE RELEASE;
49300 BEGIN
49400 EXPRESSION(FSYS OR [RPARENT],ONREGC);
49500 IF GATTR.TYPTR = INTPTR
49600 THEN
49700 BEGIN
49800 (* 12 - RECODE FOR NEW DYNAMIC MEMORY *)
49900 LOAD(GATTR);
50000 (* 122 - retrofit for KA *)
50100 (* 132 - separate KA10 into NOVM and KACPU *)
50200 if novm
50300 then macro3(200B%move\,newreg,regc)
50400 ELSE BEGIN
50500 MACRO3R(202B%MOVEM\,REGC,LSTNEW);
50600 LSTNEW := IC-1; % GLOBAL FIXUP \
50700 end
50800 END
50900 ELSE ERROR(458)
51000 END %RELEASE\ ;
51100
51200 PROCEDURE GETLINENR;
51300 BEGIN
51400 (* 33 - ALLOW GETFILENAME WITH NON-TEXT *)
51500 (* 171 - PREDECL FILES ARE SPECIAL *)
51600 GETFILENAME(INFILE,TRUE,THISFILE,GOTARG,TRUE);
51700 IF NOT GOTARG
51800 THEN ERROR(554);
51900 IF GATTR.KIND <> VARBL
52000 THEN ERROR(458)
52100 ELSE IF GATTR.TYPTR # NIL
52200 THEN
52300 IF COMPTYPES(CHARPTR,GATTR.TYPTR^.AELTYPE) AND (GATTR.TYPTR^.FORM = ARRAYS)
52400 THEN
52500 BEGIN
52600 MACRO4(200B%MOVE\,REGC,REGC,FILLNR); STORE(REGC,GATTR)
52700 END
52800 ELSE ERROR(458);
52900 END;
53000
53100 PROCEDURE GETINTEGERFILENAME(DEFAULTNAME : ALFA);
53200 VAR
53300 LCP : CTP; LID : ALFA;
53400 BEGIN
53500 LID := ID;
53600 ID := DEFAULTNAME; SEARCHID([VARS],LCP);
53700 SELECTOR(FSYS OR FACBEGSYS OR [COMMA], LCP); LOADADDRESS;
53800 WITH LCP^, IDTYPE^ DO
53900 IF (FORM = FILES) AND (VLEV = 0) AND (NOT MAIN)
54000 THEN
54100 BEGIN
54200 VADDR:= IC-1; CODE.INFORMATION[CIX] := 'E'
54300 END;
54400 ID := LID
54500 END;
54600
54700 PROCEDURE PUT8BITSTOTTY;
54800 BEGIN
54900 EXPRESSION(FSYS OR [RPARENT],ONREGC) ;
55000 LOAD(GATTR);
55100 MACRO3(051B%TTCALL\,15B%IONEOU\,GATTR.REG)
55200 END %PUT8BITSTOTTY\ ;
55300
55400 PROCEDURE PAGE;
55500 BEGIN
55600 (* 33 - ALLOW GETFILENAME WITH NON-TEXT *)
55700 (* 171 - PREDECL FILES ARE SPECIAL *)
55800 GETFILENAME(OUTFILE,TRUE,THISFILE,GOTARG,TRUE);
55900 IF GOTARG
56000 THEN ERROR(554);
56100 SUPPORT(PUTPAGE)
56200 END;
56300 (* 63 - support for tops-20 time and runtime *)
56400 procedure jsysf(jsysnum,hireg:integer);
56500 var i:integer;
56600 begin
56700 if hireg > regc
56800 then hireg := regc;
56900 for i := 2 to hireg do
57000 macro3(261B%push\,topp,i);
57100 if jsysnum = 15B
57200 then macro3(211B%movni\,1,5);
57300 macro3(104B%jsys\,0,jsysnum);
57400 with gattr do
57500 begin
57600 incrementregc; typtr := intptr; reg := regc; kind := expr;
57700 macro3(200B%move\,regc,1)
57800 end;
57900 for i := hireg downto 2 do
58000 macro3(262B%pop\,topp,i)
58100 end;
58200
58300
58400 PROCEDURE RUNTIME;
58500 BEGIN
58600 (* 63 - TOPS20 *)
58700 IF TOPS10
58800 THEN WITH GATTR DO
58900 BEGIN
59000 INCREMENTREGC; TYPTR := INTPTR; REG := REGC; KIND := EXPR;
59100 MACRO3(047B,REGC,30B%PJOB-UUO\);
59200 MACRO3(047B,REGC,27B%RUNTIM-UUO\)
59300 END
59400 ELSE JSYSF(15B%RUNTM\,3)
59500 END;
59600
59700 PROCEDURE ABS;
59800 BEGIN
59900 WITH GATTR DO
60000 IF (TYPTR = INTPTR) OR (TYPTR = REALPTR)
60100 THEN
60200 WITH CODE.INSTRUCTION[CIX] DO
60300 IF INSTR = 200B%MOVE\
60400 THEN INSTR := 214B%MOVM\
60500 ELSE MACRO3(214B%MOVM\,REG,REG)
60600 ELSE
60700 BEGIN
60800 ERROR(459); TYPTR:= INTPTR
60900 END
61000 END %ABS\ ;
61100
61200 PROCEDURE TIME;
61300 BEGIN
61400 (* 63 - TOPS20 *)
61500 WITH GATTR DO
61600 BEGIN
61700 INCREMENTREGC; TYPTR := INTPTR; REG := REGC; KIND := EXPR;
61800 if tops10
61900 then MACRO3(047B,REGC,23B%MSTIME-UUO\)
62000 else begin
62100 support(getdaytime);
62200 macro3(262B%POP\,17B,regc)
62300 end
62400 END
62500 END;
62600
62700 PROCEDURE SQR;
62800 BEGIN
62900 WITH GATTR DO
63000 IF TYPTR = INTPTR
63100 THEN MACRO3(220B%IMUL\,REG,REG)
63200 ELSE
63300 IF TYPTR = REALPTR
63400 THEN MACRO3(164B%FMPR\,REG,REG)
63500 ELSE
63600 BEGIN
63700 ERROR(459); TYPTR := INTPTR
63800 END
63900 END %SQR\ ;
64000
64100 PROCEDURE TRUNC;
64200 VAR INSTRUC:1..777;
64300 BEGIN
64400 IF LKEY = 5
64500 THEN INSTRUC := 122B%FIX\
64600 ELSE INSTRUC := 126B%FIXR\;
64700 IF GATTR.TYPTR # REALPTR
64800 THEN ERROR(459)
64900 ELSE
65000 (* 2 - hard code TRUNC using KI-10 op code *)
65100 (* 10 - ADD ROUND *)
65200 (* 101 - fix bad code generation for fix and fixr *)
65300 (* 122 - put back KA code *)
65400 (* 132 - separate KA10 into NOVM and KACPU *)
65500 if kacpu
65600 then begin
65700 if lkey=5
65800 then macro3(551B%hrrzi\,tac,gattr.reg)
65900 else macro3(561B%hrroi\,tac,gattr.reg);
66000 support(convertrealtointeger);
66100 end
66200 ELSE WITH CODE.INSTRUCTION[CIX] DO
66300 IF (INSTR = 200B%MOVE\) AND (AC = GATTR.REG)
66400 THEN INSTR := INSTRUC
66500 ELSE MACRO3(INSTRUC,GATTR.REG,GATTR.REG);
66600 GATTR.TYPTR := INTPTR
66700 END %TRUNC\ ;
66800
66900 PROCEDURE ODD;
67000 BEGIN
67100 WITH GATTR DO
67200 BEGIN
67300 IF TYPTR # INTPTR
67400 THEN ERROR(459);
67500 MACRO3(405B%ANDI\,REG,1);
67600 TYPTR := BOOLPTR
67700 END
67800 END %ODD\ ;
67900
68000 PROCEDURE ORD;
68100 BEGIN
68200 IF GATTR.TYPTR # NIL
68300 THEN
68400 IF GATTR.TYPTR^.FORM >= POWER
68500 THEN ERROR(459);
68600 GATTR.TYPTR := INTPTR
68700 END %ORD\ ;
68800
68900 PROCEDURE CHR;
69000 BEGIN
69100 IF GATTR.TYPTR # INTPTR
69200 THEN ERROR(459);
69300 GATTR.TYPTR := CHARPTR
69400 END %CHR\ ;
69500
69600 PROCEDURE PREDSUCC;
69700 VAR
69800 LSTRPTR:STP; LATTR: ATTR;
69900 BEGIN
70000 IF GATTR.TYPTR # NIL
70100 THEN
70200 IF (GATTR.TYPTR^.FORM>SUBRANGE) OR (GATTR.TYPTR=REALPTR)
70300 THEN ERROR(459)
70400 ELSE
70500 IF RUNTMCHECK
70600 THEN
70700 BEGIN
70800 LSTRPTR:=GATTR.TYPTR;
70900 IF (LSTRPTR^.FORM=SUBRANGE) AND (LSTRPTR^.RANGETYPE #NIL)
71000 THEN LSTRPTR:=LSTRPTR^.RANGETYPE;
71100 IF LKEY=9
71200 THEN
71300 BEGIN
71400 IF LSTRPTR=INTPTR
71500 THEN
71600 BEGIN
71700 MACRO3R(255B%JFCL\,10B,IC+1);
71800 MACRO3(275B%SUBI\,REGC,1 );
71900 MACRO3R(255B%JFCL\,10B,IC+2);
72000 MACRO3(334B%SKIPA\,0,0 );
72100 SUPPORT(ERRORINASSIGNMENT)
72200 END
72300 ELSE% CHAR OR DECLARED \
72400 BEGIN
72500 MACRO3R(365B%SOJGE\,REGC,IC+2);
72600 SUPPORT(ERRORINASSIGNMENT)
72700 END
72800 END % LKEY = 9 \
72900 ELSE % LKEY = 10 \
73000 BEGIN
73100 IF LSTRPTR=INTPTR
73200 THEN
73300 BEGIN
73400 MACRO3R(255B%JFCL \,10B,IC+1);
73500 MACRO3(271B%ADDI \,REGC,1 );
73600 MACRO3R(255B%JFCL \,10B,IC+2);
73700 MACRO3(334B%SKIPA\,0,0 );
73800 SUPPORT(ERRORINASSIGNMENT)
73900 END
74000 ELSE %CHAR OR DECLARED\
74100 BEGIN
74200 WITH LATTR DO
74300 BEGIN
74400 TYPTR := LSTRPTR; KIND := CST; CVAL.IVAL := 0;
74500 IF LSTRPTR=CHARPTR
74600 THEN CVAL.IVAL := 177B
74700 ELSE
74800 IF LSTRPTR^.FCONST # NIL
74900 THEN CVAL.IVAL:=LSTRPTR^.FCONST^.VALUES.IVAL;
75000 MAKECODE(311B%CAML\,REGC,LATTR);
75100 SUPPORT(ERRORINASSIGNMENT);
75200 MACRO3(271B%ADDI \,REGC,1 );
75300 END
75400 END
75500 END % LKEY = 10 \;
75600 END % RUNTMCHECK \
75700 ELSE
75800 IF LKEY = 9
75900 THEN MACRO3(275B%SUBI\,REGC,1)
76000 ELSE MACRO3(271B%ADDI\,REGC,1)
76100 END %PREDSUCC\ ;
76200
76300 PROCEDURE EOFEOLN;
76400 BEGIN
76500 (* 33 - USE GETFILENAME, SO DEFAULTS TO INPUT *)
76600 (* 171 - PREDECL FILES ARE SPECIAL *)
76700 GETFILENAME(INFILE,FALSE,THISFILE,GOTARG,TRUE);
76800 IF GOTARG
76900 THEN ERROR(554);
77000 WITH GATTR DO
77100 BEGIN
77200 KIND := EXPR; REG := INDEXR;
77300 IF LKEY=11
77400 THEN
77500 BEGIN
77600 MACRO4(332B%SKIPE\,REG,REG,FILEOF) ;
77700 MACRO3(201B%MOVEI\,REG,1) ;
77800 END
77900 ELSE MACRO4(200B%MOVE\,REG,REG,FILEOL);
78000 TYPTR := BOOLPTR
78100 END
78200 END %EOF\ ;
78300
78400 PROCEDURE PROTECTION;
78500 (* FOR DETAILS SEE DEC-SYSTEM-10 MONITOR CALLS MANUAL, 3.2.4 *)
78600 BEGIN
78700 EXPRESSION ( FSYS OR [RPARENT], ONREGC );
78800 IF GATTR.TYPTR = BOOLPTR
78900 (* 63 - TOPS20 *)
79000 THEN IF TOPS10
79100 THEN
79200 BEGIN
79300 LOAD(GATTR);
79400 MACRO3(047B%CALLI\,REGC,36B%SETUWP\);
79500 MACRO3(254B%HALT\,4,0)
79600 END
79700 ELSE
79800 ELSE ERROR(458)
79900 END;
80000
80100 PROCEDURE CALLNONSTANDARD;
80200 VAR
80300 NXT,LNXT,LCP: CTP;
80400 LSP: STP;
80500 (* 33 - PROC PARAM.S*)
80600 PKIND,LKIND: IDKIND; LB: BOOLEAN;
80700 SAVECOUNT,P,I,NOFPAR: INTEGER;
80800 TOPPOFFSET,OFFSET,PARLIST,ACTUALPAR,FIRSTPAR,LLC: ADDRRANGE;
80900 LREGC: ACRANGE;
81000
81100 (* 111 - STRING, POINTER *)
81200 procedure paramfudge;
81300 var lmin,lmax:integer;
81400 (* This is used to handle special parameter types with
81500 reduced type checking, such as STRING, POINTER. They
81600 are always one of STRINGPTR, POINTERPTR, or POINTERREF.
81700 STRINGPTR is for STRING, the other two for POINTER.
81800 POINTERREF is for call by ref *)
81900 begin
82000 with gattr.typtr^ do
82100 if lsp=stringptr
82200 then if (form=arrays) and arraypf
82300 then if comptypes(aeltype,charptr)
82400 then begin (* STRING *)
82500 getbounds (gattr.typtr^.inxtype, lmin, lmax);
82600 loadaddress;
82700 incrementregc;
82800 macro3(201B%movei\,regc,lmax-lmin+1);
82900 end
83000 else error(503)
83100 else error(503)
83200 else if form=pointer {pointerptr or pointerref}
83300 then if eltype <> nil
83400 then begin (* POINTER *)
83500 (* 202 - fix up pointer by ref *)
83600 if lsp = pointerptr
83700 then load(gattr)
83800 else loadaddress;
83900 incrementregc;
84000 macro3(201B%movei\,regc,eltype^.size)
84100 end
84200 else (* bad type decl - already have error *)
84300 else error(503);
84400 gattr.typtr := lsp (* so comptypes later succeeds *)
84500 end;
84600
84700 BEGIN
84800 NOFPAR:= 0; TOPPOFFSET := 0; PARLIST := 0; ACTUALPAR := 0;
84900 WITH FCP^ DO
85000 BEGIN
85100 NXT := NEXT; LKIND := PFKIND;
85200 IF KLASS = FUNC
85300 THEN FIRSTPAR := 2
85400 ELSE FIRSTPAR := 1;
85500 (* 33 - PROC PARAM.S *)
85600 IF LKIND = ACTUAL
85700 THEN IF EXTERNDECL
85800 THEN LIBRARY[LANGUAGE].CALLED:= TRUE;
85900 SAVECOUNT := REGC - REGIN;
86000 IF SAVECOUNT > 0
86100 THEN
86200 BEGIN
86300 LLC := LC ;
86400 LC := LC + SAVECOUNT ;
86500 IF LC > LCMAX
86600 THEN LCMAX := LC ;
86700 IF SAVECOUNT > 3
86800 THEN
86900 BEGIN
87000 MACRO3(505B%HRLI\,TAC,2);
87100 MACRO4(541B%HRRI\,TAC,BASIS,LLC);
87200 MACRO4(251B%BLT\,TAC,BASIS,LLC+SAVECOUNT-1)
87300 END
87400 ELSE FOR I := 1 TO SAVECOUNT DO MACRO4(202B%MOVEM\,REGIN+I,BASIS,LLC+I-1)
87500 END;
87600 LREGC:= REGC;
87700 IF LKIND = FORMAL
87800 THEN REGC := REGIN
87900 ELSE IF LANGUAGE # PASCALSY
88000 THEN REGC:= PARREGCMAX
88100 ELSE REGC:= REGIN
88200 END;
88300 IF SY = LPARENT
88400 THEN
88500 BEGIN
88600 REPEAT
88700 LB := FALSE; %DECIDE WHETHER PROC/FUNC MUST BE PASSED\
88800 IF LKIND = ACTUAL
88900 THEN
89000 BEGIN
89100 IF NXT = NIL
89200 THEN ERROR(554)
89300 ELSE LB := NXT^.KLASS IN [PROC,FUNC]
89400 END
89500 (* 33 - PROC PARAM.S *)
89600 ELSE LB := FALSE;
89700 %FOR FORMAL PROC/FUNC LB IS FALSE AND EXPRESSION
89800 WILL BE CALLED, WHICH WILL ALLWAYS INTERPRET A PROC/FUNC ID
89900 AT ITS BEGINNING AS A CALL RATHER THAN A PARAMETER PASSING.
90000 IN THIS IMPLEMENTATION, PARAMETER PROCEDURES/FUNCTIONS
90100 ARE THEREFORE NOT ALLOWED TO HAVE PROCEDURE/FUNCTION
90200 PARAMETERS\
90300 INSYMBOL;
90400 IF LB
90500 THEN %PASS FUNCTION OR PROCEDURE\
90600 BEGIN
90700 IF SY # IDENT
90800 THEN
90900 ERRANDSKIP(209,FSYS OR [COMMA,RPARENT])
91000 ELSE
91100 BEGIN
91200 IF NXT^.KLASS = PROC
91300 THEN SEARCHID([PROC],LCP)
91400 ELSE
91500 BEGIN
91600 SEARCHID([FUNC],LCP);
91700 IF NOT COMPTYPES(LCP^.IDTYPE,NXT^.IDTYPE)
91800 THEN
91900 ERROR(555)
92000 END;
92100 INSYMBOL;
92200 IFERRSKIP(166,FSYS OR [COMMA,RPARENT])
92300 END;
92400 (* 33 - PROC PARAM.S *)
92500 WITH LCP^ DO
92600 IF (PFDECKIND = STANDARD) OR (PFKIND = ACTUAL) AND (LANGUAGE # PASCALSY)
92700 THEN ERROR (466)
92800 ELSE BEGIN
92900 INCREMENTREGC;
93000 (* 67 - fix proc param's *)
93100 if pflev > 1
93200 then p := level - pflev
93300 else p := 0;
93400 IF PFKIND = ACTUAL
93500 THEN BEGIN
93600 IF P = 0
93700 THEN MACRO3(514B%HRLZ\,REGC,BASIS)
93800 ELSE IF P=1
93900 THEN MACRO4(514B%HRLZ\,REGC,BASIS,-1)
94000 ELSE %P>1\
94100 BEGIN
94200 MACRO4(550B%HRRZ\,REGC,BASIS,-1);
94300 FOR I := 3 TO P DO MACRO4(550B%HRRZ\,REGC,REGC,-1);
94400 MACRO4(514B%HRLZ\,REGC,REGC,-1)
94500 END;
94600 IF PFADDR = 0
94700 THEN BEGIN
94800 (* 67 - fix typo: R in macro3r omitted *)
94900 MACRO3R(541B%HRRI\,REGC,LINKCHAIN[P]);
95000 LINKCHAIN[P] := IC - 1;
95100 IF EXTERNDECL
95200 THEN CODE.INFORMATION[CIX] := 'E'
95300 ELSE CODE.INFORMATION[CIX] := 'F'
95400 END
95500 ELSE MACRO3R(541B%HRRI\,REGC,PFADDR);
95600 END %OF PFKIND = ACTUAL \
95700 ELSE %PFKIND = FORMAL \
95800 IF P = 0
95900 THEN MACRO4(200B%MOVE\,REGC,BASIS,PFADDR)
96000 ELSE
96100 BEGIN
96200 MACRO4(200B%MOVE\,REGC,BASIS,-1);
96300 FOR I := 2 TO P DO MACRO4(200B%MOVE\,REGC,REGC,-1);
96400 MACRO4(200B%MOVE\,REGC,REGC,PFADDR)
96500 END
96600 END;
96700 END %IF LB\
96800 ELSE
96900 BEGIN
97000 EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
97100 IF GATTR.TYPTR # NIL
97200 THEN
97300 (* 33 - PROC PARAM.S *)
97400 BEGIN
97500 %NOTE : WE TREAT ALL PARAM'S OF A FORMAL PROC AS ACTUAL\
97600 IF (NXT # NIL) OR (LKIND = FORMAL)
97700 THEN
97800 BEGIN
97900 (*33 - PROC PARAM.S *)
98000 IF LKIND = FORMAL
98100 THEN BEGIN LSP := GATTR.TYPTR; PKIND := ACTUAL END
98200 ELSE BEGIN LSP := NXT^.IDTYPE; PKIND := NXT^.VKIND END;
98300 IF LSP # NIL
98400 THEN
98500 BEGIN
98600 (* 33 - PROC PARAM.S *)
98700 (* 161 - fix STRING,POINTER *)
98800 IF (PKIND = ACTUAL)
98900 THEN
99000 IF LSP^.SIZE <= 2
99100 THEN
99200 BEGIN
99300 (* 104 - more range checking for subrange things *)
99400 (* 202 - pointer by ref *)
99500 if (lsp = stringptr) or
99600 (lsp = pointerptr) or
99700 (lsp = pointerref)
99800 then paramfudge
99900 else if lsp^.form = subrange
00100 then loadsubrange(gattr,lsp)
00200 else load(gattr);
00300 IF COMPTYPES(REALPTR,LSP)
00400 AND (GATTR.TYPTR = INTPTR)
00500 THEN MAKEREAL(GATTR)
00600 END
00700 ELSE
00800 BEGIN
00900 LOADADDRESS;
01000 (* 33 - PROC PARAM.S *)
01100 IF (LKIND = ACTUAL) AND (FCP^.LANGUAGE # PASCALSY)
01200 THEN CODE.INSTRUCTION[CIX].INSTR := 505B%HRLI\
01300 END
01400 ELSE
01500 IF GATTR.KIND = VARBL
01600 THEN LOADADDRESS
01700 ELSE ERROR(463) ;
01800 (* 22 - ALLOW EXTERNAL FILE REFERENCES *)
01900 IF GATTR.TYPTR#NIL
02000 THEN IF GATTR.TYPTR^.FORM=FILES
02100 THEN WITH LASTFILE^ DO
02200 IF (VLEV=0) AND (NOT MAIN)
02300 THEN BEGIN VADDR:=IC-1;CODE.INFORMATION[CIX]:='E' END;
02400 (* 64 - fix proc param's that don't fit in ac's *)
02500 IF NOT COMPTYPES(LSP,GATTR.TYPTR)
02600 THEN ERROR(503)
02700 END
02800 END
02900 END
03000 (* 33 - PROC PARAM.S *)
03100 END;
03200 IF REGC>PARREGCMAX
03300 THEN
03400 (* 33 - PROC PARAM.S *)
03500 (* NOTE: CURRENTLY WE PUNT IF ARG'S DON'T FIT IN AC'S IN FORMAL PROC*)
03600 IF LKIND=FORMAL
03700 THEN ERROR(413)
03800 ELSE BEGIN
03900 IF TOPPOFFSET = 0
04000 THEN
04100 BEGIN
04200 LNXT := FCP^.NEXT ;
04300 IF FCP^.LANGUAGE = PASCALSY
04400 (* 62 - clean up offset *)
04500 then toppoffset := fcp^.poffset + 1
04600 ELSE
04700 BEGIN
04800 TOPPOFFSET := 1 + FIRSTPAR;
04900 REPEAT
05000 WITH LNXT^ DO
05100 BEGIN
05200 NOFPAR := NOFPAR +1;
05300 TOPPOFFSET := TOPPOFFSET + 1;
05400 IF VKIND = ACTUAL
05500 THEN TOPPOFFSET := TOPPOFFSET + IDTYPE^.SIZE;
05600 IF LKIND = ACTUAL
05700 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 D=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 I F 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;
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 if (highestcode > 777777B) or (lcmain > 377777B)
55100 then error(266);
55200
55300 (* 5 - CREF *)
55400 IF CREF
55500 THEN WRITE(CHR(16B),CHR(10),'.GLOBAL. ');
55600
55700 (* 16 - EOF *)
55800 ENDOFLINE(TRUE);
55900 (* 5 - CREF *)
56000 if cref and not eof(input)
56100 then write(chr(177B),'A'); %balances <ro>B from ENDOFLINE\
56200 (* 136 - LISTING FORMAT *)
56300 NEWLINE ; NEWLINE ;
56400 IF NOT ERRORFLAG
56500 THEN
56600 BEGIN
56700 (* 4 - Make us look normal if called by COMPIL *)
56800 WRITE('No ') ; IF NOT RPGENTRY THEN WRITE(TTY,'No ')
56900 END
57000 ELSE WRITE(TTY,'?');
57100 (* 136 - LISTING FORMAT *)
57200 WRITE('error detected') ; NEWLINE;
57300 IF (NOT RPGENTRY) OR ERRORFLAG
57400 THEN
57500 (* 26 - break not needed for TTY *)
57600 WRITELN(TTY,'error detected');
57700 IF ERRORFLAG
57800 (* 112 - clrbfi when error *)
57900 THEN BEGIN
58000 REWRITE(OUTPUTREL);
58100 clribf;
58200 end
58300 ELSE IF NOT RPGENTRY THEN
00100 BEGIN
00200 (* 136 - LISTING FORMAT *)
00300 WRITELN(TTY); NEWLINE;
00400 I := (HIGHESTCODE - 400000B + 1023) DIV 1024;
00500 WRITELN(TTY,'Highseg: ',I:3,'K'); WRITELN('Highseg: ',I:3,'K');
00600 I := (LCMAIN + 1023) DIV 1024;
00700 WRITELN(TTY,'Lowseg : ',I:3,'K'); WRITELN('Lowseg : ',I:3,'K');
00800 END;
00900 (* 4 - Make us look normal if called by COMPIL *)
01000 IF NOT RPGENTRY THEN BEGIN
01100 RTIME := RUNTIME - RTIME;
01200 WRITE(TTY,'Runtime: ',(RTIME DIV 60000):3,':');
01300 RTIME := RTIME MOD 60000;
01400 WRITE(TTY,(RTIME DIV 1000):2,'.');
01500 RTIME := RTIME MOD 1000;
01600 WRITELN(TTY,RTIME:3)
01700 (* 4 - get back to SCAN if appropriate *)
01800 END;
01900 PASXIT(INPUT,OUTPUT,OUTPUTREL)
02000 END.