Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-11 - 43,50530/pascmp.pas
There are 4 other files named pascmp.pas in the archive. Click here to see a list.
00100	  %$L-,C-,D-,T-,V:001200000217B\
00200	program pascmp;
00300	 include 'pasprm.pas';   (* set up tops10 and tops20 *)
00400	  %*********************************************************
00500	   *							   *
00600	   *							   *
00700	   *	 STEP-WISE DEVELOPMENT OF A PASCAL COMPILER	   *
00800	   *	 ******************************************	   *
00900	   *							   *
01000	   *							   *
01100	   *	 STEP 5:   SYNTAX ANALYSIS INCLUDING ERROR	   *
01200	   *		   HANDLING; CHECKS BASED ON DECLARA-	   *
01300	   *	 15/3/73   TIONS; ADDRESS AND CODE GENERATION	   *
01400	   *		   FOR A HYPOTHETICAL STACK COMPUTER	   *
01500	   *							   *
01600	   *							   *
01700	   *	 AUTHOR:   URS AMMANN				   *
01800	   *		   FACHGRUPPE COMPUTERWISSENSCHAFTEN	   *
01900	   *		   EIDG. TECHNISCHE HOCHSCHULE		   *
02000	   *	   CH-8006 ZUERICH				   *
02100	   *							   *
02200	   *	 CODE GENERATION FOR DECSYSTEM 10 BY		   *
02300	   *	 C.-O. GROSSE-LINDEMANN, F.-W. LORENZ,		   *
02400	   *	 H.-H. NAGEL, P.J. STIRL			   *
02500	   *							   *
02600	   *	 MODIFICATIONS TO GENERATE RELOCATABLE OBJECT CODE *
02700	   *	 BY E. KISICKI (DEC 74) 			   *
02800	   *							   *
02900	   *	 DEBUG SYSTEM BY P. PUTFARKEN (DEC 74)		   *
03000	   *							   *
03100	   *	 INSTITUT FUER INFORMATIK, D-2 HAMBURG 13,	   *
03200	   *	 SCHLUETERSTRASSE 70 / GERMANY			   *
03300	   *							   *
03400	   *							   *
03500	   *********************************************************\
03600	
03700	
03800	
03900	  %	  HOW  TO  GENERATE  A	NEW  PASCAL  COMPILER
04000	
04100	   SOURCES:
04200	   A) ASCII:	  PASREL.PAS
04300			  RUNTIM.MAC
04400			  DEBSUP.MAC
04500			  DEBUG .PAS
04600	   B) BINARY:	  PASREL.SHR
04700			  PASREL.LOW
04800			  PASLIB.REL (CHECK INITPROCEDURE "SEARCH LIBRARIES")
04900	
05000	   !              IF THE NEW COMPILER SHOULD NOT BE MADE AVAILABLE FOR GENERAL USE ON SYS,
05100	   !		  ENTER THE APPROPIATE DIRECTORY SPECIFICATIONS IN INITPROCEDURE "SEARCH LIBRARIES"
05200	
05300	
05400	  STEP			  ACTION
05500	
05600	  0	  SAVE ALL SOURCE FILES ON DECTAPES!!
05700	  1	  .COPY PASLBN.REL=PASLIB.REL
05800	  2	  IF THERE ARE NO CHANGES TO RUNTIM.MAC, DEBSUP.MAC, OR DEBUG.PAS
05900		  THEN GOTO STEP 9
06000	  3	  UPDATE RUNTIM.MAC
06100	  4	  ASSEMBLE   "		  -->	  RUNTIM.REL
06200	  5	  UPDATE DEBSUP.MAC
06300	  6	  ASSEMBLE   "		  -->	  DEBSUP.REL
06400	  7	  UPDATE DEBUG.PAS
06500		  .RUN PASREL
06600		  *DEBUG.PAS		  -->	  DEBUG.REL
06700	  8	  .R FUDGE2
06800		  *PASLBN.REL=PASLBN.REL<RUNSP>,RUNTIM.REL<RUNSP>(R)$
06900		  *PASLBN.REL=PASLBN.REL<DEBSP>,DEBSUP.REL<DEBSP>(R)$
07000		  *PASLBN.REL=PASLBN.REL<DEBUG>,DEBUG.REL<DEBUG>(R)$
07100		  *^C
07200					  -->	  PASLBN.REL
07300	  9	  UPDATE PASREL.PAS
07400		  UPDATE "HEADER" IN PASREL.PAS
07500		  IF THERE ARE NEW ENTRIES TO RUNSP OR DEBSP
07600		  CHECK
07700		  INITPROCEDURE "RUNTIME-, DEBUG-SUPPORTS", "SUPPORTS"
07800		    AND
07900		  PROCEDURE "SUPPORT"
08000	  10		.RUN PASREL
08100		      	*PASREL.PAS	      -->     PASREL.REL
08200	  11      	.LOAD PASREL,/SEARCH PASLBN.REL
08300	      		.SSAVE PASREL 36      -->     PASREL.SHR
08400	      					      PASREL.LOW
08500	
08600				      36 K CORE ONLY IF NO RUNTIMECHECK (C-) AND NO DEBUG OPTION (D-) , OTHERWISE MORE !
08700	
08800	  12      	.RENAME PAS1.PAS=PASREL.PAS
08900	  13      	.RUN PASREL
09000	      		*PAS1.PAS 	      -->     PAS1.REL
09100	  14      	.LOAD PAS1,/SEARCH PASLBN.REL
09200	      		.SSAVE PAS1 36	      -->     PAS1.SHR
09300	      					      PAS1.LOW
09400	  14.1    	.RENAME PAS2.PAS=PAS1.PAS
09500	  14.2    	.RUN PAS1
09600	      		*PAS2.PAS 	      -->      PAS2.REL
09700	  14.3    	.LOAD PAS2,/SEARCH PASLBN.REL
09800	      		.SSAVE PAS2 36	      -->      PAS2.SHR
09900	      				      -->      PAS2.LOW
10000	  15      	.R FILCOM
10100	      		*TTY:=PAS2.LOW,PAS1.LOW
10200	      		NO DIFFERENCES ENCOUNTERED
10300	      		*TTY:=PAS2.SHR,PAS1.SHR
10400	      		FILE 1) DSK:PAS2.SHR  CREATED: XXX
10500	      		FILE 2) DSK:PAS1.SHR  CREATED: XXX
10600	      		400005  604163 XXXXXX   604163 XXXXXX	     XXXXXX
10700	      		%FILES ARE DIFFERENT
10800	
10900	  16      	.DELETE PASREL.*,PAS1.*,PAS2.REL,PASLIB.REL
11000	       		.PRINT PAS2.LST
11100	       		.RENAME PASREL.*=PAS2.*
11200			.RENAME PASLIB.REL=PASLBN.REL
11300	
11400	
11500	  *******************************************************************\
11600	
11700	       %HINTS FOR INTERPRETING ABBREVIATED IDENTIFIERS
11800	       BRACK  : BRACKET "[ ]"	       IX  : INDEX
11900	       C  : CURRENT		       L  : LOCAL
12000	       C  : COUNTER		       L  : LEFT
12100	       CST  : CONSTANT		       PARENT  : "( )"
12200	       CTP  : IDENTIFIER POINTER       P/PTR  : POINTER
12300	       EL  : ELEMENT		       P/PROC  : PROCEDURE
12400	       F  : FORMAL		       R  : RIGHT
12500	       F  : FIRST		       S  : STRING
12600	       F  : FILE		       SY  : SYMBOL
12700	       F/FUNC  : FUNCTION	       V  : VARIABLE
12800	       G  : GLOBAL		       V  : VALUE
12900	       ID  : IDENTIFIER
13000	       REL  : RELATIVE		       REL  : RELOCATION\
13100	
13200	(*LOCAL CHANGE HISTORY
13300		1	CLEAN UP COMMENT SCANNING AND ALLOW /* */ BRACKETS.
13400			NOTE THAT THIS \ WOULD HAVE TERMINATED THIS COMMENT
13500			PRIOR TO FIX.
13600		2	INCREASE STACKANDHEAP, GET CORE IF NEEDED ON PROGRAM
13700			ENTRY, FIX PARAMETER PASSING BUG, LOAD PASREL FROM
13800			SYS: INSTEAD OF DSK:, GENERATE FLOAT AND FIX INLINE.
13900			(FROM HEDRICK)
14000		NB:	RUNTIM has now been modified to pass all characters,
14100			including control characters as well as lower case.
14200			It no longer turns tabs into spaces.  Thus it was
14300			necessary to put this file through a program that
14400			expanded tabs into spaces when they were in strings.
14500			Thus FILCOM with the old version should specify /S
14600			or lots of irrelevant differences will be found.
14700		3	MAP LOWER CASE TO UPPER EXCEPT IN STRINGS.  (DOESN'T
14800			SOLVE THE PROBLEM ABOUT SETS, THOUGH.)  HEDRICK.
14900		4	use SCAN for file spec's, and fix to be called by
15000			COMPIL.  Hedrick.
15100		5	add /CREF switch.  Hedrick.
15200		6	allow PROGRAM statement.  Syntax check but ignore it.
15300			fix bug that caused lower case char. after a string to put compiler in loop
15400			allow <> for #
15500			allow LABEL declaration.  Syntax check bug ignore it.
15600			with /CREF/OBJ put only 3 instructions per line (4
15700			  overflow a LPT line)
15800			use standard PACK and UNPACK
15900			catch illegal characters
16000		7	add /HEAP switch for size of stack and heap
16100			treat lower case as upper in sets
16200		10	Add STRSET and STRWRITE - equivalent to RESET and
16300			REWRITE, but sets I/O into string
16400			also GETINDEX, CLOSE, ROUND, CALLI
16500			ALSO REDID RESET/REWRITE TO TAKE GOOD FILE NAMES
16600		11	Modify compiler to use new RESET/REWRITE.
16700		12	Make PASCAL programs self-expanding
16800		13	ADD DDT SYMBOL NAMES FOR ROUTINES(BLOCK-STRUCTURED)
16900			use PROGRAM name as module and entry name
17000			allow strset/write on non-TEXT files
17100			add opt. 4th arg to strset/write: limit
17200		14	allow read of string - gets rest of line
17300					add rename,dismiss,update,dumpin/out,useti/o, and xblock arg to
17400			reset and friends
17500		15	a few more arg's to some runtimes
17600		16	detect unexpected EOF
17700		17	DECUS VERSION - CHANGE DDT SYMBOLS TO BE OK FOR DEC DDT
17800		20	CMU patch: do packed struct. correctly. Did not adopt:
17900			(1) replace CAMG, etc., for text (their fix did unnecessary work for
18000			  the most common cases, and didn't get all of the obscure ones)
18100			(2) use Knuth's defn of MOD (the one here is so much faster, who care about
18200			  negative numbers?)
18300			(3) clean up variants in NEW (they say it is unnecessary)
18400			Also: fix ill mem ref if undef var first after READ
18500		21	allow PROGRAM <name>; (i.e. no file list)
18600			allow null field list in record (for null variant, mainly)
18700			fix MOD.  Much cleaner fix than CMUs.  Usually adds just one instruction
18800			fix compare of PACKED ARRAY OF CHAR.  Get it all (I hope)
18900			keep new from storing tag if no id (CMU's fix)
19000			implement +,*,- as set operators
19100		22	restore MOD to be REM (Cyber does it that way)
19200			fix all my added file things to use GETFN to scan
19300			  file name, so we properly handle external files, etc.
19400			fix callnonstandard to pass external files
19500			fix writewriteln so doesn't ill mem ref on undef file
19600		23	change enterbody to always zero locals.  Needed to ensure
19700			  that certain comparisons work, but a good thing anyway.
19800			if typechecking is on, check for following nil or 0 pointer
19900		24	do not allow comparisons except those in manual.
20000			 means we don't have to zero locals on proc entry, ever.
20100			add LOC(<proc>) that returns address of proc or ftn
20200			add S:<integer> and H:<integer> comments, to set starting
20300			  addr of stack and heap respectively
20400			change starting code to not disturb %rndev, etc. on restart
20500		25	add /ZERO (and $z) to control whether locals initialized
20600			  to zero.  Useful mostly to help find uninit.'ed pointers.
20700		26	allow record as extended lookup block
20800			add error message's for ext. lookup block
20900			don't check file pointers as if they were pointers!
21000			use getfn instead of getfilename in break,breakin,
21100			  and close, to allow non-ascii files
21200		27	add NEWZ that does what NEW used to (zeros what it gets)
21300		30	fix NEW with : syntax, per Nagel.
21400		31	FIX ILL MEM REF IN READREADLN
21500			ADD ERR MSG FOR ASSIGN TO FTN NAME OUTSIDE BODY
21600		32	add APPEND
21700		33	full implementation of PROGRAM statement
21800			version numbering of output files and program
21900			allow proc and func as parameters
22000			remove LOC (subsumed by above)
22100			add $V directive for version number
22200		34	allow list of entry points in PROGRAM statement
22300		35	fix error recovery in BLOCK, especially for /NOMAIN
22400		36	ALLOW DEBUGGING MULTIPLE FILES
22500			remove T- option
22600			NB: I have not removed the variables for T-, and also
22700			  supports exist for indeb. and exdeb., though they
22800			  are no longer used in PASCMP.
22900		37	fix bug in static link for level one proc's
23000		40	use RESDEV as external name for DISMISS
23100			by default put request for PASLIB before FORLIB
23200			improve format of /OBJECT listing
23300			fix arg's to predefined functions
23400			fix comparison of unpacked strings
23500		41	make it restartable
23600			change kludge for file OUTPUT
23700		42	allow variable records for GET,PUT,and DUMPx
23800			Currently DUMPx implemented in kludgey way.
23900		43	add 5 locations to file block for new runtimes
24000			add PUTX
24100			add optional arg to useti
24200			allow 12 digit octal number
24300		44	Add SETPOS and CURPOS to compiler
24400		45	Add NEXTBLOCK to compiler and make check for
24500			AC overlap with APPEND,UPDATE
24600		46	Repair CALLI to use 1 for true, and accept all
24700			 possible argument formats.
24800		47	Add some more functions
24900			Repair calculations for NEW with packed arrays
25000		50	Generate correct code for 400000,,0
25100			Reinitialize file ctl blocks at start
25200			Don't open INPUT or OUTPUT unless asked
25300		51	Allow mismatch of byte size for SETSTRING
25400			Fix GETLINENR
25500		52	Fixes from CMU:
25600			To CALLNONSTANDARD: when depositing directly into
25700			  display, moved 2 ac's for all arg's of size 2,
25800			  without checking to see if VAR.  Assumed AC was
25900			  unchanged by BLT.
26000			To SIMPLEEXPRESSION: optimization sometimes negated
26100			  a real constant.  If had been declared by CONST,
26200			  future ref's were to the negated quantity!
26300		53	Problems with dynamic memory expansion:
26400			Arbitrarily asked for 40b more locations above
26500			  end of stack (for runtimes).  But some odd
26600			  procedure calls use more.  Need to figure out
26700			  how much memory is used.
26800			CORERR just allocated memory up to (P).  Should
26900			  be 40(P), or however much is really needed.
27000			So add STKOFFMAX, to keep track of how much
27100			  really needed.  CORALLOC is addr of the test for
27200			  sufficient memory, fixed up.
27300		54	More dynamic memory: Need to accumulate offsets
27400			  above top of stack, in case of
27500			  x(1,2,3,4,5,f(1,2,3,4,5,6)), etc., though an
27600			  actual problem seems a bit unlikely.
27700		55	Add require source file feature
27800		56	Clean up syntax for require file
27900		57	add tops20 version
28000		60	make tops20 strings work more like tops10
28100		61	add jsys pseudo-runtime
28200			add tops20 runtimes and restrict runtimes that work only on one system
28300			add +*@ after file name to control gtfjn in tops20
28400		62	make sure there is never data above the stack pointer
28500		63	convert time, runtime, setuwp for tops20
28600		64	input:/ for tops-20
28700			empty entry in record
28800			non-local goto's
28900			fix procedure param's if not in ac's
29000		65	allow extra semicolon in case
29100			remove references to exit labels
29200		66	speed up non-local goto's
29300		67	fix external proc's as proc param's
29400		70	fix ill mem ref if certain errors in type decl
29500		71	make file name in fcb be 7 bit for tops20
29600		72	make two fixup chains for 2 word constants, to
29700			prevent giving LINK an ill mem ref
29800		73	make new use getfn for file names, to get EXTERN files
29900		74	allow new init. so tops10 version can work with emulator
30000		75	fix non-loc goto's - typo made goto chain bad
30100		76	allow a set in reset/rewrite to specify bits.
30200			allow break char set in read/readln
30300		77	fix jsys and reset set arguments
30400		100	fix ac usage in readreadln from strings
30500	        101	fix fltr and fix code generation
30600		102	Add klcpu - put improved packed array code under it
30700		103	Fix pointer to global symbol table in case that level
30800			has already been output by some inner procedure
30900		104	Check stack overflow
31000			Check to be sure structures aren't too big
31100			Range check subranges in for loop and value parameters
31200		105	Use tables instead of -40B to convert from lower case
31300		106	Make subranges of reals illegal
31400		107	Abort creation of .REL file on all errors
31500		110	Allow [x..y] set construct
31600		111	Allow STRING and POINTER parameters to EXTERN proc's
31700		112	Clrbfi when error detected.  Bounds check sets [a..b]
31800		113	Make real number reader handle exact things exactly
31900			Don't demand foward type ref's resolved at end of require file
32000		114	Write local fixups even if only non-loc gotos
32100			Make CREF not say .FIELDID. for local gotos
32200			maxint = 377777777777B
32300		115	Make tops10=false, kl=false work (tenex)
32400		116	IDRECSIZE entries for param, labelt type
32500			Make NEXT NIL instead of 0 when not used, for COPYCTP
32600		117	Fix enumerated type in record
32700		120	Make initialization routine use JSP, for T20/Tenex so
32800			don't have ill mem ref if emulator present
32900		121	Initialize CODEARRAY: fix bollixed INITPROC's
33000		122	KA's.  This includes fixing COPYSTP so it doesn't
33100			 try to follow NIL pointers.  Harmless if 377777 is a
33200			 legal address, but it isn't for KA's.
33300		123	Do POPF when can't find included file, so close gets done.
33400		124	Limit initprocedures to top level.
33500			Initialize CREF off
33600		125	Do POPF when expected eof inside included file.
33700		126	Detect procedures not beginning with BEGIN
33800		127	INit CREF to FALSE, fix [const..var] set construct
33900		130	Fix KA bug wherein random word in core image is garbage
34000		131	Move cixmax to pasprm.pas so tops20 can use big value
34100		132	Replace KA10 with KACPU for op codes and NOVM for old
34200			memory allocation.
34300		133	Fix JSYS to allow functions within it.  Garbaged stack.
34400		134	Allow DELETE in Tops-10, too.
34500		135	Fix LOG2 for big numbers.  Prevent ill mem ref's in
34600			PACK and UNPACK with syntax errors.
34700		136	Add header line at top of each page with pg. number
34800		137	Reset line no. to 1 at start of page.
34900			Fix bug in set constructors for CHAR
35000		140	Chnage order of SETMAP to closer to ASCII collating seq.
35100		141	Fix problem where REGC gets messed up by array subscript
35200			 calculations when ONFIXEDREGC is in effect.
35300			Detect overflow in number scanning with JFCL.
35400		142	Make real number scanner scan anything legitimate
35500		143	Redo I/O to string in Tops-10 for new runtimes and fix
35600			 onfixedregc code for packed arrays
35700		144	Allow :/ in program and :@ in reset for Tops-10
35800		145	Change external name of GET to GET. for Wharton
35900		146	Reinit count in putrelcode to avoid garbage in .REL file
36000		147	Lines start with 2 on new pages.
36100		150	Fix bug in forward type references,
36200			error recovery in fieldlist if garbage case type
36300			symbol table in forward proc's for debugger
36400		151	Fix reversed args in I,J:INTEGER in procedure decl.
36500		152	Add DISPOSE
36600		153	Fix some reg usage problems with DISPOSE
36700		154	More reg usage problems with DISPOSE
36800		155	Source file name in DEBUG block
36900		156	Detect FTNNAME^.field := value.  Only bare ftn name
37000			allowed on LHS of assignment.
37100		157	Add $A- to turn off arith check
37200		160	Add compiler switch /ARITHCHECK
37300		161	fix STRINg and POINTER
37400		162	fix REGSIZE
37500		163	fix TIME for Tops-20
37600		164	use Polish fixups in CASE
37700		165	in type decl, make sure ^THING gets local defn of THING,
37800			even if it happens later and there is a higher level defn.
37900			(This requires treating ^THING as forward always.)
38000		166	make assignment to func id from inner func work
38100			initialize frecvar in fieldlist, to prevent ill mem ref
38200			  with null record decl.
38300		167	improvements to edit 165
38400		170	more improvements to 165 (this time to error handling)
38500		171	allow read into packed objects
38600			allow read and write of binary files
38700			make sure default file names don't use user-declared INPUT,
38800			   and OUTPUT
38900			fix NEW of pointer that is part of packed array
39000		172	option string as third arg of RESET, etc.
39100			evaluate upper bound of FOR statement only once
39200		173	allow files in any context; internal files
39300		174	fix to initprocedures from Hisgen
39400		175	make getfn take a param telling runtime validity check
39500			needed.  SETSTRING, etc., do not
39600		176	better unterminated-comment error messages
39700		177	fix AC allocation in GETFILENAME
39800		200	fix addressing problem in loading file pointers
39900		201	make most manipulation of zero size objects be no-op.
40000			Previously one might stomp on the next variable.
40100		202	insufficient initialization before RESET(TTY), etc.
40200			fix POINTER passed by ref
40300		203	fix glitch in edit 202
40400		204	don't validity check the FCB for CLOSE, RCLOSE, and DISMISS
40500		205	fix AC in RENAME
40600		206	allow constants in WRITE statements for FILE OF INTEGER, etc.
40700		207	fix AC in GETFILENAME (again...)
40800		210	Allow 9 digit HEX numbers
40900		211	Fix output of string constants in .REL file
41000		212	Better error message if INPUT or OUTPUT redefined
41100		213	Fix procedure exit code if there is local variable
41200		214	Make debugger see locals of forward declared proc's
41300		215	Fix loop in CALLNONSTANDARD when args omitted in defn.
41400		216	Add $P: to set start of highseg (pure code)
41500		217	LASTFILE can be NIL even when current expr is a file, if it
41600			 was gotten by indexing, etc.  Replace it with a field in
41700			 the ATTR, which is going to be more general.
41800			Fix FIELDLIST to set up SIZE of the TAGWITHOUTID.  Did it
41900			 only with TAGWITHID
42000	*)
42100	
42200	    CONST
42300	      HEADER = 'PASCAL %12(217)';
42400	
42500	      DISPLIMIT = 20; MAXLEVEL = 8;
42600	      STRGLGTH = 120; BITMAX = 36;
42700	(* 43 - longer file block for new runtimes *)
42800	      SIZEOFFILEBLOCK=43B ;  {plus size of component}
42900	      OFFSET=40B;	%FUER SETVERARBEITUNG DER ASCIICHARACTER\
43000	      CHCNTMAX = 132;	%MAXIMUM OF CHARACTERS IN ONE LINE\
43100	      LEFT = 2;RIGHT = 1;BOTH = 3;NO = 0;
43200	
43300	      %KONSTANTEN VON BODY: \
43400	      %*********************\
43500	
43600	(* move cixmax to param file *)
43700	      HWCSTMAX = 377777B;		  LABMAX = 20;
43800	(* 2 - increase default stack space *)
43900	(* 7 - stackandheap now set by switch *)
44000	(* 137 - fix set constructor for CHAR *)
44100	      MAXERR = 4;		  BASEMAX = 71;		CHARMAX = 177B;
44200	
44300	      %ADDRESSES:
44400	       **********\
44500	
44600	      HAC=0;		%HILFSREGISTER\
44700	      TAC=1;		%HILFSREGISTER AUCH FUER BYTEPOINTER\
44800	      REGIN=1;		%INITIALISE REGC\
44900	      PARREGCMAX=6;	%HIGHEST REGISTER USED FOR PARAMETERS\
45000	      WITHIN=12;	%FIRST REGISTER FOR WITHSTACK\
45100	      NEWREG=13;	%LAST PLACE OF NEW-STACK\
45200	      BASIS=14; 	%BASIS ADDRESS STACK\
45300	      TOPP=15;		%FIRST FREE PLACE IN DATASTACK\
45400	      PROGRST = 145B;	%LOC 140B..144B RESERVED FOR DEBUG-PROGR.\
45500	(* 216 - HIGHSTART is now variable *)
45600	      MAXADDR=777777B;
45700	
45800	
45900	
46000	
46100	
46200	    TYPE
46300	      %DESCRIBING:\
46400	      %***********\
46500	
46600	
46700	      %BASIC SYMBOLS\
46800	      %*************\
46900	
47000	      SYMBOL = (IDENT,INTCONST,REALCONST,STRINGCONST,NOTSY,MULOP,ADDOP,RELOP,
47100			LPARENT,RPARENT,LBRACK,RBRACK,COMMA,SEMICOLON,PERIOD,ARROW,
47200			COLON,BECOMES,LABELSY,CONSTSY,TYPESY,VARSY,VALUESY,FUNCTIONSY,
47300	(* 6 - add PROGRAM statement *)
47400	(* 56 - ADD INCLUDE *)
47500			PROCEDURESY,SETSY,PACKEDSY,ARRAYSY,RECORDSY,FILESY,FORWARDSY,PROGRAMSY,INCLUDESY,
47600			BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITHSY,LOOPSY,
47700			GOTOSY,EXITSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY,
47800			EXTERNSY,PASCALSY,FORTRANSY,ALGOLSY,COBOLSY,
47900			THENSY,OTHERSY,INITPROCSY,OTHERSSY);
48000	
48100	      OPERATOR = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,LTOP,LEOP,GEOP,GTOP,
48200			  NEOP,EQOP,INOP,NOOP);
48300	
48400	      SETOFSYS = SET OF SYMBOL;
48500	
48600	(* 23 - check for bad pointer *)
48700	(* 24 - ONLY CLEAR NEW WHEN TYPECHECKING *)
48800	(* 104 - new tops10 stackoverflow *)
48900	(* 152 - DISPOSE *)
49000	      SUPPORTS = (FIRSTSUPPORT,STACKOVERFLOW,DEBSTACK,BADPOINT,ALLOCATE,CLEARALLOC,DEALLOCATE,
49100	(* 173 - internal files *)
49200			  WITHFILEDEALLOCATE,
49300	(* 43 - add PUTX *)
49400	(* 64 - non-loc goto *)
49500			  EXITGOTO,EXITPROGRAM,GETLINE,GETFILE,PUTLINE,PUTFILE,PUTXFILE,
49600	(* 57 - Add strset and strwrite external routines *)
49700			  RESETFILE,REWRITEFILE,RESETSTRING,REWRITESTRING,GETCHARACTER,PUTPAGE,ERRORINASSIGNMENT,
49800	(* 173 - internal files *)
49900			  FILEUNINITIALIZED,INITFILEBLOCK,
50000			  WRITEPACKEDSTRING,WRITESTRING,WRITEBOOLEAN,READCHARACTER,READINTEGER,READREAL,
50100	(* 171 - RECORD READ/WRITE *)
50200	(* 206 - extend for constants *)
50300			  READRECORD,WRITERECORD,WRITESCALAR,
50400			  BREAKOUTPUT,OPENTTY,INITIALIZEDEBUG,ENTERDEBUG,INDEXERROR,WRITEOCTAL,WRITEINTEGER,WRITEREAL,
50500	(* 10 add CLOSE *)
50600			  WRITEHEXADECIMAL,WRITECHARACTER,CONVERTINTEGERTOREAL,
50700	(* 14 and lots more *)
50800	(* 33 - PROGRAM statement *)
50900			  CONVERTREALTOINTEGER,CLOSEFILE,READSTRING,READPACKEDSTRING,READFILENAME,
51000			  NAMEFILE,DISFILE,UPFILE,APFILE,READDUMP,WRITEDUMP,SETIN,SETOUT,BREAKINPUT,
51100	(* 74 - tops20 routines *)
51200			  SETPOSF,CURPOSF,NEXTBLOCKF,SPACELEFTF,GETXF,DELFILE,RELFILE,INITMEM,INITFILES,
51300	(* 163 - tops20 TIME function *)
51400			  GETDAYTIME,LASTSUPPORT);
51500	
51600	      %CONSTANTS\
51700	      %*********\
51800	
51900	      CSTCLASS = (INT,REEL,PSET,STRD,STRG);
52000	      CSP = ^ CONSTNT;
52100	(* 55 - add require files *)
52200	      STRGARR = PACKED ARRAY[1..STRGLGTH] OF CHAR;
52300	      CONSTNT = RECORD
52400			  SELFCSP: CSP; NOCODE: BOOLEAN;
52500			  CASE CCLASS: CSTCLASS OF
52600			       INT : (INTVAL: INTEGER; INTVAL1:INTEGER %TO ACCESS SECOND WORD OF PVAL\ );
52700			       REEL: (RVAL: REAL);
52800			       PSET: (PVAL: SET OF 0..71);
52900			       STRD,
53000			       STRG: (SLGTH: 0..STRGLGTH;
53100				      SVAL: PACKED ARRAY [1..STRGLGTH] OF CHAR)
53200			END;
53300	
53400	      VALU = RECORD
53500		       CASE BOOLEAN OF
53600			    TRUE:   (IVAL: INTEGER);
53700			    FALSE:  (VALP: CSP)
53800		     END;
53900	
54000	      %DATA STRUCTURES\
54100	      %***************\
54200	
54300	      LEVRANGE = 0..MAXLEVEL; ADDRRANGE = 0..MAXADDR; INSTRANGE = 0..677B ;
54400	      RADIXRANGE = 0..37777777777B; FLAGRANGE = 0..17B;
54500	      BITRANGE = 0..BITMAX; ACRANGE = 0..15; IBRANGE = 0..1; CODERANGE = 0..CIXMAX ;
54600	(* 173 - internal files *)
54700	      BITS5 = 0..37B; BITS6 = 0..77B;  BITS7 = 0..177B;
54800	      STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,ARRAYS,RECORDS,FILES,TAGFWITHID,TAGFWITHOUTID,VARIANT);
54900	      DECLKIND = (STANDARD,DECLARED);
55000	      STP = ^ STRUCTURE; CTP = ^ IDENTIFIER; BTP = ^BYTEPOINT;
55100	      FTP = ^FILBLCK;
55200	      GTP = ^GLOBPTR ;
55300	
55400	{A STRUCTURE is used whenever it is necessary to say what something is.
55500	 I.e. each variable entry in the symbol table points to a STRUCTURE to
55600	 say what kind of thing it is, and expressions and other structured
55700	 objects use a STRUCTURE to say what kind of object is involved.
55800	 SELFSTP is used for dumping out the symbol table into the object file
55900	 for PASDDT.}
56000	
56100	      STRUCTURE = PACKED RECORD
56200				   SELFSTP: STP; SIZE: ADDRRANGE;
56300				   NOCODE: BOOLEAN; BITSIZE: BITRANGE;
56400	(* 173 - internal files *)
56500				   HASFILE: BOOLEAN;
56600				   CASE FORM: STRUCTFORM OF
56700					SCALAR:   (CASE SCALKIND: DECLKIND OF
56800							DECLARED: (DB0: BITS5; FCONST: CTP));
56900					SUBRANGE: (DB1: BITS6; RANGETYPE: STP; MIN,MAX: VALU);
57000					POINTER:  (DB2: BITS6; ELTYPE: STP);
57100					POWER:	  (DB3: BITS6; ELSET: STP);
57200					ARRAYS:   (ARRAYPF: BOOLEAN; DB4: BITS5; ARRAYBPADDR: ADDRRANGE;
57300						   AELTYPE,INXTYPE: STP);
57400					RECORDS:  (RECORDPF: BOOLEAN; DB5: BITS5;
57500						   FSTFLD: CTP; RECVAR: STP);
57600					FILES:	  (DB6: BITS5; FILEPF: BOOLEAN;FILTYPE: STP);
57700					TAGFWITHID,
57800					TAGFWITHOUTID: (DB7: BITS6; FSTVAR: STP;
57900							CASE BOOLEAN OF
58000							TRUE : (TAGFIELDP: CTP);
58100							FALSE  : (TAGFIELDTYPE: STP));
58200					VARIANT:  (DB9: BITS6; NXTVAR,SUBVAR: STP; FIRSTFIELD: CTP; VARVAL: VALU; QXLYPRTWRR: BOOLEAN)
58300				 END;
58400	
58500	      BPOINTER = PACKED RECORD
58600				  SBITS,PBITS: BITRANGE;
58700				  IBIT,DUMMYBIT: IBRANGE;
58800				  IREG: ACRANGE;
58900				  RELADDR: ADDRRANGE
59000				END;
59100	
59200	      BPKIND = (RECORDD,ARRAYY);
59300	
59400	      BYTEPOINT = PACKED RECORD
59500				   BYTE: BPOINTER;
59600				   LAST   :BTP;
59700				   CASE BKIND:BPKIND OF
59800					RECORDD: (FIELDCP: CTP);
59900					ARRAYY : (ARRAYSP: STP)
60000				 END;
60100	      GLOBPTR = RECORD
60200			  NEXTGLOBPTR: GTP ;
60300			  FIRSTGLOB,
60400			  LASTGLOB   : ADDRRANGE ;
60500			  FCIX	     : CODERANGE
60600			END ;
60700	
60800	      FILBLCK = PACKED RECORD
60900				 NEXTFTP : FTP ;
61000				 FILEIDENT : CTP
61100			       END ;
61200	
61300	      %NAMES\
61400	      %*****\
61500	
61600	(* 64 - non-loc goto *)
61700	(* 111 - STRING, POINTER *)
61800		(* PARAMS is a special kind of TYPES.  It is used only for
61900		   predeclared identifiers describing kludgey types that are
62000		   valid only in procedure parameter lists. *)
62100	      IDCLASS = (TYPES,KONST,VARS,FIELD,PROC,FUNC,LABELT,PARAMS);
62200	      SETOFIDS = SET OF IDCLASS;
62300	      IDKIND = (ACTUAL,FORMAL);
62400	      PACKKIND = (NOTPACK,PACKK,HWORDR,HWORDL);
62500	      CHARWORD = PACKED ARRAY [1..5] OF CHAR;
62600	      %ALFA = PACKED ARRAY [1..ALFALENG] OF CHAR;\
62700	
62800	{An IDENTIFIER record is the permanent symbol table record for a
62900	 simple identifier.  It doesn't specify what kind of object the
63000	 identifier is. (IDTYPE points to a STRUCTURE, which does that.)
63100	 However it does have the address, in VADDR. The symbol table is
63200	 a binary tree.  LLINK and RLINK point to subtrees that are
63300	 alphabetically less than or greater than this symbol.  NEXT is
63400	 used in constructing linked lists of identifiers, such as args
63500	 to procedures, or fields in a record.  SELFCTP is used for
63600	 dumping out the symbol table into the object file for PASDDT.}
63700	
63800	      IDENTIFIER = PACKED RECORD
63900				    NAME: ALFA;
64000				    LLINK, RLINK: CTP;
64100				    IDTYPE: STP; NEXT: CTP;
64200				    SELFCTP: CTP; NOCODE: BOOLEAN;
64300				    CASE KLASS: IDCLASS OF
64400					 KONST: (VALUES: VALU);
64500					 VARS:	(VKIND: IDKIND; VLEV: LEVRANGE;
64600						 CHANNEL: ACRANGE; VDUMMY: 0..31; VADDR: ADDRRANGE);
64700					 FIELD: (PACKF: PACKKIND; FDUMMY: 0..7777B;
64800						 FLDADDR: ADDRRANGE);
64900					 %IF PACKF=PACKK THEN FLDADDR CONTAINS THE
65000					  ABSOLUTE ADDRESS OF THE CORRESPONDING BYTEPOINTER
65100					  -----> ENTERBODY\
65200					 PROC,
65300					 FUNC:	(PFCHAIN: CTP; CASE PFDECKIND: DECLKIND OF
65400								    STANDARD: (KEY: 1..44);
65500								    DECLARED: (PFLEV: LEVRANGE; PFADDR: ADDRRANGE;
65600									       CASE PFKIND: IDKIND OF
65700										    ACTUAL: (FORWDECL: BOOLEAN; TESTFWDPTR: CTP;
65800											     EXTERNDECL: BOOLEAN; LANGUAGE: SYMBOL;
65900											     EXTERNALNAME: ALFA;
66000											     LINKCHAIN: PACKED ARRAY[LEVRANGE] OF ADDRRANGE;
66100	(* 62 - clean of stack offsets *)
66200											     POFFSET:ADDRRANGE)));
66300	(* 66 - non-local goto's *)
66400				         LABELT: (SCOPE:LEVRANGE;NONLOCGOTO:BOOLEAN;
66500						  GOTOCHAIN:ADDRRANGE;LABELADDRESS:ADDRRANGE)
66600				  END;
66700	
66800	
66900	      DISPRANGE = 0..DISPLIMIT;
67000	      WHERE = (BLCK,CREC);
67100	(* 61 - new type to separate tops10 and tops20 ftns *)
67200	      machine = (okname,t10name,t20name);
67300	
67400	      %RELOCATION\
67500	      %**********\
67600	
67700	      RELBYTE = 0..3B %(NO,RIGHT,LEFT,BOTH)\;
67800	
67900	      RELWORD = PACKED ARRAY[0..17] OF RELBYTE;
68000	
68100	      %EXPRESSIONS\
68200	      %***********\
68300	
68400	      ATTRKIND = (CST,VARBL,EXPR);
68500	
68600	{An ATTR contains the current status of an object that is being used by
68700	 the code generator.  I.e. its lexical level, where it currently is
68800	 (can be the permanent location, or an AC), etc.  This differs from
68900	 an identifier record both because it exists for things other than
69000	 identifiers, e.g. constants and expressions, and because it is current
69100	 state in code generation, rather than permanent symbol table value.
69200	 The non-obvious fields are:
69300	   DPLMT - displacement, i.e. address, possibly indexed by INDEXR,
69400		or modified by byte pointer fields, etc.
69500	   EXTERNCTP - this is non-NIL only for if the expression represented
69600		is a reference to an external variable.  External variables
69700		are the only case where we have to have a handle on the
69800		identifier record in the symbol table.  We need this because
69900		the way externals are referred to involves changing the
70000		address for them in the symbol table every time they are
70100		refered to.  Currently the only external variables allowed
70200		are files.  You should be able to test EXTERNCTP <> NIL to
70300		see whether a file is external.}
70400	
70500	      ATTR = RECORD
70600		       TYPTR: STP;
70700		       CASE KIND: ATTRKIND OF
70800			    CST:   (CVAL: VALU);
70900			    VARBL: (PACKFG: PACKKIND; INDEXR: ACRANGE; INDBIT: IBRANGE;
71000				    VLEVEL: LEVRANGE; BPADDR,DPLMT: ADDRRANGE;
71100	(* 217 - add EXTERNCTP *)
71200				    VRELBYTE: RELBYTE; SUBKIND: STP; EXTERNCTP: CTP);
71300			    EXPR:  (REG:ACRANGE)
71400		     END;
71500	
71600	      TESTP = ^ TESTPOINTER;
71700	      TESTPOINTER = PACKED RECORD
71800				     ELT1,ELT2: STP;
71900				     LASTTESTP: TESTP
72000				   END;
72100	
72200	(* 65 - remove exit labels *)
72300	
72400	      %TYPES FROM BODY \
72500	      %****************\
72600	
72700	(* 13 - ADD WRITEBLOCK FOR DDT SYMBOLS *)
72800	      WRITEFORM = (WRITEENTRY,WRITENAME,WRITEHISEG,WRITEGLOBALS,WRITECODE,WRITEINTERNALS,
72900	(* 164 - add Polish fixups *)
73000			   WRITEPOLISH,WRITELIBRARY,
73100	(* 173 - remove writefileblock *)
73200			   WRITESYMBOLS,WRITEBLK,WRITESTART,WRITEEND);
73300	
73400	      UPDATEFORM = (C,D);
73500	      ETP = ^ ERRORUPDATE;
73600	      ERRORUPDATE = PACKED RECORD
73700				     NUMBER: INTEGER;
73800				     NEXT: ETP;
73900				     CASE FORM: UPDATEFORM OF
74000					  C:  (STRING: ALFA);
74100					  D: (INTVAL: INTEGER)
74200				   END;
74300	
74400	      KSP = ^ KONSTREC;
74500	      KONSTREC = PACKED RECORD
74600	(* 72 - two fixup chains for 2 word consts *)
74700				  ADDR, ADDR1, KADDR: ADDRRANGE;
74800				  CONSTPTR: CSP;
74900				  NEXTKONST: KSP
75000				END;
75100	(* 164 - Polish fixups for CASE *)
75200	      POLPT = ^ POLREC;
75300	{This record indicates a Polish fixup to be done at address WHERE in
75400	 the code.  The RH of WHERE is to get the BASE (assumed relocatable),
75500	 adjusted by OFFSET (a constant).  This is needed because the loader
75600	 assumes that any address < 400000B is in the lowseg.  So to get the
75700	 virtual start of the CASE statement branch table we need to use
75800	 this to adjust the physical start of the table by the first case
75900	 index}
76000	      POLREC = PACKED RECORD
76100				  WHERE: ADDRRANGE;
76200				  BASE:  ADDRRANGE;
76300				  OFFSET: INTEGER;
76400				  NEXTPOL: POLPT
76500				END;
76600	
76700	      PDP10INSTR = PACKED RECORD
76800				    INSTR   : INSTRANGE ;
76900				    AC	    : ACRANGE;
77000				    INDBIT  : IBRANGE;
77100				    INXREG  : ACRANGE;
77200				    ADDRESS : ADDRRANGE
77300				  END ;
77400	
77500	      HALFS = PACKED RECORD
77600			       LEFTHALF: ADDRRANGE;
77700			       RIGHTHALF: ADDRRANGE
77800			     END;
77900	
78000	      PAGEELEM = PACKED RECORD
78100				  WORD1: PDP10INSTR;
78200				  LHALF: ADDRRANGE; RHALF: ADDRRANGE
78300				END;
78400	      DEBENTRY = RECORD
78500	(* 36 - ALLOW MULTIPLE MODULES *)
78600			   NEXTDEB: INTEGER;  %WILL BE PTR TO NEXT ENTRY\
78700			   LASTPAGEELEM: PAGEELEM;
78800	(* 103 - fix global id tree *)
78900			   GLOBALIDTREE: CTP;
79000			   STANDARDIDTREE: CTP;
79100			   INTPOINT:  STP;
79200			   REALPOINT: STP;
79300			   CHARPOINT: STP;
79400			   MODNAME: ALFA;
79500	(* 155 - add source information *)
79600			   SOURCE: PACKED ARRAY[1..167]OF CHAR;
79700			 END;
79800	
79900	(* 4 - add data structure for SCAN to return *)
80000	(* 11 - modify structure and add type for the REL file *)
80100	INTFILE = FILE OF INTEGER;
80200	RPGDATA = RECORD
80300	(* 7 - add /HEAP switch *)
80400		RELNAME:ALFA;
80500	(* 24 - allow user to set first loc of stack and heap *)
80600		STACKVAL:INTEGER;
80700		HEAPVAL:INTEGER;
80800	(* 33 - version no. *)
80900		VERVAL:INTEGER;
81000	(* 25 - add /ZERO *)
81100	(* 160 - add /ARITHCHECK *)
81200		ASW,ZSW,LSW,TSW,MSW,CSW,DSW,CRSW,RPGSW:BOOLEAN
81300		END;
81400	RPGPT = ^ RPGDATA;
81500	(* 33 - PROGRAM statement *)
81600	(* 61 - allow +* in tops20 *)
81700	PROGFILE = PACKED RECORD
81800		FILID:ALFA;
81900		NEXT:^PROGFILE;
82000	(* 64 - INPUT:/ *)
82100		wild,newgen,oldfile,interact,seeeol:Boolean
82200		END;
82300	(* 157 - See if we need INITTTY *)
82400	PROGFILEPT = ^ PROGFILE;
82500	
82600	      %------------------------------------------------------------------------------\
82700	
82800	
82900	    VAR
83000	      %RETURNED BY SOURCE PROGRAM SCANNER INSYMBOL:\
83100	      %********************************************\
83200	
83300	      SY: SYMBOL;		      %LAST SYMBOL\
83400	      OP: OPERATOR;		      %CLASSIFICATION OF LAST SYMBOL\
83500	      VAL: VALU;		      %VALUE OF LAST CONSTANT\
83600	      LGTH: INTEGER;		      %LENGTH OF LAST STRING CONSTANT\
83700	      ID: ALFA; 		      %LAST IDENTIFIER (POSSIBLY TRUNCATED)\
83800	      CH: CHAR; 		      %LAST CHARACTER\
83900	
84000	
84100	      %COUNTERS:\
84200	      %*********\
84300	
84400	      RTIME,
84500	      I: INTEGER;
84600	      SUPPORTIX: SUPPORTS;
84700	      LANGUAGEIX: SYMBOL;
84800	      CHCNT: 0..132;		      %CHARACTER COUNTER\
84900	(* 216 - variable high segment start *)
85000	      HIGHSTART,		      %START OF HIGH SEGMENT\
85100	      CODEEND,			      %FIRST LOCATION NOT USED FOR INSTRUCTIONS\
85200	      LCMAIN,
85300	(* 5 - some new variables for CREF *)
85400	      LC,IC,BEGLC,BEGIC: ADDRRANGE; 	      %DATA LOCATION AND INSTRUCTION COUNTER\
85500	(* 176 - new vars for unterminated comment *)
85600	      comment_page, comment_line: integer;
85700	
85800	      %SWITCHES:\
85900	      %*********\
86000	
86100	(* 25 - ADD /ZERO *)
86200	      ZERO,				%ON TO INITIALIZE LOCAL VAR'S\
86300	(* 4 - variable for COMPIL linkage *)
86400	      RPGENTRY,				%ON IF CALLED CALLED BY COMPIL\
86500	(* 5 - new variables for CREF *)
86600	      CREF,				%ON IF CREF LISTING BEING MADE\
86700	      DP,BEGDP,			      %DECLARATION PART\
86800	      RESETFLAG,		      %TO IGNORE SWITCHES WHICH MUST NOT BE RESET\
86900	      PRTERR,			      %TO ALLOW FORWARD REFERENCES IN POINTER TYPE
87000					       DECLARATION BY SUPPRESSING ERROR MESSAGE\
87100	      MAIN,			      %IF FALSE COMPILER PRODUCES EXTERNAL PROCEDURE OR FUNCTION\
87200	      doinitTTY,		      %TTYOPEN needed\
87300	      TTYINUSE, 		      %no longer used ?\
87400	      TTYSEEEOL,		      %TTY:# in program state\
87500	      DEBUG,			      %ENABLE DEBUGGING\
87600	      DEBUGSWITCH,		      %INSERT DEBUGINFORMATION\
87700	      LISTCODE, 		      %LIST MACRO CODE\
87800	      INITGLOBALS,		      %INITIALIZE GLOBAL VARIABLES\
87900	      LOADNOPTR,		      %TRUE IF NO POINTERVARIABLE SHALL BE LOADED\
88000	(* 157 - separate control for arith overflow *)
88100	      ARITHCHECK,		      %SWITCH FOR DETECTING ARITH ERRORS\
88200	      RUNTMCHECK: BOOLEAN;	      %SWITCH FOR RUNTIME-TESTS\
88300	(* 24 - ALLOW USER TO SET FIRST LOC OF STACK AND HEAP *)
88400	      STACK,HEAP: ADDRRANGE;		%FIRST ADDR OF STACK AND HEAP\
88500	(* 12 - stackandheap no longer needed *)
88600	(* 33 - VERSION NO. *)
88700	      version:packed record			%version no. for output\
88800		case boolean of
88900		  true:(word:integer);
89000		  false:(who:0..7B;major:0..777B;minor:0..77B;edit:0..777777B)
89100		end;
89200	
89300	
89400	      %POINTERS:\
89500	      %*********\
89600	
89700	      LOCALPFPTR, EXTERNPFPTR: CTP;   %PTRS TO LOCAL/EXTERNAL PROC/FUNC-CHAIN\
89800	(* 111 - STRING, POINTER *)
89900	(* 202 - POINTER by ref *)
90000	      INTPTR,REALPTR,CHARPTR,ANYFILEPTR,STRINGPTR,POINTERPTR,POINTERREF,
90100	      BOOLPTR,NILPTR,TEXTPTR: STP;    %POINTERS TO ENTRIES OF STANDARD IDS\
90200	(* 135 - ill mem ref in PACK, UNPACK *)
90300	      UARRTYP:STP;
90400	      UTYPPTR,UCSTPTR,UVARPTR,
90500	      UFLDPTR,UPRCPTR,UFCTPTR,	      %POINTERS TO ENTRIES FOR UNDECLARED IDS\
90600	(* 64 - non-loc goto *)
90700	      ulblptr,
90800	      FWPTR: CTP;		      %HEAD OF CHAIN OF FORW DECL TYPE IDS\
90900	      ERRMPTR,ERRMPTR1: ETP;	      %TO CHAIN ERROR-UPDATES\
91000	(* 65 - remove exit labels *)
91100	      LASTBTP: BTP;		      %HEAD OF BYTEPOINTERTABLE\
91200	      SFILEPTR,
91300	      FILEPTR: FTP;
91400	      FIRSTKONST: KSP;
91500	(* 164 - Polish fixups for CASE *)
91600	      FIRSTPOL: POLPT;
91700	      ALFAPTR, DATEPTR: STP;
91800	      FGLOBPTR,CGLOBPTR : GTP ;       %POINTER TO FIRST AND CURRENT GLOBAL INITIALISATION RECORD\
91900	      GLOBTESTP : TESTP ;	      %POINTER TO LAST PAIR OF POINTERTYPES\
92000	(* 4 - Here is the main structure for the SCAN linkage *)
92100	      SCANDATA : RPGPT ;		%DATA FROM SCAN OF FILE NAMES\
92200	(* 33 - PROGRAM STATEMENT *)
92300	      NPROGFILE,			%NEW FILE NAME\
92400	      LPROGFILE,			%LAST FILE NAME IN LIST\
92500	      FPROGFILE:PROGFILEPT;		%FIRST FILE NAME IN LIST\
92600	(* 64 - non-loc goto *)
92700	      lastlabel:ctp;
92800	(* 171 - treat file names as special *)
92900	      infile,outfile,ttyfile,ttyoutfile:ctp;    {Pointers to ID's for 
93000		INPUT, OUTPUT, TTY,    TTYOUT}
93100	
93200	      %BOOKKEEPING OF DECLARATION LEVELS:\
93300	      %**********************************\
93400	
93500	(* 5 - new variable for CREF *)
93600	      LEVEL,BEGLEVEL: LEVRANGE;		      %CURRENT STATIC LEVEL\
93700	      DISX,			      %LEVEL OF LAST ID SEARCHED BY SEARCHID\
93800	      TOP: DISPRANGE;		      %TOP OF DISPLAY\
93900	
94000	      DISPLAY:				    %WHERE:   MEANS:\
94100	      ARRAY[DISPRANGE] OF
94200	      PACKED RECORD
94300		       %=BLCK:	 ID IS VARIABLE ID\
94400	(* 5 - new variable for CREF *)
94500		       BLKNAME: ALFA;		    %NAME OF BLOCK\
94600		       FNAME: CTP;		    %=CREC:   ID IS FIELD ID IN RECORD WITH\
94700		       CASE OCCUR: WHERE OF	    %	      CONSTANT ADDRESS\
94800			    CREC: (CLEV: LEVRANGE;  %=VREC:   ID IS FIELD ID IN RECORD WITH\
94900				   CINDR: ACRANGE;  %	      VARIABLE ADDRESS\
95000				   CINDB: IBRANGE;
95100				   CRELBYTE: RELBYTE;
95200				   CDSPL,
95300				   CLC	: ADDRRANGE)
95400		     END;
95500	
95600	
     
00100	      %ERROR MESSAGES:\
00200	      %***************\
00300	
00400	      ERRORFLAG: BOOLEAN;	      %TRUE IF SYNTACTIC ERRORS DETECTED\
00500	      ERRINX: 0..MAXERR ;	      %NR OF ERRORS IN CURRENT SOURCE LINE\
00600	      ERRLIST:
00700	      ARRAY [1..MAXERR] OF
00800	      PACKED RECORD
00900		       ARW : 1..4;
01000		       POS: 1..CHCNTMAX;
01100		       NMR: 1..600;
01200		       TIC: CHAR
01300		     END;
01400	
01500	      ERRMESS15 : ARRAY [1..24] OF PACKED ARRAY [1..15] OF CHAR;
01600	(* 6 - add error msg for illegal character *)
01700	      ERRMESS20 : ARRAY [1..16] OF PACKED ARRAY [1..20] OF CHAR;
01800	(* 104 - error message for too much data for address space *)
01900	      ERRMESS25 : ARRAY [1..16] OF PACKED ARRAY [1..25] OF CHAR;
02000	      ERRMESS30 : ARRAY [1..17] OF PACKED ARRAY [1..30] OF CHAR;
02100	(* 156 - ftnname^ := *)
02200	      ERRMESS35 : ARRAY [1..18] OF PACKED ARRAY [1..35] OF CHAR;
02300	(* 31 - ADD MESSAGE  FOR BAD ASSIGN TO FTN. NAME *)
02400	      ERRMESS40 : ARRAY [1..13] OF PACKED ARRAY [1..40] OF CHAR;
02500	(* 24 - NEW ERROR MSG FOR LOC *)
02600	      ERRMESS45 : ARRAY [1..16] OF PACKED ARRAY [1..45] OF CHAR;
02700	(* 33 - PROGRAM STATEMENT *)
02800	      ERRMESS50 : ARRAY [1.. 9] OF PACKED ARRAY [1..50] OF CHAR;
02900	(* 124 - bad initprocedure *)
03000	      ERRMESS55 : ARRAY [1.. 7] OF PACKED ARRAY [1..55] OF CHAR;
03100	      ERRORINLINE,
03200	      FOLLOWERROR : BOOLEAN;
03300	      ERRLINE,
03400	      BUFFER: ARRAY [1..CHCNTMAX] OF CHAR;
03500	(* 136 - listing format *)
03600	      PAGECNT,SUBPAGE,CURLINE,
03700	      LINECNT: INTEGER;
03800	      LINENR: PACKED ARRAY [1..5] OF CHAR;
03900	
04000	
04100	
04200	
04300	      %EXPRESSION COMPILATION:\
04400	      %***********************\
04500	
04600	      GATTR: ATTR;		      %DESCRIBES THE EXPR CURRENTLY COMPILED\
04700	(* 105 - character mapping from lower case *)
04800	      charmap,setmap:array[0..177B]of integer;	%fast mapping to upper case\
04900	      setmapchain:addrrange;		%for external reference to runtime version of setmap\
05000	
05100	
05200	      %COUNTERS FOR TESTS:\
05300	      %*******************\
05400	
05500	
05600	
05700	      %DEBUG-SYSTEM:\
05800	      %*************\
05900	
06000	      LASTSTOP: ADDRRANGE;	      %LAST BREAKPOINT\
06100	      LASTLINE, 		      %LINENUMBER FOR BREAKPOINTS\
06200	      LINEDIFF, 		      %DIFFERENCE BETWEEN ^ AND LINECNT\
06300	      LASTPAGE:INTEGER; 	      %LAST PAGE THAT CONTAINS A STOP\
06400	      PAGEHEADADR,		      %OVERGIVE TO DEBUG.PAS\
06500	      LASTPAGER: ADDRRANGE;	      %POINTS AT LAST PAGERECORD\
06600	      PAGER: PAGEELEM;		      %ACTUAL PAGERECORD\
06700	      DEBUGENTRY: DEBENTRY;
06800	      IDRECSIZE: ARRAY[IDCLASS] OF INTEGER;
06900	      STRECSIZE: ARRAY[STRUCTFORM] OF INTEGER;
07000	
07100	
07200	
07300	      %STRUCTURED CONSTANTS:\
07400	      %*********************\
07500	
07600	      LETTERSORDIGITS,LETTERS,DIGITS,LETTERSDIGITSORLEFTARROW,HEXADIGITS: SET OF CHAR;
07700	      CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS,BLOCKBEGSYS,SELECTSYS,FACBEGSYS,
07800	      LANGUAGESYS,STATBEGSYS,TYPEDELS: SETOFSYS;
07900	(* 6 - add PROGRAM statement *)
08000	(* 56 - ADD INCLUDE *)
08100	      RW:  ARRAY [1..45%NR. OF RES. WORDS\] OF ALFA;
08200	      FRW: ARRAY [1..11%ALFALENG+1\] OF 1..46%NR. OF RES. WORDS + 1\;
08300	      RSY: ARRAY [1..45%NR. OF RES. WORDS\] OF SYMBOL;
08400	      SSY: ARRAY [' '..'_'] OF SYMBOL;
08500	      ROP: ARRAY [1..45%NR. OF RES. WORDS\] OF OPERATOR;
08600	      SOP: ARRAY [' '..'_'] OF OPERATOR;
08700	(* 10 make room for 12 more proc's, 8 more ftn's *)
08800	      NA:  ARRAY [1..81] OF ALFA;
08900	(* 61 - new array to declare which are tops10 and tops20 *)
09000	      machna: array[1..81] of machine;
09100	      othermachine: machine;
09200	      EXTNA: ARRAY[39..53] OF ALFA;
09300	      EXTLANGUAGE: ARRAY[39..53] OF SYMBOL;
09400	      MNEMONICS : ARRAY[1..45] OF PACKED ARRAY[1..60] OF CHAR ;
09500	
09600	
09700	      %VARIABLES FROM BODY\
09800	      %*******************\
09900	
10000	
10100	(* 173 - internal files *)
10200	{Chantab is very strange.  It is used as a kludge because we need
10300	 two global request chains for each of INPUT, OUTPUT, TTY, and TTYOUTPUT.
10400	 So the second one is stored here.  From an identifier record, you can
10500	 look at CHANNEL to find which of these corresponds to that one.}
10600	      CHANTAB:ARRAY[1..4] OF ADDRRANGE;
10700	      FILEINBLOCK:ARRAY[LEVRANGE]OF BOOLEAN;   {True is there is a local file}
10800	(* 12 - VAR'S FOR GLOBAL REF TO RUNTIMES. FOR DYNAMIC ALLOC *)
10900	      LSTNEW,NEWBND: ADDRRANGE;	%references to these global variables\
11000	(* 13 - ADD DATA FOR DDT SYMBOLS *)
11100	      PFPOINT,PFDISP:ADDRRANGE;	%ADDRESS OF FIRST CODE IN PROCEDURE\
11200	      RELBLOCK: PACKED RECORD
11300				 CASE BOOLEAN OF
11400				      TRUE: (COMPONENT: ARRAY[1..20] OF INTEGER);
11500				      FALSE: (ITEM: ADDRRANGE; COUNT: ADDRRANGE;
11600					      RELOCATOR: RELWORD;
11700					      CODE: ARRAY[0..17] OF INTEGER)
11800			       END;
11900	
12000	      RNTS: RECORD
12100		      NAME: ARRAY[SUPPORTS] OF ALFA;
12200		      LINK: PACKED ARRAY[SUPPORTS] OF ADDRRANGE
12300		    END;
12400	
12500	      CODE: PACKED RECORD
12600			     RELOCATION:  PACKED ARRAY[CODERANGE] OF RELBYTE;
12700			     INFORMATION: PACKED ARRAY[CODERANGE] OF CHAR;
12800			     CASE INTEGER OF
12900				  1: (INSTRUCTION: PACKED ARRAY[CODERANGE] OF PDP10INSTR);
13000				  2: (WORD:	   PACKED ARRAY[CODERANGE] OF INTEGER);
13100				  3: (HALFWORD:    PACKED ARRAY[CODERANGE] OF HALFS)
13200			   END;
13300	
13400	      LABELS: ARRAY [1:LABMAX] OF
13500	      RECORD
13600		LABSVAL,LABSADDR: INTEGER
13700	      END;
13800	      GOTOS: ARRAY [1:LABMAX] OF
13900	      RECORD
14000		GOTOVAL,GOTOADDR: INTEGER
14100	      END;
14200	
14300	      REGC,				%TOP OF REGISTERSTACK\
14400	      REGCMAX: ACRANGE; 		%MAXIMUM OF REGISTERS FOR EXPRESSION STACK\
14500	      LIX,JIX,CIX,
14600	      INSERTSIZE,			%TOO INSERT LCMAX IN ENTRYCODE\
14700	      PFSTART: INTEGER; 		%START OF NORMAL ENTRYCODE OF EACH FUNC. OR PROC.\
14800	      IX: INTEGER;
14900	(* 54 - var's needed to keep track of stack space needed *)
15000	      STKOFF, STKOFFMAX, CORALLOC: INTEGER;	%STACK SPACE NEEDED ABOVE LOCALS\
15100	      LCMAX: ADDRRANGE; LCP: CTP;
15200	      OUTPUTREL: FILE OF INTEGER;	%RELOCATABLE BINARY OUTPUT\
15300	      WITHIX,				%TOP OF WITH-REG STACK\
15400	      HIGHESTCODE,			%MAXIMUM OF HIGH SEGMENTS ADDRESS\
15500	      MAINSTART,			%FIRST CODE OF BODY OF MAIN\
15600	(* 16 - add CCLSW set by entry with offset=1 *)
15700	      CCLSW,
15800	(* 66 - nonloc goto's *)
15900	      globtopp,globbasis,
16000	      STARTADDR: INTEGER;		%STARTADDRESSE\
16100	
16200	(* 33 - VERSION NO. *)
16300	      LOOKBLOCK: ARRAY[0..6] OF INTEGER;
16400	      LST,REL: PACKED ARRAY[1..3] OF CHAR ;
16500	(* 34 - entry no longer needed *)
16600	      FILENAME: ALFA;
16700	      DAY: PACKED ARRAY[1..9] OF CHAR;
16800	(* 125 - moved to global so insymbol can see it *)
16900	      REQFILE,ENTRYDONE: BOOLEAN;
17000	(* 171 - read/write of records *)
17100	      THISFILE: STP;
17200	      GOTARG: BOOLEAN;
17300	
17400	      LIBIX: INTEGER;
17500	      LIBORDER: PACKED ARRAY[1..4] OF SYMBOL;
17600	      LIBRARY: ARRAY[PASCALSY..COBOLSY] OF RECORD
17700						     INORDER, CALLED: BOOLEAN;
17800						     NAME: ALFA;
17900						     PROJNR: ADDRRANGE;
18000						     PROGNR: ADDRRANGE;
18100						     DEVICE: ALFA
18200						   END;
18300	
18400	      %------------------------------------------------------------------------------\
18500	
18600	      INITPROCEDURE ;
18700	       BEGIN
18800	
18900	(* 33 - VERSION NO. *)
19000	(* 34 - using filename instead of entry *)
19100		LST:= 'LST'  ;	REL:= 'REL'  ;	FILENAME:= '          '  ;  LOOKBLOCK[0] := 6;
19200	
19300		MNEMONICS[ 1] := '***001***002***003***004***005***006***007***010***011***012' ;
19400		MNEMONICS[ 2] := '***013***014***015***016***017***020***021***022***023***024' ;
19500		MNEMONICS[ 3] := '***025***026***027***030***031***032***033***034***035***036' ;
19600		MNEMONICS[ 4] := '***037CALL  INIT  ***042***043***044***045***046CALLI OPEN  ' ;
19700		MNEMONICS[ 5] := 'TTCALL***052***053***054RENAMEIN    OUT   SETSTSSTATO STATUS' ;
19800		MNEMONICS[ 6] := 'STATZ INBUF OUTBUFINPUT OUTPUTCLOSE RELEASMTAPE UGETF USETI ' ;
19900	(* 133 - add mnemonics for ADJSP and JSYS *)
20000		MNEMONICS[ 7] := 'USETO LOOKUPENTER UJEN  ***101***102***103JSYS  ADJSP ***106' ;
20100		MNEMONICS[ 8] := '***107***110***111***112***113***114***115***116***117***120' ;
20200	(* 2 - add mnemonics for KI-10, since we are using some of them *)
20300		MNEMONICS[ 9] := '***121FIX   ***123***124***125FIXR  FLTR  UFA   DFN   FSC   ' ;
20400		MNEMONICS[10] := 'IBP   ILDB  LDB   IDPB  DPB   FAD   FADL  FADM  FADB  FADR  ' ;
20500		MNEMONICS[11] := 'FADRI FADRM FADRB FSB   FSBL  FSBM  FSBB  FSBR  FSBRI FSBRM ' ;
20600		MNEMONICS[12] := 'FSBRB FMP   FMPL  FMPM  FMPB  FMPR  FMPRI FMPRM FMPRB FDV   ' ;
20700		MNEMONICS[13] := 'FDVL  FDVM  FDVB  FDVR  FDVRI FDVRM FDVRB MOVE  MOVEI MOVEM ' ;
20800		MNEMONICS[14] := 'MOVES MOVS  MOVSI MOVSM MOVSS MOVN  MOVNI MOVNM MOVNS MOVM  ' ;
20900		MNEMONICS[15] := 'MOVMI MOVMM MOVMS IMUL  IMULI IMULM IMULB MUL   MULI  MULM  ' ;
21000		MNEMONICS[16] := 'MULB  IDIV  IDIVI IDIVM IDIVB DIV   DIVI  DIVM  DIVB  ASH   ' ;
21100		MNEMONICS[17] := 'ROT   LSH   JFFO  ASHC  ROTC  LSHC  ***247EXCH  BLT   AOBJP ' ;
21200		MNEMONICS[18] := 'AOBJN JRST  JFCL  XCT   ***257PUSHJ PUSH  POP   POPJ  JSR   ' ;
21300		MNEMONICS[19] := 'JSP   JSA   JRA   ADD   ADDI  ADDM  ADDB  SUB   SUBI  SUBM  ' ;
21400		MNEMONICS[20] := 'SUBB  CAI   CAIL  CAIE  CAILE CAIA  CAIGE CAIN  CAIG  CAM   ' ;
21500		MNEMONICS[21] := 'CAML  CAME  CAMLE CAMA  CAMGE CAMN  CAMG  JUMP  JUMPL JUMPE ' ;
21600		MNEMONICS[22] := 'JUMPLEJUMPA JUMPGEJUMPN JUMPG SKIP  SKIPL SKIPE SKIPLESKIPA ' ;
21700		MNEMONICS[23] := 'SKIPGESKIPN SKIPG AOJ   AOJL  AOJE  AOJLE AOJA  AOJGE AOJN  ' ;
21800		MNEMONICS[24] := 'AOJG  AOS   AOSL  AOSE  AOSLE AOSA  AOSGE AOSN  AOSG  SOJ   ' ;
21900		MNEMONICS[25] := 'SOJL  SOJE  SOJLE SOJA  SOJGE SOJN  SOJG  SOS   SOSL  SOSE  ' ;
22000		MNEMONICS[26] := 'SOSLE SOSA  SOSGE SOSN  SOSG  SETZ  SETZI SETZM SETZB AND   ' ;
22100		MNEMONICS[27] := 'ANDI  ANDM  ANDB  ANDCA ANDCAIANDCAMANDCABSETM  SETMI SETMM ' ;
22200		MNEMONICS[28] := 'SETMB ANDCM ANDCMIANDCMMANDCMBSETA  SETAI SETAM SETAB XOR   ' ;
22300		MNEMONICS[29] := 'XORI  XORM  XORB  IOR   IORI  IORM  IORB  ANDCB ANDCBIANDCBM' ;
22400		MNEMONICS[30] := 'ANDCBBEQV   EQVI  EQVM  EQVB  SETCA SETCAISETCAMSETCABORCA  ' ;
22500		MNEMONICS[31] := 'ORCAI ORCAM ORCAB SETCM SETCMISETCMMSETCMBORCM  ORCMI ORCMM ' ;
22600		MNEMONICS[32] := 'ORCMB ORCB  ORCBI ORCBM ORCBB SETO  SETOI SETOM SETOB HLL   ' ;
22700		MNEMONICS[33] := 'HLLI  HLLM  HLLS  HRL   HRLI  HRLM  HRLS  HLLZ  HLLZI HLLZM ' ;
22800		MNEMONICS[34] := 'HLLZS HRLZ  HRLZI HRLZM HRLZS HLLO  HLLOI HLLOM HLLOS HRLO  ' ;
22900		MNEMONICS[35] := 'HRLOI HRLOM HRLOS HLLE  HLLEI HLLEM HLLES HRLE  HRLEI HRLEM ' ;
23000		MNEMONICS[36] := 'HRLES HRR   HRRI  HRRM  HRRS  HLR   HLRI  HLRM  HLRS  HRRZ  ' ;
23100		MNEMONICS[37] := 'HRRZI HRRZM HRRZS HLRZ  HLRZI HLRZM HLRZS HRRO  HRROI HRROM ' ;
23200		MNEMONICS[38] := 'HRROS HLRO  HLROI HLROM HLROS HRRE  HRREI HRREM HRRES HLRE  ' ;
23300		MNEMONICS[39] := 'HLREI HLREM HLRES TRN   TLN   TRNE  TLNE  TRNA  TLNA  TRNN  ' ;
23400		MNEMONICS[40] := 'TLNN  TDN   TSN   TDNE  TSNE  TDNA  TSNA  TDNN  TSNN  TRZ   ' ;
23500		MNEMONICS[41] := 'TLZ   TRZE  TLZE  TRZA  TLZA  TRZN  TLZN  TDZ   TSZ   TDZE  ' ;
23600		MNEMONICS[42] := 'TSZE  TDZA  TSZA  TDZN  TSZN  TRC   TLC   TRCE  TLZE  TRCA  ' ;
23700		MNEMONICS[43] := 'TLCA  TRCN  TLCN  TDC   TSC   TDCE  TSCE  TDCA  TSCA  TDCN  ' ;
23800		MNEMONICS[44] := 'TSCN  TRO   TLO   TROE  TLOE  TROA  TLOA  TRON  TLON  TDO   ' ;
23900		MNEMONICS[45] := 'TSO   TDOE  TSOE  TDOA  TSOA  TDON  TSON  ***700            ' ;
24000	       END;
24100	
24200	      INITPROCEDURE %SEARCH LIBRARIES\ ;
24300	       BEGIN
24400		LIBRARY[PASCALSY].INORDER   := FALSE;
24500		LIBRARY[FORTRANSY].INORDER  := FALSE;
24600		LIBRARY[ALGOLSY].INORDER    := FALSE;
24700		LIBRARY[COBOLSY].INORDER    := FALSE;
24800		LIBRARY[PASCALSY].CALLED    := FALSE;
24900		LIBRARY[FORTRANSY].CALLED   := FALSE;
25000		LIBRARY[ALGOLSY].CALLED     := FALSE;
25100		LIBRARY[COBOLSY].CALLED     := FALSE;
25200	(* 57 - Make library a parameter *)
25300		LIBRARY[PASCALSY].NAME	    := PASLIB;
25400		LIBRARY[FORTRANSY].NAME     := 'FORLIB    ';
25500		LIBRARY[ALGOLSY].NAME	    := 'ALGLIB    ';
25600		LIBRARY[COBOLSY].NAME	    := 'LIBOL     ';
25700	(* 2 - library now on SYS: *)
25800	(* 57 *)
25900		LIBRARY[PASCALSY].DEVICE    := PASDEV;
26000		LIBRARY[FORTRANSY].DEVICE   := 'SYS       ';
26100		LIBRARY[ALGOLSY].DEVICE     := 'SYS       ';
26200		LIBRARY[COBOLSY].DEVICE     := 'SYS       ';
26300	(* 57 *)
26400		LIBRARY[PASCALSY].PROJNR    := PASPROJ;
26500		LIBRARY[FORTRANSY].PROJNR   := 0;
26600		LIBRARY[ALGOLSY].PROJNR     := 0;
26700		LIBRARY[COBOLSY].PROJNR     := 0;
26800	(* 57 *)
26900		LIBRARY[PASCALSY].PROGNR    := PASPROG;
27000		LIBRARY[FORTRANSY].PROGNR   := 0;
27100		LIBRARY[ALGOLSY].PROGNR     := 0;
27200		LIBRARY[COBOLSY].PROGNR     := 0;
27300	       END %SEARCH LIBRARIES\ ;
27400	
27500	      INITPROCEDURE %STANDARDNAMES\ ;
27600	       BEGIN
27700		NA[ 1] := 'FALSE     '; NA[ 2] := 'TRUE      '; NA[ 3] := 'INPUT     ';
27800		NA[ 4] := 'OUTPUT    '; NA[ 5] := 'TTY       '; NA[ 6] := 'TTYOUTPUT ';
27900		NA[ 7] := 'GET       '; NA[ 8] := 'GETLN     '; NA[ 9] := 'PUT       ';
28000		NA[10] := 'PUTLN     '; NA[11] := 'RESET     '; NA[12] := 'REWRITE   ';
28100		NA[13] := 'READ      '; NA[14] := 'READLN    '; NA[15] := 'BREAK     ';
28200		NA[16] := 'WRITE     '; NA[17] := 'WRITELN   '; NA[18] := 'PACK      ';
28300		NA[19] := 'UNPACK    '; NA[20] := 'NEW       '; NA[21] := 'MARK      ';
28400		NA[22] := 'RELEASE   '; NA[23] := 'GETLINENR '; NA[24] := 'PUT8BITSTO';
28500		NA[25] := 'PAGE      '; NA[26] := 'DATE      '; NA[27] := 'RUNTIME   ';
28600		NA[28] := 'TIME      '; NA[29] := 'ABS       '; NA[30] := 'SQR       ';
28700		NA[31] := 'TRUNC     '; NA[32] := 'ODD       '; NA[33] := 'ORD       ';
28800		NA[34] := 'CHR       '; NA[35] := 'PRED      '; NA[36] := 'SUCC      ';
28900		NA[37] := 'EOF       '; NA[38] := 'EOLN      '; NA[39] := 'SIN       ';
29000		NA[40] := 'COS       '; NA[41] := 'EXP       '; NA[42] := 'SQRT      ';
29100		NA[43] := 'LN        '; NA[44] := 'ARCTAN    '; NA[45] := 'LOG       ';
29200		NA[46] := 'SIND      '; NA[47] := 'COSD      '; NA[48] := 'SINH      ';
29300		NA[49] := 'COSH      '; NA[50] := 'TANH      '; NA[51] := 'ARCSIN    ';
29400		NA[52] := 'ARCCOS    '; NA[53] := 'RANDOM    ';
29500	(* 10 make room for 12 more proc's, 8 more ftn's *)
29600		NA[54] := 'STRSET    '; NA[55] := 'STRWRITE  ';
29700		NA[56] := 'GETINDEX  '; NA[57] := 'CLOSE     ';
29800		NA[58] := 'CALLI     '; NA[59] := 'RENAME    ';
29900		NA[60] := 'DISMISS   '; NA[61] := 'UPDATE    ';
30000		NA[62] := 'DUMPIN    '; NA[63] := 'DUMPOUT   ';
30100		NA[64] := 'USETI     '; NA[65] := 'USETO     ';
30200	(* 27 - add NEWZ *)
30300		NA[66] := 'BREAKIN   '; NA[67] := 'NEWZ      ';
30400		NA[68] := 'APPEND    '; NA[69] := 'PUTX      ';
30500	(* 44 - SETPOS,CURPOS, SKIP *)
30600		NA[70] := 'SETPOS    '; NA[71] := 'NEXTBLOCK ';
30700	(* 61 - tops20 system version *)
30800		na[72] := 'GETX      '; na[73] := 'DELETE    ';
30900		na[74] := 'RCLOSE    '; na[75] := 'JSYS      ';
31000	(* 152 - add DISPOSE *)
31100		na[76] := 'DISPOSE   '; na[77] := 'NEXTFILE  ';
31200		na[78] := 'CURPOS    '; na[79] := 'SPACELEFT ';
31300		na[80] := 'ROUND     '; na[81] := 'RECSIZE   ';
31400		machna[24] := t10name; machna[58] := t10name;
31500		machna[62] := t10name; machna[63] := t10name;
31600		machna[64] := t10name; machna[65] := t10name;
31700	(* 134 - remove t20name entry for DELETE *)
31800		machna[71] := t10name; 
31900		machna[74] := t20name; machna[75] := t20name;
32000		machna[77] := t20name; machna[79] := t10name;
32100	       END %STANDARDNAMES\ ;
32200	
32300	      INITPROCEDURE %EXTERNAL NAMES\;
32400	       BEGIN
32500		EXTNA[39] := 'SIN       '; EXTLANGUAGE[39] := FORTRANSY;
32600		EXTNA[40] := 'COS       '; EXTLANGUAGE[40] := FORTRANSY;
32700		EXTNA[41] := 'EXP       '; EXTLANGUAGE[41] := FORTRANSY;
32800		EXTNA[42] := 'SQRT      '; EXTLANGUAGE[42] := FORTRANSY;
32900		EXTNA[43] := 'ALOG      '; EXTLANGUAGE[43] := FORTRANSY;
33000		EXTNA[44] := 'ATAN      '; EXTLANGUAGE[44] := FORTRANSY;
33100		EXTNA[45] := 'ALOG10    '; EXTLANGUAGE[45] := FORTRANSY;
33200		EXTNA[46] := 'SIND      '; EXTLANGUAGE[46] := FORTRANSY;
33300		EXTNA[47] := 'COSD      '; EXTLANGUAGE[47] := FORTRANSY;
33400		EXTNA[48] := 'SINH      '; EXTLANGUAGE[48] := FORTRANSY;
33500		EXTNA[49] := 'COSH      '; EXTLANGUAGE[49] := FORTRANSY;
33600		EXTNA[50] := 'TANH      '; EXTLANGUAGE[50] := FORTRANSY;
33700		EXTNA[51] := 'ASIN      '; EXTLANGUAGE[51] := FORTRANSY;
33800		EXTNA[52] := 'ACOS      '; EXTLANGUAGE[52] := FORTRANSY;
33900		EXTNA[53] := 'RAN       '; EXTLANGUAGE[53] := FORTRANSY;
34000	
34100	       END %EXTERNAL NAMES\;
34200	
34300	      INITPROCEDURE %RUNTIME-, DEBUG-SUPPORTS\ ;
34400	       BEGIN
34500	
34600		RNTS.NAME[STACKOVERFLOW]	     := 'CORERR    ';
34700	(* 104 - new tops10 stackoverflow for better checking *)
34800		RNTS.NAME[DEBSTACK]		     := 'DCORER    ';
34900	(* 23 - check for bad pointer *)
35000	        RNTS.NAME[BADPOINT]		     := 'PTRER.    ';
35100		RNTS.NAME[ALLOCATE]		     := 'NEW       ';
35200		RNTS.NAME[CLEARALLOC]		     := 'NEWCL.    ';
35300	(* 152 - DISPOSE *)
35400		RNTS.NAME[DEALLOCATE]		     := 'DISPOS    ';
35500	(* 173 - internal file *)
35600		RNTS.NAME[WITHFILEDEALLOCATE]	     := 'DISPF.    ';
35700	(* 64 - non-loc goto *)
35800		rnts.name[exitgoto]		     := 'GOTOC.    ';
35900		RNTS.NAME[EXITPROGRAM]		     := 'END       ';
36000		RNTS.NAME[GETLINE]		     := 'GETLN     ';
36100		RNTS.NAME[GETFILE]		     := 'GET.      ';
36200		RNTS.NAME[PUTLINE]		     := 'PUTLN     ';
36300		RNTS.NAME[PUTFILE]		     := 'PUT       ';
36400	(* 43 - add PUTX *)
36500		RNTS.NAME[PUTXFILE]		     := 'PUTX      ';
36600		RNTS.NAME[RESETFILE]		     := 'RESETF    ';
36700		RNTS.NAME[REWRITEFILE]		     := 'REWRIT    ';
36800	(* 57 - do strset and strwrite at runtime *)
36900		RNTS.NAME[RESETSTRING]		     := 'STSET.    ';
37000		RNTS.NAME[REWRITESTRING]	     := 'STWR.     ';
37100		RNTS.NAME[WRITEOCTAL]		     := 'WRTOCT    ';
37200		RNTS.NAME[WRITEHEXADECIMAL]	     := 'WRTHEX    ';
37300		RNTS.NAME[WRITEINTEGER] 	     := 'WRTINT    ';
37400		RNTS.NAME[WRITECHARACTER]	     := 'WRITEC    ';
37500		RNTS.NAME[WRITEREAL]		     := 'WRTREA    ';
37600		RNTS.NAME[WRITEBOOLEAN] 	     := 'WRTBOL    ';
37700		RNTS.NAME[WRITESTRING]		     := 'WRTUST    ';
37800		RNTS.NAME[WRITEPACKEDSTRING]	     := 'WRTPST    ';
37900	        RNTS.NAME[WRITERECORD]   	     := '.WRREC    ';
38000		RNTS.NAME[WRITESCALAR]		     := '.WRSCA    ';
38100		RNTS.NAME[READINTEGER]		     := '.READI    ';
38200		RNTS.NAME[READCHARACTER]	     := '.READC    ';
38300		RNTS.NAME[READREAL]		     := '.READR    ';
38400	        RNTS.NAME[READRECORD]		     := '.READD    ';
38500		RNTS.NAME[CONVERTINTEGERTOREAL]      := 'INTREA    ';
38600		RNTS.NAME[CONVERTREALTOINTEGER]      := 'TRUNC     ';
38700		RNTS.NAME[BREAKOUTPUT]		     := 'BREAK     ';
38800		RNTS.NAME[OPENTTY]		     := 'TTYPR.    ';
38900		RNTS.NAME[INITIALIZEDEBUG]	     := 'INDEB.    ';
39000		RNTS.NAME[ENTERDEBUG]		     := 'EXDEB.    ';
39100		RNTS.NAME[GETCHARACTER] 	     := 'GETCH     ';
39200		RNTS.NAME[PUTPAGE]		     := 'PUTPG     ';
39300		RNTS.NAME[INDEXERROR]		     := 'INXERR    ';
39400		RNTS.NAME[ERRORINASSIGNMENT]	     := 'SRERR     ';
39500		RNTS.NAME[FILEUNINITIALIZED]	     := 'ILFIL.    ';
39600		RNTS.NAME[INITFILEBLOCK]	     := 'INITB.    ';
39700	(* 10 ADD CLOSE *)
39800		RNTS.NAME[CLOSEFILE]		     := 'CLOFIL    ';
39900	(* 14 AND STRING READERS *)
40000		RNTS.NAME[READSTRING]		     := 'READUS    ';
40100		RNTS.NAME[READPACKEDSTRING]	     := 'READPS    ';
40200		RNTS.NAME[READFILENAME]		     := 'GETFN.    ';
40300		RNTS.NAME[NAMEFILE]		     := 'RENAME    ';
40400	(* 40 - change name so won't conflict with FORTRAN *)
40500		RNTS.NAME[DISFILE]		     := 'RESDEV    ';
40600		RNTS.NAME[UPFILE]		     := 'UPDATE    ';
40700		RNTS.NAME[APFILE]		     := 'APPEND    ';
40800		RNTS.NAME[READDUMP]		     := 'DUMPIN    ';
40900		RNTS.NAME[WRITEDUMP]		     := 'DUMPOU    ';
41000		RNTS.NAME[SETIN]		     := 'USETIN    ';
41100		RNTS.NAME[SETOUT]		     := 'USETOU    ';
41200		RNTS.NAME[BREAKINPUT]		     := 'BREAKI    ';
41300		RNTS.NAME[SETPOSF]		     := 'SETPOS    ';
41400		RNTS.NAME[CURPOSF]		     := 'CURPOS    ';
41500		RNTS.NAME[NEXTBLOCKF]		     := 'NEXTBL    ';
41600		rnts.name[spaceleftf]		     := 'SPCLF.    ';
41700		rnts.name[getxf]		     := 'GETX.     ';
41800	(* 74 - Tops20 runtimes *)
41900		rnts.name[delfile]		     := 'DELF.     ';
42000		rnts.name[relfile]		     := 'RELF.     ';
42100		rnts.name[initmem]		     := 'PASIM.    ';
42200	(* 120 - New calling convention, so changed name *)
42300		rnts.name[initfiles]		     := 'PASIF.    ';
42400		rnts.name[getdaytime]		     := 'DAYTM.    ';
42500	
42600	       END %RUNTIME-, DEBUG-SUPPORTS\ ;
42700	
42800	      INITPROCEDURE %INITSCALARS\ ;
42900	       BEGIN
43000		CHANTAB[1] := 0; CHANTAB[2] := 0; CHANTAB[3] := 0; CHANTAB[4] := 0;
43100	(* 65 - remove exit labels *)
43200		FWPTR := NIL; LASTBTP := NIL;  FGLOBPTR := NIL ; FILEPTR := NIL ;
43300		LOCALPFPTR:=NIL; EXTERNPFPTR:= NIL; GLOBTESTP := NIL; ERRMPTR := NIL;
43400	(* 24 - INITIALZE HEAP AND STACK *)
43500		HEAP := 0; STACK := 0;
43600	
43700		LISTCODE := FALSE; LOADNOPTR := TRUE; INITGLOBALS := FALSE ; RUNTMCHECK := TRUE;
43800	(* 157 - separate control for arith error *)
43900		ARITHCHECK := TRUE;
44000		TTYINUSE := TRUE; FOLLOWERROR := FALSE; ERRORINLINE := FALSE; RESETFLAG := TRUE;
44100	(* 172 *)
44200		TTYSEEEOL := FALSE;
44300		DP := TRUE; PRTERR := TRUE; ERRORFLAG := FALSE ; MAIN := TRUE;
44400		ENTRYDONE := FALSE; DEBUG := FALSE; DEBUGSWITCH := FALSE; 
44500	(* 176 *)
44600		comment_page := 0;
44700	(* 33 - PROGRAM *)
44800		FPROGFILE := NIL; LPROGFILE := NIL;
44900	(* 64 - non-loc goto *)
45000		lastlabel := nil;
45100	
45200		LC := PROGRST;	     %START OF LOWSEGMENT AVAILABLE TO PROGRAM\
45300	(* 136 - listing format *)
45400		CHCNT := 0; LINECNT := 1; PAGECNT := 1; SUBPAGE := 0; 
45500		LASTLINE := -1; LASTPAGE := 0;
45600	(* 12 - initialize new variables for dynamic core *)
45700		LIBIX := 0; ERRINX := 0; LSTNEW := 0; NEWBND := 0;
45800	       END %INITSCALARS\ ;
45900	
46000	      INITPROCEDURE %INITSETS\ ;
46100	       BEGIN
46200		DIGITS := ['0'..'9'];
46300		LETTERS := ['A'..'Z'];
46400		HEXADIGITS := ['0'..'9','A'..'F'];
46500		LETTERSORDIGITS := [ '0'..'9','A'..'Z'];
46600		LETTERSDIGITSORLEFTARROW := ['0'..'9','A'..'Z','_'];
46700		LANGUAGESYS := [FORTRANSY,ALGOLSY,COBOLSY,PASCALSY];
46800		CONSTBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT];
46900		SIMPTYPEBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT] ;
47000		TYPEBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,ARROW,PACKEDSY,ARRAYSY,RECORDSY,SETSY,FILESY] ;
47100		TYPEDELS := [ARRAYSY,RECORDSY,SETSY,FILESY];
47200	(* 56 - add require files *)
47300		BLOCKBEGSYS := [INCLUDESY,LABELSY,CONSTSY,TYPESY,VARSY,INITPROCSY,PROCEDURESY,FUNCTIONSY,BEGINSY];
47400		SELECTSYS := [ARROW,PERIOD,LBRACK];
47500		FACBEGSYS := [INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,LBRACK,NOTSY];
47600		STATBEGSYS := [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,LOOPSY,FORSY,WITHSY,CASESY]
47700	       END %INITSETS\ ;
47800	
47900	      INITPROCEDURE %RESWORDS\ ;
48000	       BEGIN
48100		RW[ 1] := 'IF        '; RW[ 2] := 'DO        '; RW[ 3] := 'OF        ';
48200		RW[ 4] := 'TO        '; RW[ 5] := 'IN        '; RW[ 6] := 'OR        ';
48300		RW[ 7] := 'END       '; RW[ 8] := 'FOR       '; RW[ 9] := 'VAR       ';
48400		RW[10] := 'DIV       '; RW[11] := 'MOD       '; RW[12] := 'SET       ';
48500		RW[13] := 'AND       '; RW[14] := 'NOT       '; RW[15] := 'THEN      ';
48600		RW[16] := 'ELSE      '; RW[17] := 'WITH      '; RW[18] := 'GOTO      ';
48700		RW[19] := 'LOOP      '; RW[20] := 'CASE      '; RW[21] := 'TYPE      ';
48800		RW[22] := 'FILE      '; RW[23] := 'EXIT      '; RW[24] := 'BEGIN     ';
48900		RW[25] := 'UNTIL     '; RW[26] := 'WHILE     '; RW[27] := 'ARRAY     ';
49000		RW[28] := 'CONST     '; RW[29] := 'LABEL     '; RW[30] := 'ALGOL     ';
49100		RW[31] := 'COBOL     '; RW[32] := 'EXTERN    '; RW[33] := 'PASCAL    ';
49200		RW[34] := 'RECORD    '; RW[35] := 'DOWNTO    '; RW[36] := 'PACKED    ';
49300		RW[37] := 'OTHERS    '; RW[38] := 'REPEAT    '; RW[39] := 'FORTRAN   ';
49400	(* 6 - add PROGRAM statement *)
49500	(* 56 - ADD INCLUDE *)
49600		RW[40] := 'FORWARD   '; RW[41] := 'PROGRAM   '; RW[42] := 'INCLUDE   ';
49700	        RW[43] := 'FUNCTION  '; RW[44] := 'PROCEDURE ';
49800		RW[45] := 'INITPROCED';
49900		FRW[1] :=  1; FRW[2] :=  1; FRW[3] :=  7; FRW[4] := 15; FRW[5] := 24;
50000		FRW[6] := 32; FRW[7] := 39; FRW[8] := 43; FRW[9] := 44; FRW[10] := 45;
50100		FRW[11] := 46;
50200	       END %RESWORDS\ ;
50300	
50400	      INITPROCEDURE %SYMBOLS\ ;
50500	       BEGIN
50600		RSY[1] := IFSY; RSY[2] := DOSY; RSY[3] := OFSY; RSY[4] := TOSY;
50700		RSY[5] := RELOP; RSY[6] := ADDOP; RSY[7] := ENDSY; RSY[8] := FORSY;
50800		RSY[9] := VARSY; RSY[10] := MULOP; RSY[11] := MULOP; RSY[12] := SETSY;
50900		RSY[13] := MULOP; RSY[14] := NOTSY; RSY[15] := THENSY;
51000		RSY[16] := ELSESY; RSY[17] := WITHSY; RSY[18] := GOTOSY;
51100		RSY[19] := LOOPSY; RSY[20] := CASESY; RSY[21] := TYPESY;
51200		RSY[22] := FILESY; RSY[23] := EXITSY; RSY[24] := BEGINSY;
51300		RSY[25] := UNTILSY; RSY[26] := WHILESY; RSY[27] := ARRAYSY;
51400		RSY[28] := CONSTSY; RSY[29] := LABELSY;
51500		RSY[30] := ALGOLSY; RSY[31] := COBOLSY;
51600		RSY[32] := EXTERNSY; RSY[33] := PASCALSY; RSY[34] := FORTRANSY;
51700		RSY[34] := RECORDSY; RSY[35]:= DOWNTOSY; RSY[36] := PACKEDSY;
51800		RSY[37] := OTHERSSY; RSY[38]:= REPEATSY; RSY[39] := FORTRANSY;
51900	(* 6 - add PROGRAM statement *)
52000	(* 56 - ADD INCLUDE *)
52100		RSY[40] := FORWARDSY; RSY[41] := PROGRAMSY; RSY[42] := INCLUDESY; RSY[43] := FUNCTIONSY;
52200		RSY[44] := PROCEDURESY; RSY[45] := INITPROCSY;
52300	
52400		SSY['A'] := OTHERSY; SSY['B'] := OTHERSY; SSY['C'] := OTHERSY;
52500		SSY['D'] := OTHERSY; SSY['E'] := OTHERSY; SSY['F'] := OTHERSY;
52600		SSY['G'] := OTHERSY; SSY['H'] := OTHERSY; SSY['I'] := OTHERSY;
52700		SSY['J'] := OTHERSY; SSY['K'] := OTHERSY; SSY['L'] := OTHERSY;
52800		SSY['M'] := OTHERSY; SSY['N'] := OTHERSY; SSY['O'] := OTHERSY;
52900		SSY['P'] := OTHERSY; SSY['Q'] := OTHERSY; SSY['R'] := OTHERSY;
53000		SSY['S'] := OTHERSY; SSY['T'] := OTHERSY; SSY['U'] := OTHERSY;
53100		SSY['V'] := OTHERSY; SSY['W'] := OTHERSY; SSY['X'] := OTHERSY;
53200		SSY['Y'] := OTHERSY; SSY['Z'] := OTHERSY; SSY['0'] := OTHERSY;
53300		SSY['1'] := OTHERSY; SSY['2'] := OTHERSY; SSY['3'] := OTHERSY;
53400		SSY['4'] := OTHERSY; SSY['5'] := OTHERSY; SSY['6'] := OTHERSY;
53500		SSY['7'] := OTHERSY; SSY['8'] := OTHERSY; SSY['9'] := OTHERSY;
53600		SSY['_'] := OTHERSY;
53700		SSY['+'] := ADDOP;   SSY['-'] := ADDOP;   SSY['*'] := MULOP;
53800		SSY['/'] := MULOP;   SSY['('] := LPARENT; SSY[')'] := RPARENT;
53900		SSY['$'] := OTHERSY; SSY['='] := RELOP;   SSY[' '] := OTHERSY;
54000		SSY[','] := COMMA;   SSY['.'] := PERIOD;  SSY[''''] := OTHERSY;
54100		SSY['['] := LBRACK;  SSY[']'] := RBRACK;  SSY[':'] := COLON;
54200		SSY['#'] := RELOP;   SSY['%'] := OTHERSY; SSY['!'] := ADDOP;
54300		SSY['&'] := MULOP;   SSY['^'] := ARROW;   SSY['\'] := OTHERSY;
54400		SSY['<'] := RELOP;   SSY['>'] := RELOP;   SSY['@'] := RELOP;
54500		SSY['"'] := RELOP;   SSY['?'] := NOTSY;   SSY[';'] := SEMICOLON;
54600	       END %SYMBOLS\ ;
54700	
54800	      INITPROCEDURE %OPERATORS\ ;
54900	       BEGIN
55000		ROP[ 1] := NOOP; ROP[ 2] := NOOP; ROP[ 3] := NOOP; ROP[ 4] := NOOP;
55100		ROP[ 5] := INOP; ROP[ 6] := OROP; ROP[ 7] := NOOP; ROP[ 8] := NOOP;
55200		ROP[ 9] := NOOP; ROP[10] := IDIV; ROP[11] := IMOD; ROP[12] := NOOP;
55300		ROP[13] :=ANDOP; ROP[14] := NOOP; ROP[15] := NOOP; ROP[16] := NOOP;
55400		ROP[17] := NOOP; ROP[18] := NOOP; ROP[19] := NOOP; ROP[20] := NOOP;
55500		ROP[21] := NOOP; ROP[22] := NOOP; ROP[23] := NOOP; ROP[24] := NOOP;
55600		ROP[25] := NOOP; ROP[26] := NOOP; ROP[27] := NOOP; ROP[28] := NOOP;
55700		ROP[29] := NOOP; ROP[30] := NOOP; ROP[31] := NOOP; ROP[32] := NOOP;
55800		ROP[33] := NOOP; ROP[34] := NOOP; ROP[35] := NOOP; ROP[36] := NOOP;
55900		ROP[37] := NOOP; ROP[38] := NOOP; ROP[39] := NOOP; ROP[40] := NOOP;
56000	(* 6 - add PROGRAM statement *)
56100	(* 56 - ADD INCLUDE *)
56200		ROP[41] := NOOP; ROP[42] := NOOP; ROP[43] := NOOP; ROP[44] := NOOP; ROP[45] := NOOP;
56300	
56400		SOP['+'] := PLUS; SOP['-'] := MINUS; SOP['*'] := MUL;  SOP['/'] := RDIV;
56500		SOP['='] := EQOP; SOP['#'] := NEOP;  SOP['!'] := OROP; SOP['&'] := ANDOP;
56600		SOP['<'] := LTOP; SOP['>'] := GTOP;  SOP['@'] := LEOP; SOP['"'] := GEOP;
56700		SOP[' '] := NOOP; SOP['$'] := NOOP; SOP['%'] := NOOP; SOP['('] := NOOP;
56800		SOP[')'] := NOOP; SOP[','] := NOOP; SOP['.'] := NOOP; SOP['0'] := NOOP;
56900		SOP['1'] := NOOP; SOP['2'] := NOOP; SOP['3'] := NOOP; SOP['4'] := NOOP;
57000		SOP['5'] := NOOP; SOP['6'] := NOOP; SOP['7'] := NOOP; SOP['8'] := NOOP;
57100		SOP['9'] := NOOP; SOP[':'] := NOOP; SOP[';'] := NOOP; SOP['?'] := NOOP;
57200		SOP['A'] := NOOP; SOP['B'] := NOOP; SOP['C'] := NOOP; SOP['D'] := NOOP;
57300		SOP['E'] := NOOP; SOP['F'] := NOOP; SOP['G'] := NOOP; SOP['H'] := NOOP;
57400		SOP['I'] := NOOP; SOP['J'] := NOOP; SOP['K'] := NOOP; SOP['L'] := NOOP;
57500		SOP['M'] := NOOP; SOP['N'] := NOOP; SOP['O'] := NOOP; SOP['P'] := NOOP;
57600		SOP['Q'] := NOOP; SOP['R'] := NOOP; SOP['S'] := NOOP; SOP['T'] := NOOP;
57700		SOP['U'] := NOOP; SOP['V'] := NOOP; SOP['W'] := NOOP; SOP['X'] := NOOP;
57800		SOP['Y'] := NOOP; SOP['Z'] := NOOP; SOP['['] := NOOP; SOP['\'] := NOOP;
57900		SOP[']'] := NOOP; SOP['^'] := NOOP; SOP['_'] := NOOP; SOP[''''] := NOOP;
58000	       END %OPERATORS\ ;
58100	
58200	      INITPROCEDURE %RECORDSIZES\;
58300	       BEGIN
58400		IDRECSIZE[TYPES]  := 5;
58500		IDRECSIZE[KONST]  := 6;
58600		IDRECSIZE[VARS]   := 6;
58700		IDRECSIZE[FIELD]  := 6;
58800		IDRECSIZE[PROC]   := 5;
58900		IDRECSIZE[FUNC]   := 8;
59000	(* 116 - define size of the new types for copyctp *)
59100		IDRECSIZE[PARAMS] := 5;
59200		IDRECSIZE[LABELT] := 6;
59300		STRECSIZE[SCALAR] := 2;
59400		STRECSIZE[SUBRANGE]:=4;
59500		STRECSIZE[POINTER]:= 2;
59600		STRECSIZE[POWER]  := 2;
59700		STRECSIZE[ARRAYS] := 3;
59800		STRECSIZE[RECORDS]:= 3;
59900		STRECSIZE[FILES]  := 2;
60000		STRECSIZE[TAGFWITHID]:=3;
60100		STRECSIZE[TAGFWITHOUTID] := 3;
60200		STRECSIZE[VARIANT] :=4
60300	       END;
60400	
60500	      INITPROCEDURE %ERRORMESSAGES\ ;
60600	       BEGIN
60700		ERRMESS15[ 1] := '":" expected   ';
60800		ERRMESS15[ 2] := '")" expected   ';
60900		ERRMESS15[ 3] := '"(" expected   ';
61000		ERRMESS15[ 4] := '"[" expected   ';
61100		ERRMESS15[ 5] := '"]" expected   ';
61200		ERRMESS15[ 6] := '";" expected   ';
61300		ERRMESS15[ 7] := '"=" expected   ';
61400		ERRMESS15[ 8] := '"," expected   ';
61500		ERRMESS15[ 9] := '":=" expected  ';
61600		ERRMESS15[10] := '"OF" expected  ';
61700		ERRMESS15[11] := '"DO" expected  ';
61800		ERRMESS15[12] := '"IF" expected  ';
61900		ERRMESS15[13] := '"END" expected ';
62000		ERRMESS15[14] := '"THEN" expected';
62100		ERRMESS15[15] := '"EXIT" expected';
62200		ERRMESS15[16] := 'Illegal symbol ';
62300		ERRMESS15[17] := 'No sign allowed';
62400		ERRMESS15[18] := 'Number expected';
62500		ERRMESS15[19] := 'Not implemented';
62600		ERRMESS15[20] := 'Error in type  ';
62700	(* 35 - new error - no longer need old one, so we replaced*)
62800		ERRMESS15[21] := 'Compiler error ';
62900		ERRMESS15[22] := '"." expected   ';
63000		ERRMESS15[23] := 'Error in factor';
63100		ERRMESS15[24] := 'Too many digits';
63200	
63300		ERRMESS20[ 1] := '"BEGIN" expected    ';
63400		ERRMESS20[ 2] := '"UNTIL" expected    ';
63500		ERRMESS20[ 3] := 'Error in options    ';
63600		ERRMESS20[ 4] := 'Constant too large  ';
63700		ERRMESS20[ 5] := 'Digit must follow   ';
63800		ERRMESS20[ 6] := 'Exponent too large  ';
63900		ERRMESS20[ 7] := 'Constant expected   ';
64000		ERRMESS20[ 8] := 'Simple type expected';
64100		ERRMESS20[ 9] := 'Identifier expected ';
64200		ERRMESS20[10] := 'Realtype not allowed';
64300		ERRMESS20[11] := 'Multidefined label  ';
64400		ERRMESS20[12] := 'Filename expected   ';
64500		ERRMESS20[13] := 'Set type expected   ';
64600		ERRMESS20[14] := 'Undeclared exitlabel';
64700		ERRMESS20[15] := 'Undeclared label    ';
64800	(* 6 - add error msg for illegal character *)
64900		ERRMESS20[16] := 'Illegal character   ';
65000	
65100		ERRMESS25[ 1] := '"TO"/"DOWNTO" expected   ';
65200		ERRMESS25[ 2] := '8 OR 9 in octal number   ';
65300		ERRMESS25[ 3] := 'Identifier not declared  ';
65400		ERRMESS25[ 4] := 'File not allowed here    ';
     
00100		ERRMESS25[ 5] := 'Integer constant expected';
00200		ERRMESS25[ 6] := 'Error in parameterlist   ';
00300		ERRMESS25[ 7] := 'Already forward declared ';
00400		ERRMESS25[ 8] := 'This format for real only';
00500		ERRMESS25[ 9] := 'Varianttype must be array';
00600		ERRMESS25[10] := 'Type conflict of operands';
00700		ERRMESS25[11] := 'Multidefined case label  ';
00800		ERRMESS25[12] := 'Octal for integer only   ';
00900		ERRMESS25[13] := 'Array index out of bounds';
01000	(* 26 - two new error messages for reset/rewrite/update *)
01100		ERRMESS25[14] := 'Must be array or record  ';
01200		ERRMESS25[15] := 'Must be at least 5 words ';
01300	(* 104 - error message for too much data for address space *)
01400		ERRMESS25[16] := 'Data won''t fit in memory ';
01500	
01600		ERRMESS30[ 1] := 'String constant is too long   ';
01700		ERRMESS30[ 2] := 'Identifier already declared   ';
01800		ERRMESS30[ 3] := 'Subrange bounds must be scalar';
01900		ERRMESS30[ 4] := 'Incompatible subrange types   ';
02000		ERRMESS30[ 5] := 'Incompatible with tagfieldtype';
02100		ERRMESS30[ 6] := 'Index type may not be integer ';
02200		ERRMESS30[ 7] := 'Type of variable is not array ';
02300		ERRMESS30[ 8] := 'Type of variable is not record';
02400		ERRMESS30[ 9] := 'No such field in this record  ';
02500		ERRMESS30[10] := 'Expression too complicated    ';
02600		ERRMESS30[11] := 'Illegal type of operand(s)    ';
02700		ERRMESS30[12] := 'Tests on equality allowed only';
02800		ERRMESS30[13] := 'Strict inclusion not allowed  ';
02900	(* 24 - CAN'T COMPARE RECORDS OR ARRAYS NOW *)
03000		ERRMESS30[14] := 'Structure comparison illegal  ';
03100		ERRMESS30[15] := 'Illegal type of expression    ';
03200		ERRMESS30[16] := 'Value of case label too large ';
03300		ERRMESS30[17] := 'Too many nested withstatements';
03400	
03500		ERRMESS35[ 1] := 'String constant contains "<CR><LF>"';
03600		ERRMESS35[ 2] := 'Basetype requires more than 72 bits';
03700		ERRMESS35[ 3] := 'Basetype must be scalar or subrange';
03800		ERRMESS35[ 4] := 'More than 12 files declared by user';
03900		ERRMESS35[ 5] := 'File as value parameter not allowed';
04000		ERRMESS35[ 6] := 'Procedure too long (too much code) ';
04100		ERRMESS35[ 7] := 'No packed structure allowed here   ';
04200		ERRMESS35[ 8] := 'Variant must belong to tagfieldtype';
04300		ERRMESS35[ 9] := 'Type of operand(s) must be boolean ';
04400		ERRMESS35[10] := 'Set element types not compatible   ';
04500		ERRMESS35[11] := 'Assignment to files not allowed    ';
04600		ERRMESS35[12] := 'Too many labels in this procedure  ';
04700		ERRMESS35[13] := 'Too many cases in case statement   ';
04800		ERRMESS35[14] := 'Control variable may not be formal ';
04900		ERRMESS35[15] := 'Illegal type of for-controlvariable';
05000		ERRMESS35[16] := 'Type of filecomponent must be char ';
05100		ERRMESS35[17] := 'Constant not in bounds of subrange ';
05200	(* 156 ftn^ := *)
05300		ERRMESS35[18] := 'Illegal when assigning to function ';
05400	
05500		ERRMESS40[ 1] := 'Identifier is not of appropriate class  ';
05600		ERRMESS40[ 2] := 'Tagfield type must be scalar or subrange';
05700		ERRMESS40[ 3] := 'Index type must be scalar or subrange   ';
05800		ERRMESS40[ 4] := 'Too many nested scopes of identifiers   ';
05900		ERRMESS40[ 5] := 'Pointer forward reference unsatisfied   ';
06000		ERRMESS40[ 6] := 'Previous declaration was not forward    ';
06100		ERRMESS40[ 7] := 'Type of variable must be file or pointer';
06200		ERRMESS40[ 8] := 'Missing corresponding variantdeclaration';
06300		ERRMESS40[ 9] := 'Too many variants in call of NEW (max 6)';
06400		ERRMESS40[10] := 'More than four errors in this sourceline';
06500		ERRMESS40[11] := 'No initialisation on records or files   ';
06600	(* 31 - new message *)
06700		ERRMESS40[12] := 'Assignment to func. must be in its body ';
06800		ERRMESS40[13] := 'Too many parameters (must fit in AC''s)  ';
06900	
07000		ERRMESS45[ 1] := 'Low bound may not be greater than high bound ';
07100		ERRMESS45[ 2] := 'Identifier or "CASE" expected in fieldlist   ';
07200		ERRMESS45[ 3] := 'Too many nested procedures and/or functions  ';
07300		ERRMESS45[ 4] := 'File declaration in procedures not allowed   ';
07400		ERRMESS45[ 5] := 'Missing result type in function declaration  ';
07500		ERRMESS45[ 6] := 'Assignment to formal function is not allowed ';
07600		ERRMESS45[ 7] := 'Index type is not compatible with declaration';
07700		ERRMESS45[ 8] := 'Error in type of standard procedure parameter';
07800		ERRMESS45[ 9] := 'Error in type of standard function parameter ';
07900		ERRMESS45[10] := 'Real and string tagfields not implemented    ';
08000		ERRMESS45[11] := 'Set element type must be scalar or subrange  ';
08100		ERRMESS45[12] := 'In initprocedure only assignments possible   ';
08200		ERRMESS45[13] := 'No constant or expression for VAR argument   ';
08300		ERRMESS45[14] := 'EXTERN declaration not allowed in procedures ';
08400		ERRMESS45[15] := 'Body of forward declared procedure missing   ';
08500	(* 24 - NEW ERROR MSG FOR LOC *)
08600		ERRMESS45[16] := 'Must be user-declared PASCAL proc. or func.  ';
08700	
08800		ERRMESS50[ 1] := 'Too many forward references of procedure entries  ';
08900		ERRMESS50[ 2] := 'Assignment to standard function is not allowed    ';
09000		ERRMESS50[ 3] := 'Parameter type does not agree with declaration    ';
09100		ERRMESS50[ 4] := 'Initialisation only by assignment of constants    ';
09200		ERRMESS50[ 5] := 'Label type incompatible with selecting expression ';
09300		ERRMESS50[ 6] := 'Statement must end with ";","END","ELSE"or"UNTIL" ';
09400		ERRMESS50[ 7] := 'Not allowed in initprocedures (packed structure?) ';
09500	(* 33 - PROGRAM *)
09600	        ERRMESS50[ 8] := 'File mentioned in PROGRAM statement not declared  ';
09700	(* 211 - better err msg *)
09800		ERRMESS50[ 9] := 'Variable mentioned in PROGRAM statement not a file';
09900	
10000		ERRMESS55[ 1] := 'Function result type must be scalar,subrange or pointer';
10100		ERRMESS55[ 2] := 'Forward decl. func:repetition of resulttype not allowed';
10200		ERRMESS55[ 3] := 'Forward decl.: repetition of parameter list not allowed';
10300		ERRMESS55[ 4] := 'Number of parameters does not agree with declaration   ';
10400		ERRMESS55[ 5] := 'Resulttype of parameter func. does not agree with decl.';
10500		ERRMESS55[ 6] := 'Selected expression must have type of control variable ';
10600	(* 124 - detect bad initproc *)
10700		ERRMESS55[ 7] := 'INITPROCEDURE can''t be within a procedure or function  ';
10800	       END %ERROR MESSAGES\ ;
10900	
11000	(* 105 - new mapping from lower case *)
11100	     initprocedure  %character mapping tables\ ;
11200		begin
11300		charmap[0B] := 0B;	charmap[1B] := 1B;	charmap[2B] := 2B;	charmap[3B] := 3B;
11400		charmap[4B] := 4B;	charmap[5B] := 5B;	charmap[6B] := 6B;	charmap[7B] := 7B;
11500		charmap[10B] := 10B;	charmap[11B] := 11B;	charmap[12B] := 12B;	charmap[13B] := 13B;
11600		charmap[14B] := 14B;	charmap[15B] := 15B;	charmap[16B] := 16B;	charmap[17B] := 17B;
11700		charmap[20B] := 20B;	charmap[21B] := 21B;	charmap[22B] := 22B;	charmap[23B] := 23B;
11800		charmap[24B] := 24B;	charmap[25B] := 25B;	charmap[26B] := 26B;	charmap[27B] := 27B;
11900		charmap[30B] := 30B;	charmap[31B] := 31B;	charmap[32B] := 32B;	charmap[33B] := 33B;
12000		charmap[34B] := 34B;	charmap[35B] := 35B;	charmap[36B] := 36B;	charmap[37B] := 37B;
12100		charmap[40B] := 40B;	charmap[41B] := 41B;	charmap[42B] := 42B;	charmap[43B] := 43B;
12200		charmap[44B] := 44B;	charmap[45B] := 45B;	charmap[46B] := 46B;	charmap[47B] := 47B;
12300		charmap[50B] := 50B;	charmap[51B] := 51B;	charmap[52B] := 52B;	charmap[53B] := 53B;
12400		charmap[54B] := 54B;	charmap[55B] := 55B;	charmap[56B] := 56B;	charmap[57B] := 57B;
12500		charmap[60B] := 60B;	charmap[61B] := 61B;	charmap[62B] := 62B;	charmap[63B] := 63B;
12600		charmap[64B] := 64B;	charmap[65B] := 65B;	charmap[66B] := 66B;	charmap[67B] := 67B;
12700		charmap[70B] := 70B;	charmap[71B] := 71B;	charmap[72B] := 72B;	charmap[73B] := 73B;
12800		charmap[74B] := 74B;	charmap[75B] := 75B;	charmap[76B] := 76B;	charmap[77B] := 77B;
12900		charmap[100B] := 100B;	charmap[101B] := 101B;	charmap[102B] := 102B;	charmap[103B] := 103B;
13000		charmap[104B] := 104B;	charmap[105B] := 105B;	charmap[106B] := 106B;	charmap[107B] := 107B;
13100		charmap[110B] := 110B;	charmap[111B] := 111B;	charmap[112B] := 112B;	charmap[113B] := 113B;
13200		charmap[114B] := 114B;	charmap[115B] := 115B;	charmap[116B] := 116B;	charmap[117B] := 117B;
13300		charmap[120B] := 120B;	charmap[121B] := 121B;	charmap[122B] := 122B;	charmap[123B] := 123B;
13400		charmap[124B] := 124B;	charmap[125B] := 125B;	charmap[126B] := 126B;	charmap[127B] := 127B;
13500		charmap[130B] := 130B;	charmap[131B] := 131B;	charmap[132B] := 132B;	charmap[133B] := 133B;
13600		charmap[134B] := 134B;	charmap[135B] := 135B;	charmap[136B] := 136B;	charmap[137B] := 137B;
13700		charmap[140B] := 140B;	charmap[141B] := 101B;	charmap[142B] := 102B;	charmap[143B] := 103B;
13800		charmap[144B] := 104B;	charmap[145B] := 105B;	charmap[146B] := 106B;	charmap[147B] := 107B;
13900		charmap[150B] := 110B;	charmap[151B] := 111B;	charmap[152B] := 112B;	charmap[153B] := 113B;
14000		charmap[154B] := 114B;	charmap[155B] := 115B;	charmap[156B] := 116B;	charmap[157B] := 117B;
14100		charmap[160B] := 120B;	charmap[161B] := 121B;	charmap[162B] := 122B;	charmap[163B] := 123B;
14200		charmap[164B] := 124B;	charmap[165B] := 125B;	charmap[166B] := 126B;	charmap[167B] := 127B;
14300		charmap[170B] := 130B;	charmap[171B] := 131B;	charmap[172B] := 132B;	charmap[173B] := 173B;
14400		charmap[174B] := 174B;	charmap[175B] := 175B;	charmap[176B] := 176B;	charmap[177B] := 177B;
14500	(* 140 - redid numbers to make it come in the same order as ASCII *)
14600		setmap[0B] := 0B;	setmap[1B] := 0B;	setmap[2B] := 0B;	setmap[3B] := 0B;
14700		setmap[4B] := 0B;	setmap[5B] := 0B;	setmap[6B] := 0B;	setmap[7B] := 0B;
14800		setmap[10B] := 0B;	setmap[11B] := 1B;	setmap[12B] := 0B;	setmap[13B] := 0B;
14900		setmap[14B] := 0B;	setmap[15B] := 0B;	setmap[16B] := 0B;	setmap[17B] := 0B;
15000		setmap[20B] := 0B;	setmap[21B] := 0B;	setmap[22B] := 0B;	setmap[23B] := 0B;
15100		setmap[24B] := 0B;	setmap[25B] := 0B;	setmap[26B] := 0B;	setmap[27B] := 0B;
15200		setmap[30B] := 0B;	setmap[31B] := 0B;	setmap[32B] := 0B;	setmap[33B] := 0B;
15300		setmap[34B] := 0B;	setmap[35B] := 0B;	setmap[36B] := 0B;	setmap[37B] := 0B;
15400		setmap[40B] := 2B;	setmap[41B] := 3B;	setmap[42B] := 4B;	setmap[43B] := 5B;
15500		setmap[44B] := 6B;	setmap[45B] := 7B;	setmap[46B] := 10B;	setmap[47B] := 11B;
15600		setmap[50B] := 12B;	setmap[51B] := 13B;	setmap[52B] := 14B;	setmap[53B] := 15B;
15700		setmap[54B] := 16B;	setmap[55B] := 17B;	setmap[56B] := 20B;	setmap[57B] := 21B;
15800		setmap[60B] := 22B;	setmap[61B] := 23B;	setmap[62B] := 24B;	setmap[63B] := 25B;
15900		setmap[64B] := 26B;	setmap[65B] := 27B;	setmap[66B] := 30B;	setmap[67B] := 31B;
16000		setmap[70B] := 32B;	setmap[71B] := 33B;	setmap[72B] := 34B;	setmap[73B] := 35B;
16100		setmap[74B] := 36B;	setmap[75B] := 37B;	setmap[76B] := 40B;	setmap[77B] := 41B;
16200		setmap[100B] := 42B;	setmap[101B] := 43B;	setmap[102B] := 44B;	setmap[103B] := 45B;
16300		setmap[104B] := 46B;	setmap[105B] := 47B;	setmap[106B] := 50B;	setmap[107B] := 51B;
16400		setmap[110B] := 52B;	setmap[111B] := 53B;	setmap[112B] := 54B;	setmap[113B] := 55B;
16500		setmap[114B] := 56B;	setmap[115B] := 57B;	setmap[116B] := 60B;	setmap[117B] := 61B;
16600		setmap[120B] := 62B;	setmap[121B] := 63B;	setmap[122B] := 64B;	setmap[123B] := 65B;
16700		setmap[124B] := 66B;	setmap[125B] := 67B;	setmap[126B] := 70B;	setmap[127B] := 71B;
16800		setmap[130B] := 72B;	setmap[131B] := 73B;	setmap[132B] := 74B;	setmap[133B] := 75B;
16900		setmap[134B] := 76B;	setmap[135B] := 77B;	setmap[136B] := 100B;	setmap[137B] := 101B;
17000		setmap[140B] := 102B;	setmap[141B] := 43B;	setmap[142B] := 44B;	setmap[143B] := 45B;
17100		setmap[144B] := 46B;	setmap[145B] := 47B;	setmap[146B] := 50B;	setmap[147B] := 51B;
17200		setmap[150B] := 52B;	setmap[151B] := 53B;	setmap[152B] := 54B;	setmap[153B] := 55B;
17300		setmap[154B] := 56B;	setmap[155B] := 57B;	setmap[156B] := 60B;	setmap[157B] := 61B;
17400		setmap[160B] := 62B;	setmap[161B] := 63B;	setmap[162B] := 64B;	setmap[163B] := 65B;
17500		setmap[164B] := 66B;	setmap[165B] := 67B;	setmap[166B] := 70B;	setmap[167B] := 71B;
17600		setmap[170B] := 72B;	setmap[171B] := 73B;	setmap[172B] := 74B;	setmap[173B] := 103B;
17700		setmap[174B] := 104B;	setmap[175B] := 105B;	setmap[176B] := 106B;	setmap[177B] := 107B;
17800		end; %character mapping tables\
17900	
18000	      %-------------------------------------------------------------------------------\
18100	
18200	(* 40 - make it restartable *)
18300	      procedure reinit;
18400		begin
18500		CHANTAB[1] := 0; CHANTAB[2] := 0; CHANTAB[3] := 0; CHANTAB[4] := 0;
18600	(* 65 - remove exit labels *)
18700		FWPTR := NIL; LASTBTP := NIL;  FGLOBPTR := NIL ; FILEPTR := NIL ;
18800		LOCALPFPTR:=NIL; EXTERNPFPTR:= NIL; GLOBTESTP := NIL; ERRMPTR := NIL;
18900	(* 24 - INITIALZE HEAP AND STACK *)
19000		HEAP := 0; STACK := 0;
19100	(* 124 - initialize CREF *)
19200	(* 125 - and REQFILE *)
19300		CREF := false;  reqfile := false;
19400	
19500		LISTCODE := FALSE; LOADNOPTR := TRUE; INITGLOBALS := FALSE ; RUNTMCHECK := TRUE;
19600	(* 157 - separate check for arith error *)
19700		ARITHCHECK := TRUE;
19800		TTYINUSE := TRUE; FOLLOWERROR := FALSE; ERRORINLINE := FALSE; RESETFLAG := TRUE;
19900	(* 172 - end of line *)
20000		TTYSEEEOL := FALSE;
20100		DP := TRUE; PRTERR := TRUE; ERRORFLAG := FALSE ; MAIN := TRUE;
20200		ENTRYDONE := FALSE; DEBUG := FALSE; DEBUGSWITCH := FALSE;
20300	(* 176 *)
20400	        comment_page := 0;
20500	(* 33 - PROGRAM *)
20600		FPROGFILE := NIL; LPROGFILE := NIL;
20700	
20800	(* 216 - variables high seg start *)
20900		highstart := 400000B;
21000		IC := HIGHSTART;     %START OF HIGHSEGMENT\
21100		LC := PROGRST;	     %START OF LOWSEGMENT AVAILABLE TO PROGRAM\
21200	(* 136 - listing format *)
21300		CHCNT := 0; LINECNT := 1; PAGECNT := 1; SUBPAGE := 0; CURLINE := 1;
21400		LASTLINE := -1; LASTPAGE := 0;
21500	(* 12 - initialize new variables for dynamic core *)
21600		LIBIX := 0; ERRINX := 0; LSTNEW := 0; NEWBND := 0;
21700		with pager.word1 do
21800		  begin instr:=0;ac:=0;indbit:=0;inxreg:=0;address:=0 end;
21900		pager.lhalf := 0; pager.rhalf := 0;
22000		debugentry.lastpageelem := pager;
22100		laststop := 0; lastpager := 0;
22200	(* 103 - changed type for idtree's *)
22300		debugentry.standardidtree := nil;
22400		debugentry.globalidtree := nil;
22500		filename := '          ';
22600		LIBRARY[PASCALSY].INORDER   := FALSE;
22700		LIBRARY[FORTRANSY].INORDER  := FALSE;
22800		LIBRARY[ALGOLSY].INORDER    := FALSE;
22900		LIBRARY[COBOLSY].INORDER    := FALSE;
23000		LIBRARY[PASCALSY].CALLED    := FALSE;
23100		LIBRARY[FORTRANSY].CALLED   := FALSE;
23200		LIBRARY[ALGOLSY].CALLED     := FALSE;
23300		LIBRARY[COBOLSY].CALLED     := FALSE;
23400	(* 105 - map lower case better *)
23500		setmapchain := 0;
23600		end;
23700	
23800	(* 136 - new listing format *)
23900	
24000	      procedure pagehead;
24100		  begin
24200		  page;
24300		  write(header,'  ',day,'     ',scandata^.relname);
24400		  if reqfile
24500		    then write('  ****Included file****');
24600		  write('     Page ',pagecnt:0);
24700		  if subpage > 0
24800		    then write('-',subpage:0);
24900		  writeln;
25000		  writeln;
25100		  curline := 1;
25200		  end;
25300	
25400	      procedure newline;
25500		begin
25600		writeln;	
25700		curline := curline+1;
25800		if curline > 53
25900		  then begin
26000		  subpage := subpage + 1;
26100		  pagehead;
26200		  end
26300		end;
26400	
26500	      PROCEDURE NEWPAGER;
26600	       BEGIN
26700		WITH PAGER, WORD1 DO
26800		 BEGIN
26900		  AC := PAGECNT DIV 16;
27000		  INXREG := PAGECNT MOD 16; ADDRESS := LASTPAGER;
27100		  LHALF := LASTLINE; RHALF := LASTSTOP;
27200		  LASTLINE := -1
27300		 END
27400	       END;
27500	
27600	(* 5 - reorganized printing somewhat for CREF *)
27700	(* The FILCOM is a bit misleading here, as global changes have been made *)
27800	      PROCEDURE BEGOFLINE;
27900		BEGIN
28000		IF CREF THEN WRITE(CHR(177B),'A');
28100		IF CHCNT > CHCNTMAX THEN CHCNT := CHCNTMAX;
28200		 IF LISTCODE
28300		 THEN
28400		   BEGIN
28500	(* 5 - more of the CREF change *)
28600		     IF BEGDP
28700		     THEN
28800		       BEGIN
28900			WRITE(BEGLC:6:O);
29000			 IF (BEGLC < PROGRST) OR (BEGLEVEL > 1)
29100			 THEN WRITE(' ')
29200			 ELSE WRITE('''')
29300		       END
29400		     ELSE WRITE(BEGIC:6:O,'''');
29500		    WRITE(' ':2)
29600		   END;
29700		 IF LINENR='-----'
29800		 THEN  WRITE(LINECNT:5)
29900		 ELSE  WRITE(LINENR) ;
30000		WRITE(' ':3);
30100	        END;
30200	
30300	      PROCEDURE WRITEBUFFER;
30400	       BEGIN
30500		 IF LISTCODE
30600		 THEN
30700		   BEGIN
30800	(* 5 - more CREF *)
30900		   IF CREF THEN WRITE(CHR(177B),'B'); BEGOFLINE;
31000	(* 136 - listing format *)
31100		    WRITE(BUFFER:CHCNT); FOR CHCNT := 1 TO 17 DO BUFFER[CHCNT] := ' '; CHCNT := 17;
31200		   newline;
31300		   END
31400	       END;
31500	
31600	      PROCEDURE GETNEXTLINE;
31700	       BEGIN
31800		 LOOP
31900		  GETLINENR(LINENR);
32000	         EXIT IF INPUT^ # CHR(14B);    %TEST END OF PAGE\
32100		   IF DEBUG AND (LASTLINE > -1)
32200		   THEN NEWPAGER;
32300	(* 136 - listing format *)
32400		  PAGECNT := PAGECNT + 1; SUBPAGE := 0;
32500		  pagehead;
32600	(* 137 - reset line to 1 on each page *)
32700		  linecnt := 1;
32800		  READLN;  %TO OVERREAD SECOND CARRIAGE RETURN IN PAGE MARK\
32900		 END;
33000		 IF CREF
33100		   THEN WRITE(CHR(177B),'B');
33200		 BEGIC:=IC;BEGLC:=LC;BEGDP:=DP;BEGLEVEL:=LEVEL;
33300	       END;
33400	
33500	(* 56 - needed for file switch *)
33600	      PROCEDURE BEGSTUFF;
33700		BEGIN
33800		IF CREF
33900		  THEN WRITE(CHR(177B),'B');
34000		BEGIC:=IC;BEGLC:=LC;BEGDP:=DP;BEGLEVEL:=LEVEL;
34100		CHCNT:=0
34200		END;
34300	
34400	(* 16 - DETECT UNEXPECTED EOF *)
34500	(* 41 - make restartable *)
34600	     PROCEDURE PASXIT(VAR A,B,C:FILE); EXTERN;
34700	(* 55 - ADD PROC'S FOR REQUIRE FILES *)
34800	     PROCEDURE PUSHF(VAR F:FILE;S:STRGARR;L:INTEGER); EXTERN;
34900	     PROCEDURE POPF(VAR F:FILE); EXTERN;
35000	(* 107 - moved declaration of analys so can be used several places *)
35100	     procedure analys(var f:file); extern;
35200	(* 112 - clrbfi when error detected *)
35300	     procedure clribf; extern;
35400	(* 141 - better detection of number overflow *)
35500	     function overflow:Boolean; extern;
35600	(* 155 - source file name *)
35700	     procedure curname(var f:file;var s:string); extern;
35800	
35900	(* 56 - SEPARATE OUT STUFF NEEDED FOR FILE SWITCH *)
36000	      PROCEDURE ENDSTUFF;
36100	      VAR
36200		I,K: INTEGER;
36300	       BEGIN
36400	(* 5 - more CREF *)
36500		BEGOFLINE;
36600	(* 136 - listing format *)
36700		WRITE(BUFFER:CHCNT); NEWLINE;
36800		 IF ERRORINLINE
36900		 THEN  %OUTPUT ERROR MESSAGES\
37000		   BEGIN
37100		     IF LISTCODE
37200		     THEN K := 11
37300		     ELSE K := 2;
37400		    WRITE(' ':K,'***** '); LISTCODE := FALSE;
37500		     IF LINENR = '-----'
37600		     THEN WRITE(TTY,LINECNT:5)
37700		     ELSE WRITE(TTY,LINENR);
37800		    WRITELN(TTY,' ':3,BUFFER:CHCNT); WRITE(TTY,'P*',PAGECNT:3,'** ');
37900	(* 5 - more CREF *)
38000		    FOR K:=1 TO CHCNT DO
38100		     IF BUFFER[K] = CHR(11B)
38200		      THEN ERRLINE[K] := CHR(11B);
38300	(* 136 - LISTING FORMAT *)
38400		    WRITE(ERRLINE :  CHCNT); WRITELN(TTY,ERRLINE : CHCNT); NEWLINE;
38500		    FOR K := 1 TO ERRINX DO
38600		    WITH ERRLIST[K] DO
38700		     BEGIN
38800		      WRITE(' ':15,ARW:1,'.',TIC,':  '); WRITE(TTY,ARW:1,'.',TIC,':  ');
38900		       IF ERRMPTR # NIL
39000		       THEN
39100			 BEGIN
39200			  ERRMPTR1 := ERRMPTR;
39300			  WHILE ERRMPTR1 # NIL DO
39400			  WITH ERRMPTR1^ DO
39500			   BEGIN
39600			     IF NMR = NUMBER
39700			     THEN
39800			       BEGIN
39900				 CASE FORM OF
40000				  C:
40100				     BEGIN
40200				      WRITE(STRING:10,' --> ');WRITE(TTY,STRING:10,' --> ')
40300				     END;
40400				  D:
40500				     BEGIN
40600				      WRITE(INTVAL:5,' --> ');WRITE(TTY,INTVAL:5,' --> ')
40700				     END
40800				 END;
40900				NUMBER := 0; ERRMPTR1 := NIL
41000			       END
41100			     ELSE ERRMPTR1 := NEXT
41200			   END
41300			 END;
41400		      I := NMR MOD 50;
41500		       CASE NMR DIV 50 OF
41600			3:
41700			   BEGIN
41800			    WRITE(ERRMESS15[I]); WRITE(TTY,ERRMESS15[I])
41900			   END;
42000			4:
42100			   BEGIN
42200			    WRITE(ERRMESS20[I]); WRITE(TTY,ERRMESS20[I])
42300			   END;
42400			5:
42500			   BEGIN
42600			    WRITE(ERRMESS25[I]); WRITE(TTY,ERRMESS25[I])
42700			   END;
42800			6:
42900			   BEGIN
43000			    WRITE(ERRMESS30[I]); WRITE(TTY,ERRMESS30[I])
43100			   END;
43200			7:
43300			   BEGIN
43400			    WRITE(ERRMESS35[I]); WRITE(TTY,ERRMESS35[I])
43500			   END;
43600			8:
43700			   BEGIN
43800			    WRITE(ERRMESS40[I]); WRITE(TTY,ERRMESS40[I])
43900			   END;
44000			9:
44100			   BEGIN
44200			    WRITE(ERRMESS45[I]); WRITE(TTY,ERRMESS45[I])
44300			   END;
44400			10:
44500			    BEGIN
44600			     WRITE(ERRMESS50[I]); WRITE(TTY,ERRMESS50[I])
44700			    END;
44800			11:
44900			    BEGIN
45000			     WRITE(ERRMESS55[I]); WRITE(TTY,ERRMESS55[I])
45100			    END
45200		       END;
45300	(* 136 - LISTING FORMAT *)
45400		      newline; WRITELN(TTY)
45500		     END;
45600	(* 26 - break not needed for TTY *)
45700		    ERRINX := 0; ERRORINLINE := FALSE;
45800		    FOR I := 1 TO CHCNT DO ERRLINE [I] := ' ';
45900		    ERRMPTR := NIL
46000		   END;
46100	(* 56 -SEPARATE OUT STUFF NEEDED FOR FILE SWITCH *)
46200	        END;
46300	
46400	      PROCEDURE ENDOFLINE(OKEOF:BOOLEAN);
46500		BEGIN
46600		ENDSTUFF;
46700	(* 16 - DETECT UNEXPECTED EOF *)
46800	        IF EOF(INPUT) AND NOT OKEOF
46900		  THEN BEGIN
47000	(* 136 - LISTING FORMAT *)
47100		  WRITE('Unexpected end of file'); NEWLINE;
47200		  WRITELN(TTY,'?  Unexpected end of file');
47300	(* 176 - error for unexpected EOF in a comment *)
47400	          if comment_page <> 0 then	(* we're in a comment *)
47500	                 begin
47600	                    write('Unterminated Comment at ',comment_page:0,
47700				  '/',comment_line:0); NEWLINE;
47800	                    writeln(tty,'?  Unterminated Comment at ',comment_page:0,
47900				    '/',comment_line:0)
48000			 end;
48100	(* 41 - make restartable *)
48200	(* 107 - abort creation of rel file on error *)
48300		  rewrite(outputrel);
48400	(* 112 - clrbfi when error *)
48500		  clribf;
48600	(* 125 - popf to be sure we get main file closed in reqfile *)
48700		  if reqfile
48800		    then begin
48900		    close(input);
49000		    popf(input)
49100		    end;
49200		  PASXIT(INPUT,OUTPUT,OUTPUTREL)
49300		  END;
49400		READLN;
49500	(* 147 - move incr linecnt here so first line of new page is 1 *)
49600		LINECNT := LINECNT + 1;
49700		 IF NOT EOF(INPUT)
49800		 THEN GETNEXTLINE;
49900	(* 136 - listing format *)
50000	        CHCNT := 0
50100	       END  %ENDOFLINE\ ;
50200	
50300	      PROCEDURE ERROR(FERRNR: INTEGER);
50400	      VAR
50500		LPOS,LARW : INTEGER;
50600	       BEGIN
50700		 IF NOT FOLLOWERROR
50800		 THEN
50900		   BEGIN
51000		    ERRORFLAG := TRUE ;
51100		     IF ERRINX >= MAXERR
51200		     THEN
51300		       BEGIN
51400			ERRLIST[MAXERR].NMR := 410; ERRINX := MAXERR
51500		       END
51600		     ELSE
51700		       BEGIN
51800			ERRINX := ERRINX + 1;
51900		        WITH ERRLIST[ERRINX] DO BEGIN NMR := FERRNR; TIC := '^' END
52000		       END;
52100		    FOLLOWERROR := TRUE; ERRORINLINE := TRUE;
52200		    IF (FERRNR # 215)
52300		    AND (FERRNR # 356)
52400		    AND (FERRNR # 405)
52500		    AND (FERRNR # 464)
52600		    THEN
52700		     IF EOLN(INPUT)
52800		     THEN ERRLINE [CHCNT] := '^'
52900		     ELSE ERRLINE [CHCNT-1] := '^'
53000		    ELSE ERRLIST[ERRINX].TIC := ' ';
53100		     IF ERRINX > 1
53200		     THEN
53300		      WITH ERRLIST [ ERRINX-1] DO
53400		       BEGIN
53500			LPOS := POS; LARW := ARW
53600		       END;
53700		    WITH ERRLIST [ERRINX] DO
53800		     BEGIN
53900		      POS := CHCNT;
54000		       IF ERRINX = 1
54100		       THEN ARW := 1
54200		       ELSE
54300			 IF LPOS = CHCNT
54400			 THEN ARW := LARW
54500			 ELSE ARW := LARW + 1
54600		     END;
54700		   END;
54800	       END %ERROR\ ;
54900	
55000	      PROCEDURE ERRORWITHTEXT ( FERRNR: INTEGER; FTEXT: ALFA ) ;
55100	       BEGIN
55200		ERROR(FERRNR); NEWZ(ERRMPTR1,C);
55300		WITH ERRMPTR1^ DO
55400		 BEGIN
55500		  NUMBER := FERRNR; STRING := FTEXT;
55600		  NEXT := ERRMPTR
55700		 END;
55800		ERRMPTR := ERRMPTR1
55900	       END %ERROR WITH TEXT\ ;
56000	
56100	      PROCEDURE INSYMBOL;
56200		%READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS
56300		 DESCRIPTION IN THE GLOBAL VARIABLES SY, OP, ID, VAL AND LGTH\
56400	(* 114 - prevent recursive comment scanning *)
56500	      LABEL 2;
56600	      CONST
56700	(* 210 - allow 9 digit hex numbers *)
56800		hexmax = 9;
56900		DIGMAX = 12; MAX8 =  37777777777B;
57000		TEST8 =  40000000000B;
57100		MIN8 = 400000000000B;
57200	(* 142 - better real number scanning *)
57300		MAX10 = 3435973836; {maximum number, sans last digit}
57400		MAX16 = 17777777777B;
57500		MAXEXP = 35;
57600	      type
57700	(* 43 - allow 12 digit octal no. *)
57800		numconv=record case Boolean of
57900			true:(oct:packed array[1:digmax]of 0..7);
58000			false:(int:integer)
58100			       end;
58200	(* 210 - allow 9 digit hex numbers *)
58300		hexconv=record case Boolean of
58400			true:(hex:packed array[1..hexmax] of 0..15);
58500			false:(int:integer)
58600			       end;
58700	      VAR
58800	(* 133 - make real numbers be read exactly *)
58900		I,K,ASCALE,SCALE,EXP,IVAL: INTEGER;
59000		RVAL,R,FAC: REAL; STRINGTOOLONG,SIGN: BOOLEAN;
59100		DIGIT: ARRAY [1..DIGMAX] OF 0..9;
59200		STRING: ARRAY [1..STRGLGTH] OF CHAR;
59300		LVP: CSP;
59400	(* 43 - allow 12 digit octal no. *)
59500		nc:numconv;
59600	(* 210 - allow 9 digit hex numbers *)
59700		hc:hexconv;
59800	
59900		PROCEDURE NEXTCH;
60000		 BEGIN
60100		   IF EOLN(INPUT)
60200		   THEN CH := ' '
60300		   ELSE
60400		     BEGIN
60500		      %READ(CH);\  CH := INPUT^; GET(INPUT); %THIS CHANGE SAVES 3 INSTRUCTIONS AT RUN-TIME\
60600		      CHCNT := CHCNT + 1;
60700		       IF CHCNT <= CHCNTMAX
60800		       THEN BUFFER[CHCNT] := CH
60900	(* 3 - map lower case to upper.  Need separate NEXTCH for strings now,
61000	       since we don't do mapping there. *)
61100		     END;
61200	(* 105 - improve lower case mapping *)
61300		   ch := chr(charmap[ord(ch)]);
61400		 END;
61500	
61600		PROCEDURE NEXTSTRCH;
61700		 BEGIN
61800		   IF EOLN(INPUT)
61900		   THEN CH := ' '
62000		   ELSE
62100		     BEGIN
62200		      CH := INPUT^; GET(INPUT);
62300		      CHCNT := CHCNT + 1;
62400		       IF CHCNT <= CHCNTMAX
62500		       THEN BUFFER[CHCNT] := CH
62600		     END
62700		 END;
62800	
62900		PROCEDURE OPTIONS;
63000		VAR
63100		  LCH : CHAR; LSWITCH : BOOLEAN;
63200		 BEGIN
63300		   REPEAT
63400		    NEXTCH; LCH := CH;
63500		     IF NOT (CH IN ['\','*'])
63600		     THEN NEXTCH;
63700		     IF NOT (CH IN ['+','-'])
63800	(* 24 - S AND H FOR STACK AND HEAP *)
63900	(* 33 - version *)
64000	(* 216 - variable start of hiseg *)
64100		     THEN IF (LCH IN ['P','H','S','V']) AND (CH = ':')
64200			THEN BEGIN
64300			     NEXTCH;
64400			     INSYMBOL;
64500			     IF SY # INTCONST
64600				THEN ERROR(203)
64700	(* 24 - S AND H FOR STACK AND HEAP *)
64800				ELSE BEGIN
64900	(* 33 - version *)
65000				IF LCH IN ['H','S']
65100				  THEN BEGIN
65200				  IF (VAL.IVAL MOD 1000B) = 0
65300				    THEN VAL.IVAL := VAL.IVAL -1;
65400				  VAL.IVAL := (VAL.IVAL DIV 1000B)*1000B + 777B;
65500				  END;
65600	(* 216 - settable high seg *)
65700				  IF LCH IN ['H','S','P']
65800				    THEN IF (VAL.IVAL < 0) OR (VAL.IVAL > MAXADDR)
65900				  	   THEN ERROR(203);
66000			          IF LCH = 'S'
66100			            THEN STACK := VAL.IVAL
66200	(* 33 - version *)
66300				  ELSE IF LCH = 'H'
66400				    THEN HEAP := VAL.IVAL
66500	(* 216 - variable start of hi seg *)
66600				  ELSE IF LCH = 'P'
66700				    THEN BEGIN
66800				    IF RESETFLAG
66900				      THEN BEGIN 
67000				      HIGHSTART := VAL.IVAL;
67100				      IC := HIGHSTART
67200				      END
67300				    END
67400				  ELSE VERSION.WORD := VAL.IVAL
67500				  END
67600			     END
67700			ELSE ERROR(203)
67800		     ELSE
67900		       BEGIN
68000			LSWITCH := CH = '+';
68100	(* 157 - use CASE instead of IF nest *)
68200			CASE LCH OF
68300			  'L':  LISTCODE := LSWITCH;
68400			  'T':  IF RESETFLAG THEN TTYINUSE := LSWITCH;
68500			  'M':  IF RESETFLAG THEN MAIN := LSWITCH;
68600			  'C':  BEGIN RUNTMCHECK := LSWITCH; ARITHCHECK := LSWITCH END;
68700			  'A':  ARITHCHECK := LSWITCH;
68800			  'Z':  ZERO := LSWITCH;
68900			  'D':  BEGIN
69000				    DEBUGSWITCH := LSWITCH;
69100	(* 36 - allow us to reset debug at beginning *)
69200				    if resetflag
69300				      then debug := lswitch
69400				      else IF LSWITCH
69500				        THEN DEBUG := TRUE
69600				END
69700			  END
69800		       END;
69900		     IF EOLN(INPUT)
70000	(* 16 - EOF *)
70100		     THEN ENDOFLINE(FALSE);
70200		     IF NOT ((CH IN ['\','*']) OR (LCH = 'H'))
70300		     THEN NEXTCH
70400		   UNTIL CH # ','
70500		 END   %OPTIONS\ ;
70600	
70700	(* 1 - reorganized a bit here, mainly to improve comment scanning *)
70800		PROCEDURE NEWCH;
70900		BEGIN
71000	(* 16 - EOF *)
71100		  IF EOLN(INPUT) THEN ENDOFLINE(FALSE);
71200		  NEXTCH
71300		END;
71400	
71500		PROCEDURE SCANCOMMENT(STOPCH:CHAR);
71600		BEGIN
71700	(* 176 - error for unexpected EOF in a comment *)
71800		  comment_page := pagecnt; { pagecnt had better not be 0 }
71900		  comment_line := linecnt;
72000		  NEWCH;
72100		  IF CH='$' THEN OPTIONS;
72200	(* 105 - curly brackets are now comments *)
72300		  if (stopch = '\') or (stopch = '}')
72400		    then while ch # stopch do newch
72500		  ELSE REPEAT WHILE CH#'*' DO NEWCH; NEXTCH UNTIL CH=STOPCH;
72600	(* 176 - error for unexpected EOF in a comment *)
72700		  comment_page := 0;
72800	(* 114 - prevent deep recursion in comment scanning *)
72900		  NEWCH;
73000		END;
73100	
73200	       BEGIN    2:
73300		%INSYMBOL\
73400	          WHILE (CH = ' ') OR (ORD(CH) = 11B) DO
73500		   BEGIN
73600		     IF EOLN(INPUT)
73700	(* 16 - EOF *)
73800		     THEN ENDOFLINE(FALSE);
73900		    NEXTCH;
74000		   END;
74100	(* 1 - code removed here for comments.  Handled better elsewhere *)
74200		 CASE CH OF
74300		  'A','B','C','D','E','F','G','H','I',
74400		  'J','K','L','M','N','O','P','Q','R',
74500		  'S','T','U','V','W','X','Y','Z':
74600						   BEGIN
74700						    K := 0 ; ID := '          ';
74800						     REPEAT
74900						       IF K < ALFALENG
75000						       THEN
75100							 BEGIN
75200							  K := K + 1; ID[K] := CH
75300							 END ;
75400						      NEXTCH
75500						     UNTIL  NOT (CH IN LETTERSDIGITSORLEFTARROW);
75600						    FOR I := FRW[K] TO FRW[K+1] - 1 DO
75700						     IF RW[I] = ID
75800						     THEN
75900						       BEGIN
76000							SY := RSY[I]; OP := ROP[I]; GOTO 1
76100						       END;
76200						    SY := IDENT; OP := NOOP;
76300	1:
76400						   END;
76500		  '0','1','2','3','4','5','6','7','8','9':
76600							   BEGIN
76700	(* 141 - better way to check overflow *)
76800							    if overflow then; {clear old errors}
76900							    SY := INTCONST; OP := NOOP;
77000	(* 64 - non-loc goto *)
77100							    id := '          ';
77200							    I := 0;
77300							     REPEAT
77400							      I := I + 1;
77500							      if i <= alfaleng
77600								then id[i] := ch;
77700							       IF I <= DIGMAX
77800	(* 142 - better real scanning *)
77900							       THEN DIGIT[I] := ORD(CH) - ORD('0');
78000							      NEXTCH
78100							     UNTIL  NOT (CH IN DIGITS);
78200							    IVAL := 0;
78300							     IF CH = 'B'
78400							     THEN
78500							       BEGIN
78600	(* 43 - allow 12 digit octal no. *)
78700	(* 142 - better real number scanning *)
78800								if i > digmax
78900								  then begin
79000								  error(174);
79100								  i := digmax
79200								  end;
79300								nc.int:=0;
79400								FOR K := 1 TO I DO
79500								     IF DIGIT[K] IN [8,9]
79600								     THEN ERROR(252)
79700								     else nc.oct[k+digmax-i]:=digit[k];
79800								val.ival := nc.int;
79900								NEXTCH
80000							       END
80100							     ELSE
80200							       BEGIN
80300	(* 142 - better real number scanning *)
80400							       scale := 0;
80500								FOR K := 1 TO I DO
80600								  if scale > 0
80700								    then scale := scale + 1
80800								  else if ival < max10
80900								    then ival := 10*ival + digit[k]
81000								  else if (ival = max10) and (digit[k] <= 7)
81100								    then ival := 10*ival + digit[k]
81200								  else scale := scale + 1;
81300								 IF CH = '.'
81400								 THEN
81500								   BEGIN
81600								    NEXTCH;
81700								     IF CH = '.'
81800								     THEN CH := ':'
81900								     ELSE
     
00100								       BEGIN
00200	(* 142 - better real scanning *)
00300									 SY := REALCONST;
00400									 IF  NOT (CH IN DIGITS)
00500									 THEN ERROR(205)
00600									 ELSE
00700									   REPEAT
00800								           if scale > 0
00900								             then scale := scale + 1
01000								           else if ival < max10
01100								             then ival := 10*ival + (ord(ch)-ord('0'))
01200								           else if (ival = max10) and (ch <= '7')
01300								             then ival := 10*ival + (ord(ch)-ord('0'))
01400								           else scale := scale + 1;
01500									    SCALE := SCALE - 1; NEXTCH
01600									   UNTIL  NOT (CH IN DIGITS);
01700								       END
01800								   END;
01900								 IF CH = 'E'
02000								 THEN
02100								   BEGIN
02200	(* 142 - better real scan *)
02300								    sy := realconst;
02400								    NEXTCH;
02500								    SIGN := CH='-';
02600								     IF (CH='+') OR (CH='-')
02700								     THEN NEXTCH;
02800								    EXP := 0;
02900								     IF  NOT (CH IN DIGITS)
03000								     THEN ERROR(205)
03100								     ELSE
03200								       REPEAT
03300									EXP := 10*EXP + (ORD(CH) - ORD('0'));
03400									NEXTCH
03500								       UNTIL  NOT (CH IN DIGITS);
03600								     IF SIGN
03700								     THEN SCALE := SCALE - EXP
03800								     ELSE SCALE := SCALE + EXP;
03900								   END;
04000	(* 142 - better real scan *)
04100								 if sy = realconst
04200								 then begin
04300								 rval := ival;
04400								 IF SCALE # 0
04500								 THEN
04600								   BEGIN
04700	(* 113 - reorganized to handle exact fractions exactly *)
04800								    FAC := 10.0;
04900								    ASCALE := ABS(SCALE);
05000	(* 141 - prevent overflow for exp > 32 *)
05100								     LOOP
05200								       IF ODD(ASCALE)
05300								       THEN if scale > 0
05400									 then rval := rval*FAC
05500									 else rval := rval/fac;
05600								      ASCALE := ASCALE DIV 2;
05700								     EXIT IF ASCALE=0;
05800								      FAC := SQR(FAC);
05900								     END;
06000	(* 141 - better overflow error handling *)
06100								   IF OVERFLOW
06200								     THEN BEGIN
06300								     ERROR(206);
06400								     RVAL := 0.0
06500								     END;
06600								   END;
06700	(* 142 - better real scanning *)
06800								 newz(lvp,reel);
06900								 lvp^.rval := rval;
07000								 val.valp := lvp
07100								 end {real}
07200								else {integer}
07300								 if scale = 0
07400								   then VAL.IVAL := IVAL
07500								   else begin
07600								     error(204);
07700								     val.ival := 0
07800								     end;
07900							       END
08000							   END;
08100		  '"':
08200		       BEGIN
08300			SY := INTCONST; OP := NOOP; IVAL := 0; I := 0; hc.int := 0;
08400			NEXTCH;
08500			WHILE CH IN HEXADIGITS DO
08600			 BEGIN
08700			     i := i + 1;
08800			     if i <= hexmax then
08900				 IF CH IN DIGITS
09000				     THEN  digit[i] := 16*IVAL + ORD(CH) - ORD('0')
09100				     ELSE  digit[i] := 16*IVAL + ORD(CH) - 67B;
09200			     NEXTCH
09300			 END;
09400			if i > hexmax then
09500			    begin
09600				error(174);
09700				i := hexmax
09800			    end;
09900			for k := 1 to i do
10000			    hc.hex[k+hexmax-i] := digit[k];
10100			VAL.IVAL := hc.int;
10200		       END;
10300		  '''':
10400			BEGIN
10500			 LGTH := 0; SY := STRINGCONST;	OP := NOOP;STRINGTOOLONG := FALSE;
10600			  REPEAT
10700			    REPEAT
10800	(* 3 - different NEXTCH so don't map lower case, etc. *)
10900			     NEXTSTRCH;
11000			      IF LGTH < STRGLGTH
11100			      THEN
11200				BEGIN
11300				 LGTH := LGTH + 1; STRING[LGTH] := CH
11400				END
11500			      ELSE STRINGTOOLONG := TRUE
11600			    UNTIL (EOLN(INPUT)) OR (CH = '''');
11700			    IF STRINGTOOLONG
11800			    THEN ERROR(301);
11900			    IF EOLN(INPUT)  AND  (CH#'''')
12000			    THEN ERROR(351)
12100	(* 3 - different NEXTCH so don't map lower case, etc. *)
12200	(* 6 - don't use nextstrch for char after end of string[caused loop] *)
12300			    ELSE NEXTCH  %this is embedded ' or char after string\
12400			  UNTIL CH # '''';
12500			 LGTH := LGTH - 1;   %NOW LGTH = NR OF CHARS IN STRING\
12600			  IF LGTH = 1
12700			  THEN VAL.IVAL := ORD(STRING[1])
12800			  ELSE
12900			    BEGIN
13000			     NEWZ(LVP,STRG:LGTH);
13100			     WITH LVP^ DO
13200			      BEGIN
13300			       SLGTH := LGTH;
13400			       FOR I := 1 TO LGTH DO SVAL[I] := STRING[I]
13500			      END;
13600			     VAL.VALP := LVP
13700			    END
13800			END;
13900		  ':':
14000		       BEGIN
14100			OP := NOOP; NEXTCH;
14200			 IF CH = '='
14300			 THEN
14400			   BEGIN
14500			    SY := BECOMES; NEXTCH
14600			   END
14700			 ELSE SY := COLON
14800		       END;
14900		  '.':
15000		       BEGIN
15100			OP := NOOP; NEXTCH;
15200			 IF CH = '.'
15300			 THEN
15400			   BEGIN
15500			    SY := COLON; NEXTCH
15600			   END
15700			 ELSE SY := PERIOD
15800		       END;
15900		  '?','*','&','+','-','!','\',
16000	(* 1 - / now handled elsewhere *)
16100		  '@','#','=',
16200		  ')','[',']',',',';','^','_','$':
16300						   BEGIN
16400						    SY := SSY[CH]; OP := SOP[CH];
16500						    NEXTCH
16600						   END;
16700	
16800		  '(':
16900		       BEGIN
17000			NEXTCH;
17100	(* 1 - improved comment scanning *)
17200			IF CH='*' THEN BEGIN SCANCOMMENT(')'); GOTO 2 END
17300			ELSE BEGIN SY := LPARENT; OP := NOOP END
17400		       END;
17500	
17600	
17700		  '{':
17800		        BEGIN SCANCOMMENT('}'); GOTO 2 END;
17900		  '%':
18000			BEGIN SCANCOMMENT('\'); GOTO 2 END;
18100	
18200		  '/':
18300			BEGIN
18400			  NEXTCH;
18500			  IF CH='*' THEN BEGIN SCANCOMMENT('/'); GOTO 2 END
18600			  ELSE BEGIN SY := MULOP; OP := RDIV END
18700			END;
18800	
18900	
19000		  '<','>':
19100			   BEGIN
19200			    SY := SSY[CH]; OP := SOP[CH]; NEXTCH;
19300			     IF CH = '='
19400			     THEN
19500			       BEGIN
19600				 IF OP = LTOP
19700				 THEN OP := LEOP
19800				 ELSE OP := GEOP;
19900				NEXTCH
20000			       END
20100	(* 6 - allow <> for not equals *)
20200			     ELSE IF (CH = '>') AND (OP = LTOP)
20300			       THEN
20400				BEGIN
20500				OP := NEOP;
20600				NEXTCH
20700				END
20800			   END;
20900	(* 6 - add error msg in case of illegal character *)
21000		  OTHERS:
21100			BEGIN
21200			ERROR(216);
21300			NEWCH;
21400			INSYMBOL
21500			END
21600		 END %CASE\
21700	       END %INSYMBOL\ ;
21800	
21900	      PROCEDURE ENTERID(FCP: CTP);
22000		%ENTER ID POINTED AT BY FCP INTO THE NAME-TABLE,
22100		 WHICH ON EACH DECLARATION LEVEL IS ORGANISED AS
22200		 AN UNBALANCED BINARY TREE\
22300	      VAR
22400		NAM: ALFA; LCP, LCP1: CTP; LLEFT: BOOLEAN;
22500	       BEGIN
22600		NAM := FCP^.NAME;
22700	(* 5 - CREF *)
22800	        IF CREF
22900		  THEN WRITE(CHR(1B),CHR(21),NAM,' ',DISPLAY[TOP].BLKNAME,CHR(2B));
23000		LCP := DISPLAY[TOP].FNAME;
23100		 IF LCP = NIL
23200		 THEN
23300		  DISPLAY[TOP].FNAME := FCP
23400		 ELSE
23500		   BEGIN
23600		     REPEAT
23700		      LCP1 := LCP;
23800		       IF LCP^.NAME <= NAM
23900		       THEN
24000			 BEGIN
24100			   IF LCP^.NAME = NAM
24200			   THEN ERROR(302) %NAME CONFLICT\;
24300			  LCP := LCP^.RLINK; LLEFT := FALSE
24400			 END
24500		       ELSE
24600			 BEGIN
24700			  LCP := LCP^.LLINK; LLEFT := TRUE
24800			 END
24900		     UNTIL LCP = NIL;
25000		     IF LLEFT
25100		     THEN LCP1^.LLINK := FCP
25200		     ELSE LCP1^.RLINK := FCP
25300		   END;
25400		WITH FCP^ DO
25500		 BEGIN
25600		  LLINK := NIL; RLINK := NIL; SELFCTP := NIL
25700		 END
25800	       END %ENTERID\ ;
25900	
26000	      PROCEDURE SEARCHSECTION(FCP: CTP; VAR FCP1: CTP);
26100		%TO FIND RECORD FIELDS AND FORWARD DECLARED PROCEDURE ID'S
26200		 --> PROCEDURE PROCEDUREDECLARATION
26300		 --> PROCEDURE SELECTOR\
26400	       BEGIN
26500		WHILE FCP # NIL DO
26600		WITH FCP^ DO
26700		 BEGIN
26800		   IF NAME = ID
26900		   THEN GOTO 1;
27000		   IF NAME < ID
27100		   THEN FCP := RLINK
27200		   ELSE FCP := LLINK
27300		 END;
27400	1:
27500		FCP1 := FCP
27600	       END %SEARCHSECTION\ ;
27700	
27800	      PROCEDURE SEARCHID(FIDCLS: SETOFIDS; VAR FCP: CTP);
27900	      VAR
28000		LCP: CTP;
28100	       BEGIN
28200		FOR DISX := TOP DOWNTO 0 DO
28300		 BEGIN
28400		  LCP := DISPLAY[DISX].FNAME;
28500		  WHILE LCP # NIL DO
28600		  WITH LCP^ DO
28700		   IF NAME = ID
28800		   THEN
28900		     IF KLASS IN FIDCLS
29000		     THEN GOTO 1
29100		     ELSE
29200		       BEGIN
29300			 IF PRTERR
29400			 THEN ERROR(401);
29500	(* 170 - fix error handling for forwards *)
29600			GOTO 2
29700		       END
29800		   ELSE
29900		     IF NAME < ID
30000		     THEN
30100		      LCP := RLINK
30200		     ELSE LCP := LLINK
30300		 END;
30400	2:	 LCP := NIL;  {Use NIL if don't find something better below}
30500	(* 5 - save some info for so CREF will know the block name *)
30600		 DISX := TOP; %IF FORWARD, WILL BE IN THIS BLOCK\
30700	(* 114 - use only real block names *)
30800	(* 116 - more elegant way to do this *)
30900	         WHILE DISPLAY[DISX].OCCUR <> BLCK DO
31000		   DISX := DISX - 1;
31100		%SEARCH NOT SUCCSESSFUL; SUPPRESS ERROR MESSAGE IN CASE
31200		 OF FORWARD REFERENCED TYPE ID IN POINTER TYPE DEFINITION
31300		 --> PROCEDURE SIMPLETYPE\
31400		 IF PRTERR
31500		 THEN
31600		   BEGIN
31700		    ERROR(253);
31800		    %TO AVOID RETURNING NIL, REFERENCE AN ENTRY
31900		     FOR AN UNDECLARED ID OF APPROPRIATE CLASS
32000		     --> PROCEDURE ENTERUNDECL\
32100		     IF TYPES IN FIDCLS
32200		     THEN LCP := UTYPPTR
32300		     ELSE
32400		       IF VARS IN FIDCLS
32500		       THEN LCP := UVARPTR
32600		       ELSE
32700			 IF FIELD IN FIDCLS
32800			 THEN LCP := UFLDPTR
32900			 ELSE
33000			   IF KONST IN FIDCLS
33100			   THEN LCP := UCSTPTR
33200			   ELSE
33300			     IF PROC IN FIDCLS
33400			     THEN LCP := UPRCPTR
33500	(* 64 - non-loc gotos *)
33600			     ELSE IF FUNC IN FIDCLS
33700				THEN LCP := UFCTPTR
33800				ELSE LCP := ULBLPTR;
33900		   END;
34000	1:
34100	(* 5 - CREF *)
34200		IF CREF
34300		  THEN WRITE(CHR(1B),CHR(21),ID,' ',DISPLAY[DISX].BLKNAME);
34400		FCP := LCP
34500	       END %SEARCHID\ ;
34600	
34700	      PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN,FMAX: INTEGER);
34800		%GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE\
34900		%ASSUME (FSP # NIL) AND (FSP^.FORM <= SUBRANGE) AND (FSP # INTPTR)
35000		 AND  NOT COMPTYPES(REALPTR,FSP)\
35100	       BEGIN
35200		WITH FSP^ DO
35300		 IF FORM = SUBRANGE
35400		 THEN
35500		   BEGIN
35600		    FMIN := MIN.IVAL; FMAX := MAX.IVAL
35700		   END
35800		 ELSE
35900		   BEGIN
36000		    FMIN := 0;
36100		     IF FSP = CHARPTR
36200		     THEN FMAX := 177B
36300		     ELSE
36400		       IF FCONST # NIL
36500		       THEN
36600			FMAX := FCONST^.VALUES.IVAL
36700		       ELSE FMAX := 0
36800		   END
36900	       END %GETBOUNDS\ ;
37000	
37100	(* 6 - move error stuff outside BLOCK so PROGSTAT can use it *)
37200		PROCEDURE SKIPIFERR(FSYINSYS:SETOFSYS; FERRNR:INTEGER; FSKIPSYS: SETOFSYS);
37300		VAR
37400		  I,OLDCHCNT,OLDLINECNT : INTEGER;
37500		 BEGIN
37600		   IF NOT (SY IN FSYINSYS)
37700		   THEN
37800		     BEGIN
37900		      ERROR(FERRNR);
38000		      OLDLINECNT := LINECNT; OLDCHCNT := CHCNT;
38100		      WHILE NOT (SY IN FSKIPSYS OR FSYINSYS) DO
38200		       BEGIN
38300			 IF OLDLINECNT # LINECNT
38400			 THEN OLDCHCNT := 1;
38500			FOR I := OLDCHCNT TO CHCNT-1 DO
38600			 IF I <= CHCNTMAX
38700			 THEN ERRLINE [I] := '*';
38800			OLDCHCNT := CHCNT; OLDLINECNT := LINECNT; ERRORINLINE := TRUE;
38900			INSYMBOL
39000		       END;
39100		      %SKIP INPUT STRING UNTIL RELEVANT SYMBOL FOUND\
39200		     END;
39300		  FOLLOWERROR := FALSE
39400		 END;
39500	
39600		PROCEDURE IFERRSKIP(FERRNR: INTEGER; FSYS: SETOFSYS);
39700		 BEGIN
39800		  SKIPIFERR(FSYS,FERRNR,FSYS)
39900		 END;
40000	
40100		PROCEDURE ERRANDSKIP(FERRNR: INTEGER; FSYS: SETOFSYS);
40200		 BEGIN
40300		  SKIPIFERR([ ],FERRNR,FSYS)
40400		 END;
40500	
40600	(* 6 - add PROGRAM statement *)
40700	      PROCEDURE PROGSTAT;
40800	(* 34 - allow list of entry point names *)
40900		  VAR STSYM,ENDSYM:SYMBOL;
41000	        BEGIN
41100		IF SY=PROGRAMSY
41200		  THEN
41300		    BEGIN
41400	(* 34 - allow entry point names *)
41500		    IF MAIN
41600		      THEN BEGIN STSYM:=LPARENT; ENDSYM := RPARENT END
41700		      ELSE BEGIN STSYM:=COMMA; ENDSYM := SEMICOLON END;
41800		    INSYMBOL;
41900		    IF SY # IDENT THEN ERROR(209);
42000	(* 33 NO LONGER NEED ENTRY *)
42100		    FILENAME := ID;
42200		    INSYMBOL;
42300	(* 34 - DIFFERENT SYNTAX FOR ENTRY POINTS *)
42400		    IF SY = STSYM
42500		     THEN BEGIN
42600		      REPEAT
42700		      INSYMBOL;
42800		      IF NOT (SY = IDENT)
42900			THEN ERROR(209);
43000	(* 33 - USE FILE NAMES *)
43100		      NEWZ(NPROGFILE);
43200		      NPROGFILE^.FILID := ID;
43300		      NPROGFILE^.NEXT := NIL;
43400		      IF FPROGFILE = NIL
43500			THEN BEGIN
43600			FPROGFILE := NPROGFILE;
43700			LPROGFILE := NPROGFILE
43800			END
43900		       ELSE BEGIN
44000			LPROGFILE^.NEXT := NPROGFILE;
44100			LPROGFILE := NPROGFILE
44200			END;
44300		      INSYMBOL;
44400	(* 61 - allow +* in tops20 *)
44500	(* 144 - allow this stuff in tops10, too *)
44600		      if (sy=colon) and main
44700			then begin
44800			insymbol;
44900			while sy in [addop,mulop,relop] do
45000			  begin
45100			  if (op = mul) and (not tops10)
45200			    then nprogfile^.wild := true
45300			  else if op = plus
45400			    then nprogfile^.newgen := true
45500			  else if op = minus
45600			    then nprogfile^.oldfile := true
45700	(* 64 - input:/ *)
45800			  else if op = rdiv
45900			    then nprogfile^.interact := true
46000	(* 172 - new EOLN treatment *)
46100			  else if op = neop
46200			    then nprogfile^.seeeol := true
46300			  else error(158);
46400			  insymbol
46500			  end;
46600			end;
46700	(* 34 - DIFFERENT SYNTAX FOR ENTRY POINTS *)
46800		      IFERRSKIP(158,[ENDSYM,COMMA])
46900		      UNTIL SY=ENDSYM;
47000		     IF MAIN THEN INSYMBOL
47100		     END;
47200	(* 21 - Allow null file list in prog. statement *)
47300		    IFERRSKIP(156,[SEMICOLON]);
47400		    INSYMBOL
47500		    END
47600		END;
47700	
47800	      PROCEDURE BLOCK(FPROCP: CTP; FSYS,LEAVEBLOCKSYS: SETOFSYS);
47900	      VAR
48000	(* 56 - add reqfile for require files *)
48100	(* 125 - reqfile moved *)
48200	(* 65 - remove exit labels *)
48300		LSY: SYMBOL;
48400	(* 136 - listing format *)
48500		ORIGLINENR:PACKED ARRAY[1:5]OF CHAR;
48600		ORIGPAGECNT,ORIGSUBPAGE,ORIGLINECNT:INTEGER; 
48700		ORIGPAGE:PAGEELEM; ORIGCH:CHAR;
48800	(* 24 - testpacked no longer needed *)
48900		LCPAR: ADDRRANGE;%SAVES LOCATION FROM WHERE
49000				  LOCAL AREAS ARE SET TO ZERO\
49100		HEAPMARK,GLOBMARK: INTEGER;
49200		FORWPTR : CTP;		 %TEST FOR FORWORD DECLARED PROCEDURES\
49300	
49400	
49500		PROCEDURE CONSTANT(FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU);
49600		VAR
49700		  LSP,LSP1: STP; LCP: CTP; SIGN: (NONE,POS,NEG);
49800		 BEGIN
49900		  LSP := NIL; FVALU.IVAL := 0;
50000		  SKIPIFERR(CONSTBEGSYS,207,FSYS);
50100		   IF SY IN CONSTBEGSYS
50200		   THEN
50300		     BEGIN
50400		       IF SY = STRINGCONST
50500		       THEN
50600			 BEGIN
50700			   IF LGTH = 1
50800			   THEN LSP := CHARPTR
50900			   ELSE
51000			     IF LGTH = ALFALENG
51100			     THEN LSP := ALFAPTR
51200			     ELSE
51300			       BEGIN
51400				NEWZ(LSP,ARRAYS); NEWZ(LSP1,SUBRANGE);
51500				WITH LSP^ DO
51600				 BEGIN
51700				  AELTYPE := CHARPTR; INXTYPE := LSP1;
51800				  SIZE := (LGTH+4) DIV 5; ARRAYPF := TRUE;
51900	(* 211 - make PASDDT able to see this *)
52000				  BITSIZE := BITMAX; SELFSTP := NIL
52100				 END;
52200				WITH LSP1^ DO
52300				 BEGIN
52400				  SIZE := 1; BITSIZE := BITMAX;
52500				  MIN.IVAL := 1; MAX.IVAL := LGTH; RANGETYPE  := NIL
52600				 END
52700			       END;
52800			  FVALU := VAL; INSYMBOL
52900			 END
53000		       ELSE
53100			 BEGIN
53200			  SIGN := NONE;
53300			   IF (SY = ADDOP) AND (OP IN [PLUS,MINUS])
53400			   THEN
53500			     BEGIN
53600			       IF OP = PLUS
53700			       THEN SIGN := POS
53800			       ELSE SIGN := NEG;
53900			      INSYMBOL
54000			     END;
54100			   IF SY = IDENT
54200			   THEN
54300			     BEGIN
54400			      SEARCHID([KONST],LCP);
54500			      WITH LCP^ DO
54600			       BEGIN
54700				LSP := IDTYPE; FVALU := VALUES
54800			       END;
54900			       IF SIGN # NONE
55000			       THEN
55100				 IF LSP = INTPTR
55200				 THEN
55300				   BEGIN
55400				     IF SIGN = NEG
55500				     THEN FVALU.IVAL := -FVALU.IVAL
55600				   END
55700				 ELSE
55800				   IF LSP = REALPTR
55900				   THEN
56000				     BEGIN
56100				       IF SIGN = NEG
56200				       THEN
56300					FVALU.VALP^.RVAL := -FVALU.VALP^.RVAL
56400				     END
56500				   ELSE ERROR(167);
56600			      INSYMBOL;
56700			     END
56800			   ELSE
56900			     IF SY = INTCONST
57000			     THEN
57100			       BEGIN
57200				 IF SIGN = NEG
57300				 THEN VAL.IVAL := -VAL.IVAL;
57400				LSP := INTPTR; FVALU := VAL; INSYMBOL
57500			       END
57600			     ELSE
57700			       IF SY = REALCONST
57800			       THEN
57900				 BEGIN
58000				   IF SIGN = NEG
58100				   THEN VAL.VALP^.RVAL := -VAL.VALP^.RVAL;
58200				  LSP := REALPTR; FVALU := VAL; INSYMBOL
58300				 END
58400			       ELSE ERRANDSKIP(168,FSYS)
58500			 END;
58600		      IFERRSKIP(166,FSYS);
58700		     END;
58800		  FSP := LSP
58900		 END %CONSTANT\ ;
59000	
59100		FUNCTION COMPTYPES(FSP1,FSP2: STP) : BOOLEAN;
59200		  %DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND FSP2 ARE COMPATIBLE\
59300		VAR
59400		  NXT1,NXT2: CTP; COMP: BOOLEAN; LMIN,LMAX,I: INTEGER;
59500		  LTESTP1,LTESTP2: TESTP;
59600		 BEGIN
59700		   IF FSP1 = FSP2
59800		   THEN COMPTYPES := TRUE
59900		   ELSE
60000		     IF (FSP1 # NIL) AND (FSP2 # NIL)
60100		     THEN
60200		       IF FSP1^.FORM = FSP2^.FORM
60300		       THEN
60400			 CASE FSP1^.FORM OF
60500			  SCALAR:
60600				 COMPTYPES := FALSE;
60700				 % IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE
60800				  NOT RECOGNIZED TO BE COMPATIBLE\
60900			  SUBRANGE:
61000				   COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2^.RANGETYPE);
61100			  POINTER:
61200				   BEGIN
61300				    COMP := FALSE; LTESTP1 := GLOBTESTP; LTESTP2 := GLOBTESTP;
61400				    WHILE LTESTP1 # NIL DO
61500				    WITH LTESTP1^ DO
61600				     BEGIN
61700				       IF (ELT1 = FSP1^.ELTYPE) AND (ELT2 = FSP2^.ELTYPE)
61800				       THEN COMP := TRUE;
61900				      LTESTP1 := LASTTESTP
62000				     END;
62100				     IF NOT COMP
62200				     THEN
62300				       BEGIN
62400					NEWZ(LTESTP1);
62500					WITH LTESTP1^ DO
62600					 BEGIN
62700					  ELT1 := FSP1^.ELTYPE;
62800					  ELT2 := FSP2^.ELTYPE;
62900					  LASTTESTP := GLOBTESTP
63000					 END;
63100					GLOBTESTP := LTESTP1; COMP := COMPTYPES(FSP1^.ELTYPE,FSP2^.ELTYPE)
63200				       END;
63300				    COMPTYPES := COMP; GLOBTESTP := LTESTP2
63400				   END;
63500			  POWER:
     
00100				COMPTYPES := COMPTYPES(FSP1^.ELSET,FSP2^.ELSET);
00200			  ARRAYS:
00300				  BEGIN
00400				   GETBOUNDS (FSP1^.INXTYPE,LMIN,LMAX);
00500				   I := LMAX-LMIN;
00600				   GETBOUNDS (FSP2^.INXTYPE,LMIN,LMAX);
00700				   COMPTYPES := COMPTYPES(FSP1^.AELTYPE,FSP2^.AELTYPE)
00800				   AND (FSP1^.ARRAYPF = FSP2^.ARRAYPF) AND ( I = LMAX - LMIN ) ;
00900				  END;
01000				 %ALTERNATIVES: -- ADD A THIRD BOOLEAN TERM: INDEXTYPE MUST
01100				  BE COMPATIBLE. MAY GIVE TROUBLE FOR ASSIGNMENT OF STRINGCONSTANTS
01200				  -- ADD A FOURTH BOOLEAN TERM: LOWBOUNDS MUST
01300				  BE THE SAME\
01400			  RECORDS:
01500				   BEGIN
01600				    NXT1 := FSP1^.FSTFLD; NXT2 := FSP2^.FSTFLD; COMP := TRUE;
01700				    WHILE (NXT1 # NIL) AND (NXT2 # NIL) DO
01800				     BEGIN
01900				      COMP := COMPTYPES(NXT1^.IDTYPE,NXT2^.IDTYPE) AND COMP;
02000				      NXT1 := NXT1^.NEXT; NXT2 := NXT2^.NEXT
02100				     END;
02200				    COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL)
02300				    AND (FSP1^.RECVAR = NIL) AND (FSP2^.RECVAR = NIL)
02400				   END;
02500				  %IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE
02600				   IFF NO VARIANTS OCCUR\
02700			  FILES:
02800				COMPTYPES := COMPTYPES(FSP1^.FILTYPE,FSP2^.FILTYPE)
02900			 END %CASE\
03000		       ELSE %FSP1^.FORM # FSP2^.FORM\
03100			 IF FSP1^.FORM = SUBRANGE
03200			 THEN
03300			  COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2)
03400			 ELSE
03500			   IF FSP2^.FORM = SUBRANGE
03600			   THEN
03700			    COMPTYPES := COMPTYPES(FSP1,FSP2^.RANGETYPE)
03800			   ELSE COMPTYPES := FALSE
03900		     ELSE COMPTYPES := TRUE
04000		 END %COMPTYPES\ ;
04100	
04200		FUNCTION STRING(FSP: STP) : BOOLEAN;
04300		 BEGIN
04400		  STRING := FALSE;
04500		   IF FSP # NIL
04600		   THEN
04700		     IF FSP^.FORM = ARRAYS
04800		     THEN
04900		       IF COMPTYPES(FSP^.AELTYPE,CHARPTR)
05000		       THEN STRING := TRUE
05100		 END %STRING\ ;
05200	
05300		PROCEDURE TYP(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE;
05400			      VAR FBITSIZE: BITRANGE);
05500		VAR
05600	(* 173 - internal files *)
05700		  FHASFILE,LHASFILE:BOOLEAN;
05800		  LSP,LSP1,LSP2: STP; OLDTOP: DISPRANGE; LCP: CTP;
05900		  LSIZE,DISPL: ADDRRANGE; I,LMIN,LMAX: INTEGER;
06000		  PACKFLAG: BOOLEAN; LBITSIZE: BITRANGE;
06100		  LBTP: BTP; BITCOUNT:INTEGER;
06200	
06300	(* 104 - check structure sizes *)
06400		  function checksize(i:addrrange):addrrange;
06500		    begin
06600	(* 216 - settable high start *)
06700		    if abs(i) < highstart
06800		      then checksize := i
06900		      else begin
07000		      error(266);
07100		      checksize := 0
07200		      end
07300		    end;
07400	
07500		  FUNCTION LOG2(FVAL: INTEGER): BITRANGE;
07600		  VAR
07700		    E: BITRANGE; H: INTEGER;
07800		   BEGIN
07900		    E :=0;
08000		    H := 1;
08100	(* 135 - numbers > 200 000 000 000B didn't work. *)
08200		      {There are two complicating issues here:
08300			1 - 200 000 000 000 is the highest power of 2, so the
08400			  loop below goes forever for them
08500			2 - the caller has often added 1, thus making 377 777 777 777
08600			  into 400 000 000 000, which is negative!!
08700			In both of these cases we want to return 35}
08800		    IF (FVAL-1) >= 200000000000B 
08900		      THEN E := 35
09000		      ELSE REPEAT
09100		        E := E + 1; H := H * 2
09200		       UNTIL FVAL <= H;
09300		    LOG2 := E
09400		   END %LOG2\;
09500	
09600		  PROCEDURE SIMPLETYPE(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE;
09700				       VAR FBITSIZE: BITRANGE);
09800		  VAR
09900		    LSP,LSP1: STP; LCP,LCP1: CTP; TTOP: DISPRANGE;
10000		    LCNT: INTEGER; LVALU: VALU; LBITSIZE: BITRANGE;
10100		   BEGIN
10200		    FSIZE := 1;
10300		    SKIPIFERR(SIMPTYPEBEGSYS,208,FSYS);
10400		     IF SY IN SIMPTYPEBEGSYS
10500		     THEN
10600		       BEGIN
10700			 IF SY = LPARENT
10800			 THEN
10900			   BEGIN
11000			    TTOP := TOP;   %DECL. CONSTS LOCAL TO INNERMOST BLOCK\
11100			    WHILE DISPLAY[TOP].OCCUR # BLCK DO TOP := TOP - 1;
11200			    NEWZ(LSP,SCALAR,DECLARED);
11300			    LSP^.SIZE := 1;
11400			    LCP1 := NIL; LCNT := 0;
11500			     REPEAT
11600			      INSYMBOL;
11700			       IF SY = IDENT
11800			       THEN
11900				 BEGIN
12000				  NEWZ(LCP,KONST);
12100				  WITH LCP^ DO
12200				   BEGIN
12300				    NAME := ID; IDTYPE := LSP; NEXT := LCP1;
12400				    VALUES.IVAL := LCNT;
12500				   END;
12600				  ENTERID(LCP);
12700				  LCNT := LCNT + 1;
12800				  LCP1 := LCP; INSYMBOL
12900				 END
13000			       ELSE ERROR(209);
13100			      IFERRSKIP(166,FSYS OR [COMMA,RPARENT])
13200			     UNTIL SY # COMMA;
13300			    TOP := TTOP;
13400			    WITH LSP^ DO
13500			     BEGIN
13600			      SELFSTP := NIL; FCONST := LCP1; BITSIZE := LOG2(LCNT)
13700			     END;
13800			     IF SY = RPARENT
13900			     THEN INSYMBOL
14000			     ELSE ERROR(152)
14100			   END
14200			 ELSE
14300			   BEGIN
14400			     IF SY = IDENT
14500			     THEN
14600			       BEGIN
14700				SEARCHID([TYPES,KONST],LCP);
14800				INSYMBOL;
14900				 IF LCP^.KLASS = KONST
15000				 THEN
15100				   BEGIN
15200				    NEWZ(LSP,SUBRANGE);
15300				    WITH LSP^, LCP^ DO
15400				     BEGIN
15500				      SELFSTP := NIL; RANGETYPE := IDTYPE;
15600				       IF STRING(RANGETYPE)
15700				       THEN
15800					 BEGIN
15900					  ERROR(303); RANGETYPE := NIL
16000					 END;
16100				      MIN := VALUES; SIZE := 1
16200				     END;
16300				     IF SY = COLON
16400				     THEN INSYMBOL
16500				     ELSE ERROR(151);
16600				    CONSTANT(FSYS,LSP1,LVALU);
16700				    WITH LSP^ DO
16800				     BEGIN
16900				      MAX := LVALU;
17000				       IF MIN.IVAL<0
17100				       THEN BITSIZE := BITMAX
17200				       ELSE BITSIZE := LOG2(MAX.IVAL + 1);
17300				       IF RANGETYPE # LSP1
17400				       THEN ERROR(304)
17500				     END;
17600				   END
17700				 ELSE
17800				   BEGIN
17900				    LSP := LCP^.IDTYPE;
18000				     IF LSP # NIL
18100				     THEN FSIZE := LSP^.SIZE;
18200				   END
18300			       END %SY = IDENT\
18400			     ELSE
18500			       BEGIN
18600				NEWZ(LSP,SUBRANGE);
18700				CONSTANT(FSYS OR [COLON],LSP1,LVALU);
18800				 IF STRING(LSP1)
18900				 THEN
19000				   BEGIN
19100				    ERROR(303); LSP1 := NIL
19200				   END;
19300				WITH LSP^ DO
19400				 BEGIN
19500				  RANGETYPE := LSP1; MIN := LVALU; SIZE := 1
19600				 END;
19700				 IF SY = COLON
19800				 THEN INSYMBOL
19900				 ELSE ERROR(151);
20000				CONSTANT(FSYS,LSP1,LVALU);
20100				WITH LSP^ DO
20200				 BEGIN
20300				  SELFSTP := NIL; MAX := LVALU;
20400				   IF MIN.IVAL<0
20500				   THEN BITSIZE := BITMAX
20600				   ELSE BITSIZE := LOG2(MAX.IVAL + 1);
20700				   IF RANGETYPE # LSP1
20800				   THEN ERROR(304)
20900				 END
21000			       END;
21100			     IF LSP # NIL
21200			     THEN
21300			      WITH LSP^ DO
21400			       IF FORM = SUBRANGE
21500			       THEN
21600				 IF RANGETYPE # NIL
21700				 THEN
21800				   IF RANGETYPE = REALPTR
21900				   THEN
22000	(* 106 - make subranges of real illegal *)
22100				     error(210)
22200				   ELSE
22300				     IF MIN.IVAL > MAX.IVAL
22400				     THEN ERROR(451)
22500			   END;
22600			FSP := LSP;
22700			 IF LSP#NIL
22800			 THEN FBITSIZE := LSP^.BITSIZE
22900			 ELSE FBITSIZE := 0;
23000			IFERRSKIP(166,FSYS)
23100		       END
23200		     ELSE
23300		       BEGIN
23400			FSP := NIL; FBITSIZE := 0
23500		       END
23600		   END %SIMPLETYPE\ ;
23700	
23800	(* 173 - internal files *)
23900		  PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FRECVAR: STP; VAR FFIRSTFIELD: CTP; VAR FHASFILE:BOOLEAN);
24000		  VAR
24100		    LHASFILE:BOOLEAN;
24200		    LCP,LCP1,NXT,NXT1: CTP; LSP,LSP1,LSP2,LSP3,LSP4,TAGSP: STP;
24300		    MINSIZE,MAXSIZE,LSIZE: ADDRRANGE; LVALU: VALU;
24400		    LBITSIZE: BITRANGE;
24500		    LBTP: BTP; MINBITCOUNT:INTEGER;
24600		    LID : ALFA ;
24700	
24800		    PROCEDURE RECSECTION( VAR FCP: CTP; FSP: STP );
24900		     BEGIN
25000		       IF NOT PACKFLAG OR (LSIZE > 1)  OR  (LBITSIZE = 36)
25100		       THEN
25200			 BEGIN
25300			   IF BITCOUNT > 0
25400			   THEN
25500			     BEGIN
25600			      DISPL := DISPL + 1; BITCOUNT := 0
25700			     END;
25800			  WITH FCP^ DO
25900			   BEGIN
26000			    IDTYPE := FSP; FLDADDR := DISPL;
26100			    PACKF := NOTPACK; FCP := NEXT;
26200			    DISPL := DISPL + LSIZE
26300			   END
26400			 END
26500		       ELSE %PACK RECORD-SECTION\
26600	
26700			 BEGIN
26800			  BITCOUNT := BITCOUNT + LBITSIZE;
26900			   IF BITCOUNT>BITMAX
27000			   THEN
27100			     BEGIN
27200			      DISPL := DISPL + 1;
27300			      BITCOUNT := LBITSIZE
27400			     END;
27500			   IF (LBITSIZE = 18)  AND  (BITCOUNT IN [18,36])
27600			   THEN
27700			     BEGIN
27800			      WITH FCP^ DO
27900			       BEGIN
28000				IDTYPE := FSP;
28100				FLDADDR := DISPL;
28200				 IF BITCOUNT = 18
28300				 THEN PACKF := HWORDL
28400				 ELSE PACKF := HWORDR;
28500				FCP := NEXT
28600			       END
28700			     END
28800			   ELSE
28900			     BEGIN
29000			      NEWZ(LBTP,RECORDD);
29100			      WITH LBTP^.BYTE DO
29200			       BEGIN
29300				SBITS := LBITSIZE;
29400				PBITS := BITMAX - BITCOUNT;
29500				RELADDR := DISPL;
29600				DUMMYBIT := 0;
29700				IBIT := 0;
29800				IREG := TAC
29900			       END;
30000			      WITH LBTP^ DO
30100			       BEGIN
30200				LAST := LASTBTP; FIELDCP := FCP
30300			       END;
30400			      LASTBTP := LBTP;
30500			      WITH FCP^ DO
30600			       BEGIN
30700				IDTYPE := FSP;
30800				PACKF := PACKK;
30900				FCP := NEXT
31000			       END
31100			     END
31200			 END
31300		     END % RECSECTION \ ;
31400		   BEGIN
31500	(* 173 - internal files *)
31600	(* 166 - In case of null record declaration, FRECVAR was getting junk.
31700		I don't understand the logic of this routine, but initializing
31800		it to NIL seems safe enough *)
31900		    NXT1 := NIL; LSP := NIL; FRECVAR := NIL; FHASFILE := FALSE;
32000	(* 21 - Allow null fieldlist (added FSYS OR to next statement) *)
32100	(* 65 - allow extra semicolons *)
32200		    while sy=semicolon do
32300			insymbol;
32400		    SKIPIFERR(FSYS OR [IDENT,CASESY],452,FSYS);
32500		    WHILE SY = IDENT DO
32600		     BEGIN
32700		      NXT := NXT1;
32800		       LOOP
32900			 IF SY = IDENT
33000			 THEN
33100			   BEGIN
33200			    NEWZ(LCP,FIELD);
33300			    WITH LCP^ DO
33400			     BEGIN
33500			      NAME := ID; IDTYPE := NIL; NEXT := NXT
33600			     END;
33700			    NXT := LCP;
33800			    ENTERID(LCP);
33900			    INSYMBOL
34000			   END
34100			 ELSE ERROR(209);
34200			SKIPIFERR([COMMA,COLON],166,FSYS OR [SEMICOLON,CASESY]);
34300		       EXIT IF SY # COMMA;
34400			INSYMBOL
34500		       END;
34600		       IF SY = COLON
34700		       THEN INSYMBOL
34800		       ELSE ERROR(151);
34900		      TYP(FSYS OR [CASESY,SEMICOLON],LSP,LSIZE,LBITSIZE);
35000		       IF LSP # NIL
35100		       THEN
35200	(* internal files *)
35300			 IF (LSP^.FORM = FILES) OR LSP^.HASFILE
35400			 THEN FHASFILE := TRUE;
35500		      WHILE NXT # NXT1 DO    RECSECTION(NXT,LSP); %RESERVES SPACE FOR ONE RECORDSECTION \
35600		      NXT1 := LCP;
35700	(* 64 - allow null entry *)
35800		       WHILE SY = SEMICOLON DO
35900			 BEGIN
36000			  INSYMBOL;
36100			  SKIPIFERR(FSYS OR [IDENT,CASESY,SEMICOLON],452,FSYS)
36200			 END
36300		     END %WHILE\;
36400		    NXT := NIL;
36500		    WHILE NXT1 # NIL DO
36600		    WITH NXT1^ DO
36700		     BEGIN
36800		      LCP := NEXT; NEXT := NXT; NXT := NXT1; NXT1 := LCP
36900		     END;
37000		    FFIRSTFIELD := NXT;
37100		     IF SY = CASESY
37200		     THEN
37300		       BEGIN
37400			LCP:=NIL;  %POSSIBILITY OF NO TAGFIELDIDENTIFIER\
37500			INSYMBOL;
37600			 IF SY = IDENT
37700			 THEN
37800			   BEGIN
37900			    LID := ID ;
38000			    INSYMBOL ;
38100			     IF (SY#COLON) AND (SY#OFSY)
38200			     THEN
38300			       BEGIN
38400				ERROR(151) ;
38500				ERRANDSKIP(160,FSYS OR [LPARENT])
38600			       END
38700			     ELSE
38800			       BEGIN
38900				 IF SY = COLON
39000				 THEN
39100				   BEGIN
39200				    NEWZ(LSP,TAGFWITHID);
39300				    NEWZ(LCP,FIELD) ;
39400				    WITH LCP^ DO
39500				     BEGIN
39600				      NAME := LID ; IDTYPE := NIL ; NEXT := NIL
39700				     END ;
39800				    ENTERID(LCP) ;
39900				    INSYMBOL ;
40000				     IF SY # IDENT
40100				     THEN
40200				       BEGIN
40300					ERRANDSKIP(209,FSYS OR [LPARENT]) ; GOTO 1
40400				       END
40500				     ELSE
40600				       BEGIN
40700					LID := ID ;
40800					INSYMBOL ;
40900					 IF SY # OFSY
41000					 THEN
41100					   BEGIN
41200					    ERRANDSKIP(160,FSYS OR [LPARENT]) ; GOTO 1
41300					   END
41400				       END
41500				   END
41600				 ELSE NEWZ(LSP,TAGFWITHOUTID) ;
41700				WITH LSP^ DO
41800				 BEGIN
41900				  SIZE:= 0 ; SELFSTP := NIL ;
42000				  FSTVAR := NIL;
42100				   IF FORM=TAGFWITHID
42200				   THEN TAGFIELDP:=NIL
42300				   ELSE TAGFIELDTYPE := NIL
42400				 END;
42500				FRECVAR := LSP;
42600				ID := LID ;
42700				SEARCHID([TYPES],LCP1) ;
42800				TAGSP := LCP1^.IDTYPE;
42900				 IF TAGSP # NIL
43000				 THEN
43100				   IF (TAGSP^.FORM <= SUBRANGE) OR STRING(TAGSP)
43200				   THEN
43300				     BEGIN
43400				       IF COMPTYPES(REALPTR,TAGSP)
43500				       THEN ERROR(210)
43600				       ELSE
43700					 IF STRING(TAGSP)
43800					 THEN ERROR(169);
43900				      WITH LSP^ DO
44000				       BEGIN
44100					BITSIZE := TAGSP^.BITSIZE;
44200					 IF FORM = TAGFWITHID
44300					 THEN TAGFIELDP := LCP
44400					 ELSE TAGFIELDTYPE := TAGSP;
44500				       END;
44600				       IF LCP # NIL
44700				       THEN
44800					 BEGIN
44900					  LBITSIZE :=TAGSP^.BITSIZE;
45000					  LSIZE := TAGSP^.SIZE;
45100					  RECSECTION(LCP,TAGSP); %RESERVES SPACE FOR THE TAGFIELD \
45200	(* 217 - set up SIZE field even when no tag field, for NEW *)
45300					 END;
45400				       IF BITCOUNT > 0
45500	(* 104 - check structure sizes *)
45600					 THEN LSP^.SIZE:=CHECKSIZE(DISPL + 1)
45700					 ELSE LSP^.SIZE:= CHECKSIZE(DISPL);
45800				     END
45900				   ELSE ERROR(402);
46000	
46100				INSYMBOL;
46200			       END
46300			   END
46400	(* 150 - fix ill mem ref trying to follow tagsp if not set *)
46500			 ELSE BEGIN TAGSP := NIL; ERRANDSKIP(209,FSYS OR [LPARENT]) END ;
46600	1:
46700			LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL; MINBITCOUNT:=BITCOUNT;
46800	(* 65 - allow extra semicolons *)
46900			while sy=semicolon do
47000			 insymbol;
47100			 LOOP
47200			  LSP2 := NIL;
47300			   LOOP
47400			    CONSTANT(FSYS OR [COMMA,COLON,LPARENT],LSP3,LVALU);
47500			     IF  NOT COMPTYPES(TAGSP,LSP3)
47600			     THEN ERROR(305);
47700			    NEWZ(LSP3,VARIANT);
47800			    WITH LSP3^ DO
47900			     BEGIN
48000			      NXTVAR := LSP1; SUBVAR := LSP2; VARVAL := LVALU;
48100			      BITSIZE := LSP^.BITSIZE; SELFSTP := NIL
48200			     END;
48300			    LSP1 := LSP3; LSP2 := LSP3;
48400			   EXIT IF SY # COMMA;
48500			    INSYMBOL;
48600			   END;
48700			   IF SY = COLON
48800			   THEN INSYMBOL
48900			   ELSE ERROR(151);
49000			   IF SY = LPARENT
49100			   THEN INSYMBOL
49200			   ELSE ERROR(153);
49300	(* 173 - internal files *)
49400			  FIELDLIST(FSYS OR [RPARENT,SEMICOLON],LSP2,LCP,LHASFILE);
49500			  FHASFILE := FHASFILE OR LHASFILE;
49600			   IF DISPL > MAXSIZE
49700			   THEN MAXSIZE := DISPL;
49800			  WHILE LSP3 # NIL DO
49900			   BEGIN
50000			    LSP4 := LSP3^.SUBVAR; LSP3^.SUBVAR := LSP2; LSP3^.FIRSTFIELD := LCP;
50100	(* 20 - deleted if bitcount>0 use displ+1 - done in fieldlist *)
50200	(* 104 - check structure sizes *)
50300			     LSP3^.SIZE := CHECKSIZE(DISPL) ;
50400			    LSP3 := LSP4
50500			   END;
50600			   IF SY = RPARENT
50700			   THEN
50800			     BEGIN
50900			      INSYMBOL;
51000			      IFERRSKIP(166,FSYS OR [SEMICOLON])
51100			     END
51200			   ELSE ERROR(152);
51300	(* 65 - allow extra semicolons *)
51400			  while sy=semicolon
51500			   do insymbol;
51600			 exit if sy in fsys;
51700			  DISPL := MINSIZE;
51800			  BITCOUNT:=MINBITCOUNT; %RESTAURATION \
51900			 END;
52000			DISPL := MAXSIZE;
52100			LSP^.FSTVAR := LSP1;
52200		       END  %IF SY = CASESY\
52300		     ELSE
52400		       IF LSP # NIL
52500		       THEN
52600			 IF LSP^.FORM = ARRAYS
52700			 THEN FRECVAR := LSP
52800			 ELSE FRECVAR := NIL;
52900	(* 20 - fix packed records - from CMU *)
53000		   IF BITCOUNT > 0 THEN
53100		     BEGIN DISPL:=DISPL+1; BITCOUNT := 0 END
53200		   END %FIELDLIST\ ;
53300	
53400		 BEGIN
53500		  %TYP\
53600	(* 173 - internal files *)
53700		  FHASFILE := FALSE;
53800		  SKIPIFERR(TYPEBEGSYS,170,FSYS);
53900		  PACKFLAG := FALSE;
54000		   IF SY IN TYPEBEGSYS
54100		   THEN
54200		     BEGIN
54300		       IF SY IN SIMPTYPEBEGSYS
54400		       THEN SIMPLETYPE(FSYS,FSP,FSIZE,FBITSIZE)
54500		       ELSE
54600			%^\
     
00100			 IF SY = ARROW
00200			 THEN
00300			   BEGIN
00400			    NEWZ(LSP,POINTER); FSP := LSP;
00500			    LBITSIZE := 18;
00600			    WITH LSP^ DO
00700			     BEGIN
00800			      SELFSTP := NIL;  ELTYPE := NIL; SIZE := 1; BITSIZE := LBITSIZE
00900			     END;
01000			    INSYMBOL;
01100			     IF SY = IDENT
01200			     THEN
01300			       BEGIN
01400	(* 165 - fix scoping problem with pointer ref's *)
01500	{All declarations of the form ^THING must be treated as forward references.
01600	 The problem is that we want to use the local declaration of THING if there
01700	 is any.  So we have to wait til we have seen all type declarations before
01800	 we can look up pointer references.}
01900				NEWZ(LCP,TYPES);
02000				WITH LCP^ DO
02100				  BEGIN
02200				   NAME := ID; IDTYPE := LSP;
02300				   NEXT := FWPTR
02400				  END;
02500				FWPTR := LCP;
02600				INSYMBOL;
02700				FBITSIZE:=18
02800			       END
02900			     ELSE ERROR(209);
03000			   END
03100			 ELSE
03200			   BEGIN
03300			     IF SY = PACKEDSY
03400			     THEN
03500			       BEGIN
03600				INSYMBOL;
03700				SKIPIFERR(TYPEDELS,170,FSYS);
03800				PACKFLAG := TRUE
03900			       END;
04000			      %ARRAY\
04100			     IF SY = ARRAYSY
04200			     THEN
04300			       BEGIN
04400				INSYMBOL;
04500				 IF SY = LBRACK
04600				 THEN INSYMBOL
04700				 ELSE ERROR(154);
04800				LSP1 := NIL;
04900				 LOOP
05000				  NEWZ(LSP,ARRAYS);
05100				  WITH LSP^ DO
05200				   BEGIN
05300				    AELTYPE := LSP1; INXTYPE := NIL; SELFSTP := NIL;
05400				    ARRAYPF := PACKFLAG; SIZE := 1
05500				   END;
05600				  LSP1 := LSP;
05700				  SIMPLETYPE(FSYS OR [COMMA,RBRACK,OFSY],LSP2,LSIZE,LBITSIZE);
05800				   IF LSP2 # NIL
05900				   THEN
06000				     IF LSP2^.FORM <= SUBRANGE
06100				     THEN
06200				       BEGIN
06300					 IF LSP2 = REALPTR
06400					 THEN
06500					   BEGIN
06600					    ERROR(210); LSP2 := NIL
06700					   END
06800					 ELSE
06900					   IF LSP2 = INTPTR
07000					   THEN
07100					     BEGIN
07200					      ERROR(306); LSP2 := NIL
07300					     END;
07400					LSP^.INXTYPE := LSP2
07500				       END
07600				     ELSE
07700				       BEGIN
07800					ERROR(403); LSP2 := NIL
07900				       END;
08000				 EXIT IF SY # COMMA;
08100				  INSYMBOL
08200				 END;
08300				 IF SY = RBRACK
08400				 THEN INSYMBOL
08500				 ELSE ERROR(155);
08600				 IF SY = OFSY
08700				 THEN INSYMBOL
08800				 ELSE ERROR(160);
08900				TYP(FSYS,LSP,LSIZE,LBITSIZE);
09000				 IF  LSP # NIL
09100				 THEN
09200	(* 173 - internal files *)
09300				   IF  (LSP^.FORM = FILES) OR (LSP^.HASFILE)
09400				   THEN  FHASFILE := TRUE;
09500				 REPEAT
09600				  WITH LSP1^ DO
09700				   BEGIN
09800				    LSP2 := AELTYPE; AELTYPE := LSP;
09900				     IF INXTYPE # NIL
10000				     THEN
10100				       BEGIN
10200					GETBOUNDS(INXTYPE,LMIN,LMAX);
10300	(* 104 - check structure sizes *)
10400					lmin := checksize(lmin);
10500					lmax := checksize(lmax);
10600					I := LMAX - LMIN + 1;
10700					 IF ARRAYPF AND (LBITSIZE<=18)
10800					 THEN
10900					   BEGIN
11000					    NEWZ(LBTP,ARRAYY);
11100					    WITH LBTP^,BYTE DO
11200					     BEGIN
11300					      SBITS := LBITSIZE;
11400					      PBITS := BITMAX; DUMMYBIT := 0;
11500					      IBIT := 0; IREG := TAC; RELADDR := 0;
11600					      LAST := LASTBTP; LASTBTP := LBTP;
11700					      ARRAYSP := LSP1;
11800					     END;
11900					    LSIZE := (I+(BITMAX DIV LBITSIZE)-1) DIV (BITMAX DIV LBITSIZE);
12000					   END
12100					 ELSE
12200					   BEGIN
12300					    LSIZE := LSIZE * I;
12400					    ARRAYPF := FALSE
12500					   END;
12600					LBITSIZE := BITMAX;
12700					BITSIZE := LBITSIZE;
12800	(* 104 - check structure sizes *)
12900					SIZE := CHECKSIZE(LSIZE);
13000				       END
13100				   END;
13200				  LSP := LSP1; LSP1 := LSP2
13300				 UNTIL LSP1 = NIL
13400			       END
13500			     ELSE
13600			      %RECORD\
13700			       IF SY = RECORDSY
13800			       THEN
13900				 BEGIN
14000				  INSYMBOL;
14100				  OLDTOP := TOP;
14200				   IF TOP < DISPLIMIT
14300				   THEN
14400				     BEGIN
14500	(* 5 - save block name for CREF *)
14600				      TOP := TOP + 1; DISPLAY[TOP].FNAME := NIL;
14700				     DISPLAY[TOP].BLKNAME := '.FIELDID. ';
14800	(* 117 - fix enumerated types in record *)
14900				     DISPLAY[TOP].OCCUR := CREC
15000				     END
15100				   ELSE ERROR(404);
15200				  DISPL := 0;
15300				  BITCOUNT:=0;
15400	(* 173 - internal files *)
15500				  FIELDLIST(FSYS-[SEMICOLON] OR [ENDSY],LSP1,LCP,LHASFILE);
15600				  FHASFILE := FHASFILE OR LHASFILE;
15700				  
15800				  LBITSIZE := BITMAX;
15900				  NEWZ(LSP,RECORDS);
16000				  WITH LSP^ DO
16100				   BEGIN
16200				    SELFSTP := NIL;
16300				    FSTFLD := %LCP;\ DISPLAY[TOP].FNAME;
16400				    RECVAR := LSP1;
16500	(* 20 - FIX PACKED RECORDS - FROM CMU - DELETED CODE NOW IN FIELDLIST *)
16600	(* 104 - check structure sizes *)
16700				     SIZE := CHECKSIZE(DISPL);
16800				    BITSIZE := LBITSIZE; RECORDPF := PACKFLAG;
16900				   END;
17000				  TOP := OLDTOP;
17100				   IF SY = ENDSY
17200				   THEN INSYMBOL
17300				   ELSE ERROR(163)
17400				 END
17500			       ELSE
17600				%SET\
17700				 IF SY = SETSY
17800				 THEN
17900				   BEGIN
18000				    INSYMBOL;
18100				     IF SY = OFSY
18200				     THEN INSYMBOL
18300				     ELSE ERROR(160);
18400				    SIMPLETYPE(FSYS,LSP1,LSIZE,LBITSIZE);
18500				     IF LSP1 # NIL
18600				     THEN
18700				      WITH LSP1^ DO
18800				       CASE FORM OF
18900					SCALAR:
19000						IF (LSP1=REALPTR) OR (LSP1=INTPTR)
19100						THEN ERROR(352)
19200						ELSE
19300						  IF SCALKIND =DECLARED
19400						  THEN
19500						    IF FCONST^.VALUES.IVAL > BASEMAX
19600						    THEN ERROR(352);
19700					SUBRANGE:
19800						  IF ( RANGETYPE = REALPTR )
19900						   OR ( ( RANGETYPE # CHARPTR ) AND ((MAX.IVAL > BASEMAX) OR (MIN.IVAL < 0) ) )
20000						  THEN ERROR(352);
20100					OTHERS:
20200						BEGIN
20300						 ERROR(353); LSP1 := NIL
20400						END
20500				       END;
20600				    LBITSIZE := BITMAX;
20700				    NEWZ(LSP,POWER);
20800				    WITH LSP^ DO
20900				     BEGIN
21000				      SELFSTP := NIL; ELSET := LSP1; SIZE:=2; BITSIZE := LBITSIZE
21100				     END;
21200				   END
21300				 ELSE
21400				  %FILE\
21500				   IF SY = FILESY
21600				   THEN
21700				     BEGIN
21800				      FHASFILE := TRUE;
21900				      INSYMBOL;
22000				       IF SY = OFSY
22100				       THEN INSYMBOL
22200				       ELSE ERROR(160);
22300				      TYP(FSYS,LSP1,LSIZE,LBITSIZE);
22400				      NEWZ(LSP,FILES);
22500				      LBITSIZE := BITMAX;
22600				      WITH LSP^ DO
22700				       BEGIN
22800					SELFSTP := NIL;
22900	(* 104 - check structure sizes *)
23000					FILTYPE := LSP1; 
23100	(* 173 - internal files *)
23200					SIZE := CHECKSIZE(LSIZE) + SIZEOFFILEBLOCK;
23300					FILEPF := PACKFLAG; BITSIZE := LBITSIZE
23400				       END;
23500				       IF LSP1 # NIL
23600				       THEN
23700					 IF (LSP1^.FORM = FILES) OR (LSP1^.HASFILE)
23800					 THEN
23900					   BEGIN
24000					    ERROR(254); LSP^.FILTYPE := NIL
24100					   END;
24200	(* 70 - fix ill mem ref if type error *)
24300				     END
24400				   ELSE LSP := NIL;
24500			    FSP := LSP; FBITSIZE := LBITSIZE
24600			   END;
24700		      IFERRSKIP(166,FSYS)
24800		     END
24900		   ELSE FSP := NIL;
25000		   IF FSP = NIL
25100		   THEN
25200		     BEGIN
25300		      FSIZE := 1;FBITSIZE := 0
25400		     END
25500	(* 173 - internal files *)
25600		   ELSE BEGIN
25700		   FSIZE := FSP^.SIZE;
25800		   FSP^.HASFILE := FHASFILE
25900		   END
26000		 END %TYP\ ;
26100	
26200		PROCEDURE LABELDECLARATION;
26300		VAR
26400	(* 64 - NON-LOCAL GOTOS *)
26500		  lcp:ctp;
26600		 BEGIN
26700	(* 6 - remove error message. Allow LABEL declaration but ignore it *)
26800		   LOOP
26900		     IF SY = INTCONST
27000		     THEN
27100		       BEGIN
27200			newz(lcp,labelt);
27300			with lcp^ do
27400			  begin
27500			  scope := level; name := id; idtype := nil;
27600			  next := lastlabel; lastlabel := lcp;
27700			  gotochain := 0; labeladdress := 0
27800			  end;
27900			enterid(lcp);
28000	1:
28100			INSYMBOL
28200		       END
28300		     ELSE ERROR(255);
28400		    IFERRSKIP(166,FSYS OR [COMMA,SEMICOLON]);
28500		   EXIT IF SY # COMMA;
28600		    INSYMBOL
28700		   END;
28800		   IF SY = SEMICOLON
28900		   THEN INSYMBOL
29000		   ELSE ERROR(156)
29100		 END %LABELDECLARATION\ ;
29200	
29300		PROCEDURE CONSTANTDECLARATION;
29400		VAR
29500		  LCP: CTP; LSP: STP; LVALU: VALU;
29600		 BEGIN
29700		  SKIPIFERR([IDENT],209,FSYS);
29800		  WHILE SY = IDENT DO
29900		   BEGIN
30000		    NEWZ(LCP,KONST);
30100		    WITH LCP^ DO
30200		     BEGIN
30300		      NAME := ID; IDTYPE := NIL; NEXT := NIL
30400		     END;
30500		    INSYMBOL;
30600		     IF (SY = RELOP) AND (OP = EQOP)
30700		     THEN INSYMBOL
30800		     ELSE ERROR(157);
30900	(* 56 - REQ FILE SYNTAX *)
31000		    CONSTANT(FSYS OR [SEMICOLON,PERIOD],LSP,LVALU);
31100		    ENTERID(LCP);
31200		    LCP^.IDTYPE := LSP; LCP^.VALUES := LVALU;
31300		     IF SY = SEMICOLON
31400		     THEN
31500		       BEGIN
31600			INSYMBOL;
31700			IFERRSKIP(166,FSYS OR [IDENT])
31800		       END
31900	(* 56 - REQ FILE SYNTAX *)
32000		     ELSE IF NOT ((SY=PERIOD) AND REQFILE)
32100		       THEN ERROR(156)
32200		   END
32300		 END %CONSTANTDECLARATION\ ;
32400	
32500		PROCEDURE TYPEDECLARATION;
32600		VAR
32700		  LCP,LCP1,LCP2: CTP; LSP: STP; LSIZE: ADDRRANGE;
32800		  LBITSIZE: BITRANGE;
32900		 BEGIN
33000		  SKIPIFERR([IDENT],209,FSYS);
33100		  WHILE SY = IDENT DO
33200		   BEGIN
33300		    NEWZ(LCP,TYPES);
33400		    WITH LCP^ DO
33500		     BEGIN
33600	(* 116 - be sure NEXT is NIL when unused, for COPYCTP *)
33700		      NAME := ID; IDTYPE := NIL; NEXT := NIL;
33800		     END;
33900		    INSYMBOL;
34000		     IF (SY = RELOP) AND (OP = EQOP)
34100		     THEN INSYMBOL
34200		     ELSE ERROR(157);
34300	(* 56 - REQ FILE SYNTAX *)
34400		    TYP(FSYS OR [SEMICOLON,PERIOD],LSP,LSIZE,LBITSIZE);
34500		    ENTERID(LCP);
34600		    WITH LCP^ DO
34700		     BEGIN
34800		      IDTYPE := LSP;
34900	(* 165 - fix scoping for pointer ref's *)
35000		     END;
35100		     IF SY = SEMICOLON
35200		     THEN
35300		       BEGIN
35400			INSYMBOL;
35500			IFERRSKIP(166,FSYS OR [IDENT]);
35600		       END
35700	(* 56 - REQ FILE SYNTAX *)
35800		     ELSE IF NOT ((SY=PERIOD) AND REQFILE)
35900		       THEN ERROR(156)
36000		   END;
36100	(* 113 - don't check for forw. ref's satisfied in req. file *)
36200		 END %TYPEDECLARATION\ ;
36300	
36400	(* 166 - must resolve forwards separately, in case of TYPE section
36500	         in required file but none in main *)
36600		PROCEDURE FWDRESOLVE;
36700		  BEGIN
36800	{For each forward request, look up the variable requested.  If
36900	 you find the request, use it.  Note that all declarations of
37000	 the form ^THING produce forward requests.  This is to force
37100	 THING to be looked up after all type declarations have been
37200	 processed, so we get the local definition if there is one.}
37300		  WHILE FWPTR # NIL DO
37400	 	    BEGIN
37500	(* 165 - fix scoping problem with pointers *)
37600		     ID := FWPTR^.NAME;
37700		     PRTERR := FALSE;   %NO ERROR IF SEARCH NOT SUCCESSFUL\
37800		     SEARCHID([TYPES],LCP); PRTERR := TRUE;
37900		     IF LCP <> NIL
38000		       THEN IF LCP^.IDTYPE # NIL
38100			      THEN IF LCP^.IDTYPE^.FORM = FILES
38200				     THEN ERROR(254)
38300				     ELSE FWPTR^.IDTYPE^.ELTYPE := LCP^.IDTYPE
38400			      ELSE
38500		       ELSE ERRORWITHTEXT(405,FWPTR^.NAME);
38600		     FWPTR := FWPTR^.NEXT
38700		    END
38800		 END %FWDRESOLVE\ ;
38900	
39000		PROCEDURE VARIABLEDECLARATION;
39100		VAR
39200		  LCP,NXT: CTP; LSP: STP; LSIZE: ADDRRANGE;
39300		  LBITSIZE: BITRANGE; II: INTEGER;
39400	(* 173 - removed lfileptr *)
39500		 BEGIN
39600		  NXT := NIL;
39700		   REPEAT
39800		     LOOP
39900		       IF SY = IDENT
40000		       THEN
40100			 BEGIN
40200			  NEWZ(LCP,VARS);
40300			  WITH LCP^ DO
40400			   BEGIN
40500			    NAME := ID; NEXT := NXT;
40600			    IDTYPE := NIL; VKIND := ACTUAL; VLEV := LEVEL
40700			   END;
40800			  ENTERID(LCP);
40900			  NXT := LCP;
41000			  INSYMBOL;
41100			 END
41200		       ELSE ERROR(209);
41300		      SKIPIFERR(FSYS OR [COMMA,COLON] OR TYPEDELS,166,[SEMICOLON]);
41400		     EXIT IF SY # COMMA;
41500		      INSYMBOL
41600		     END;
41700		     IF SY = COLON
41800		     THEN INSYMBOL
41900		     ELSE ERROR(151);
42000		    TYP(FSYS OR [SEMICOLON] OR TYPEDELS,LSP,LSIZE,LBITSIZE);
42100	(* 24 - testpacked no longer needed *)
42200	(* 173 - internal files *)
42300		    IF LSP <> NIL
42400		      THEN IF (LSP^.FORM = FILES) OR LSP^.HASFILE
42500			THEN FILEINBLOCK[LEVEL] := TRUE;
42600		    WHILE NXT # NIL DO
42700		    WITH  NXT^ DO
42800		     BEGIN
42900		      IDTYPE := LSP; VADDR := LC;
43000		      LC := LC + LSIZE ;
43100	(* 173 - internal files - removed file code here *)
43200		      NXT := NEXT ;
43300		     END;
43400		     IF SY = SEMICOLON
43500		     THEN
43600		       BEGIN
43700			INSYMBOL;
43800			IFERRSKIP(166,FSYS OR [IDENT])
43900		       END
44000		     ELSE ERROR(156)
44100		   UNTIL (SY # IDENT) AND  NOT (SY IN TYPEDELS);
44200	(* 167 - code removed from here.  It is now part of FWDRESOLVE,
44300		which is called right after this procedure *)
44400		 END %VARIABLEDECLARATION\ ;
44500	
44600		PROCEDURE PROCEDUREDECLARATION(FSY: SYMBOL);
44700		VAR
44800		  OLDLEV: 0..MAXLEVEL; LSY: SYMBOL; LCP,LCP1: CTP; LSP: STP;
44900		  FORW: BOOLEAN; OLDTOP: DISPRANGE; LNXT: CTP;
45000	(* 62 - clean up stack offsets *)
45100		  LLC,LCM: ADDRRANGE;  TOPPOFFSET: ADDRRANGE;
45200	
45300		  PROCEDURE PARAMETERLIST(FSY: SETOFSYS; VAR FPAR: CTP; VAR TOPPOFFSET: ADDRRANGE);
45400		  VAR
45500		    LCP,LCP1,LCP2,LCP3: CTP; LSP: STP; LKIND: IDKIND;
45600	(* 62 - clean up stack offset *)
45700		    REGC:INTEGER;
45800		   BEGIN
45900		    LCP1 := NIL; REGC := REGIN+1;
46000		    SKIPIFERR(FSY OR [LPARENT],256,FSYS);
46100		     IF SY = LPARENT
46200		     THEN
46300		       BEGIN
46400			 IF FORW
46500			 THEN ERROR(553);
46600			INSYMBOL;
46700			SKIPIFERR([IDENT,VARSY,PROCEDURESY,FUNCTIONSY],256,FSYS OR [RPARENT]);
46800			WHILE SY IN [IDENT,VARSY,PROCEDURESY,FUNCTIONSY] DO
46900			 BEGIN
47000			   IF SY = PROCEDURESY
47100			   THEN
47200			     BEGIN
47300	(* 33 - PROC PARAM.S *)
47400			       REPEAT
47500				INSYMBOL;
47600				 IF SY = IDENT
47700				 THEN
47800				   BEGIN
47900				    NEWZ(LCP,PROC,DECLARED,FORMAL);
48000				    WITH LCP^ DO
48100				     BEGIN
48200				      NAME := ID; IDTYPE := NIL; NEXT := LCP1;
48300				      PFLEV := LEVEL; PFADDR := LC
48400				     END;
48500				    ENTERID(LCP);
48600	(* 62 - clean up stack offset *)
48700				    LCP1 := LCP; LC := LC + 1; REGC := REGC+1;
48800				    INSYMBOL
48900				   END
49000				 ELSE ERROR(209);
49100				IFERRSKIP(256,FSYS OR [COMMA,SEMICOLON,RPARENT])
49200			       UNTIL SY # COMMA
49300			     END
49400			   ELSE
49500			     IF SY = FUNCTIONSY
49600			     THEN
49700			       BEGIN
49800	(* 33 - PROC PARAM.S *)
49900				LCP2 := NIL;
     
00100				 REPEAT
00200				  INSYMBOL;
00300				   IF SY = IDENT
00400				   THEN
00500				     BEGIN
00600				      NEWZ(LCP,FUNC,DECLARED,FORMAL);
00700				      WITH LCP^ DO
00800				       BEGIN
00900					NAME := ID; IDTYPE := NIL; NEXT := LCP2;
01000					PFLEV := LEVEL; PFADDR := LC
01100				       END;
01200				      ENTERID(LCP);
01300	(* 62 - clean up stack offset *)
01400				      LCP2 := LCP; LC := LC + 1; REGC := REGC+1;
01500				      INSYMBOL;
01600				     END;
01700				   IF  NOT (SY IN [COMMA,COLON] OR FSYS)
01800				   THEN
01900				    ERRANDSKIP(256,FSYS OR [COMMA,SEMICOLON,RPARENT])
02000				 UNTIL SY # COMMA;
02100				 IF SY = COLON
02200				 THEN
02300				   BEGIN
02400				    INSYMBOL;
02500				     IF SY = IDENT
02600				     THEN
02700				       BEGIN
02800					SEARCHID([TYPES],LCP);
02900					LSP := LCP^.IDTYPE;
03000					 IF LSP # NIL
03100					 THEN
03200					   IF  NOT (LSP^.FORM IN [SCALAR,SUBRANGE,POINTER])
03300					   THEN
03400					     BEGIN
03500					      ERROR(551); LSP := NIL
03600					     END;
03700					LCP3 := LCP2;
03800					WHILE LCP2 # NIL DO
03900					 BEGIN
04000					  LCP2^.IDTYPE := LSP; LCP := LCP2;
04100					  LCP2 := LCP2^.NEXT
04200					 END;
04300					LCP^.NEXT := LCP1; LCP1 := LCP3;
04400					INSYMBOL
04500				       END
04600				     ELSE ERROR(209);
04700				    IFERRSKIP(256,FSYS OR [SEMICOLON,RPARENT])
04800				   END
04900				 ELSE ERROR(151)
05000			       END
05100			     ELSE
05200			       BEGIN
05300				 IF SY = VARSY
05400				 THEN
05500				   BEGIN
05600				    LKIND := FORMAL; INSYMBOL
05700				   END
05800				 ELSE LKIND := ACTUAL;
05900				LCP2 := NIL;
06000				 LOOP
06100				   IF SY = IDENT
06200				   THEN
06300				     BEGIN
06400				      NEWZ(LCP,VARS);
06500				      WITH LCP^ DO
06600				       BEGIN
06700					NAME := ID; IDTYPE := NIL;
06800					VKIND := LKIND; NEXT := LCP2; VLEV := LEVEL;
06900				       END;
07000				      ENTERID(LCP);
07100				      LCP2 := LCP;
07200				      INSYMBOL;
07300				     END
07400				   ELSE ERROR(256);
07500				   IF  NOT (SY IN [COMMA,COLON] OR FSYS)
07600				   THEN
07700				    ERRANDSKIP(256,FSYS OR [COMMA,SEMICOLON,RPARENT])
07800				 EXIT IF SY # COMMA;
07900				  INSYMBOL
08000				 END;
08100				 IF SY = COLON
08200				 THEN
08300				   BEGIN
08400				    INSYMBOL;
08500	(* 15 - ALLOW :FILE AS KLUDGEY THING THAT MATCHES ALL FILES *)
08600				     IF SY IN [IDENT,FILESY]
08700				     THEN
08800				       BEGIN
08900					IF SY=IDENT
09000					THEN BEGIN
09100	(* 111 - STRING, POINTER *)
09200					SEARCHID([TYPES,PARAMS],LCP);
09300					  (* PARAMS IS A PREDECLARED IDENTIFIER DESCRIBING
09400					     A CLASS OF PARAMETERS WITH REDUCED TYPE CHECKING,
09500					     E.G. STRING OR POINTER *)
09600					LSP := LCP^.IDTYPE;
09700					END
09800					 ELSE LSP:=ANYFILEPTR;
09900					 IF LSP # NIL
10000					 THEN
10100					   IF (LKIND = ACTUAL) AND (LSP^.FORM = FILES)
10200					   THEN
10300					    ERROR(355);
10400	(* 151 - fix reversed args in case I,J:INTEGER *)
10500	{LCP2 is reversed at the moment.  Put it forwards so memory alloc is right}
10600					LCP3 := NIL;
10700					WHILE LCP2 # NIL DO
10800					 BEGIN
10900					 LCP := LCP2;
11000					 LCP2 := LCP2^.NEXT;
11100					 LCP^.NEXT := LCP3;
11200					 LCP3 := LCP;
11300					 END;
11400					WHILE LCP3 # NIL DO
11500					 BEGIN
11600					  WITH LCP3^ DO
11700					   BEGIN
11800					    IDTYPE := LSP;
11900					    VADDR := LC;
12000	(* 161 - fix POINTER and STRING *)
12100	(* 202 - pointer by ref *)
12200	{POINTER and STRING are passed by a kludgey mechanism.  Since it uses 2 AC's
12300	 we choose to call this thing call by value, with a size of 2.  STRING
12400	 works the same for value and ref anyway.  POINTER doesn't, so we
12500	 use pointerref instead of pointerptr to distinguish. If we call these
12600	 things 2-word quantities passed by value, then mostly the right thing
12700	 happens automatically.   The only other place special code is required
12800	 is in CALLNONSTANDARD where by use a special routine in place of LOAD,
12900	 to do the actually funny passing.}
13000	 				    if (lsp = stringptr) or (lsp = pointerptr)
13100					      then if (lsp = pointerptr) and
13200						      (vkind = formal)
13300	{If it is POINTER called by ref, use a special tag, POINTERREF }
13400					             then begin 
13500					              idtype := pointerref;
13600					              vkind := actual
13700					              end
13800	{In any case, consider it actual so the size = 2 works }
13900						     else vkind := actual;
14000					     IF VKIND = FORMAL
14100					     THEN LC := LC + 1
14200					     ELSE
14300					       IF IDTYPE # NIL
14400					       THEN LC := LC + IDTYPE^.SIZE;
14500	(* 62 - clean up stack offset *)
14600					    IF IDTYPE = NIL
14700					      THEN REGC := REGC+1
14800					      ELSE IF (VKIND = ACTUAL) AND (IDTYPE^.SIZE = 2)
14900						THEN REGC := REGC+2
15000						ELSE REGC := REGC+1
15100					   END;
15200					  LCP := LCP3;
15300					  LCP3 := LCP3^.NEXT;
15400	(* 151 - CONS the new thing on individually instead of APPENDing the whole
15500	   string, in order to avoid getting I and J reversed in I,J:INTEGER *)
15600	{Note that we are here reversing the order again.  This is because the
15700	 whole thing gets reversed below.}
15800					  LCP^.NEXT := LCP1;
15900					  LCP1 := LCP;
16000					 END;
16100					INSYMBOL
16200				       END
16300				     ELSE ERROR(209);
16400				    IFERRSKIP(256,FSYS OR [SEMICOLON,RPARENT])
16500				   END
16600				 ELSE ERROR(151);
16700			       END;
16800			   IF SY = SEMICOLON
16900			   THEN
17000			     BEGIN
17100			      INSYMBOL;
17200			      SKIPIFERR(FSYS OR [IDENT,VARSY,PROCEDURESY,FUNCTIONSY],256,[RPARENT])
17300			     END
17400			 END %WHILE\ ;
17500			 IF SY = RPARENT
17600			 THEN
17700			   BEGIN
17800			    INSYMBOL;
17900			    IFERRSKIP(166,FSY OR FSYS)
18000			   END
18100			 ELSE ERROR(152);
18200			LCP3 := NIL;
18300			%REVERSE POINTERS\
18400			WHILE LCP1 # NIL DO
18500			WITH LCP1^ DO
18600			 BEGIN
18700			  LCP2 := NEXT; NEXT := LCP3;
18800			  LCP3 := LCP1; LCP1 := LCP2
18900			 END;
19000			FPAR := LCP3
19100		       END
19200		     ELSE FPAR := NIL;
19300	(* 62 - clean up stack offset *)
19400		   IF (REGC - 1) > PARREGCMAX
19500		     THEN TOPPOFFSET := LC - 1
19600		     ELSE TOPPOFFSET := 0;
19700		   END %PARAMETERLIST\ ;
19800	
19900		 BEGIN
20000		  %PROCEDUREDECLARATION\
20100		  LLC := LC;
20200		   IF FSY = PROCEDURESY
20300		   THEN LC := 1
20400		   ELSE LC := 2;
20500		   IF SY = IDENT
20600		   THEN
20700		     BEGIN
20800	(* 5 - CREF *)
20900		      IF CREF
21000		        THEN WRITE(CHR(15B),CHR(10),ID);
21100		      SEARCHSECTION(DISPLAY[TOP].FNAME,LCP);   %DECIDE WHETHER FORW.\
21200		       IF LCP # NIL
21300		       THEN
21400			WITH LCP^ DO
21500			 BEGIN
21600			   IF KLASS = PROC
21700			   THEN
21800			    FORW := FORWDECL AND (FSY = PROCEDURESY) AND (PFKIND = ACTUAL)
21900			   ELSE
22000			     IF KLASS = FUNC
22100			     THEN
22200			      FORW := FORWDECL AND (FSY = FUNCTIONSY) AND (PFKIND = ACTUAL)
22300			     ELSE FORW := FALSE;
22400			   IF  NOT FORW
22500			   THEN ERROR(406)
22600			 END
22700		       ELSE FORW := FALSE;
22800		       IF  NOT FORW
22900		       THEN
23000			 BEGIN
23100			   IF FSY = PROCEDURESY
23200			   THEN NEWZ(LCP,PROC,DECLARED,ACTUAL)
23300			   ELSE NEWZ(LCP,FUNC,DECLARED,ACTUAL);
23400			  WITH LCP^ DO
23500			   BEGIN
23600	(* 116 - be sure NEXT is NIL when unused, for COPYCTP *)
23700			    NAME := ID; IDTYPE := NIL; TESTFWDPTR := NIL; NEXT := NIL;
23800			    FORWDECL := FALSE; EXTERNDECL := FALSE; LANGUAGE := PASCALSY;
23900			    PFLEV := LEVEL; PFADDR := 0; FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0
24000			   END;
24100			  ENTERID(LCP)
24200			 END
24300		       ELSE
24400			 BEGIN
24500			  LCP1 := LCP^.NEXT;
24600			  WHILE LCP1 # NIL DO
24700			   BEGIN
24800			    WITH LCP1^ DO
24900			     IF KLASS = VARS
25000			     THEN
25100			       IF IDTYPE # NIL
25200			       THEN
25300				 BEGIN
25400				  LCM := VADDR + IDTYPE^.SIZE;
25500				   IF LCM > LC
25600				   THEN LC := LCM
25700				 END;
25800			    LCP1 := LCP1^.NEXT
25900			   END
26000			 END;
26100		      INSYMBOL
26200		     END
26300		   ELSE
26400		     BEGIN
26500		      ERROR(209);
26600		       IF FSY = PROCEDURESY
26700		       THEN LCP := UPRCPTR
26800		       ELSE LCP := UFCTPTR
26900		     END;
27000		  OLDLEV := LEVEL; OLDTOP := TOP;
27100		   IF LEVEL < MAXLEVEL
27200		   THEN LEVEL := LEVEL + 1
27300		   ELSE ERROR(453);
27400		   IF TOP < DISPLIMIT
27500		   THEN
27600		     BEGIN
27700		      TOP := TOP + 1;
27800		      WITH DISPLAY[TOP] DO
27900		       BEGIN
28000	(* 5 - save block name for CREF *)
28100			FNAME := NIL; OCCUR := BLCK; BLKNAME := LCP^.NAME;
28200			 IF DEBUG THEN BEGIN
28300	(* 214 - use ULBLPTR because UPRCPTR will not have NEXT treated
28400		properly *)
28500	{This is a dummy entry in the symbol table strictly for the debugger.
28600	 The debugger looks at its NEXT field to find the procedure name}
28700					NEWZ(LCP1); LCP1^ := ULBLPTR^;
28800					LCP1^.NEXT := LCP;
28900					ENTERID(LCP1);
29000					IF FORW AND (LCP^.NEXT # NIL)
29100					THEN BEGIN
29200	(* 150 - removed lcp1^.llink := lcp^.next.  LCP^.NEXT is a tree containing
29300	         the parameters.  It needs to be put into the symbol table.  Since
29400	         all legal symbols > blanks, just put it in Rlink.  Previously got
29500	         all symbols twice in debugger! *)
29600					  LCP1^.RLINK := LCP^.NEXT
29700					  END
29800				       END
29900				  ELSE IF FORW THEN FNAME := LCP^.NEXT
30000			END %WITH DISPLAY[TOP]\
30100		     END
30200		   ELSE ERROR(404);
30300		   IF FSY = PROCEDURESY
30400		   THEN
30500		     BEGIN
30600	(* 62 - clean up stack offset *)
30700		      PARAMETERLIST([SEMICOLON],LCP1,TOPPOFFSET);
30800		       IF  NOT FORW
30900			THEN WITH LCP^ DO
31000			  BEGIN NEXT := LCP1; POFFSET := TOPPOFFSET END
31100		     END
31200		   ELSE
31300		     BEGIN
31400	(* 62 - clean up stack offset *)
31500		      PARAMETERLIST([SEMICOLON,COLON],LCP1,TOPPOFFSET);
31600		       IF  NOT FORW
31700			THEN WITH LCP^ DO
31800			  BEGIN NEXT := LCP1; POFFSET := TOPPOFFSET END;
31900		       IF SY = COLON
32000		       THEN
32100			 BEGIN
32200			  INSYMBOL;
32300			   IF SY = IDENT
32400			   THEN
32500			     BEGIN
32600			       IF FORW
32700			       THEN ERROR(552);
32800			      SEARCHID([TYPES],LCP1);
32900			      LSP := LCP1^.IDTYPE;
33000			      LCP^.IDTYPE := LSP;
33100			       IF LSP # NIL
33200			       THEN
33300				 IF  NOT (LSP^.FORM IN [SCALAR,SUBRANGE,POINTER])
33400				 THEN
33500				   BEGIN
33600				    ERROR(551); LCP^.IDTYPE := NIL
33700				   END;
33800			      INSYMBOL
33900			     END
34000			   ELSE ERRANDSKIP(209,FSYS OR [SEMICOLON])
34100			 END
34200		       ELSE
34300			 IF  NOT FORW
34400			 THEN ERROR(455)
34500		     END;
34600		   IF SY = SEMICOLON
34700		   THEN INSYMBOL
34800		   ELSE ERROR(156);
34900		   IF SY = FORWARDSY
35000		   THEN
35100		     BEGIN
35200		       IF FORW
35300		       THEN ERROR(257)
35400		       ELSE
35500			WITH LCP^ DO
35600			 BEGIN
35700			  TESTFWDPTR := FORWPTR; FORWPTR := LCP; FORWDECL := TRUE
35800			 END;
35900		      INSYMBOL;
36000		       IF SY = SEMICOLON
36100		       THEN INSYMBOL
36200		       ELSE ERROR(156);
36300		      IFERRSKIP(166,FSYS)
36400		     END % SY = FORWARDSY \
36500		   ELSE
36600		    WITH LCP^ DO
36700		     BEGIN
36800		       IF SY = EXTERNSY
36900		       THEN
37000			 BEGIN
37100			   IF FORW
37200			   THEN ERROR(257)
37300			   ELSE EXTERNDECL := TRUE;
37400			  INSYMBOL;
37500			   IF LEVEL # 2
37600			   THEN ERROR(464);
37700			   IF SY IN LANGUAGESYS
37800			   THEN
37900			     BEGIN
38000			      LANGUAGE := SY;
38100			      INSYMBOL
38200			     END;
38300			   IF (LIBIX = 0) OR (NOT LIBRARY[LANGUAGE].INORDER)
38400			   THEN
38500			     BEGIN
38600			      LIBIX:= LIBIX+1;
38700			      LIBORDER[LIBIX]:= LANGUAGE;
38800			      LIBRARY[LANGUAGE].INORDER:= TRUE
38900			     END;
39000			  PFLEV := 1; PFCHAIN := EXTERNPFPTR; EXTERNPFPTR := LCP;
39100			   IF SY = SEMICOLON
39200	(* 56 - ACCEPT SYNTAX OF REQUIRE FILE *)
39300			     THEN BEGIN
39400			     INSYMBOL;
39500			     IFERRSKIP(166,FSYS)
39600			     END
39700			    ELSE IF NOT((SY=PERIOD) AND REQFILE)
39800			     THEN ERROR(166)
39900			 END % SY = EXTERNSY \
40000		       ELSE
40100			 BEGIN
40200	(* 55 - ONLY EXTERN DECL'S ALLOWED IN REQUIRE FILE *)
40300			  IF REQFILE
40400			    THEN ERROR(169);
40500			  PFCHAIN := LOCALPFPTR; LOCALPFPTR := LCP; FORWDECL := FALSE;
40600			  BLOCK(LCP,FSYS,[BEGINSY,FUNCTIONSY,PROCEDURESY,PERIOD,SEMICOLON]);
40700			   IF SY = SEMICOLON
40800			   THEN
40900			     BEGIN
41000			      INSYMBOL;
41100			      SKIPIFERR([BEGINSY,PROCEDURESY,FUNCTIONSY],166,FSYS)
41200			     END
41300			   ELSE
41400			     IF MAIN OR (LEVEL > 2) OR (SY # PERIOD)
41500			     THEN ERROR(156)
41600			 END % SY # EXTERNSY \
41700		     END % SY # FORWARDSY \ ;
41800		  LEVEL := OLDLEV; TOP := OLDTOP; LC := LLC;
41900	(* 5 - CREF *)
42000		  IF CREF
42100		    THEN WRITE(CHR(16B),CHR(10),LCP^.NAME)
42200		 END %PROCEDUREDECLARATION\ ;
42300	
42400		PROCEDURE BODY(FSYS: SETOFSYS);
42500		CONST
42600	(* 173 - rework for internal files *)
42700		  FILEOF = 1B; FILEOL = 2B; FILSTA = 11B;  FILTST=40B;
42800		  FILBFH =26B; FILLNR = 31B;
42900	(* 43 - new stuff for blocked files *)
43000	(* 50 - new labels for reinit *)
43100		  FILCMP =43B; filbll=36b; 
43200	(* 61 - tops20 *)
43300		  filjfn =4b;
43400		VAR
43500	(* 217 - removed LASTFILE, EXTERNCTP in the ATTR record now plays its role *)
43600		  IDTREE: ADDRRANGE; %POINTER(IN THE USER'S CODE) TO THE IDENTIFIER-TREE\
43700	
43800		  PROCEDURE FULLWORD(FRELBYTE: RELBYTE; FLEFTH: ADDRRANGE; FRIGHTH: ADDRRANGE);
43900		   BEGIN
44000		    %FULLWORD\
44100		    CIX := CIX + 1;
44200		     IF CIX > CIXMAX
44300		     THEN
44400		       BEGIN
44500			IF FPROCP = NIL THEN ERRORWITHTEXT(356,'MAIN      ')
44600					ELSE ERRORWITHTEXT(356, FPROCP^.NAME);
44700			CIX := 0
44800		       END;
44900		    WITH CODE, HALFWORD[CIX] DO
45000		     BEGIN
45100		      LEFTHALF := FLEFTH;
45200		      RIGHTHALF := FRIGHTH;
45300		      INFORMATION[CIX] := 'W'; RELOCATION[CIX] := FRELBYTE
45400		     END;
45500		    IC := IC + 1
45600		   END %FULLWORD\ ;
45700	
45800	(* 164 - routine to allow Polish fixup in case ADDR can't be done by compiler *)
45900	
46000		procedure insertpolish(place,original:addrrange;adjust:integer);
46100		    var pol:polpt;
46200	{This routine requests the loader to fix up the right half of PLACE, by
46300	 putting in ORIGINAL (assumed relocatable) + ADJUST (assumed absolute).
46400	 A POLREC is created, and the actual request is put in the file by
46500	 WRITEMC(WRITEPOLISH).}
46600		  begin
46700		  if abs(adjust) > 377777B
46800		    then error(266)
46900		    else begin
47000		    new(pol);
47100		    with pol^ do
47200		      begin
47300		      where := place;
47400		      base := original;
47500		      offset := adjust;
47600		      nextpol := firstpol  {Link into chain of requests - FIRSTPOL}
47700		      end;
47800		    firstpol := pol
47900		    end;
48000		  end;
48100	
48200		  PROCEDURE INSERTADDR(FRELBYTE: RELBYTE; FCIX:CODERANGE;FIC:ADDRRANGE);
48300		   BEGIN
48400		     IF NOT ERRORFLAG
48500		     THEN
48600		      WITH CODE DO
48700		       BEGIN
48800			INSTRUCTION[FCIX].ADDRESS := FIC;
48900			RELOCATION[FCIX] := FRELBYTE
49000		       END
49100		   END;
49200	
49300		  PROCEDURE INCREMENTREGC;
49400		   BEGIN
49500		    REGC := REGC + 1 ;
49600		     IF REGC > REGCMAX
49700		     THEN
49800		       BEGIN
49900			ERROR(310) ; REGC := REGIN
50000		       END
50100		   END ;
50200	
50300		  PROCEDURE DEPCST(KONSTTYP:CSTCLASS; FATTR:ATTR);
50400		  VAR
50500		    II:INTEGER; LKSP,LLKSP: KSP; LCSP: CSP;
50600		    NEUEKONSTANTE,GLEICH:BOOLEAN; LCIX: CODERANGE;
50700		   BEGIN
50800		    I:=1;
50900		    NEUEKONSTANTE:=TRUE; LKSP := FIRSTKONST;
51000		    WHILE (LKSP#NIL) AND NEUEKONSTANTE DO
51100		    WITH LKSP^,CONSTPTR^ DO
51200		     BEGIN
51300		       IF CCLASS = KONSTTYP
51400		       THEN
51500			 CASE KONSTTYP OF
51600			  REEL:
51700				IF RVAL = FATTR.CVAL.VALP^.RVAL
51800				THEN
51900				 NEUEKONSTANTE := FALSE;
52000			  INT:
52100			       IF INTVAL = FATTR.CVAL.IVAL
52200			       THEN
52300				NEUEKONSTANTE := FALSE;
52400			  PSET:
52500				IF PVAL = FATTR.CVAL.VALP^.PVAL
52600				THEN
52700				 NEUEKONSTANTE := FALSE;
52800			  STRD,
52900			  STRG:
53000				IF FATTR.CVAL.VALP^.SLGTH = SLGTH
53100				THEN
53200				  BEGIN
53300				   GLEICH := TRUE;
53400				   II := 1;
53500				    REPEAT
53600				      IF FATTR.CVAL.VALP^.SVAL[II] # SVAL[II]
53700				      THEN
53800				       GLEICH := FALSE;
53900				     II:=II+1
54000				    UNTIL (II>SLGTH) OR NOT GLEICH;
54100				    IF GLEICH
54200				    THEN NEUEKONSTANTE := FALSE
54300				  END
54400			 END %CASE\;
54500		      LLKSP := LKSP; LKSP := NEXTKONST
54600		     END %WHILE\;
54700		     IF NOT NEUEKONSTANTE
54800		     THEN
54900		      WITH LLKSP^ DO
55000		       BEGIN
55100			INSERTADDR(RIGHT,CIX,ADDR); CODE.INFORMATION[CIX]:= 'C';
55200			 IF KONSTTYP IN [PSET,STRD]
55300			 THEN
55400			   BEGIN
55500			    INSERTADDR(RIGHT,CIX-1,ADDR1); CODE.INFORMATION[CIX-1]:= 'C'; ADDR1 := IC-2;
55600			   END;
55700			ADDR:= IC-1
55800		       END
55900		     ELSE
56000		       BEGIN
56100			 IF KONSTTYP = INT
56200			 THEN
56300			   BEGIN
56400			    NEWZ(LCSP,INT); LCSP^.INTVAL := FATTR.CVAL.IVAL
56500			   END
56600			 ELSE
56700			  LCSP := FATTR.CVAL.VALP;
56800			CODE.INFORMATION[CIX] := 'C';
56900			 IF KONSTTYP IN [PSET,STRD]
57000			 THEN CODE.INFORMATION[CIX-1] := 'C';
57100			NEWZ(LKSP);
57200			WITH LKSP^ DO
57300			 BEGIN
57400			  ADDR := IC-1;
57500	(* 72 - two fixup chains for 2 word consts *)
57600			  if konsttyp in [strd,pset]
57700			    then addr1 := ic-2;
57800			  CONSTPTR := LCSP; NEXTKONST := NIL
57900			 END;
58000			 IF FIRSTKONST = NIL
58100			 THEN FIRSTKONST := LKSP
58200			 ELSE LLKSP^.NEXTKONST := LKSP
58300		       END
58400		   END %DEPCST\;
58500	
58600		  PROCEDURE MACRO(FRELBYTE : RELBYTE;
58700				  FINSTR   : INSTRANGE;
58800				  FAC	   : ACRANGE;
58900				  FINDBIT  : IBRANGE;
59000				  FINXREG  : ACRANGE;
59100				  FADDRESS : INTEGER);
59200		   BEGIN
59300		     IF NOT INITGLOBALS
59400		     THEN
59500		       BEGIN
59600			CIX := CIX + 1;
59700			 IF CIX > CIXMAX
59800			 THEN
59900			   BEGIN
60000			     IF FPROCP = NIL
60100			     THEN ERRORWITHTEXT(356,'MAIN      ')
60200			     ELSE ERRORWITHTEXT(356, FPROCP^.NAME);
60300			    CIX := 0
60400			   END;
60500			WITH CODE, INSTRUCTION[CIX] DO
60600			 BEGIN
60700			  INSTR    :=FINSTR;
60800			  AC	   :=FAC;
60900			  INDBIT   :=FINDBIT;
61000			  INXREG   :=FINXREG;
61100			  ADDRESS  :=FADDRESS;
61200			  INFORMATION[CIX]:= ' '; RELOCATION[CIX] := FRELBYTE
     
00100			 END;
00200			IC := IC + 1
00300		       END
00400		     ELSE ERROR(507)
00500		   END %MACRO\;
00600	
00700		  PROCEDURE MACRO5(FRELBYTE: RELBYTE; FINSTR : INSTRANGE; FAC,FINXREG : ACRANGE; FADDRESS : INTEGER);
00800		   BEGIN
00900		    MACRO(FRELBYTE,FINSTR,FAC,0,FINXREG,FADDRESS)
01000		   END;
01100	
01200		  PROCEDURE MACRO4(FINSTR: INSTRANGE;FAC, FINXREG: ACRANGE;FADDRESS: INTEGER);
01300		   BEGIN
01400		    MACRO(NO,FINSTR,FAC,0,FINXREG,FADDRESS)
01500		   END;
01600	
01700		  PROCEDURE MACRO3(FINSTR : INSTRANGE; FAC:ACRANGE; FADDRESS: INTEGER);
01800		   BEGIN
01900		    MACRO(NO,FINSTR,FAC,0,0,FADDRESS)
02000		   END;
02100	
02200		  PROCEDURE MACRO4R(FINSTR : INSTRANGE; FAC,FINXREG : ACRANGE; FADDRESS : INTEGER);
02300		   BEGIN
02400		    MACRO(RIGHT,FINSTR,FAC,0,FINXREG,FADDRESS)
02500		   END;
02600	
02700		  PROCEDURE MACRO3R(FINSTR : INSTRANGE; FAC:ACRANGE; FADDRESS: INTEGER);
02800		   BEGIN
02900		    MACRO(RIGHT,FINSTR,FAC,0,0,FADDRESS)
03000		   END;
03100	
03200		  PROCEDURE PUTPAGER;
03300		   BEGIN
03400		    WITH PAGER DO
03500		     BEGIN
03600		      LASTPAGER := IC;
03700		      WITH WORD1 DO MACRO4R(304B%CAIA\,AC,INXREG,ADDRESS);
03800		      FULLWORD(RIGHT,LHALF,RHALF);
03900		      LASTPAGE := PAGECNT
04000		     END
04100		   END;
04200	
04300		  PROCEDURE PUTLINER;
04400		   BEGIN
04500		     IF PAGECNT # LASTPAGE
04600		     THEN PUTPAGER;
04700		     IF LINECNT # LASTLINE
04800		     THEN %BREAKPOINT\
04900		       BEGIN
05000			 IF LINENR # '-----'
05100			 THEN
05200			   BEGIN
05300			    LINECNT := 0;
05400			    FOR I := 1 TO 5 DO	LINECNT := 10*LINECNT + ORD(LINENR[I]) - ORD('0')
05500			   END;
05600			LINEDIFF := LINECNT - LASTLINE;
05700			 IF LINEDIFF > 255
05800			 THEN
05900			   BEGIN
06000			    MACRO3R(334B%SKIPA\,0,LASTSTOP);
06100			    LASTSTOP := IC-1;
06200			    MACRO3(320B%JUMP\,0,LASTLINE)
06300			   END
06400			 ELSE
06500			   BEGIN
06600			    MACRO4R(320B%JUMP\,LINEDIFF MOD 16,LINEDIFF DIV 16, LASTSTOP); %NOOP\
06700			    LASTSTOP := IC - 1
06800			   END;
06900			LASTLINE := LINECNT
07000		       END
07100		   END;
07200	
07300		  PROCEDURE SUPPORT(FSUPPORT: SUPPORTS);
07400		   BEGIN
07500		     CASE FSUPPORT OF
07600	(* 23 - check for bad pointer *)
07700		      BADPOINT,
07800		      ERRORINASSIGNMENT,
07900		      INDEXERROR    : MACRO3R(265B%JSA\,HAC,RNTS.LINK[FSUPPORT]);
08000	(* 12 - NOW STACKOVERFLOW IS NOT AN ERROR - GETS MORE MEMORY *)
08100	(* 74 - add initmem for 10 version under emulator *)
08200	(* 104 - debstack for tops-10 debugging stack check *)
08300	(* 120 - new calling method for INITFILES, for T20/Tenex *)
08400		      INITFILES,INITMEM,STACKOVERFLOW,DEBSTACK: MACRO3R(265B%JSP\,TAC,RNTS.LINK[FSUPPORT]);
08500	(* 64 - non-local gotos *)
08600		      EXITPROGRAM   : MACRO3R(254B%JRST\,0,RNTS.LINK[FSUPPORT]);
08700		      OTHERS	    : MACRO3R(260B%PUSHJ\,TOPP,RNTS.LINK[FSUPPORT])
08800		     END;
08900		    CODE.INFORMATION[CIX]:= 'E';
09000		    RNTS.LINK[FSUPPORT]:= IC-1
09100		   END;
09200	
09300		  PROCEDURE ENTERBODY;
09400		  VAR
09500		    I: INTEGER; LCP : CTP;
09600	(* 66 - NON-LOC GOTO *)
09700		    LBTP: BTP; NONLOC,INLEVEL: BOOLEAN;
09800		   BEGIN
09900		    LBTP := LASTBTP;
10000	(* 13 - ADD DATA FOR DDT SYMBOLS *)
10100		    PFPOINT := IC;
10200		    WHILE LBTP # NIL DO
10300		     BEGIN
10400		      WITH LBTP^ DO
10500		       CASE BKIND OF
10600			RECORDD: FIELDCP^.FLDADDR := IC;
10700			ARRAYY : ARRAYSP^.ARRAYBPADDR := IC
10800		       END;
10900		      LBTP := LBTP^.LAST;
11000		      IC := IC + 1
11100		     END;
11200	(* 66 - NON-LOC GOTO *)
11300		     LCP:=LASTLABEL;
11400		     INLEVEL:=TRUE; NONLOC:=FALSE;
11500		     WHILE(LCP#NIL) AND INLEVEL DO
11600			WITH LCP^ DO
11700			  IF SCOPE=LEVEL
11800			    THEN BEGIN
11900			    NONLOC := NONLOC OR NONLOCGOTO;
12000			    LCP := NEXT
12100			    END
12200			   ELSE INLEVEL := FALSE;
12300		     IF FPROCP # NIL
12400		     THEN
12500		       BEGIN
12600			FULLWORD(NO,0,377777B); IDTREE := CIX; %IF DEBUG, INSERT TREEPOINTER HERE\
12700	(* 13 - SAVE START ADDRESS FOR DDT SYMBOL *)
12800			PFDISP := IC;
12900			WITH FPROCP^ DO
13000			 IF PFLEV > 1
13100			 THEN
13200			  FOR I := MAXLEVEL DOWNTO PFLEV+1 DO
13300			  MACRO4(540B%HRR\,BASIS,BASIS,-1);
13400			PFSTART := IC;
13500	(* 62 - clean up stack offset *)
13600		        if fprocp^.poffset # 0
13700			  then macro4(262B%pop\,topp,topp,-fprocp^.poffset-1);
13800	(* 37 - fix static link for level one procedures *)
13900			if fprocp^.pflev = 1
14000			  then macro4(512b%hllzm\,basis,topp,-fprocp^.poffset-1)
14100			  ELSE MACRO4(202B%MOVEM\,BASIS,TOPP,-FPROCP^.POFFSET-1);
14200			if fprocp^.poffset # 0
14300			  then begin
14400			  macro4(201B%movei\,basis,topp,-fprocp^.poffset);
14500	(* 104 - several changes below to allow detection stack overflow *)
14600			  macro3(504B%hrl\,basis,basis);
14700			  end
14800			 ELSE MACRO3(507B%HRLS\,BASIS,TOPP);
14900	(* 115 - tenex *)
15000			IF KLCPU AND NOT TOPS10
15100			  THEN MACRO3(105B%ADJSP\,TOPP,0)
15200			  ELSE MACRO4(541B%HRRI\,TOPP,TOPP,0);
15300			INSERTSIZE := CIX;
15400	(* 66 - NONLOC GOTO *)
15500			IF NONLOC
15600			  THEN MACRO4(506B%HRLM\,TOPP,BASIS,0);
15700	(* If anyone has done a non-local goto into this block, save the
15800	   stack pointer here where the goto can recover it. *)
15900	(* 53 - figure out later how many loc's above stack we need *)
16000	(* 57 - LIMIT CORE ALLOCATION TO TOPS-10 VERSION *)
16100			IF TOPS10 THEN BEGIN
16200			IF RUNTMCHECK
16300			  THEN BEGIN
16400			  MACRO4(201B%MOVEI\,HAC,TOPP,0); CORALLOC := CIX;
16500			   %Will be fixed up - get highest core needed \
16600			  MACRO4(301B%CAIL\,HAC,BASIS,0); %check wraparound > 777777\
16700			  MACRO4(303B%CAILE\,HAC,NEWREG,0); %see if need more\
16800			  SUPPORT(DEBSTACK)
16900			  END
17000			 ELSE BEGIN %NOT DEBUG\
17100			  MACRO4(307B%CAIG\,NEWREG,TOPP,0); CORALLOC := CIX;
17200			    %will be fixed up - fails if wrap around 777777\
17300			  SUPPORT(STACKOVERFLOW);
17400			  END
17500			END;
17600	(* 24 - NOW ZERO ONLY IF RUNTIME CHECKING ON *)
17700	(* 25 - SEPARATE SWITCH /ZERO FOR THIS NOW *)
17800			IF ZERO
17900			THEN BEGIN
18000			IF LCPAR < LC  %ANY VARIABLES?\
18100			  THEN MACRO4(402B%SETZM\,0,BASIS,LCPAR);
18200			IF LCPAR < (LC-1) %MORE THAN ONE?\
18300			  THEN BEGIN
18400			  MACRO4(505B%HRLI\,TAC,BASIS,LCPAR);
18500			  MACRO4(541B%HRRI\,TAC,BASIS,LCPAR+1);
18600			  MACRO4(251B%BLT\,TAC,BASIS,LC-1)
18700			  END
18800			END;
18900			REGC := REGIN+1;
19000			LCP := FPROCP^.NEXT;
19100			WHILE LCP # NIL DO
19200			WITH LCP^ DO
19300			 BEGIN
19400	(* 33 - proc param.'s*)
19500			   IF KLASS # VARS
19600			   THEN
19700			     BEGIN
19800			     IF REGC <= PARREGCMAX
19900				THEN BEGIN
20000				MACRO4(202B%MOVEM\,REGC,BASIS,PFADDR);
20100				REGC := REGC+1
20200				END
20300			     END
20400			   ELSE
20500			     IF IDTYPE # NIL
20600			     THEN
20700			       IF (VKIND=FORMAL) OR (IDTYPE^.SIZE=1)
20800			       THEN   %COPY PARAMETERS FROM REGISTERS INTO LOCAL CELLS\
20900				 BEGIN
21000				   IF REGC <= PARREGCMAX
21100				   THEN
21200				     BEGIN
21300				      MACRO4(202B%MOVEM\,REGC,BASIS,VADDR); REGC := REGC + 1
21400				     END
21500				 END
21600			       ELSE
21700				 IF IDTYPE^.SIZE=2
21800				 THEN
21900				   BEGIN
22000				     IF REGC < PARREGCMAX
22100				     THEN
22200				       BEGIN
22300					MACRO4(202B%MOVEM\,REGC,BASIS,VADDR);
22400					MACRO4(202B%MOVEM\,REGC+1,BASIS,VADDR+1);
22500					REGC:=REGC+2
22600				       END
22700	(* 2 - bug fix for parameter passing *)
22800				     ELSE REGC:=PARREGCMAX+1
22900				   END
23000	(* 201 - zero size things *)
23100				 ELSE IF IDTYPE^.SIZE > 0
23200				   THEN BEGIN
23300				     IF REGC <= PARREGCMAX
23400				     THEN  %COPY MULTIPLE VALUES INTO LOCAL CELLS\
23500				       BEGIN
23600					MACRO3(504B%HRL\,TAC,REGC); REGC := REGC + 1
23700				       END
23800				     ELSE
23900				      MACRO4(504B%HRL\,TAC,BASIS,VADDR);
24000				    MACRO4(541B%HRRI\,TAC,BASIS,VADDR);
24100				    MACRO4(251B%BLT\,TAC,BASIS,VADDR+IDTYPE^.SIZE-1)
24200				   END
24300	(* 201 - zero size things *)
24400				 ELSE {zero size}
24500				  REGC := REGC + 1;
24600			  LCP := LCP^.NEXT;
24700			 END
24800		       END
24900		     ELSE  MAINSTART := IC
25000		   END %ENTERBODY\;
25100	
25200		  PROCEDURE LEAVEBODY;
25300		  VAR
25400		    J,K : ADDRRANGE ;
25500		    LFILEPTR: FTP; LKSP: KSP ;
25600	(* 33 - PROGRAM *)
25700		    LCP : CTP; OLDID : ALFA;
25800		   PROCEDURE ALFACONSTANT(FSTRING:ALFA);
25900		   VAR LCSP:CSP;
26000		     BEGIN
26100		     NEW(LCSP,STRG);
26200		     WITH LCSP^ DO
26300		       BEGIN
26400		       SLGTH := 10; FOR I := 1 TO 10 DO SVAL[I] := FSTRING[I]
26500		       END;
26600		     WITH GATTR DO
26700		       BEGIN
26800		       TYPTR := ALFAPTR;
26900		       KIND := CST; CVAL.VALP := LCSP
27000		       END
27100		     END;
27200		   BEGIN
27300		     IF DEBUG
27400		     THEN PUTLINER;
27500		     IF  FPROCP # NIL
27600		     THEN
27700	(* 173 - internal files - close them *)
27800		      if fileinblock[level]
27900		       then begin
28000	{We have to close any files in this block before we can change TOPP,
28100	 or we might be playing with locals above the stack!  So this is
28200	 coded like a non-local goto - new basis in regc, new topp in regc+1}
28300			regc := regin+1;
28400	(* 213 - forgot to subtract 1 from TOPP to simulate POPJ *)
28500			  {simulate HRLS TOPP,BASIS.  But have to subtract 1
28600			   since there would have been a POPJ TOPP, later.
28700			   Because of this, things that would be -1(TOPP) are
28800			   now (TOPP)}
28900			macro4(505B%hrli\,regc+1,basis,-1);
29000			macro3(544B%hlr\,regc+1,regc+1);
29100			  {simulate HLRS BASIS,-1(TOPP), but note that -1 has
29200			   already been done}
29300			macro4(544B%hlr\,regc,regc+1,0);
29400			macro3(504B%hrl\,regc,regc);
29500			  {now get return address from where POPJ TOPP, would
29600			   get it, i.e. (TOPP).  However note that -1 has been
29700			   done}
29800			macro4(550B%hrrz\,regc+2,regc+1,1);
29900			support(exitgoto)
30000			end
30100		      else
30200		       BEGIN
30300	(* 104 - keep LH=RH in topp for tops20 adjsp *)
30400			MACRO3(507B%HRLS\,TOPP,BASIS);
30500			MACRO4(547B%HLRS\,BASIS,TOPP,-1);
30600			MACRO3(263B%POPJ\,TOPP,0);
30700		       END
30800		     ELSE
30900		       BEGIN
31000			 IF MAIN
31100			 THEN
31200			   BEGIN
31300			    SUPPORT(EXITPROGRAM);
31400			    STARTADDR := IC;
31500	(* 2 - get some core by default if none there *)
31600	(* 12 - REDO INITIALIZATION FOR DYNAMIC EXPANDING CORE *)
31700	(* 16 - change entry code in case execute-only or entry at +1 *)
31800	(* 24 - CHANGE AGAIN TO ALLOW ST. ADDR OF HEAP AND STACK SPECIFIED *)
31900			MACRO3R(254B%JRST\,1,IC+2); %PORTAL - IN CASE EXEC-ONLY\
32000			MACRO3R(254B%JRST\,1,IC+2); %IN CASE OFFSET =1\
32100			MACRO3(634B%TDZA\,1,1); %NORMAL ENTRY - ZERO AND SKIP\
32200			MACRO3(201B%MOVEI\,1,1); %CCL ENTRY - SET TO ONE\
32300			MACRO3R(202B%MOVEM\,1,CCLSW); %STORE CCL VALUE\
32400			MACRO3R(200B%MOVE\,1,CCLSW+4); %SEE IF INIT DONE\
32500			MACRO3R(326B%JUMPN\,1,IC+5); %YES - DON'T RESAVE AC'S\
32600			MACRO3R(202B%MOVEM\,0,CCLSW+1); %RUNNAME\
32700			MACRO3R(202B%MOVEM\,7B,CCLSW+2); %RUNPPN\
32800			MACRO3R(202B%MOVEM\,11B,CCLSW+3); %RUNDEV\
32900			MACRO3R(476B%SETOM\,0,CCLSW+4); %SAY WE HAVE DONE IT\
33000	(* 132 - separate KA10 into NOVM and KACPU *)
33100			IF (HEAP = 0) AND (NOT NOVM)
33200	(* 216 - variable start of high seg *)
33300			  THEN HEAP := HIGHSTART - 1;
33400			MACRO3(201B%MOVEI\,BASIS,HEAP); %LSTNEW_377777\
33500			MACRO3R(202B%MOVEM\,BASIS,LSTNEW); %WILL GET GLOBAL FIXUP\
33600			LSTNEW := IC-1;
33700			MACRO3(201B%MOVEI\,BASIS,HEAP+1); %NEWBND_400000\
33800			MACRO3R(202B%MOVEM\,BASIS,NEWBND); %GLOBAL FIXUP\
33900			NEWBND := IC-1;
34000			IF STACK#0
34100			  THEN MACRO3(201B%MOVEI\,BASIS,STACK)
34200			  ELSE MACRO3(550B%HRRZ\,BASIS,115B); %BASIS_.JBHRL\
34300			MACRO3(306B%CAIN\,BASIS,0); %IF NO HISEG\
34400	(* 216 - variable start of high seg *)
34500			MACRO3(201B%MOVEI\,BASIS,HIGHSTART - 1); %START STACK 400000\
34600			MACRO3(200B%MOVE\,NEWREG,BASIS); %NEWREG=HIGHEST ALLOC\
34700			MACRO3(271B%ADDI\,BASIS,1); %BASIS=NEXT TO USE\
34800			    MACRO4(505B%HRLI\,BASIS,BASIS,0);
34900			    MACRO4(541B%HRRI\,TOPP,BASIS,0); %GETS FIXED UP\
35000			    INSERTSIZE:= CIX;
35100	(* 104 - KEEP LH=RH FOR TOPS20 ADJSP *)
35200			    MACRO3(504B%HRL\,TOPP,TOPP);
35300	(* 66 - nonloc goto's *)
35400			    macro3r(202B%movem\,basis,globbasis);
35500			    macro3r(202B%movem\,topp,globtopp);
35600	(* 17 - LEAVE .JBFF ALONE, SINCE BUFFER HEADERS POINT INTO FREE AREA *)
35700	(* 57 - LIMIT UUO'S AND CORE ALLOC TO TOPS-10 VERSION *)
35800			IF TOPS10 THEN BEGIN
35900	(* 122 - seem not to need to save .jbff any more *)
36000		  {	    MACRO3(550B%HRRZ\,1,121B); %.JBFF\
36100			    MACRO3(506B%HRLM\,1,120B); %TO LH(.JBSA)\
36200		  }	    MACRO3(047B,0,0%RESET-UUO\); %.JBFF=.JBSA\
36300	(* 74 - new init stuff for tops10 under emulator *)
36400			    support(initmem);
36500	(* 53 - figure out later how many loc's above stack we need *)
36600	(* 130 - leave in dummy CAI in KA version so there is some place for the CORALLOC fixup to go *)
36700			  MACRO4(300B%CAI\,NEWREG,TOPP,0); CORALLOC := CIX;  %Will be fixed up later\
36800	(* 122 - already get core in initmem for KA *)
36900	(* 132 - separate KA10 into novm and kacpu *)
37000			  if not novm 
37100			    THEN SUPPORT(STACKOVERFLOW);	% GET CORE FOR STACK\
37200	(* 34 - TRAP ARITH EXCEPTIONS WHEN CHECKING *)
37300			IF ARITHCHECK
37400			  THEN BEGIN
37500			  MACRO3(201B%MOVEI\,1,110B); %TRAP ALL ARITH. EXCEPTIONS\
37600			  MACRO3(047B%CALLI\,1,16B); %APRENB - TURN ON APR SYS\
37700			  END;
37800	(* 57 - INIT ALL IN RUNTIMES FOR NON-TOPS10 *)
37900			END
38000			 ELSE MACRO3(201B%MOVEI\,2,ORD(ARITHCHECK));
38100	(* 50 - reinit file ctl. blocks *)
38200			support(initfiles);
38300			doinitTTY := false;
38400			    LFILEPTR := SFILEPTR ;
38500			    REGC := REGIN + 1 ;
38600	(* 33 - PROGRAM *)
38700	(* 50 - changed logic to only open INPUT and OUTPUT if in pgm state *)
38800			    LPROGFILE := FPROGFILE;
38900			    WHILE LPROGFILE # NIL DO
39000			      BEGIN
39100			      PRTERR := FALSE; OLDID := ID; ID := LPROGFILE^.FILID;
39200			      SEARCHID([VARS],LCP);
39300			      PRTERR := TRUE; ID := OLDID;
39400			      IF LCP = NIL
39500				THEN ERRORWITHTEXT(508,LPROGFILE^.FILID)
39600				ELSE
39700				  WITH LCP^ DO
39800				  BEGIN
39900				  IF IDTYPE#NIL THEN IF IDTYPE^.FORM#FILES
40000				    THEN ERRORWITHTEXT(509,LPROGFILE^.FILID);
40100				  MACRO3R(201B%MOVEI\,REGC,VADDR);
40200				  IF (VLEV = 0) AND (NOT MAIN)
40300				    THEN BEGIN
40400				    VADDR := IC -1;
40500				    CODE.INFORMATION[CIX] := 'E'
40600				    END;
40700			          ALFACONSTANT(LPROGFILE^.FILID);
40800				  MACRO3(551B%HRRZI\,REGC+1,0);DEPCST(STRG,GATTR);
40900	(* 61 - set up flags for gtjfn *)
41000				  i := 60023b; %mandatory flags for gtjfn\
41100				  if lprogfile^.wild
41200				    then i := i + 100B;
41300				  if lprogfile^.newgen
41400				    then i := i + 400000B;
41500				  if lprogfile^.oldfile
41600				    then i := i + 100000B;
41700				  macro3(505B%hrli\,regc+1,i);
41800	(* 172 - end of line proc *)
41900				  if lcp = ttyfile
42000				    then ttyseeeol := lprogfile^.seeeol;
42100				  if not ((lcp = ttyfile) or (lcp = ttyoutfile))
42200				    then SUPPORT(READFILENAME)
42300				  END;
42400	(* 171 - handle input and output as special - many changes to lcp = in/outfile *)
42500			      if (lcp = infile)
42600				and not lprogfile^.interact
42700				  then doinitTTY := true;
42800			      if (lcp = infile) or (lcp = outfile)
42900				then begin
43000				macro3(201B%movei\,regc-1,0);  {AC1=0 for text file}
43100				macro3(403B%setzb\,regc+1,regc+2);
43200				macro3(403B%setzb\,regc+3,regc+4);
43300	(* 64 - input:/ *)
43400	(* 157 - always open INPUT interactive - do GET below *)
43500				if lcp = infile
43600				  then macro3(201B%movei\,regc+3,1);
43700				macro3(403B%setzb\,regc+5,regc+6);
43800	(* 172 - new eoln handling *)
43900				if (lcp = infile) and lprogfile^.seeeol
44000				  then if tops10
44100					 then macro3(201B%movei\,regc+5,40000B)
44200					 else macro3(201B%movei\,regc+6,20B);
44300				if lcp = infile
44400				  then support(resetfile)
44500				  else support(rewritefile)
44600				end;
44700			      LPROGFILE := LPROGFILE^.NEXT
44800			      END;
44900	(* 15 - ZERO ALL ARGS TO OPEN *)
45000			    TTYINUSE := TTYINUSE OR DEBUG;
45100			    WHILE LFILEPTR # NIL DO
45200			    WITH LFILEPTR^ , FILEIDENT^ DO
45300	(* 50 - only open TTY here, as INPUT and OUTPUT done above *)
45400			    begin
45500			    if (fileident = ttyfile) or (fileident = ttyoutfile)
45600				then
45700			     BEGIN
45800			      MACRO3R(201B%MOVEI\,REGC,VADDR) ;
45900			      macro3(201B%movei\,regc-1,0);  {0=text file}
46000	(* 202 - fix illegal option *)
46100			      macro3(403B%setzb\,regc+1,regc+2);
46200			      macro3(403B%setzb\,regc+3,regc+4);
46300	(* 172 - new EOL *)
46400			      macro3(403B%setzb\,regc+5,regc+6);
46500			      if (fileident = ttyfile) and ttyseeeol
46600				  then if tops10
46700					 then macro3(201B%movei\,regc+5,40000B)
46800					 else macro3(201B%movei\,regc+6,20B);
46900	(* 36 - allow debugging non-main modules *)
47000			       IF fileident = ttyfile
47100			       THEN
47200				SUPPORT(RESETFILE)
47300			       ELSE
47400				  SUPPORT(REWRITEFILE) ;
47500			     end;
47600	(* 3 - Removed OPENTTY because of RUNTIM changes *)
47700			      LFILEPTR := NEXTFTP ;
47800			    END ;
47900			    if doinitTTY
48000			      then support(opentty);
48100			    macro3(200b%move\,tac,74b);  %get .jbddt\
48200			    macro3(602b%trne\,tac,777777b);  %if zero RH\
48300			    macro3(603b%tlne\,tac,777777b);  %or non-0 LH\
48400			    macro3r(254b%jrst\,0,mainstart); %isn't PASDDT\
48500			    macro4(260b%pushj\,topp,tac,-2); %init pt. is start-2\
48600			    MACRO3R(254B%JRST\,0,MAINSTART);
48700			   END;
48800		       END;
48900		    CODEEND := IC;
49000		    LKSP:= FIRSTKONST;
49100		    WHILE LKSP # NIL DO
49200		    WITH LKSP^,CONSTPTR^ DO
49300		     BEGIN
49400		      KADDR:= IC;
49500		       CASE  CCLASS OF
49600			INT,
49700			REEL: IC := IC + 1 ;
49800			PSET: IC := IC + 2 ;
49900			STRD,
50000			STRG: IC := IC + (SLGTH+4) DIV 5
50100		       END ;
50200		      %CASE\
50300		      LKSP := NEXTKONST
50400		     END  %WITH , WHILE\;
50500		     IF DEBUGSWITCH
50600		     THEN
50700		       BEGIN
50800			 IF (LEVEL > 1) AND ( DISPLAY[TOP].FNAME # NIL )
50900			 THEN INSERTADDR(RIGHT,IDTREE,IC)
51000		       END
51100		     ELSE
51200		       IF LEVEL = 1
51300		       THEN HIGHESTCODE := IC
51400		   END%LEAVEBODY\;
51500	
51600		  PROCEDURE FETCHBASIS(VAR FATTR: ATTR);
51700		  VAR
51800		    P,Q: INTEGER;
51900		   BEGIN
52000		    WITH FATTR DO
52100		     IF VLEVEL>1
52200		     THEN
52300		       BEGIN
52400			P := LEVEL - VLEVEL;
52500			 IF P=0
52600			 THEN
52700			   IF INDEXR=0
52800			   THEN INDEXR := BASIS
52900			   ELSE MACRO3(270B%ADD\,INDEXR,BASIS)
53000			 ELSE
53100			   BEGIN
53200			    MACRO4(540B%HRR\,TAC,BASIS,-1);
53300			    FOR Q := P DOWNTO 2 DO
53400			    MACRO4(540B%HRR\,TAC,TAC,-1);
53500			     IF INDEXR=0
53600			     THEN INDEXR := TAC
53700			     ELSE MACRO3(270B%ADD\,INDEXR,TAC)
53800			   END;
53900			VLEVEL:=1	%DA IN WITHSTATEMENT DIE MOEGLICHKEIT BESTEHT,
54000					 DASS ES 2-MAL DURCH FETCHBASIS LAEUFT\
54100		       END
54200		   END;
54300		  %FETCHBASIS\
54400	
54500		  PROCEDURE GETPARADDR;
54600		   BEGIN
54700		    FETCHBASIS(GATTR);
54800		    WITH GATTR DO
54900		     BEGIN
55000		      INCREMENTREGC;
55100		      MACRO5(VRELBYTE,200B%MOVE\,REGC,INDEXR,DPLMT);
55200		      INDEXR := REGC; VRELBYTE:= NO;
55300		      INDBIT := 0; VLEVEL := 1; DPLMT := 0;
55400		     END
55500		   END;
55600	
55700	{Warning to future modifiers: At the end of EXPRESSION, there is code that
55800	 second-guesses the register allocation in this procedure.  If you change
55900	 the register allocation here, please look at that code.}
56000		  PROCEDURE MAKECODE(FINSTR: INSTRANGE; FAC: ACRANGE; VAR FATTR: ATTR);
56100		  VAR
56200		    LINSTR: INSTRANGE; LREGC: ACRANGE;
56300		   BEGIN
56400		    WITH FATTR DO
56500		     IF TYPTR#NIL
56600		     THEN
56700		       BEGIN
56800			 CASE KIND OF
56900			  CST:
57000			       IF TYPTR=REALPTR
57100			       THEN
57200				 BEGIN
57300				  MACRO3(FINSTR,FAC,0); DEPCST(REEL,FATTR)
57400				 END
57500			       ELSE
57600				 IF TYPTR^.FORM=SCALAR
57700				 THEN
57800				  WITH CVAL DO
57900				   IF ((IVAL >= 0) AND (IVAL <= MAXADDR))
58000				    OR
58100	(* 50 - correct code for 400000,,0 *)
58200				    ((ABS(IVAL) <= HWCSTMAX+1) AND (IVAL # 400000000000B)
58300				     AND
58400				     ((FINSTR = 200B%MOVE\) OR (IVAL >= 0)))
58500				   THEN
58600				     BEGIN
58700				       IF FINSTR=200B%MOVE\
58800				       THEN
58900					 IF IVAL < 0
59000					 THEN FINSTR := 571B%HRREI\
59100					 ELSE FINSTR := 551B%HRRZI\
59200				       ELSE
59300					 IF (FINSTR>=311B) AND (FINSTR <= 317B)
59400					 THEN FINSTR := FINSTR - 10B %E.G. CAML --> CAIL\
59500					 ELSE FINSTR := FINSTR+1;
59600				      MACRO3(FINSTR,FAC,IVAL);
59700				     END
59800				   ELSE
59900				     BEGIN
60000				      MACRO3(FINSTR,FAC,0); DEPCST(INT,FATTR)
60100				     END
60200				 ELSE
60300				   IF TYPTR=NILPTR
60400				   THEN
60500				     BEGIN
60600				       IF FINSTR=200B%MOVE\
60700				       THEN FINSTR := 571B%HRREI\
60800				       ELSE
60900					 IF (FINSTR>=311B) AND (FINSTR<=317B)
61000					 THEN FINSTR := FINSTR-10B
61100					 ELSE FINSTR := FINSTR+1;
61200				      MACRO3(FINSTR,FAC,377777B);
61300				     END
61400				   ELSE
61500				     IF TYPTR^.FORM=POWER
61600				     THEN
61700				       BEGIN
61800					MACRO3(FINSTR,FAC,0); MACRO3(FINSTR,FAC-1,0); DEPCST(PSET,FATTR);
61900				       END
62000				     ELSE
62100				       IF TYPTR^.FORM=ARRAYS
62200				       THEN
62300					 IF TYPTR^.SIZE = 1
62400					 THEN
62500					   BEGIN
62600					    MACRO3(FINSTR,FAC,0); DEPCST(STRG,FATTR)
62700					   END
62800					 ELSE
62900					   IF TYPTR^.SIZE = 2
63000					   THEN
63100					     BEGIN
63200					      FATTR.CVAL.VALP^.CCLASS := STRD;
63300					      MACRO3(FINSTR,FAC,0); MACRO3(FINSTR,FAC-1,0); DEPCST(STRD,FATTR);
63400					     END;
63500			  VARBL:
63600				 BEGIN
63700				  FETCHBASIS(FATTR); LREGC := FAC;
63800				   IF (INDEXR>REGIN) AND (INDEXR<=REGCMAX) AND ((PACKFG#NOTPACK) OR (FINSTR=200B%MOVE\))
63900				   THEN
64000				     IF (TYPTR^.SIZE = 2) AND LOADNOPTR
64100				     THEN LREGC := INDEXR+1
64200				     ELSE LREGC := INDEXR
64300				   ELSE
64400				     IF (PACKFG#NOTPACK) AND (FINSTR#200B%MOVE\)
64500				     THEN
64600				       BEGIN
64700					INCREMENTREGC; LREGC := REGC
64800				       END;
64900				   CASE PACKFG OF
65000				    NOTPACK:
65100					     BEGIN
65200					       IF (TYPTR^.SIZE = 2) AND LOADNOPTR
65300					       THEN
65400	(* 141 - protect against obscure case where INDEXR = LREGC *)
65500						IF LREGC <> INDEXR
65600						 THEN BEGIN
65700						  MACRO5(VRELBYTE,FINSTR,LREGC,INDEXR,DPLMT+1);
65800						  MACRO5(VRELBYTE,FINSTR,LREGC-1,INDEXR,DPLMT)
65900						  END
66000						 ELSE BEGIN
66100						  MACRO5(VRELBYTE,FINSTR,LREGC-1,INDEXR,DPLMT);
66200						  MACRO5(VRELBYTE,FINSTR,LREGC,INDEXR,DPLMT+1)
66300						  END
66400					       ELSE MACRO(VRELBYTE,FINSTR,LREGC,INDBIT,INDEXR,DPLMT);
66500					     END;
66600				    PACKK:
66700					   BEGIN
66800					    MACRO5(VRELBYTE,201B%MOVEI\,TAC,INDEXR,DPLMT);
66900					     IF (BPADDR>REGIN) AND (BPADDR<=REGCMAX)
67000					     THEN
67100					       IF (INDEXR<=REGIN) OR (BPADDR<INDEXR)
67200					       THEN LREGC := BPADDR
67300					       ELSE LREGC := INDEXR;
67400					    MACRO3R(135B%LDB\,LREGC,BPADDR);
67500					   END;
67600				    HWORDL:  MACRO5(VRELBYTE,554B%HLRZ\,LREGC,INDEXR,DPLMT);
67700				    HWORDR:  MACRO5(VRELBYTE,550B%HRRZ\,LREGC,INDEXR,DPLMT)
67800				   END %CASE\;
67900				   IF (FINSTR#200B%MOVE\) AND (PACKFG#NOTPACK)
68000				   THEN
68100				    MACRO3(FINSTR,FAC,LREGC)
68200				   ELSE FAC := LREGC
68300				 END;
68400			  EXPR:
68500				IF FINSTR#200B%MOVE\
68600				THEN
68700				  IF TYPTR^.SIZE = 2
68800				  THEN
68900				    BEGIN
69000				     MACRO3(FINSTR,FAC,REG); MACRO3(FINSTR,FAC-1,REG-1)
69100				    END
69200				  ELSE MACRO3(FINSTR,FAC,REG)
69300			 END %CASE\;
69400			KIND := EXPR; REG := FAC;
69500		       END;
69600		   END;
69700	
69800		  PROCEDURE LOAD(VAR FATTR: ATTR);
69900		   BEGIN
70000		    WITH FATTR DO
70100		     IF TYPTR#NIL
70200		     THEN
70300		       IF KIND#EXPR
70400		       THEN
70500			 BEGIN
70600			  INCREMENTREGC ;
70700			   IF (TYPTR^.SIZE = 2) AND LOADNOPTR
70800			   THEN INCREMENTREGC ;
70900			  MAKECODE(200B%MOVE\,REGC,FATTR);REGC := REG
71000			 END;
71100		   END;
71200		  %LOAD\
71300	
71400	(* 104 - common procedure for improved range check on subranges *)
71500		  procedure loadsubrange(var gattr:attr;lsp:stp);
71600		    var slattr:attr; srmin,srmax:integer;
71700		    begin
71800	            GETBOUNDS(LSP,SRMIN,SRMAX);
71900		    IF (GATTR.KIND=CST)
72000		    THEN
72100		      IF (GATTR.CVAL.IVAL >= SRMIN) AND (GATTR.CVAL.IVAL <=SRMAX)
72200		      THEN LOAD (GATTR)
72300		      ELSE ERROR (367)
72400		    ELSE
72500		      BEGIN
72600		        IF RUNTMCHECK AND (( GATTR.KIND#VARBL) OR (GATTR.SUBKIND # LSP))
72700		        THEN
72800		          BEGIN
72900		           LOAD (GATTR);
73000		           WITH SLATTR DO
73100				BEGIN
73200				 TYPTR:=INTPTR;
73300				 KIND :=CST;
73400				 CVAL.IVAL:=SRMAX
73500				END;
73600		           MAKECODE(317B%CAMG\,REGC,SLATTR);
73700		           SLATTR.KIND:=CST;
73800		           SLATTR.CVAL.IVAL:=SRMIN;
73900		           MAKECODE(315B%CAMGE\,REGC,SLATTR);
74000		           SUPPORT(ERRORINASSIGNMENT)
74100		          END
74200		        ELSE LOAD (GATTR);
74300		      END
74400		    end;
74500	
74600		  PROCEDURE STORE(FAC: ACRANGE; VAR FATTR: ATTR);
74700		  VAR
74800		    LATTR: ATTR;
74900		   BEGIN
75000		    LATTR := FATTR;
75100		    WITH LATTR DO
75200		     IF TYPTR # NIL
75300		     THEN
75400		       BEGIN
75500			FETCHBASIS(LATTR);
75600			 CASE PACKFG OF
75700			  NOTPACK:
75800				   BEGIN
75900				     IF TYPTR^.SIZE = 2
76000				     THEN
76100				       BEGIN
76200					MACRO5(VRELBYTE,202B%MOVEM\,FAC,INDEXR,DPLMT+1); FAC := FAC-1
76300				       END;
76400				    MACRO(VRELBYTE,202B%MOVEM\,FAC,INDBIT,INDEXR,DPLMT)
76500				   END;
76600			  PACKK:
76700				 BEGIN
76800				  MACRO5(VRELBYTE,201B%MOVEI\,TAC,INDEXR,DPLMT);
76900				  MACRO3R(137B%DPB\,FAC,BPADDR);
77000				 END;
77100			  HWORDL:  MACRO5(VRELBYTE,506B%HRLM\,FAC,INDEXR,DPLMT);
77200			  HWORDR:  MACRO5(VRELBYTE,542B%HRRM\,FAC,INDEXR,DPLMT)
77300			 END  %CASE\ ;
77400		       END %WITH\ ;
77500		   END %STORE\ ;
77600	
77700	{Warning to future modifiers: At the end of EXPRESSION, there is code that
77800	 second-guesses the register allocation in this procedure.  If you change
77900	 the register allocation here, please look at that code.}
78000		  PROCEDURE LOADADDRESS;
78100		   BEGIN
78200		    INCREMENTREGC ;
78300		     BEGIN
78400		      WITH GATTR DO
78500		       IF TYPTR # NIL
78600		       THEN
78700			 BEGIN
78800			   CASE KIND OF
78900			    CST:
79000				 IF STRING(TYPTR)
     
00100				 THEN
00200				   BEGIN
00300				    MACRO3(201B%MOVEI\,REGC,0);
00400				    DEPCST(STRG,GATTR)
00500				   END
00600				 ELSE ERROR(171);
00700			    VARBL:
00800				   BEGIN
00900				     IF (INDEXR>REGIN)	AND  (INDEXR <= REGCMAX)
01000				     THEN REGC := INDEXR;
01100				    FETCHBASIS(GATTR);
01200				     CASE PACKFG OF
01300				      NOTPACK: MACRO(VRELBYTE,201B%MOVEI\,REGC,INDBIT,INDEXR,DPLMT);
01400				      PACKK,HWORDL,HWORDR: ERROR(357)
01500				     END;
01600				   END;
01700			    EXPR:  ERROR(171)
01800			   END;
01900			  KIND := VARBL;  DPLMT := 0; INDEXR:=REGC; INDBIT:=0; VRELBYTE := NO
02000			 END
02100		     END
02200		   END %LOADADDRESS\ ;
02300	
02400		  PROCEDURE WRITEMC(WRITEFLAG:WRITEFORM);
02500		  CONST
02600	(* 155 *)
02700		    MAXSIZE %OF CONSTANT-, STRUCTURE-, AND ID.-RECORD\ = 44 %WORDS\ ;
02800		  TYPE
02900		    WANDELFORM=(KONSTANTE,PDP10CODE,REALCST,STRCST,SIXBITCST,HALFWD,PDP10BP,RADIX) ;
03000		    RECORDFORM=(NONE,CONSTNTREC,STRUCTUREREC,IDENTIFREC,DEBUGREC);
03100		    BIGALFA = PACKED ARRAY[1..15] OF CHAR ;
03200		  VAR
03300		    I,J,L  : INTEGER; LLISTCODE: BOOLEAN; CHECKER: CTP;
03400		    LIC  : ADDRRANGE; LFIRSTKONST: KSP; LRELBYTE: RELBYTE;
03500		    STRING: ARRAY[1..6] OF CHAR; LFILEPTR: FTP; SWITCHFLAG: FLAGRANGE;
03600		    FILBLOCKADR : ADDRRANGE ; CODEARRAY: BOOLEAN; LICMOD4: ADDRRANGE;
03700		    LSIZE: 1..MAXSIZE; RUN1: BOOLEAN; SAVELISTCODE: BOOLEAN;
03800		    CSP0: CSP; %INSTEAD OF NIL\
03900		    RELARRAY, RELEMPTY: ARRAY[1..MAXSIZE] OF RELBYTE;
04000		    WANDLUNG : PACKED RECORD
04100					CASE WANDELFORM  OF
04200					     KONSTANTE:(WKONST :INTEGER);
04300					     PDP10CODE:(WINSTR :PDP10INSTR);
04400					     REALCST  :(WREAL: REAL);
04500					     STRCST   :(WSTRING:CHARWORD);
04600					     SIXBITCST:(WSIXBIT:PACKED ARRAY[1..6] OF 0..77B);
04700					     HALFWD   :(WLEFTHALF:ADDRRANGE ; WRIGHTHALF : ADDRRANGE);
04800					     PDP10BP  :(WBYTE: BPOINTER);
04900					     RADIX    :(FLAG: FLAGRANGE; SYMBOL: RADIXRANGE)
05000	
05100				      END;
05200		    ICWANDEL: PACKED RECORD
05300				       CASE VARIANTE:INTEGER OF
05400					    1:(ICVAL: ADDRRANGE);
05500					    2:(ICCSP: CSP);
05600					    3:(ICCTP: CTP);
05700					    4:(ICSTP: STP)
05800				     END;
05900		    RECORDWANDEL: PACKED RECORD
06000					   CASE RECORDFORM OF
06100						NONE:  (WORD:ARRAY[1..MAXSIZE] OF INTEGER);
06200						CONSTNTREC:(CONSTREC: CONSTNT);
06300						STRUCTUREREC:(STRUCTREC: STRUCTURE);
06400						IDENTIFREC:(IDENTREC: IDENTIFIER);
06500						DEBUGREC:(DEBUGREC: DEBENTRY)
06600					 END;
06700	
06800		    PROCEDURE NEUEZEILE;
06900		     BEGIN
07000	(* 6 - if CREFing, less stuff fits on a line *)
07100		      IF CREF
07200			THEN LICMOD4 := LIC MOD 3
07300			ELSE LICMOD4 := LIC MOD 4;
07400		       IF (LICMOD4 = 0) AND LISTCODE AND (LIC > 0)
07500		       THEN
07600			 BEGIN
07700	(* 136 - LISTING FORMAT *)
07800			  newline ;
07900			   IF RELBLOCK.ITEM = 1
08000			   THEN
08100			     BEGIN
08200			      WRITE(LIC:6:O);
08300			       IF LIC >= PROGRST
08400			       THEN WRITE('''')
08500			       ELSE WRITE(' ')
08600			     END
08700			   ELSE WRITE(' ':7)
08800			 END
08900		     END %NEUEZEILE\ ;
09000	
09100		    PROCEDURE PUTRELCODE;
09200		    VAR
09300		      I: INTEGER;
09400	
09500		     BEGIN
09600		      WITH RELBLOCK DO
09700	(* 146 - Move count := 0 outside the test, since we must zero count in
09800	   the case where COUNT = 1 and ITEM = 1. *)
09900		       BEGIN
10000		       IF ((COUNT > 1) OR (ITEM # 1)) AND (COUNT > 0)
10100		       THEN
10200			 BEGIN
10300			  FOR I:= COUNT+1 TO 18 DO RELOCATOR[I-1] := NO;
10400			  FOR I:= 1 TO COUNT+2 DO
10500			   BEGIN
10600			    OUTPUTREL^:= COMPONENT[I];
10700			    PUT(OUTPUTREL)
10800			   END;
10900			 END;
11000	(* 146 *)
11100		       COUNT := 0;
11200		       END;
11300		     END;
11400	
11500		    PROCEDURE SHOWRELOCATION(FSIDE: RELBYTE; FRELBYTE: RELBYTE);
11600		     BEGIN
11700		       IF (FRELBYTE = FSIDE) OR (FRELBYTE = BOTH)
11800		       THEN WRITE('''')
11900		       ELSE WRITE(' ')
12000		     END;
12100	
12200		    PROCEDURE WRITEBLOCKST( FITEM: ADDRRANGE);
12300		    VAR
12400		      WANDLUNG: PACKED RECORD
12500					 CASE BOOLEAN OF
12600					      TRUE: (WKONST: INTEGER);
12700					      FALSE: (WLEFTHALF: ADDRRANGE;WRIGHTHALF: ADDRRANGE)
12800				       END;
12900		     BEGIN
13000		      WITH RELBLOCK , WANDLUNG DO
13100		       BEGIN
13200			 IF COUNT # 0
13300			 THEN PUTRELCODE;
13400			ITEM:= FITEM;
13500			 IF ITEM = 1
13600			 THEN
13700			   BEGIN
13800			    WLEFTHALF:= 0;
13900			    WRIGHTHALF:= LIC;
14000			    CODE[0]:= WKONST;
14100			     IF WRIGHTHALF < PROGRST
14200			     THEN RELOCATOR[0] := NO
14300			     ELSE RELOCATOR[0] := RIGHT;
14400			    COUNT:= 1
14500			   END
14600		       END
14700		     END;
14800	
14900		    PROCEDURE WRITEWORD(FRELBYTE: RELBYTE; FWORD: INTEGER);
15000		    VAR
15100		      WANDLUNG: PACKED RECORD
15200					 CASE BOOLEAN OF
15300					      TRUE: (WKONST: INTEGER);
15400					      FALSE: (WLEFTHALF: ADDRRANGE; WRIGHTHALF: ADDRRANGE)
15500				       END;
15600		     BEGIN
15700		      WITH WANDLUNG DO
15800		       BEGIN
15900			WKONST := FWORD;
16000			WITH RELBLOCK DO
16100			 BEGIN
16200			   IF COUNT = 0
16300			   THEN WRITEBLOCKST(ITEM);
16400			  CODE[COUNT]:= FWORD;
16500			   IF FRELBYTE IN [LEFT,BOTH]
16600			   THEN
16700			     IF (WLEFTHALF < PROGRST) OR (WLEFTHALF = 377777B)
16800			     THEN FRELBYTE := FRELBYTE - LEFT;
16900			   IF FRELBYTE IN [RIGHT,BOTH]
17000			   THEN
17100			     IF (WRIGHTHALF < PROGRST) OR (WRIGHTHALF = 377777B)
17200			     THEN FRELBYTE := FRELBYTE - RIGHT;
17300			  RELOCATOR[COUNT]:= FRELBYTE; LRELBYTE := FRELBYTE;
17400			  COUNT := COUNT+1;
17500			   IF COUNT = 18
17600			   THEN PUTRELCODE
17700			 END;
17800			 IF LLISTCODE
17900			 THEN
18000			   BEGIN
18100			    NEUEZEILE;
18200			     IF LIC > 0
18300			     THEN WRITE(' ':13);
18400	(* 173 - remove writefileblocks *)
18500			     IF WRITEFLAG > WRITELIBRARY
18600			     THEN WRITE(' ':7)
18700			     ELSE
18800			       BEGIN
18900				WRITE(WLEFTHALF:6:O); SHOWRELOCATION(LEFT,FRELBYTE)
19000			       END;
19100			    WRITE(WRIGHTHALF:6:O); SHOWRELOCATION(RIGHT,FRELBYTE); WRITE(' ':3)
19200			   END;
19300			 IF NOT CODEARRAY
19400			 THEN LIC := LIC + 1
19500		       END
19600		     END;
19700	
19800		    FUNCTION RADIX50( FNAME: ALFA): RADIXRANGE;
19900		    VAR
20000		      I: INTEGER; OCTALCODE, RADIXVALUE: RADIXRANGE;
20100	
20200		     BEGIN
20300		      RADIXVALUE:= 0;
20400		      I:=1;
20500		      WHILE (FNAME[I] # ' ') AND (I <= 6) DO
20600		       BEGIN
20700			 IF FNAME[I] IN DIGITS
20800			 THEN OCTALCODE:= ORD(FNAME[I])-ORD('0')+1
20900			 ELSE
21000			   IF FNAME[I] IN LETTERS
21100			   THEN OCTALCODE:= ORD(FNAME[I])-ORD('A')+11
21200			   ELSE
21300			     CASE FNAME[I] OF
21400			      '.': OCTALCODE:= 37;
21500			      '$': OCTALCODE:= 38;
21600			      '%': OCTALCODE:= 39
21700			     END;
21800			RADIXVALUE:= RADIXVALUE*50B; RADIXVALUE:= RADIXVALUE+OCTALCODE; I:=I+1
21900		       END;
22000		      RADIX50:= RADIXVALUE
22100		     END;
22200	
22300		    PROCEDURE WRITEPAIR( FRELBYTE: RELBYTE; FADDR1, FADDR2: ADDRRANGE);
22400		     BEGIN
22500		      WITH WANDLUNG DO
22600		       BEGIN
22700			WLEFTHALF:= FADDR1;
22800			WRIGHTHALF:= FADDR2;
22900			WRITEWORD(FRELBYTE,WKONST)
23000		       END
23100		     END;
23200	
23300		    PROCEDURE WRITEIDENTIFIER( FFLAG: FLAGRANGE; FSYMBOL: ALFA);
23400		     BEGIN
23500		      LLISTCODE := FALSE;
23600		      WITH WANDLUNG DO
23700		       BEGIN
23800			 IF LISTCODE AND (WRITEFLAG > WRITEHISEG)
23900			 THEN
24000			   BEGIN
24100	(* 40 - if CREFing, less stuff fits on a line *)
24200			     IF ((NOT CREF) AND (LIC MOD 4 = 0) OR
24300				 CREF AND (LIC MOD 3 = 0)) AND (LIC > 0)
24400			     THEN
24500			       BEGIN
24600	(* 136 - LISTING FORMAT *)
24700				NEWLINE;
24800				WRITE(' ':7)
24900			       END;
25000			     IF LIC > 0
25100			     THEN WRITE(' ':13); WRITE(FSYMBOL:6,' ':11)
25200			   END;
25300	(* 40 - print format *)
25400			 if listcode and cref then lic := lic+1;
25500			 IF FFLAG # 6B
25600			 THEN
25700			   BEGIN
25800			    FLAG:= FFLAG; SYMBOL:= RADIX50(FSYMBOL)
25900			   END;
26000			WRITEWORD(NO,WKONST); LLISTCODE := LISTCODE
26100		       END
26200		     END;
26300	
26400		    PROCEDURE WRITEFIRSTLINE ;
26500		     BEGIN
26600		       IF LISTCODE
26700		       THEN
26800			 BEGIN
26900	(* 136 - LISTING FORMAT *)
27000			  NEWLINE;
27100	(* 6 - if CREFing, less stuff fits on a line *)
27200			  IF CREF
27300			    THEN LICMOD4 := LIC MOD 3
27400			    ELSE LICMOD4 := LIC MOD 4;
27500			   IF LICMOD4 > 0
27600			   THEN
27700			     BEGIN
27800			      WRITE(LIC-LICMOD4:6:O);
27900			       IF LIC >= PROGRST
28000			       THEN WRITE('''')
28100			       ELSE WRITE(' ');
28200			      WRITE(' ':LICMOD4*30);
28300			       IF (WRITEFLAG = WRITECODE) AND CODEARRAY
28400			       THEN WRITE(' ':2)
28500			     END
28600			 END
28700		     END ;
28800	
28900		    PROCEDURE WRITEHEADER(FTEXT: BIGALFA);
29000		     BEGIN
29100		      LIC := 0;
29200		       IF LISTCODE
29300		       THEN
29400			 BEGIN
29500	(* 136 - LISTING FORMAT *)
29600			  NEWLINE;
29700			  WRITE(FTEXT:15,':',' ':4)
29800			 END
29900		     END;
30000	
30100	(*173 - remove writefileblocks *)
30200	
30300		    PROCEDURE MCGLOBALS;
30400		     BEGIN
30500		      %MCGLOBALS\
30600		       IF LISTCODE AND (FGLOBPTR # NIL)
30700		       THEN WRITEBUFFER;
30800		      WHILE FGLOBPTR # NIL DO
30900		      WITH FGLOBPTR^ DO
31000		       BEGIN
31100			LIC := FIRSTGLOB ; WRITEFIRSTLINE ;
31200			J := FCIX ;
31300			WRITEBLOCKST(1);
31400			FOR I := FIRSTGLOB TO LASTGLOB DO
31500			 BEGIN
31600			  WANDLUNG.WINSTR := CODE.INSTRUCTION[J] ; J := J + 1 ;
31700			  WRITEWORD(NO,WANDLUNG.WKONST) ;
31800			 END ;
31900			FGLOBPTR := NEXTGLOBPTR
32000		       END;
32100		     END %MCGLOBALS\;
32200	
32300		    PROCEDURE MCCODE;
32400	
32500		      PROCEDURE WRITERECORD;
32600		       BEGIN
32700			FOR I := 1 TO LSIZE DO WRITEWORD(RELARRAY[I], RECORDWANDEL.WORD[I] )
32800		       END;
32900	
33000	(* 211 - MAKE CONSTANTS WORK IN THE DEBUGGER *)
33100		      FUNCTION CONSTRECSIZE(FCSP: CSP): INTEGER;
33200		       BEGIN
33300			WITH FCSP^ DO
33400			 CASE CCLASS OF
33500			  INT,PSET: CONSTRECSIZE := 5;
33600			  REEL	  : CONSTRECSIZE := 4;
33700			  STRD,STRG:CONSTRECSIZE := 4 + (SLGTH+4) DIV 5
33800			 END
33900		       END;
34000	
34100		      PROCEDURE COPYCSP(FCSP:CSP);
34200		       BEGIN
34300			 IF FCSP # NIL
34400			 THEN  WITH FCSP^ DO
34500			   IF RUN1
34600			   THEN
34700			     BEGIN
34800			       IF SELFCSP = CSP0%NIL\
34900			       THEN WITH ICWANDEL DO
35000				 BEGIN
35100				  ICVAL := IC; SELFCSP := ICCSP;
35200				  NOCODE := TRUE;
35300				  IC := IC + CONSTRECSIZE(FCSP)
35400				 END
35500			     END
35600			   ELSE
35700			     IF NOCODE
35800			     THEN
35900			       BEGIN
36000				RECORDWANDEL.CONSTREC := FCSP^;
36100				LSIZE := CONSTRECSIZE(FCSP);
36200				RELARRAY := RELEMPTY;
36300				WRITERECORD; NOCODE := FALSE
36400			       END
36500		       END %COPYCSP\;
36600	
36700		      PROCEDURE COPYSTP(FSP:STP); FORWARD;
36800	
36900		      PROCEDURE COPYCTP(FCP:CTP);
37000		       BEGIN
37100			 IF FCP # NIL
37200			 THEN WITH FCP^ DO
37300			   IF RUN1 AND (SELFCTP=NIL) OR NOT RUN1 AND NOCODE
37400			   THEN
37500			     BEGIN
37600			       IF RUN1
37700			       THEN
37800				WITH ICWANDEL DO
37900				 BEGIN
38000				  ICVAL := IC;
38100				  SELFCTP := ICCTP; NOCODE := TRUE;
38200				  IC := IC + IDRECSIZE[KLASS]
38300				 END %WITH\
38400			       ELSE %NOW RUN 2\
38500				WITH RECORDWANDEL DO
38600				 BEGIN
38700				  RELARRAY := RELEMPTY;
38800				  IDENTREC := FCP^;
38900				  WITH IDENTREC DO
39000				   BEGIN
39100				     IF LLINK#NIL
39200				     THEN
39300				       BEGIN
39400					LLINK:=LLINK^.SELFCTP; RELARRAY[3] := 1
39500				       END;
39600				     IF RLINK#NIL
39700				     THEN
39800				       BEGIN
39900					RLINK:=RLINK^.SELFCTP; RELARRAY[3] := RELARRAY[3] + 2
40000				       END;
40100				     IF NEXT #NIL
40200				     THEN
40300				       BEGIN
40400					NEXT := NEXT^.SELFCTP; RELARRAY[4] := 1B
40500				       END;
40600				     IF IDTYPE # NIL
40700				     THEN
40800				       BEGIN
40900					 IF KLASS = KONST
41000					 THEN
41100					   IF IDTYPE^.FORM > POINTER
41200					   THEN
41300	(* 211 - FIX CONSTANT PRINTING *)
41400					     BEGIN
41500					     VALUES.VALP := VALUES.VALP^.SELFCSP;
41600					     RELARRAY[6] := 1B
41700					     END
41800					   ELSE
41900					     IF IDTYPE = REALPTR
42000					     THEN
42100					       BEGIN
42200						WANDLUNG.WREAL := VALUES.VALP^.RVAL;
42300						VALUES.IVAL := WANDLUNG.WKONST
42400					       END;
42500					 IF KLASS=VARS
42600					 THEN
42700					   IF VLEV<2
42800					   THEN RELARRAY[6] := 2;
42900					 IF KLASS = FIELD
43000					 THEN
43100					   IF PACKF = PACKK
43200					   THEN RELARRAY[6] := 2;
43300					IDTYPE:=IDTYPE^.SELFSTP; RELARRAY[4] := RELARRAY[4] + 2
43400				       END
43500				   END;
43600				  LSIZE := IDRECSIZE[KLASS]; WRITERECORD;
43700				  NOCODE := FALSE
43800				 END %WITH RECORDWANDEL\;
43900			      COPYCTP(LLINK);
44000			      COPYCTP(RLINK);
44100			      COPYSTP(IDTYPE);
44200	(* 214 - fix debugger problem with foward declared proc's *)
44300	{The following is somewhat of a kludge. We don't want to do COPYCTP
44400	 on the NEXT field of a procedure.  If we did, the following could
44500	 happen:
44600		procedure foo(x:integer); forward;
44700		...
44800		  foo(1);
44900		...
45000		procedure foo;
45100		  var i,j;
45200	 When the final declaration of FOO is supplied, the symbol table is
45300	 initialized from symboltable(FOO)^.NEXT, which contains the parameters,
45400	 as supplied in the forward decl.  Then I and J are added to the symbol
45500	 table.  The result is that X points to I and J in the symbol table
45600	 tree.  This is all fine.  The problem comes when the identifier
45700	 record for FOO is put into the .REL file before the final declaration.
45800	 If COPYCTP traces the NEXT field, then the identifier records for all
45900	 the parameters are also put out.  Since a given identifier is put out
46000	 only once, this means that X is put into the .REL file before pointers
46100	 to I and J are added to it.  The effect is that the debugger can't
46200	 see I and J.
46300	    It turns out that the  debugger never uses the NEXT field of a
46400	 procedure entry.  Thus it is not crucial to have a correctly mapped
46500	 value when the identifier record for the procedure is put out.
46600	 If we don't call COPYCTP on NEXT, then the NEXT field put into the
46700	 .REL file will be junk, but at least records for the parameters won't
46800	 be put out prematurely.  They will get put out eventually even without
46900	 tracing NEXT, since they will show up in the symbol table for the
47000	 procedure when it is finally declared.  That should suffice.}
47100	
47200			      IF NOT (KLASS IN [PROC,FUNC])
47300			        THEN COPYCTP(NEXT);
47400			       IF (KLASS = KONST)  AND (IDTYPE # NIL)
47500			       THEN
47600				 IF IDTYPE^.FORM > POINTER
47700				 THEN COPYCSP(VALUES.VALP)
47800			     END %WITH FCP^\
47900		       END %COPYCTP\;
48000	
48100		      PROCEDURE COPYSTP;
48200		       BEGIN
48300			 IF FSP # NIL
48400			 THEN WITH FSP^ DO
48500			   IF RUN1 AND (SELFSTP = NIL)	OR  NOT RUN1 AND NOCODE
48600			   THEN
48700			     BEGIN
48800			       IF RUN1
48900			       THEN
49000				WITH ICWANDEL DO
49100				 BEGIN
49200				  NOCODE:=TRUE;
49300				  ICVAL := IC; SELFSTP := ICSTP;
49400				  IC := IC + STRECSIZE[FORM]
49500				 END
49600			       ELSE %NOW RUN 2\
49700				 IF NOCODE
49800				 THEN WITH RECORDWANDEL DO
49900				   BEGIN
50000				    RELARRAY := RELEMPTY; RELARRAY[2] := 1;
50100				    STRUCTREC := FSP^;
50200				    WITH STRUCTREC DO
50300				     CASE FORM OF
50400				      SCALAR:
50500					      IF SCALKIND = DECLARED
50600					      THEN
50700						IF FCONST#NIL
50800						THEN FCONST:=FCONST^.SELFCTP;
50900				      SUBRANGE:
51000						BEGIN
     
00100						 RANGETYPE:=RANGETYPE^.SELFSTP; RELARRAY[2]:=1
00200						END;
00300				      POINTER:
00400					       IF ELTYPE # NIL
00500					       THEN ELTYPE := ELTYPE^.SELFSTP;
00600				      POWER:	ELSET := ELSET^.SELFSTP;
00700				      ARRAYS:
00800					      BEGIN
00900	(* 122 - DON'T FOLLOW NILS ON FUDGED TYPES *)
01000					      IF AELTYPE#NIL
01100					        THEN AELTYPE := AELTYPE^.SELFSTP;
01200					      IF INXTYPE#NIL
01300						THEN INXTYPE := INXTYPE^.SELFSTP; 
01400					      RELARRAY[3] := 3
01500					      END;
01600				      RECORDS:
01700					       BEGIN
01800						 IF FSTFLD # NIL
01900						 THEN FSTFLD := FSTFLD^.SELFCTP;
02000						 IF RECVAR # NIL
02100						 THEN
02200						   BEGIN
02300						    RECVAR := RECVAR^.SELFSTP; RELARRAY[3] := 2
02400						   END
02500					       END;
02600				      FILES:	IF FILTYPE # NIL 
02700						  THEN FILTYPE := FILTYPE^.SELFSTP;
02800				      TAGFWITHID,
02900				      TAGFWITHOUTID:
03000						     BEGIN
03100						      FSTVAR := FSTVAR^.SELFSTP;
03200						       IF FORM = TAGFWITHID
03300						       THEN TAGFIELDP := TAGFIELDP^.SELFCTP
03400						       ELSE TAGFIELDTYPE := TAGFIELDTYPE^.SELFSTP;
03500						      RELARRAY[3] := 2
03600						     END;
03700				      VARIANT:
03800					       BEGIN
03900						 IF SUBVAR # NIL
04000						 THEN SUBVAR := SUBVAR^.SELFSTP;
04100						 IF FIRSTFIELD # NIL
04200						 THEN
04300						   BEGIN
04400						    FIRSTFIELD := FIRSTFIELD^.SELFCTP; RELARRAY[3]:=1
04500						   END;
04600						 IF NXTVAR # NIL
04700						 THEN
04800						   BEGIN
04900						    NXTVAR := NXTVAR^.SELFSTP; RELARRAY[3] :=RELARRAY[3] + 2
05000						   END;
05100					       END
05200				     END %CASE\;
05300				    LSIZE := STRECSIZE[FORM]; WRITERECORD;
05400				    NOCODE := FALSE
05500				   END %RUN 2\;
05600			       CASE FORM OF
05700				SCALAR:
05800					IF SCALKIND = DECLARED
05900					THEN COPYCTP(FCONST);
06000				SUBRANGE:COPYSTP(RANGETYPE);
06100				POINTER: COPYSTP(ELTYPE);
06200				POWER:	 COPYSTP(ELSET);
06300				ARRAYS:
06400					BEGIN
06500					 COPYSTP(AELTYPE);
06600					 COPYSTP(INXTYPE)
06700					END;
06800				RECORDS:
06900					 BEGIN
07000					  COPYCTP(FSTFLD);
07100					  COPYSTP(RECVAR)
07200					 END;
07300				FILES:	 COPYSTP(FILTYPE);
07400				TAGFWITHID,
07500				TAGFWITHOUTID:
07600					       BEGIN
07700						COPYSTP(FSTVAR);
07800						 IF FORM = TAGFWITHID
07900						 THEN COPYCTP(TAGFIELDP)
08000						 ELSE COPYSTP(TAGFIELDTYPE)
08100					       END;
08200				VARIANT:
08300					 BEGIN
08400					  COPYSTP(NXTVAR);
08500					  COPYSTP(SUBVAR);
08600					  COPYCTP(FIRSTFIELD)
08700					 END
08800			       END %CASE\
08900			     END %WITH\
09000		       END %COPYSTP\;
09100	
09200		     BEGIN
09300		      %MCCODE\
09400		      CODEARRAY := FALSE; LLISTCODE:= FALSE;
09500		       IF LISTCODE
09600		       THEN WRITEBUFFER;
09700		       IF LASTBTP # NIL
09800		       THEN
09900			WITH LASTBTP^ DO
10000			 CASE BKIND OF
10100			  RECORDD:  LIC := FIELDCP^.FLDADDR ;
10200			  ARRAYY :  LIC := ARRAYSP^.ARRAYBPADDR
10300			 END ;
10400		      WRITEFIRSTLINE ; WRITEBLOCKST(1);
10500		      WHILE LASTBTP # NIL DO
10600		       BEGIN
10700			WITH  LASTBTP^,BYTE  DO
10800			 BEGIN
10900			   IF LISTCODE
11000			   THEN
11100			     BEGIN
11200			      NEUEZEILE;
11300			       IF LICMOD4 = 0
11400			       THEN WRITE(' ':7)
11500			       ELSE WRITE(' ':5);
11600			      WRITE(' POINT  ',SBITS:2,',') ;
11700			       IF IBIT = 0
11800			       THEN WRITE('  ')
11900			       ELSE WRITE(' @') ;
12000			      WRITE(RELADDR:5:O,'(',IREG:2:O,'),',35-PBITS:2) ;
12100			     END;
12200			  WITH WANDLUNG DO
12300			   BEGIN
12400			    WBYTE := BYTE;
12500			    WRITEWORD(NO,WKONST)
12600			   END;
12700			  LASTBTP := LAST
12800			 END
12900		       END % WHILE\ ;
13000		      LIC := CODEEND - CIX - 1 ; CODEARRAY := TRUE;
13100		      WRITEBLOCKST(1); WRITEFIRSTLINE;
13200		      FOR  I := 0 TO  CIX  DO
13300		      WITH CODE, INSTRUCTION[I], HALFWORD[I] DO
13400		       BEGIN
13500			LRELBYTE := RELOCATION[I]; WRITEWORD(LRELBYTE,WORD[I]);
13600			 IF LISTCODE
13700			 THEN
13800			   BEGIN
13900			    NEUEZEILE;
14000			     IF LICMOD4 = 0
14100			     THEN WRITE(' ':7)
14200			     ELSE WRITE(' ':5);
14300			     CASE INFORMATION[I] OF
14400			      'W':
14500				   BEGIN
14600				    WRITE(' ':6,LEFTHALF :6:O); SHOWRELOCATION(LEFT,LRELBYTE);
14700				    WRITE(RIGHTHALF:6:O); SHOWRELOCATION(RIGHT,LRELBYTE);
14800				    WRITE(' ':5)
14900				   END;
15000				  %'B': WITH WANDLUNG.WBYTE DO
15100				   BEGIN
15200				   WANDLUNG.WKONST := WORD[I];
15300				   WRITE(' POINT  ',SBITS:2,',');
15400				   IF IBIT = 0 THEN WRITE('  ') ELSE WRITE(' @');
15500				   WRITE(RELADDR:5:O,'(',IREG:2:O,'),',35-PBITS:2)
15600				   END;\
15700			      OTHERS:
15800				      BEGIN
15900	(* 6 - UNPACK CAN'T DO THIS NOW *)
16000				       %UNPACK(MNEMONICS[(INSTR+9) DIV 10],((INSTR+9) MOD 10)*6+1,STRING,6);\
16100				       FOR J := 1 TO 6 DO
16200					STRING[J] := MNEMONICS[(INSTR+9) DIV 10, ((INSTR+9) MOD 10)*6 + J];
16300				       WRITE(' ',STRING:6, ' ',AC:2:O,', ');
16400					IF INDBIT = 0
16500					THEN WRITE(' ')
16600					ELSE WRITE('@');
16700				       WRITE(ADDRESS:6:O); SHOWRELOCATION(RIGHT,LRELBYTE);
16800					IF INXREG > 0
16900					THEN WRITE('(',INXREG:2:O,')',INFORMATION[I]:1)
17000					ELSE WRITE(' ':4,INFORMATION[I]:1)
17100				      END
17200			     END
17300			   END;
17400			LIC := LIC + 1
17500		       END  %FOR \ ;
17600		      CODEARRAY := FALSE; LLISTCODE := LISTCODE;
17700		       IF FIRSTKONST # NIL
17800		       THEN
17900			 BEGIN
18000			  LFIRSTKONST := FIRSTKONST; WRITEFIRSTLINE; WRITEBLOCKST(1);
18100			  WHILE LFIRSTKONST # NIL DO
18200			   BEGIN
18300			    WITH LFIRSTKONST^.CONSTPTR^ DO
18400			     CASE  CCLASS  OF
18500			      INT,
18600			      REEL: WRITEWORD(NO,INTVAL) ;
18700			      PSET:
18800				    BEGIN
18900				     % THE SET IS PICKED UP
19000				      AND WRITTEN OUT AS TWO OCTAL NUMBERS \
19100				     WRITEWORD(NO,INTVAL) ;
19200				     WRITEWORD(NO,INTVAL1) ;
19300				    END ;
19400			      STRD,
19500			      STRG: WITH WANDLUNG DO
19600				    BEGIN
19700				     J :=0; WKONST := 0;
19800				     FOR I := 1 TO SLGTH DO
19900				      BEGIN
20000				       J := J+1;
20100				       WSTRING[J] := SVAL[I];
20200					IF J=5
20300					THEN
20400					  BEGIN
20500					   J := 0;
20600					   WRITEWORD(NO,WKONST);
20700					   WKONST := 0
20800					  END
20900				      END;
21000				      IF J#0
21100				      THEN
21200				       WRITEWORD(NO,WKONST)
21300				    END
21400			     END;
21500			    LFIRSTKONST := LFIRSTKONST^.NEXTKONST
21600			   END	%WHILE\
21700			 END;
21800		       IF DEBUG
21900		       THEN
22000			 BEGIN
22100			   IF DEBUGSWITCH
22200			   THEN
22300			     BEGIN
22400	(* 103 - globalidtree moved below *)
22500			      WRITEFIRSTLINE;
22600			      FOR RUN1 := TRUE DOWNTO FALSE DO COPYCTP(DISPLAY[TOP].FNAME);
22700			       IF LEVEL = 1
22800			       THEN
22900				 BEGIN
23000	(* 103 - new way to set globalidtree and standardidtree *)
23100				  FOR RUN1 := TRUE DOWNTO FALSE DO COPYCTP(DISPLAY[0].FNAME);
23200				  if display[top].fname = nil
23300				    then debugentry.globalidtree := nil
23400				    else debugentry.globalidtree := display[top].fname^.selfctp;
23500				  debugentry.standardidtree := display[0].fname^.selfctp;
23600				 END;
23700			     END %DEBUGSWITCH\;
23800			   IF LEVEL = 1
23900			   THEN
24000			     BEGIN
24100			      WITH DEBUGENTRY DO
24200			       BEGIN
24300				NEWPAGER; LASTPAGEELEM := PAGER;
24400				INTPOINT  := INTPTR^. SELFSTP;
24500				REALPOINT := REALPTR^.SELFSTP;
24600				CHARPOINT := CHARPTR^.SELFSTP;
24700	(* 36 - ALLOW MULTIPLE MODULES *)
24800				NEXTDEB := 0; %LINK WILL MAKE THIS PTR TO SIMILAR ENTRY IN NEXT MODULE\
24900				MODNAME := FILENAME;
25000			       CURNAME(INPUT,SOURCE);
25100			       END;
25200			      PAGEHEADADR := IC;
25300			      LSIZE := 44; %LENGTH OF DEBUGENTRY-RECORD\
25400			      RELARRAY[1] := 0;
25500			      FOR I:=2 TO 8 DO RELARRAY[I] := 1;
25600			      FOR I:= 9 TO LSIZE DO RELARRAY[I] := 0;
25700			      RECORDWANDEL.DEBUGREC := DEBUGENTRY;
25800			      IC := IC + LSIZE;
25900			      WRITERECORD;
26000			      HIGHESTCODE := IC;
26100	(* 40 - fix printing format *)
26200	(* 136 - LISTING FORMAT *)
26300			      if listcode then NEWLINE;
26400			      WRITEHEADER('LINK IN CHAIN 1');
26500			      LLISTCODE := FALSE;
26600			      WRITEBLOCKST(12B); %LINK BLOCK\
26700			      WRITEPAIR(NO,0,1); %LINK NUMBER 1\
26800			      LLISTCODE := LISTCODE;
26900			      WRITEPAIR(RIGHT,0,PAGEHEADADR); %NEXTDEB FIELD\
27000	(* NB: LOCATION 141/2 ARE NOW HANDLED BY DEBSUP. 143 GETS .LNKEND FOR THE
27100	      LINK SET UP ABOVE *)
27200			     END;
27300	(* 5 - CREF *)
27400			 END;
27500	(* 136 - LISTING FORMAT *)
27600		     IF LISTCODE THEN NEWLINE;
27700		     END %MCCODE\;
27800	
27900		    PROCEDURE MCVARIOUS;
28000		    VAR
28100	(* 17 - MAKE SYMBOLS ACCEPTABLE TO DEC DDT *)
28200		      INLEVEL: BOOLEAN; PNAME:ALFA;
28300		     BEGIN
28400		      %MCVARIOUS\
28500		       CASE WRITEFLAG OF
28600	
28700	(* 13 - ADD WRITEBLOCK FOR DDT SYMBOLS *)
28800	(* 16 - MAKE ACCEPTABLE TO DEC DDT *)
28900			WRITEBLK:
29000					BEGIN
29100					PNAME := DISPLAY[TOP].BLKNAME;
29200	(* 40 - fix print format *)
29300				        WRITEHEADER('LOCAL SYMBOLS  ');
29400					WRITEBLOCKST(2);
29500					WRITEIDENTIFIER(2B,PNAME);
29600					WRITEPAIR(RIGHT,0,PFSTART);
29700					I:=5;
29800					WHILE PNAME[I]=' ' DO I:=I-1;
29900					IF PFDISP#PFSTART
30000					 THEN BEGIN
30100					 PNAME[I+1]:='.';
30200					 WRITEIDENTIFIER(2B,PNAME);
30300					 WRITEPAIR(RIGHT,0,PFDISP)
30400					 END;
30500					IF PFPOINT#PFDISP
30600					 THEN BEGIN
30700					 PNAME[I+1]:='%';
30800					 WRITEIDENTIFIER(2B,PNAME);
30900					 WRITEPAIR(RIGHT,0,PFPOINT)
31000					 END
31100					END;
31200	(* 164 - add Polish fixups *)
31300			WRITEPOLISH:
31400					BEGIN
31500					WRITEHEADER('POLISH FIXUPS  ');
31600					WHILE FIRSTPOL <> NIL DO
31700					  WITH FIRSTPOL^ DO
31800					    BEGIN
31900	{A Polish fixup block looks like this:
32000	   type 11
32100	   operator,,0		0 means next half word is operand
32200	   operand1,,0
32300	   operand2,,-1		-1 means put in RH of result addr
32400	   place to put result,,0
32500	}
32600					    WRITEBLOCKST(11B);
32700					    IF OFFSET < 0
32800					      THEN WRITEPAIR(NO,4,0)  {4 - SUB}
32900					      ELSE WRITEPAIR(NO,3,0); {3 - ADD}
33000					    WRITEPAIR(LEFT,BASE,0);
33100					    WRITEPAIR(NO,ABS(OFFSET),777777B);
33200					    WRITEPAIR(LEFT,WHERE,0);
33300					    PUTRELCODE;
33400					    FIRSTPOL := NEXTPOL;  {CDR down list}
33500					    END;
33600					if cref and listcode then NEWLINE;
33700					END;
33800					    
33900			WRITEINTERNALS:
34000					BEGIN
34100					 WRITEHEADER('LOCAL REQUESTS '); INLEVEL := TRUE;
34200					 WRITEBLOCKST(8); CHECKER := LOCALPFPTR;
34300					 WHILE (CHECKER # NIL) AND INLEVEL DO
34400					 WITH CHECKER^ DO
34500					  IF PFLEV = LEVEL
34600					  THEN
34700					    BEGIN
34800					      IF PFADDR # 0
34900					      THEN
35000					       FOR I := 0 TO MAXLEVEL DO
35100						IF LINKCHAIN[I] # 0
35200						THEN WRITEPAIR(BOTH,LINKCHAIN[I],PFADDR-I);
35300					     CHECKER:= PFCHAIN
35400					    END
35500					  ELSE INLEVEL := FALSE;
35600					  IF LEVEL > 1
35700					  THEN LOCALPFPTR := CHECKER;
35800					 WHILE FIRSTKONST # NIL DO
35900					 WITH FIRSTKONST^, CONSTPTR^ DO
36000					  BEGIN
36100					   WRITEPAIR(BOTH,ADDR,KADDR);
36200	(* 72 - two fixup chains for 2 word consts *)
36300					    IF (CCLASS IN [PSET,STRD]) AND (ADDR1 <> 0)
36400					    THEN WRITEPAIR(BOTH,ADDR1,KADDR+1);
36500					   FIRSTKONST:= NEXTKONST
36600					  END;
36700	(* 64 - non-local gotos *)
36800					inlevel := true;
36900					while (lastlabel # nil) and inlevel do
37000					  with lastlabel^ do
37100					    if scope = level
37200					      then begin
37300					      if gotochain # 0
37400						then if labeladdress = 0
37500						  then errorwithtext(215,name)
37600						  else writepair(both,gotochain,labeladdress);
37700					      lastlabel := next
37800					      end
37900					     else inlevel := false;
38000	(* 40 - print format *)
38100	(* 136 - LISTING FORMAT *)
38200					if cref and listcode then NEWLINE;
38300					END;
38400			WRITEEND:
38500				  BEGIN
38600				   WRITEHEADER('HIGHSEG-BREAK  ');
38700				   WRITEBLOCKST(5);
38800				   WRITEPAIR(RIGHT,0,HIGHESTCODE);
38900				   WRITEHEADER('LOWSEG-BREAK   ');
39000				   WRITEPAIR(RIGHT,0,LCMAIN); PUTRELCODE
39100				  END;
39200	
39300			WRITESTART:
39400				    IF MAIN
39500				    THEN
39600				      BEGIN
39700	(* 33 - VERSION NO. *)
39800					WRITEHEADER('VERSION NUMBER ');
39900					LIC := 137B;
40000	(* 40 - fix print format *)
40100					WRITEBLOCKST(1);
40200				  	if listcode then with version do
40300					  write('    ',who:1:o,'  ',major:3:o,'  ',minor:2:o,'  ',edit:6:o);
40400					llistcode := false;
40500					WRITEWORD(NO,VERSION.WORD);
40600					llistcode := listcode;
40700				       WRITEHEADER('STARTADDRESS   ');
40800				       WRITEBLOCKST(7);
40900				       WRITEPAIR(RIGHT,0,STARTADDR)
41000				      END;
41100	
41200			WRITEENTRY:
41300				    BEGIN
41400				     WRITEBLOCKST(4);
41500	(* 34 - USE LIST OF ENTRIES IN PROGRAM IF APPROPRIATE *)
41600				     IF MAIN OR (FPROGFILE = NIL)
41700				       THEN WRITEIDENTIFIER(0,FILENAME)
41800				       ELSE
41900					 BEGIN
42000					 NPROGFILE := FPROGFILE;
42100					 WHILE NPROGFILE # NIL DO
42200					   BEGIN
42300					   WRITEIDENTIFIER(0,NPROGFILE^.FILID);
42400					   NPROGFILE := NPROGFILE^.NEXT
42500					   END
42600					 END
42700				    END;
42800	
42900			WRITENAME:
43000				   BEGIN
43100				    WRITEBLOCKST(6);
43200				    WRITEIDENTIFIER(0,FILENAME)
43300				   END;
43400	
43500			WRITEHISEG:
43600				    BEGIN
43700				     LLISTCODE := FALSE;
43800				     WRITEBLOCKST(3);
43900	(* 216 - allow high seg to start other than 400000 *)
44000				     WRITEPAIR(NO,HIGHSTART,HIGHSTART);
44100				    END
44200		       END %CASE\
44300		     END %MCVARIOUS\ ;
44400	
44500		    PROCEDURE MCSYMBOLS;
44600		    VAR
44700		      ENTRYFOUND: BOOLEAN; POLHEADERDONE:Boolean; chan:integer;
44800		     BEGIN
44900		      %MCSYMBOLS\
45000		      WRITEHEADER('ENTRYPOINT(S)  ');
45100		      WRITEBLOCKST(2);
45200		      SAVELISTCODE := LISTCODE;
45300		      LISTCODE := FALSE;
45400		      FOR SWITCHFLAG := 1B TO 2B DO
45500		       BEGIN
45600			 IF MAIN
45700			 THEN
45800			   BEGIN
45900			    WRITEIDENTIFIER(SWITCHFLAG,FILENAME);
46000			    WRITEPAIR(RIGHT,0,STARTADDR)
46100			   END
46200			 ELSE
46300			   BEGIN
46400	(* 34 - LOOK FOR FTN=FILENAME ONLY IF NOT SPEC. IN PROGRAM STATE. *)
46500			    CHECKER := LOCALPFPTR;
46600			    IF FPROGFILE=NIL
46700			      THEN ENTRYFOUND := FALSE
46800			      ELSE ENTRYFOUND := TRUE;
46900			    WHILE CHECKER # NIL DO
47000			    WITH CHECKER^ DO
47100			     BEGIN
47200			       IF PFADDR # 0
47300			       THEN
47400				 BEGIN
47500				   IF NOT ENTRYFOUND
47600	(* 34 - USING FILENAME FOR ENTRY NOW *)
47700				   THEN ENTRYFOUND := FILENAME = NAME;
47800				  WRITEIDENTIFIER(SWITCHFLAG,NAME);
47900				  WRITEPAIR(RIGHT,0,PFADDR);
48000				   IF PFCHAIN = NIL
48100				   THEN
48200				     IF NOT ENTRYFOUND
48300				     THEN
48400				       BEGIN
48500	(* 34 - USING FILENAME FOR ENTRY NOW *)
48600					WRITEIDENTIFIER(SWITCHFLAG,FILENAME);
48700					WRITEPAIR(RIGHT,0,PFADDR)
48800				       END
48900				 END;
49000			      CHECKER:= PFCHAIN
49100			     END
49200			   END;
49300			LISTCODE := SAVELISTCODE; LIC := 0
49400		       END;
49500		       IF MAIN
49600		       THEN
49700			 BEGIN
49800			  SWITCHFLAG:= 1B; WRITEHEADER('GLOBAL SYMBOLS ');
49900	(* 16 - ADD CCL SWITCH *)
50000			  WRITEIDENTIFIER(SWITCHFLAG,'%CCLSW    ');
50100			  WRITEPAIR(RIGHT,0,CCLSW);
50200			  WRITEIDENTIFIER(SWITCHFLAG,'%RNNAM    ');
50300			  WRITEPAIR(RIGHT,0,CCLSW+1);
50400			  WRITEIDENTIFIER(SWITCHFLAG,'%RNPPN    ');
50500			  WRITEPAIR(RIGHT,0,CCLSW+2);
50600			  WRITEIDENTIFIER(SWITCHFLAG,'%RNDEV    ');
50700			  WRITEPAIR(RIGHT,0,CCLSW+3);
50800			 END
50900		       ELSE
51000			 BEGIN
51100			  SWITCHFLAG:= 14B; WRITEHEADER('GLOBAL REQUESTS')
51200			 END;
51300		      FILEPTR := SFILEPTR;
51400		      WHILE FILEPTR # NIL DO
51500		      WITH FILEPTR^, FILEIDENT^ DO
51600		       BEGIN
51700			 IF VADDR # 0
51800			 THEN
51900			   BEGIN
52000			    WRITEIDENTIFIER(SWITCHFLAG,NAME);
52100			    WRITEPAIR(RIGHT,0,VADDR)
52200			   END;
52300			FILEPTR:= NEXTFTP
52400		       END;
52500		       IF MAIN
52600		       THEN WRITEHEADER('GLOBAL REQUESTS');
52700		      CHECKER:= EXTERNPFPTR;
52800		      WHILE CHECKER # NIL DO
52900		      WITH CHECKER^ DO
53000		       BEGIN
53100			 IF LINKCHAIN[0] # 0
53200			 THEN
53300			   BEGIN
53400			     IF PFLEV = 0
53500			     THEN WRITEIDENTIFIER(14B,EXTERNALNAME)
53600			     ELSE WRITEIDENTIFIER(14B,NAME);
53700			    WRITEPAIR(RIGHT,0,LINKCHAIN[0])
53800			   END;
53900			CHECKER:= PFCHAIN
54000		       END;
54100	(* 12 - ADD EXTERNAL REF TO RUNTIMES FOR DYNAMIC CORE ALLOC *)
54200		      IF LSTNEW # 0
54300		       THEN BEGIN
54400		       WRITEIDENTIFIER(14B,'LSTNEW    ');
54500		       WRITEPAIR(RIGHT,0,LSTNEW); % GLOBAL FIXUP TO INIT. CODE\
54600		       END;
54700		      IF NEWBND # 0
54800		       THEN BEGIN
54900		       WRITEIDENTIFIER(14B,'NEWBND    ');
55000		       WRITEPAIR(RIGHT,0,NEWBND); % DITTO \
55100		       END;
55200	(* 105 - improve lower case mapping in sets *)
55300		      if setmapchain # 0
55400			then begin
55500			writeidentifier (14B,'.STCHM    ');
55600			writepair (right,0,setmapchain)
55700			end;
55800		      FOR SUPPORTIX:= SUCC(FIRSTSUPPORT) TO PRED(LASTSUPPORT) DO
55900		       IF RNTS.LINK[SUPPORTIX] # 0
56000		       THEN
56100			 BEGIN
56200			  WRITEIDENTIFIER(14B,RNTS.NAME[SUPPORTIX]);
56300			  WRITEPAIR(RIGHT,0,RNTS.LINK[SUPPORTIX])
56400			 END;
56500	(* 36 - 141 is now set up elsewhere *)
56600	{In non-main modules, if there are references to TTY^, etc., a
56700	 Polish fixup may be needed to resolve them.}
56800		      polheaderdone := false;
56900		      FILEPTR := SFILEPTR;
57000		      IF NOT MAIN THEN WHILE FILEPTR # NIL DO
57100		      WITH FILEPTR^, FILEIDENT^ DO
57200		       begin
57300		       if chantab[channel] <> 0
57400			then begin
57500			if not polheaderdone
57600			  then begin
57700			  writeheader('SYMBOLIC POLISH');
57800			  polheaderdone := true;
57900			  end;
58000	{A Polish fixup block looks like this:
58100	   type 11
58200	   operator,,2		2 means next word is global req - that is operand
58300	   operand1
58400	   0,,operand2		0 means next half word is operand
58500	   -1,,place to put	-1 means put in RH of result addr
58600	}
58700			writeblockst(11B);
58800			writepair(no,3,2);  {add}
58900			writeidentifier(0,name);
59000			writepair(no,0,filcmp);
59100			writepair(right,777777B,chantab[channel]);
59200			putrelcode;
59300			end;
59400			FILEPTR:= NEXTFTP
59500		       END;
59600		     if polheaderdone and cref and listcode then NEWLINE;
59700		     END %MCSYMBOLS\ ;
59800	
59900		    PROCEDURE MCLIBRARY;
60000		     BEGIN
60100		      %MCLIBRARY\
60200		      WRITEHEADER('LINK LIBRARIES ');
60300		      WRITEBLOCKST(15);
60400		      FOR L := 1 TO 2 DO
60500		       BEGIN
60600			FOR I := 1 TO LIBIX DO
60700			WITH LIBRARY[LIBORDER[I]] DO
60800			 IF CALLED
60900			 THEN WITH WANDLUNG DO
61000			   BEGIN
61100			    FOR J := 1 TO 6 DO WSIXBIT[J] := ORD(NAME[J]) - 40B;
61200			    WRITEIDENTIFIER(6B,NAME);
61300			    WRITEPAIR(NO,PROJNR,PROGNR);
61400			    FOR J := 1 TO 6 DO WSIXBIT[J] := ORD(DEVICE[J]) - 40B;
61500			    WRITEIDENTIFIER(6B,DEVICE); LIC := LIC + 1
61600			   END;
61700			I := 1;
61800	(* 40 - load PASLIB first *)
61900			for languageix := pascalsy to fortransy do
62000			WITH LIBRARY[LANGUAGEIX] DO
62100			 BEGIN
62200			  CALLED := (NOT INORDER AND CALLED) OR (LANGUAGEIX = PASCALSY);
62300			  LIBORDER[I] := LANGUAGEIX; I := I + 1
62400			 END;
62500			LIBIX := 2
62600		       END;
62700		     END %MCLIBRARY\;
62800	
62900		   BEGIN
63000		    %WRITEMC\
63100	(* 121 - missing initialization - fix bollixed INITPROC's *)
63200		     CODEARRAY := FALSE;
63300		     IF NOT ERRORFLAG
63400		     THEN
63500		       BEGIN
63600	(* 5 - CREF *)
63700			IF CREF AND LISTCODE
63800			  THEN WRITE(CHR(177B),'F');
63900			FOR I:=1 TO MAXSIZE DO RELEMPTY[I] := 0;
64000			WITH ICWANDEL DO
64100			 BEGIN
64200			  ICVAL := 0;
64300			  CSP0 := ICCSP
64400			 END;
64500			LLISTCODE := LISTCODE;
64600			 CASE WRITEFLAG OF
64700			  WRITEGLOBALS	 : MCGLOBALS;	 %LINK-ITEM 01B\
64800			  WRITECODE	 : MCCODE;	 %LINK-ITEM 01B\
64900			  WRITESYMBOLS	 : MCSYMBOLS;	 %LINK-ITEM 02B\
65000			  WRITEBLK,			 %LINK-ITEM 02B\
65100			  WRITEINTERNALS,		 %LINK-ITEM 10B\
65200	(* 164 - Polish fixups *)
65300			  WRITEPOLISH,			 %LINK-ITEM 11B\
65400			  WRITEENTRY,			 %LINK-ITEM 04B\
65500			  WRITEEND,			 %LINK-ITEM 05B\
65600			  WRITESTART,			 %LINK-ITEM 07B\
65700			  WRITEHISEG,			 %LINK-ITEM 03B\
65800			  WRITENAME	 : MCVARIOUS;	 %LINK-ITEM 06B\
65900			  WRITELIBRARY	 : MCLIBRARY	 %LINK-ITEM 17B\
66000			 END %CASE\;
66100			 IF LISTCODE AND (WRITEFLAG > WRITEHISEG)
66200	(* 5 - CREF *)
66300	(* 136 - LISTING FORMAT *)
66400			 THEN NEWLINE;
66500		       IF CREF AND LISTCODE
66600		         THEN WRITE(CHR(177B),'B')
66700		       END %IF ERRORFLAG\
66800		     ELSE
66900		       IF WRITEFLAG = WRITECODE
67000		       THEN LASTBTP := NIL
67100		   END %WRITEMC\;
67200	
67300		  PROCEDURE STATEMENT(FSYS,STATENDS: SETOFSYS);
67400		  TYPE
67500		    VALUEKIND = (ONREGC,ONFIXEDREGC,TRUEJMP,FALSEJMP);
67600		  VAR
67700		    LCP: CTP;	  IX,J: INTEGER;
67800	
67900		    PROCEDURE EXPRESSION(FSYS: SETOFSYS; FVALUE:VALUEKIND); FORWARD;
68000	
68100		    PROCEDURE MAKEREAL(VAR FATTR: ATTR);
68200		     BEGIN
68300		       IF FATTR.TYPTR=INTPTR
68400		       THEN
68500			 BEGIN
68600			  LOAD(FATTR);
     
00100	(* 2 - hard code FLOAT using KI-10 op code *)
00200	(* 101 - fix code generation for fltr *)
00300	(* 122 - add back KA-10 code *)
00400	(* 132 - separate KA10 into NOVM and KACPU *)
00500			  if kacpu
00600			    then begin
00700			    macro3(201B%movei\,tac,fattr.reg);
00800			    support(convertintegertoreal);
00900			    end
01000			   ELSE WITH CODE.INSTRUCTION[CIX] DO
01100			    IF (INSTR = 200B%MOVE\) AND (AC = FATTR.REG)
01200			      THEN INSTR := 127B%FLTR\
01300			      ELSE MACRO3(127B%FLTR\,FATTR.REG,FATTR.REG);
01400			  FATTR.TYPTR := REALPTR
01500			 END;
01600		       IF GATTR.TYPTR=INTPTR
01700		       THEN MAKEREAL(GATTR)
01800		     END;
01900	
02000		    PROCEDURE SELECTOR(FSYS: SETOFSYS; FCP: CTP);
02100		    VAR
02200		      LATTR: ATTR; LCP: CTP; LSP: STP;
02300		      LMIN,LMAX,INDEXVALUE,INDEXOFFSET: INTEGER;
02400		      OLDIC: ACRANGE;
02500	
02600		      PROCEDURE SUBLOWBOUND;
02700		       BEGIN
02800			 IF LMIN > 0
02900			 THEN MACRO3(275B%SUBI\,REGC,LMIN)
03000			 ELSE
03100			   IF LMIN < 0
03200			   THEN MACRO3(271B%ADDI\,REGC,-LMIN);
03300			 IF RUNTMCHECK
03400			 THEN
03500			   BEGIN
03600			    MACRO3(301B%CAIL\,REGC,0);
03700			    MACRO3(303B%CAILE\,REGC,LMAX-LMIN);
03800			    SUPPORT(INDEXERROR)
03900			   END
04000		       END;
04100	
04200		     BEGIN
04300		      WITH FCP^, GATTR DO
04400		       BEGIN
04500			TYPTR := IDTYPE; KIND := VARBL; PACKFG := NOTPACK;
04600			 CASE KLASS OF
04700			  VARS:
04800				BEGIN
04900				 VLEVEL := VLEV;  DPLMT := VADDR; INDEXR := 0;
05000				  IF VLEV > 1
05100				  THEN VRELBYTE:= NO
05200				  ELSE VRELBYTE:= RIGHT;
05300				 EXTERNCTP := NIL;
05400	(* 217 - We want to set EXTERNCTP in case this is an external variable.
05500		 At the moment this is only files, and the following test
05600		 works *)
05700				 IF IDTYPE^.FORM = FILES
05800				   THEN IF (VLEV=0) AND (NOT MAIN)
05900				     THEN EXTERNCTP := FCP;
06000				  IF VKIND=ACTUAL
06100				  THEN INDBIT:=0
06200				  ELSE INDBIT:=1
06300				END;
06400			  FIELD:
06500				WITH DISPLAY[DISX] DO
06600				 IF OCCUR = CREC
06700				 THEN
06800				   BEGIN
06900				    VLEVEL := CLEV; PACKFG := PACKF; VRELBYTE:= CRELBYTE;
07000				     IF PACKFG = PACKK
07100				     THEN
07200				       BEGIN
07300					BPADDR := FLDADDR;
07400					DPLMT := CDSPL
07500				       END
07600				     ELSE DPLMT := CDSPL+FLDADDR;
07700				    INDEXR := CINDR; INDBIT:=CINDB
07800				   END
07900				 ELSE
08000				  ERROR(171);
08100			  FUNC:
08200				IF PFDECKIND = STANDARD
08300				THEN ERROR(502)
08400				ELSE
08500				  IF PFLEV = 0
08600				  THEN ERROR(502)   %EXTERNAL FCT\
08700				  ELSE
08800				    IF PFKIND = FORMAL
08900				    THEN ERROR(456)
09000	(* 31 - BE SURE WE'RE IN THE BODY OF THE FTN *)
09100				    ELSE IF (LEVEL <= PFLEV) OR (DISPLAY[PFLEV+1].BLKNAME # NAME)
09200					THEN ERROR(412)
09300				    ELSE
09400				      BEGIN
09500	(* 166 - use pflev+1 for vlevel, to allow assignment from inner function *)
09600				       VLEVEL := PFLEV + 1; VRELBYTE := NO;
09700				       DPLMT := 1;   %IMPL. RELAT. ADDR. OF FCT. RESULT\
09800				       INDEXR :=0; INDBIT :=0
09900				      END
10000			 END;
10100			%CASE\
10200		       END %WITH\;
10300		      IFERRSKIP(166,SELECTSYS OR FSYS);
10400		      WHILE SY IN SELECTSYS DO
10500		       BEGIN
10600	(* 156 - error for selector on ftn name *)
10700		       IF FCP^.KLASS = FUNC
10800			 THEN ERROR(368);
10900			%[\
11000			 IF SY = LBRACK
11100			 THEN
11200			   BEGIN
11300			     IF GATTR.INDBIT = 1
11400			     THEN GETPARADDR;
11500			    OLDIC := GATTR.INDEXR;
11600			    INDEXOFFSET := 0 ;
11700			     LOOP
11800			      LATTR := GATTR; INDEXVALUE := 0 ;
11900			      WITH LATTR DO
12000			       IF TYPTR # NIL
12100			       THEN
12200				 BEGIN
12300				   IF TYPTR^.FORM # ARRAYS
12400				   THEN
12500				     BEGIN
12600				      ERROR(307); TYPTR := NIL
12700				     END;
12800				  LSP := TYPTR
12900				 END;
13000			      INSYMBOL;
13100			      EXPRESSION(FSYS OR [COMMA,RBRACK],ONREGC);
13200			       IF  GATTR.KIND#CST
13300			       THEN  LOAD(GATTR)
13400			       ELSE  INDEXVALUE := GATTR.CVAL.IVAL ;
13500			       IF GATTR.TYPTR # NIL
13600			       THEN
13700				 IF GATTR.TYPTR^.FORM # SCALAR
13800				 THEN ERROR(403);
13900			       IF LATTR.TYPTR # NIL
14000			       THEN
14100				WITH LATTR,TYPTR^ DO
14200				 BEGIN
14300				   IF COMPTYPES(INXTYPE,GATTR.TYPTR)
14400				   THEN
14500				     BEGIN
14600				       IF INXTYPE # NIL
14700				       THEN
14800					 BEGIN
14900					  GETBOUNDS(INXTYPE,LMIN,LMAX);
15000					   IF GATTR.KIND = CST
15100					   THEN
15200					     IF (INDEXVALUE < LMIN) OR (INDEXVALUE > LMAX)
15300					     THEN ERROR(263)
15400					 END
15500				     END
15600				   ELSE ERROR(457);
15700				  TYPTR := AELTYPE ;
15800				 END ;
15900			     EXIT IF SY # COMMA;
16000			      WITH LATTR DO
16100			       IF TYPTR#NIL
16200			       THEN
16300				 IF  GATTR.KIND = CST
16400				 THEN DPLMT := DPLMT +( INDEXVALUE - LMIN ) * TYPTR^.SIZE
16500				 ELSE
16600				   BEGIN
16700				    SUBLOWBOUND;
16800				     IF TYPTR^.SIZE > 1
16900				     THEN MACRO3(221B%IMULI\,REGC,TYPTR^.SIZE);
17000				     IF OLDIC = 0
17100				     THEN OLDIC := REGC
17200				     ELSE
17300				       IF OLDIC > REGCMAX
17400				       THEN
17500					 BEGIN
17600					  MACRO3(270B%ADD\,REGC,OLDIC);
17700					  OLDIC := REGC
17800					 END
17900				       ELSE
18000					 BEGIN
18100					  MACRO3(270B%ADD\,OLDIC,REGC) ;
18200					  REGC := REGC - 1
18300					 END;
18400				    INDEXR := OLDIC
18500				   END ;
18600			      GATTR := LATTR ;
18700			     END;
18800			    %LOOP\
18900			    WITH LATTR DO
19000			     IF  TYPTR # NIL
19100			     THEN
19200			       BEGIN
19300				 IF GATTR.KIND = CST
19400				 THEN INDEXOFFSET :=  ( INDEXVALUE - LMIN ) * TYPTR^.SIZE
19500				 ELSE
19600				   BEGIN
19700				     IF (TYPTR^.SIZE > 1) OR RUNTMCHECK
19800				     THEN SUBLOWBOUND
19900				     ELSE INDEXOFFSET := -LMIN;
20000				     IF TYPTR^.SIZE > 1
20100				     THEN MACRO3(221B%IMULI\,REGC,TYPTR^.SIZE);
20200				    INDEXR := REGC ;
20300				   END ;
20400				 IF LSP^.ARRAYPF
20500				 THEN
20600				   BEGIN
20700	(* 102 - kl array code *)
20800				     if not klcpu
20900				       THEN INCREMENTREGC;
21000				     IF INDEXR=OLDIC
21100				     THEN
21200				       BEGIN
21300					INCREMENTREGC; INDEXR := 0
21400				       END;
21500	(* 102 - kl adjbp code *)
21600				    if not klcpu then begin
21700				    MACRO4(571B%HRREI\,REGC,INDEXR,INDEXOFFSET);
21800				    INCREMENTREGC;   %TEST FOR IDIVI-INSTRUCTION\
21900				    REGC := REGC-1; INDEXOFFSET := 0;
22000				    MACRO3R(200B%MOVE\,REGC-1,LSP^.ARRAYBPADDR);
22100				    MACRO3(231B%IDIVI\,REGC,BITMAX DIV LSP^.AELTYPE^.BITSIZE);
22200				    MACRO3(133B%IBP\,0,REGC-1);
22300				    MACRO3R(365B%SOJGE\,REGC+1,IC-1);
22400				    BPADDR := REGC-1;  PACKFG := PACKK; INDEXR := REGC;
22500	(* 102 - kl adjbp code *)
22600				    end
22700				     else begin (* kl code*)
22800				     macro4(571B%hrrei\,regc,indexr,indexoffset+1);
22900				     macro3r(133B%adjbp\,regc,lsp^.arraybpaddr);
23000				     bpaddr := regc; packfg := packk; indexr := 0;
23100				     indexoffset := 0;
23200				     end;
23300				   END;
23400				DPLMT := DPLMT + INDEXOFFSET ;
23500				KIND := VARBL ;
23600				 IF ( OLDIC # INDEXR )	AND  ( OLDIC # 0 )
23700				 THEN
23800				   BEGIN
23900	(* 102 - new packed array code *)
24000				   if indexr = 0
24100				     then indexr := oldic
24200				     ELSE IF OLDIC > REGCMAX
24300				     THEN  MACRO3(270B%ADD\,INDEXR,OLDIC)
24400				     ELSE
24500				       BEGIN
24600					MACRO3(270B%ADD\,OLDIC,INDEXR);
24700					REGC := REGC - 1;
24800					INDEXR := OLDIC
24900				       END
25000				   END
25100			       END %WITH.. IF TYPTR # NIL\ ;
25200			    GATTR := LATTR ;
25300			     IF SY = RBRACK
25400			     THEN INSYMBOL
25500			     ELSE ERROR(155)
25600			   END %IF SY = LBRACK\
25700			 ELSE
25800			  %.\
25900			   IF SY = PERIOD
26000			   THEN
26100			     BEGIN
26200			      WITH GATTR DO
26300			       BEGIN
26400				 IF TYPTR # NIL
26500				 THEN
26600				   IF TYPTR^.FORM # RECORDS
26700				   THEN
26800				     BEGIN
26900				      ERROR(308); TYPTR := NIL
27000				     END;
27100				 IF INDBIT=1
27200				 THEN GETPARADDR;
27300				INSYMBOL;
27400				 IF SY = IDENT
27500				 THEN
27600				   BEGIN
27700				     IF TYPTR # NIL
27800				     THEN
27900				       BEGIN
28000					SEARCHSECTION(TYPTR^.FSTFLD,LCP);
28100	(* 5 - CREF *)
28200					IF CREF
28300				          THEN WRITE(CHR(1B),CHR(21),ID,' .FIELDID. ');
28400					 IF LCP = NIL
28500					 THEN
28600					   BEGIN
28700					    ERROR(309); TYPTR := NIL
28800					   END
28900					 ELSE
29000					  WITH LCP^ DO
29100					   BEGIN
29200					    TYPTR := IDTYPE;PACKFG := PACKF;
29300					     IF PACKFG = PACKK
29400					     THEN
29500					      BPADDR := FLDADDR
29600					     ELSE
29700					      DPLMT := DPLMT + FLDADDR;
29800					   END
29900				       END;
30000				    INSYMBOL
30100				   END %SY = IDENT\
30200				 ELSE ERROR(209)
30300			       END %WITH GATTR\
30400			     END %IF SY = PERIOD\
30500			   ELSE
30600			    %^\
30700			     BEGIN
30800			       IF GATTR.TYPTR # NIL
30900			       THEN
31000				WITH GATTR,TYPTR^ DO
31100	(* 173 - changes for internal files, since we can't assume FILPTR is set up *)
31200				 IF FORM = FILES
31300				   THEN BEGIN
31400				    TYPTR := FILTYPE;
31500	{What we are trying to do here is to generate code like
31600		MOVEI 2,INPUT+FILCMP
31700	 In the usual case, we just do a loadaddress on the file, after add
31800	 filcmp to the displacement.  There are two cases where this won't
31900	 work:
32000	   - when the address is an external reference, since it then
32100		becomes an address in a fixup chain, and can't have FILCMP
32200		added to it at compile time.  Thus we have a separate
32300		fixup chain stored in CHANTAB which the loader will add
32400		FILCMP to after fixing up.
32500	   - when the thing is indirect, since we have to add the displacemtn
32600		after doing the indirection.  The only solution there is 
32700		an ADDI, as far as I can see.
32800	 Hamburg used to just do a LOAD, which works because at INPUT there
32900	 is a pointer to INPUT+FILCMP.  I can't do that because if the
33000	 FCB isn't initialized that will be garbage, and I need the real
33100	 address to do the validity check}
33200				    WITH FCP^ DO
33300				     IF (VLEV = 0) AND (NOT MAIN)
33400				      THEN BEGIN
33500				      INCREMENTREGC;
33600				      MACRO3R(201B%MOVEI\,REGC,CHANTAB[CHANNEL]);
33700				      CHANTAB[CHANNEL] := IC-1;
33800				      CODE.INFORMATION[CIX] := 'E';
33900			  	      WITH GATTR DO
34000					BEGIN
34100					KIND := VARBL;  DPLMT := 0; INDEXR:=REGC;
34200					INDBIT:=0; VRELBYTE := NO
34300					END
34400				      END
34500	(* 200 - fix addressing *)
34600				     ELSE IF INDBIT = 0
34700				      THEN BEGIN
34800				      DPLMT := DPLMT + FILCMP;
34900				      LOADADDRESS;
35000				      END
35100				     ELSE BEGIN
35200				     LOADADDRESS;
35300				     MACRO3(271B%ADDI\,REGC,FILCMP)
35400				     END;
35500				    IF RUNTMCHECK
35600				      THEN BEGIN
35700	{See if the file is open.  A magic value of 314157 is left in FILTST if so }
35800				      MACRO4(200B%MOVE\,HAC,REGC,FILTST-FILCMP);
35900				      MACRO3(302B%CAIE\,HAC,314157B);
36000				      SUPPORT(FILEUNINITIALIZED)
36100				      END
36200				   END
36300				 ELSE IF FORM = POINTER
36400				  THEN
36500				   BEGIN
36600				    TYPTR := ELTYPE;
36700				     IF TYPTR # NIL
36800				     THEN WITH GATTR DO
36900				       BEGIN
37000					LOADNOPTR := FALSE;
37100					LOAD(GATTR); LOADNOPTR := TRUE;
37200	(* 23 - check for bad pointer *)
37300	(* 26 - but not for file *)
37400					IF RUNTMCHECK
37500					  THEN BEGIN
37600					  MACRO3(302B%CAIE\,REG,0);
37700					  MACRO3(306B%CAIN\,REG,377777B);
37800					  SUPPORT(BADPOINT)
37900					  END;
38000					INDEXR := REG; DPLMT := 0; INDBIT:=0; 
38100					PACKFG := NOTPACK; KIND := VARBL; 
38200					VRELBYTE:= NO
38300				       END
38400				   END
38500				 ELSE ERROR(407);
38600			      INSYMBOL
38700			     END;
38800			IFERRSKIP(166,FSYS OR SELECTSYS)
38900		       END;
39000		      %WHILE\
39100		      WITH GATTR DO
39200		       IF TYPTR#NIL
39300		       THEN
39400			 IF TYPTR^.SIZE = 2
39500			 THEN
39600			   BEGIN
39700			     IF INDBIT = 1
39800			     THEN GETPARADDR;
39900			     IF (INDEXR>REGIN) AND (INDEXR<=REGCMAX)
40000			     THEN INCREMENTREGC
40100			   END
40200		     END %SELECTOR\ ;
40300	
40400		    PROCEDURE CALL(FSYS: SETOFSYS; FCP: CTP);
40500		    VAR
40600	(* 10 - ALLOW MORE RUNTIMES *)
40700		      LKEY: 1..44;
40800		      LFOLLOWERROR, NORIGHTPARENT : BOOLEAN;
40900	
41000	(* 33 - allow use with non-TEXT files *)
41100	(* 171 - allow read/write of records *)
41200	(* 173 - completely new getfilename *)
41300	(* 204 - don't check validty of file to be closed *)
41400		      PROCEDURE GETFILENAME(DEFAULTFILE:CTP;TEXTPROC:BOOLEAN;
41500				VAR FILETYPE:STP;VAR GOTARG:BOOLEAN;CHECK:BOOLEAN);
41600		      VAR
41700	(* 177 - fix AC *)
41800			GOTFILE : BOOLEAN;  FILEREGC: ACRANGE;
41900	{When we are finished we will have loaded a file into REGC, and parsed
42000	 the next parameter if there is one, using EXPRESSION with REGC incremented}
42100		       BEGIN
42200			INCREMENTREGC;  {by default we will load into 3}
42300			FILEREGC := REGC;  {but file goes into 2, which this still is}
42400	    {REGC = 2}
42500			GOTARG := FALSE; NORIGHTPARENT := TRUE; GOTFILE := FALSE;
42600			IF SY = LPARENT
42700			 THEN BEGIN
42800			 NORIGHTPARENT := FALSE;
42900			 INSYMBOL;
43000			 EXPRESSION(FSYS OR [COMMA,RPARENT,COLON],ONFIXEDREGC);
43100	   {REGC = 3 if expression (file can't be), 2 otherwise}
43200			 GOTFILE := FALSE;
43300	{We have an expression, see if it is a legal file.  If so, load it into
43400	 REGC (note: no incrementregc first) and do a few tests.  We have to do
43500	 our own loading mostly to avoid the INCREMENTREGC done by LOADADDRESS}
43600			 WITH GATTR DO
43700			  IF TYPTR <> NIL
43800			   THEN WITH TYPTR^ DO
43900			    IF FORM = FILES
44000			     THEN BEGIN
44100			     IF TEXTPROC
44200			      THEN IF NOT (COMPTYPES(FILTYPE,CHARPTR))
44300			      	     THEN ERROR(366);
44400	{Yes, it is a legal file.  Now load it}
44500	{If TTY that is supposed to be mapped to TTYOUTPUT, handle that}
44600	(* 217 - EXTERNCTP instead of LASTFILE *)
44700			     IF (EXTERNCTP = TTYFILE) AND (DEFAULTFILE = OUTFILE)
44800			       THEN BEGIN
44900			       EXTERNCTP := TTYOUTFILE;
45000			       MACRO3R(201B%MOVEI\,REGC,TTYOUTFILE^.VADDR);
45100			       END
45200			      ELSE BEGIN
45300			       FETCHBASIS(GATTR);
45400			       MACRO(VRELBYTE,201B%MOVEI\,REGC,INDBIT,INDEXR,DPLMT);
45500			       END;
45600			     KIND := VARBL;  DPLMT := 0; INDEXR:=REGC; 
45700			     INDBIT:=0; VRELBYTE := NO;
45800	(* 217 - allow complex file expr's *)
45900			     IF EXTERNCTP <> NIL
46000			       THEN BEGIN EXTERNCTP^.VADDR:=IC-1;
46100					  CODE.INFORMATION[CIX]:='E' END;
46200			     GOTFILE := TRUE;
46300			     FILETYPE := TYPTR;
46400	{Runtime checks if appropriate}
46500	(* 204 - don't check for CLOSE *)
46600			     if runtmcheck and check
46700			      then begin
46800			      macro4(200B%MOVE\,hac,regc,filtst);  {File test word}
46900			      macro3(302B%CAIE\,hac,314157B);  {True if file is open}
47000			      support(fileuninitialized);   {Not open}
47100			      end;
47200	{Now see if there is an arg}
47300			     IF SY <> RPARENT
47400			      THEN BEGIN
47500			      IF SY = COMMA
47600			       THEN INSYMBOL
47700			       ELSE ERROR(158);
47800	    {Note that this is guaranteed not to change REGC unless it sees an
47900	     expression, in which case it advances to 3.  We can't have two
48000	     advances (i.e. due to the EXPRESSION above and this one), since
48100	     this is done only if the one above saw a file, which can't have
48200	     advanced REGC}
48300			      EXPRESSION(FSYS OR [COMMA,RPARENT,COLON],ONFIXEDREGC);
48400			      GOTARG := TRUE
48500			      END
48600			     END;
48700	{Now we are done processing a file arg}
48800			 IF NOT GOTFILE  {If expression wasn't a file, use it as arg}
48900			  THEN GOTARG := TRUE
49000			 END;
49100	{End of IF RPARENT}
49200	   {At this point REGC = 2 unless what we saw was an expr (which a file
49300		can't be), in which case REGC = 3 and it is loaded}
49400			IF NOT GOTFILE
49500			 THEN WITH DEFAULTFILE^ DO
49600	{If we didn't get a file above, here is the code to do it}
49700			  BEGIN
49800	(* 177 - fix AC *)
49900			  MACRO3R(201B%MOVEI\,FILEREGC,VADDR);
50000			  IF NOT GOTARG
50100			   THEN WITH GATTR DO
50200			    BEGIN
50300			    KIND := VARBL;  DPLMT := 0; INDEXR:=REGC; 
50400			    INDBIT:=0; VRELBYTE := NO;
50500			    END;
50600			  IF (VLEV=0) AND (NOT MAIN)
50700			   THEN BEGIN VADDR:=IC-1; CODE.INFORMATION[CIX]:='E' END;
50800			  FILETYPE := IDTYPE;
50900	(* 204 - don't check for CLOSE *)
51000			  if runtmcheck and check
51100			   then begin
51200	(* 207 - more bad AC's *)
51300			    macro4(200B%MOVE\,hac,fileregc,filtst);  {File test word}
51400			    macro3(302B%CAIE\,hac,314157B);  {True if file is open}
51500			    support(fileuninitialized);   {Not open}
51600			    end;
51700			  END;		 
51800	  {If we saw an arg, REGC is exactly like it would have been with a
51900	   simple   INCREMENTREGC;  EXPRESSION;  which is the whole point.
52000	   That is,it is 2 unless an expression was seen, in which case the
52100	   expression is loaded into 3.  If we didn't see an expression, then
52200	   REGC is guaranteed to be 2.  Very shady...}
52300		       END %GETFILENAME\ ;
52400	
52500		      PROCEDURE VARIABLE(FSYS: SETOFSYS);
52600		      VAR
52700			LCP: CTP;
52800		       BEGIN
52900			 IF SY = IDENT
53000			 THEN
53100			   BEGIN
53200			    SEARCHID([VARS,FIELD],LCP); INSYMBOL
53300			   END
53400			 ELSE
53500			   BEGIN
53600			    ERROR(209); LCP := UVARPTR
53700			   END;
53800			SELECTOR(FSYS,LCP)
53900		       END %VARIABLE\ ;
54000	(* 22 - add GETFN - common non-defaulting file name scanner *)
54100	(* 73 - add ,COLON since used in NEW *)
54200	(* 175 - internal files *)
54300		      PROCEDURE GETFN(TEST:BOOLEAN);
54400		        BEGIN
54500			VARIABLE(FSYS OR [RPARENT,COLON,COMMA]);
54600			LOADADDRESS;
54700			IF GATTR.TYPTR#NIL
54800			  THEN IF GATTR.TYPTR^.FORM#FILES
54900			    THEN ERROR(212)
55000	(* 217 - complex file expressions *)
55100			    ELSE IF GATTR.EXTERNCTP <> NIL
55200				THEN BEGIN GATTR.EXTERNCTP^.VADDR:=IC-1;
55300					   CODE.INFORMATION[CIX]:='E' END;
55400	(* 175 - internal files *)
55500			if test and runtmcheck
55600			  then begin
55700			  macro4(200B%MOVE\,hac,regc,filtst);  {File test word}
55800			  macro3(302B%CAIE\,hac,314157B);  {Magic value if it is open}
55900			  support(fileuninitialized);   {Not open}
56000			  end;
56100			END;
56200	
56300	(* 14 - SEVERAL CHANGES IN THIS PROC TO ADD NEW RUNTIMES AND ADD OPTIONAL XBLOCK ARG *)
56400		      PROCEDURE GETPUTRESETREWRITE;
56500		      VAR
56600	(* 172 - new options string *)
56700			LMAX,LMIN: INTEGER;
56800	(* 173 - internal files *)
56900			LATTR: ATTR;
57000			ADR : SUPPORTS ; 
57100			DEFAULT : ARRAY [1..6] OF BOOLEAN;
57200			I,J : INTEGER;
57300	
57400			PROCEDURE GETSTRINGADDRESS ;
57500	
57600			 VAR LMAX,LMIN: INTEGER;
57700	(* 61 - allow flags for gtjfn in tops20 *)
57800			    flagbits: packed record case Boolean of
57900				true: (dum:0..777777B;usetty:Boolean;wildok:Boolean);
58000				false: (dum2:0..777777B; rh:0..777777B)
58100				end;
58200			 BEGIN
58300			   IF SY=COMMA
58400			   THEN
58500			     BEGIN
58600			      INSYMBOL;
58700			      EXPRESSION(FSYS OR [COMMA,RPARENT,COLON],ONFIXEDREGC);
58800			      WITH GATTR DO
58900			       IF TYPTR#NIL
59000			       THEN
59100				WITH TYPTR^ DO
59200				 IF(FORM=ARRAYS) AND ARRAYPF
59300				 THEN
59400				   IF COMPTYPES(AELTYPE,CHARPTR)
59500				   THEN
59600				     BEGIN
59700	(* 15 - CHANGE DUE TO SLIGHTLY DIFFERENT LOGIC IN MAIN PROC *)
59800				      DEFAULT[I] := FALSE;
59900				      I:=I+1;DEFAULT[I]:=FALSE;
60000				      LOADADDRESS;
60100					GETBOUNDS(INXTYPE,LMIN,LMAX);
60200					LMAX := LMAX-LMIN+1;
60300					INCREMENTREGC;
60400					MACRO3(201B%MOVEI\,REGC,LMAX);
60500				     END
60600				   ELSE ERROR(212)
60700				 ELSE ERROR(212);
60800	(* 61 - implement extra syntax for tops20 *)
60900	(* 144 - allow it for tops10, too *)
61000			     if (sy=colon)
61100			      then begin
61200			      insymbol;
61300			      flagbits.rh := 0;
61400			      while sy in [relop,addop,mulop] do
61500				begin
61600				if op = leop (* @ *)
61700				  then flagbits.usetty := true
61800				else if (op = mul) and (not tops10)
61900				  then flagbits.wildok := true
62000				else error(158);
62100				insymbol
62200				end;
62300			      macro3(505b%hrli\,regc-1,flagbits.rh);
62400			      end;
62500			     END;
62600			 END ;
62700	
62800		       BEGIN
62900			VARIABLE( FSYS OR [RPARENT,COMMA] ) ;
63000			LOADADDRESS ;
63100	(* 173 - internal files *)
63200			LATTR := GATTR;
63300			 IF GATTR.TYPTR # NIL
63400			 THEN
63500			   IF GATTR.TYPTR^.FORM # FILES
63600			   THEN ERRANDSKIP(458,FSYS OR [RPARENT])
63700			   ELSE
63800			     BEGIN
63900	(* 217 - file expressions *)
64000			     IF GATTR.EXTERNCTP <> NIL
64100			       THEN
64200				 BEGIN
64300				  GATTR.EXTERNCTP^.VADDR:= IC-1;
64400				  CODE.INFORMATION[CIX] := 'E'
64500				 END;
64600			       IF (LKEY>=5) AND (LKEY#28)
64700			       THEN
64800				 BEGIN
64900				  FOR I := 1 TO 6 DO DEFAULT[I] := TRUE;
65000				  I := 1;
65100				  GETSTRINGADDRESS % OF FILENAME \ ;
65200	(* 15 - ADD NEW PARAMETERS AND ALLOW OMITTING BLOCK *)
65300				  WHILE NOT DEFAULT[I] AND (SY=COMMA) DO
65400				   BEGIN
65500				    I := I+1;
65600				    INSYMBOL;
65700	(* 172 - ADD OPTION STRING AS 3RD ARG *)
65800				    IF I = 3
65900				      THEN BEGIN
66000				      EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
66100			      	      WITH GATTR DO
66200			       	       IF TYPTR#NIL
66300					THEN WITH TYPTR^ DO
66400				 	IF(FORM=ARRAYS) AND ARRAYPF
66500				 	 THEN IF COMPTYPES(AELTYPE,CHARPTR)
66600				   	  THEN BEGIN
66700				          DEFAULT[I] := FALSE;
66800				          LOADADDRESS;
66900					  GETBOUNDS(INXTYPE,LMIN,LMAX);
67000					  LMAX := LMAX-LMIN+1;
67100					  MACRO3(505B%HRLI\,REGC,LMAX);
67200					  END
67300					  ELSE ERROR(212)  {not CHAR array}
67400					 ELSE BEGIN  {not packed array}
67500					 LOAD(GATTR); DEFAULT[I] := FALSE
67600					 END
67700				      END {I=3}
67800	(* 57 - ONLY TOPS10 HAS XBLOCK ARG *)
67900				    ELSE IF (NOT TOPS10) OR (I # 4) OR ((SY=INTCONST)AND(VAL.IVAL=0))
68000				      THEN BEGIN
68100				      EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
68200				       IF GATTR.TYPTR#NIL
68300				       THEN
68400				       BEGIN
68500					LOAD(GATTR); DEFAULT[I] := FALSE;
68600	(* 77 - allow sets, since they are elegant for specifying bits *)
68700					if gattr.typtr^.form = power
68800					  then regc := regc-1;
68900				       END
69000				      END
69100				     ELSE BEGIN
69200				     VARIABLE(FSYS OR[COMMA,RPARENT]);
69300				     IF GATTR.TYPTR # NIL
69400	(* 26 - allow record as lookup block *)
69500					THEN IF NOT (GATTR.TYPTR^.FORM IN [ARRAYS,RECORDS])
69600					  THEN ERROR(264)
69700					  ELSE IF GATTR.TYPTR^.SIZE<5
69800					    THEN ERROR(265)
69900					    ELSE BEGIN LOADADDRESS; DEFAULT[I]:=FALSE END
70000					ELSE ERROR(458)
70100				     END;
70200				   END;
70300				  FOR I := 1 TO 6 DO
70400				   IF DEFAULT[I]
70500				   THEN
70600				     BEGIN
70700				      INCREMENTREGC;
70800				      IF I=6
70900					THEN MACRO3(474B%SETO\,REGC,0)
71000				        ELSE MACRO3(201B%MOVEI\,REGC,0)
71100				     END;
71200				 END;
71300	(* 173 - internal files *)
71400			       if lkey in [5,6,29,36]  {openning}
71500				 then begin
71600				 if lattr.typtr <> nil
71700				   then if lattr.typtr^.form = files
71800				     then if comptypes(lattr.typtr^.filtype,charptr)
71900	{In AC1, put size of component, or 0 if text file}
72000				       then macro3(201B%movei\,tac,0)
72100				       else macro3(201B%movei\,tac,
72200	{Normally we would have to type filtype^ for nil, but if it is nil, the
72300	 comptypes above will succeed, and this code will never happen.}
72400						   lattr.typtr^.filtype^.size)
72500				 end
72600	(* 204 - don't validty check for DISMISS *)
72700	(* 205 - fix AC for RENAME *)
72800				else if runtmcheck and (lkey <> 28)
72900				 then begin
73000			         macro4(200B%MOVE\,hac,regin+1,filtst);{File test word}
73100			         macro3(302B%CAIE\,hac,314157B); {Magic value if open}
73200			         support(fileuninitialized);   {Not open}
73300			         end;
73400			       CASE LKEY OF
73500				2: ADR:= GETLINE ;
73600				4: ADR:= PUTLINE ;
73700				5: ADR:= RESETFILE ;
73800				6: ADR:= REWRITEFILE;
73900				27:ADR:=NAMEFILE;
74000				28:ADR:=DISFILE;
74100				29:ADR:=UPFILE;
74200				36:ADR:=APFILE
74300			       END ;
74400			      SUPPORT(ADR) ;
74500			     END ;
74600		       END;
74700	
74800	(* 10 - ADD SETSTRING, TO ALLOW I/O TO STRINGS *)
74900	(* 13 - CODE MODIFIED TO ALLOW 4TH ARG, LIMIT *)
75000	(* 51 - allow any file type, any packed array *)
75100		      PROCEDURE SETSTRING;
75200		      VAR
75300			LREGC:ACRANGE;
75400			LMIN,LMAX:ADDRRANGE;
75500			ARRAY1,OFFSET,FILEP,LIMIT:ATTR;
75600			NOOFF,NOLIM: BOOLEAN;
75700	
75800			BEGIN
75900			LREGC := REGC;  NOOFF := FALSE;  NOLIM:=FALSE;
76000	(* 175 - if not inited, do it *)
76100		        GETFN(FALSE);
76200	{If the file block is not legal yet, call routine to make it so}
76300			macro4(200B%MOVE\,hac,regc,filtst);  {File test word}
76400			macro3(302B%CAIE\,hac,314157B);  {Magic value if it is open}
76500			support(initfileblock);
76600			FILEP := GATTR;
76700			IF SY = COMMA
76800			  THEN INSYMBOL
76900			  ELSE ERROR(158);
77000			VARIABLE(FSYS OR [RPARENT,COMMA]);
77100			LOADADDRESS;
77200			WITH GATTR DO
77300			  BEGIN
77400			  KIND := EXPR; REG := INDEXR;
77500			  IF TYPTR # NIL
77600			    THEN WITH TYPTR^ DO
77700			      IF FORM # ARRAYS
77800				THEN ERROR(458)
77900				ELSE IF FILEP.TYPTR#NIL
78000				  THEN IF NOT ARRAYPF
78100				    THEN ERROR(458)
78200			  END;
78300			ARRAY1 := GATTR;
78400			IF SY = RPARENT
78500			  THEN NOOFF := TRUE
78600			ELSE IF SY = COMMA
78700			  THEN BEGIN
78800			  INSYMBOL;
78900			  EXPRESSION(FSYS OR [RPARENT,COMMA],ONREGC);
79000			  IF GATTR.TYPTR # NIL
79100			    THEN IF GATTR.TYPTR^.FORM # SCALAR
79200			      THEN ERROR(458)
79300			      ELSE IF NOT COMPTYPES(ARRAY1.TYPTR^.INXTYPE,GATTR.TYPTR)
79400				THEN ERROR(458);
79500			  OFFSET := GATTR;
79600			  IF OFFSET.KIND = EXPR
79700			    THEN INCREMENTREGC
79800			  END
79900			ELSE ERROR(158);
80000			IF SY = RPARENT
80100			  THEN NOLIM := TRUE
80200			ELSE IF SY = COMMA
80300			  THEN BEGIN
80400			  INSYMBOL;
80500			  EXPRESSION(FSYS OR [RPARENT],ONREGC);
80600			  IF GATTR.TYPTR # NIL
80700			    THEN IF GATTR.TYPTR^.FORM # SCALAR
80800			      THEN ERROR(458)
80900			      ELSE IF NOT COMPTYPES(ARRAY1.TYPTR^.INXTYPE,GATTR.TYPTR)
81000				THEN ERROR(458);
81100			  LIMIT := GATTR;
81200			  IF LIMIT.KIND = EXPR
81300			    THEN INCREMENTREGC
81400			  END
81500			ELSE ERROR(158);
81600			IF NOT ERRORFLAG
81700			  THEN BEGIN
81800			  GETBOUNDS(ARRAY1.TYPTR^.INXTYPE,LMIN,LMAX);
81900			  LMAX := LMAX - LMIN;
82000			  IF NOT NOLIM
82100			    THEN BEGIN
82200			    IF LIMIT.KIND # EXPR
82300			      THEN BEGIN LOAD(LIMIT); INCREMENTREGC END;
82400			    WITH LIMIT DO
82500			      BEGIN
82600			      IF LMIN > 0
82700				THEN MACRO3(275B%SUBI\,REG,LMIN)
82800			      ELSE IF LMIN < 0
82900				THEN MACRO3(271B%ADDI\,REG,-LMIN);
83000			      IF RUNTMCHECK
83100				THEN BEGIN
83200				MACRO3(307B%CAIG\,REG,LMAX);
83300				MACRO3(305B%CAIGE\,REG,0);
83400				SUPPORT(INDEXERROR)
83500				END;
83600			      END;
83700			    END;
83800			  IF NOT NOOFF
83900			    THEN BEGIN
84000			    IF OFFSET.KIND # EXPR
84100			      THEN BEGIN LOAD(OFFSET); INCREMENTREGC END;
84200			    WITH OFFSET DO
84300			      BEGIN
84400			      IF LMIN > 0
84500				THEN MACRO3(275B%SUBI\,REG,LMIN)
84600			      ELSE IF LMIN < 0
84700				THEN MACRO3(271B%ADDI\,REG,-LMIN);
84800			      IF RUNTMCHECK
84900				THEN BEGIN
85000				MACRO3(301B%CAIL\,REG,0);
85100				MACRO3(303B%CAILE\,REG,LMAX+1);
85200				SUPPORT(INDEXERROR)
85300				END;
85400			      END;
85500			    INCREMENTREGC;
85600			    IF NOLIM
85700			      THEN MACRO4(211B%MOVNI\,REGC,OFFSET.REG,-LMAX-1)
85800			      ELSE BEGIN
85900			      MACRO4(201B%MOVEI\,REGC,LIMIT.REG,1);
86000			      MACRO4(275B%SUBI\,REGC,OFFSET.REG,0);
86100			      IF RUNTMCHECK
86200				THEN BEGIN
86300				MACRO3(305B%CAIGE\,REGC,0);
86400				SUPPORT(INDEXERROR)
86500				END
86600			      END;
86700			    MACRO4(552B%HRRZM\,REGC,FILEP.INDEXR,FILBFH+2);
86800			    MACRO3R(200B%MOVE\,REGC,ARRAY1.TYPTR^.ARRAYBPADDR);
86900			    MACRO3(621B%TLZ\,REGC,17B);
87000			    MACRO3(231B%IDIVI\,OFFSET.REG,BITMAX DIV ARRAY1.TYPTR^.AELTYPE^.BITSIZE);
87100			    MACRO3(270B%ADD\,ARRAY1.REG,OFFSET.REG);
87200			    MACRO3(540B%HRR\,REGC,ARRAY1.REG);
87300			    MACRO3(303B%CAILE\,OFFSET.REG+1,0);
87400			    MACRO3(133B%IBP\,0,REGC);
87500			    MACRO3R(367B%SOJG\,OFFSET.REG+1,IC-1);
87600			    MACRO4(202B%MOVEM\,REGC,FILEP.INDEXR,FILBFH+1)
87700			    END
87800			   ELSE BEGIN
87900			    INCREMENTREGC;
88000			    IF NOLIM
88100			      THEN MACRO3(201B%MOVEI\,REGC,LMAX+1)
88200			      ELSE MACRO4(201B%MOVEI\,REGC,LIMIT.REG,1);
88300			    MACRO4(202B%MOVEM\,REGC,FILEP.INDEXR,FILBFH+2);
88400			    MACRO3R(200B%MOVE\,REGC,ARRAY1.TYPTR^.ARRAYBPADDR);
88500			    MACRO3(621B%TLZ\,REGC,17B);
88600			    MACRO3(540B%HRR\,REGC,ARRAY1.REG);
88700			    MACRO4(202B%MOVEM\,REGC,FILEP.INDEXR,FILBFH+1)
88800			    END;
88900			  IF NOLIM
89000			    THEN MACRO3(505B%HRLI\,REGC,LMIN+LMAX+400001B)
89100			    ELSE MACRO4(505B%HRLI\,REGC,LIMIT.REG,LMIN+400001B);
89200	(* 60 - DON'T PUT IN LH(0) FOR TOPS-20.  "FILBFH" IS FREE *)
89300	(* 143 - Tops10 now like Tops20 *)
89400			  IF TOPS10
89500			    THEN MACRO4(556B%HLRZM\,REGC,FILEP.INDEXR,FILBLL)
89600			    ELSE MACRO4(556B%HLRZM\,REGC,FILEP.INDEXR,FILBFH);
89700	(* 43 - setzm to avoid blocked or dump mode I/O *)
89800	(* 60 - kludge needed only for tops10 *)
89900	(* 143 - tops10 now like tops20 *)
90000			  CASE LKEY OF
90100	(* 60 - TOPS20 USES RUNTIME TO INIT *)
90200	(* 143 - so does Tops10 *)
90300			    22: SUPPORT(RESETSTRING);
90400			    23: SUPPORT(REWRITESTRING)
90500			    END;
90600			  END;
90700			REGC := LREGC
90800			END;
90900	
91000	(* 57 - ADD SET20STRING FOR 20 STRSET,STRWRITE *)
91100	(* 60 - on further thought, use normal one *)
91200	
91300		      PROCEDURE GETINDEX;
91400			  VAR LREGC:ACRANGE;
91500			      FILEP:ATTR;
91600			BEGIN
91700			LREGC := REGC;
91800	(* 175 *)
91900			GETFN(TRUE);
92000			FILEP := GATTR;
92100			IF SY = COMMA
92200			  THEN INSYMBOL
92300			  ELSE ERROR(158);
92400			VARIABLE(FSYS OR [RPARENT]);
92500			LOADADDRESS;
92600			WITH GATTR DO
92700			  BEGIN
92800			  IF TYPTR # NIL
92900			    THEN WITH TYPTR^ DO
93000			      IF (FORM # SCALAR) AND (FORM # SUBRANGE)
93100				THEN ERROR(458)
93200			  END;
93300			IF NOT ERRORFLAG
93400			  THEN BEGIN
93500			  INCREMENTREGC;
93600			  WITH FILEP DO
93700			    BEGIN
93800	(* 60 - TOPS20 HAS MAGIC NO. IN DIFFERENT PLACE *)
93900	(* 143 - tops10 now the same *)
94000			    IF TOPS10
94100			      THEN MACRO4(200B%MOVE\,REGC,INDEXR,FILBLL)
94200			      ELSE MACRO4(200B%MOVE\,REGC,INDEXR,FILBFH);
94300			    MACRO3(620B%TRZ\,REGC,400000B);
94400			    MACRO4(274B%SUB\,REGC,INDEXR,FILBFH+2);
94500			    MACRO4(202B%MOVEM\,REGC,GATTR.INDEXR,0);
94600			    END
94700			  END;
94800			REGC := LREGC
94900			END;
     
00100	
00200		      PROCEDURE READREADLN;
00300		      VAR
00400	(* 14 ADD READING OF STRING *)
00500	(* 171 read into packed objects, ALLOW READ OF RECORDS *)
00600			LADDR : SUPPORTS;  LMIN,LMAX:INTEGER; LATTR:ATTR;
00700			READREC: BOOLEAN; LREGC: ACRANGE;
00800	{This procedure is complicated by a number of special cases.  The first is
00900	 the question of whether the file is text or binary.  The code for a binary
01000	 file is more or less completely different.  (Note also that only READLN
01100	 is not legal for a binary file.)  The second question is whether the
01200	 address is passed to the runtimes or whether they return a value.  For
01300	 binary files we must pass the address of the variable to be filled, since
01400	 it can be arbitrarily big.  Similarly for strings.  For simple values,
01500	 the runtimes return the value in AC 3, and we must do a store.  This is
01600	 to allow for storing into packed objects (what kind of address could be
01700	 pass for that?)  We do LOADADDRESS for binary files and strings, and
01800	 for simple objects we do STORE afterwards.}
01900		       BEGIN
02000	(* 33 - ALLOW GETFILENAME WITH NON-TEXT FILES *)
02100	(* 171 - PREDECL FILES ARE GLOBAL, ALSO ALLOW READ OF RECORD *)
02200			IF LKEY = 7  {read?}
02300			  THEN GETFILENAME(INFILE,FALSE,THISFILE,GOTARG,TRUE)  {might be binary}
02400			  ELSE GETFILENAME(INFILE,TRUE,THISFILE,GOTARG,TRUE);  {must be text}
02500			IF (LKEY = 7) AND NOT GOTARG
02600			  THEN ERROR(554);   {READ must have args}
02700			READREC := FALSE;   {now see if a binary file}
02800		        IF LKEY = 7
02900			  THEN IF NOT COMPTYPES(CHARPTR,THISFILE^.FILTYPE)
03000			    THEN READREC := TRUE;
03100		        LREGC := REGC;
03200			 IF GOTARG
03300			 THEN
03400			   LOOP
03500	(* 14 ADD READING OF STRING *)
03600	(* 171 read into packed objects *)
03700			    LATTR := GATTR;
03800	(* 31 - INITIALIZE LADDR IN CASE OF ERROR - PREVENT ILL MEM REF *)
03900			    IF READREC
04000			      THEN BEGIN {separate code for binary files}
04100			      LADDR := READRECORD;
04200			      IF GATTR.TYPTR#NIL
04300			        THEN IF NOT COMPTYPES(THISFILE^.FILTYPE,GATTR.TYPTR)
04400				  THEN ERROR(260);
04500			      LOADADDRESS
04600			      END
04700			    ELSE BEGIN  {Here is the code for TEXT files}
04800			    LADDR := READCHARACTER;
04900			     IF GATTR.TYPTR#NIL
05000			     THEN
05100			       IF GATTR.TYPTR^.FORM<=SUBRANGE
05200			       THEN
05300				 IF COMPTYPES(INTPTR,GATTR.TYPTR)
05400				 THEN
05500				  LADDR := READINTEGER
05600				 ELSE
05700				   IF COMPTYPES(REALPTR,GATTR.TYPTR)
05800				   THEN
05900				    LADDR := READREAL
06000				   ELSE
06100				     IF COMPTYPES(CHARPTR,GATTR.TYPTR)
06200				     THEN
06300				      LADDR := READCHARACTER
06400				     ELSE ERROR(169)
06500			       ELSE WITH GATTR.TYPTR^ DO
06600				  IF FORM = ARRAYS
06700				    THEN IF COMPTYPES(CHARPTR,AELTYPE)
06800				      THEN
06900					BEGIN
07000	(* 171 - read into packed objects *)
07100					LOADADDRESS;  {of array}
07200					GETBOUNDS(INXTYPE,LMIN,LMAX);
07300					INCREMENTREGC;
07400					MACRO3(201B%MOVEI\,REGC,LMAX-LMIN+1);
07500					IF ARRAYPF
07600					  THEN LADDR := READPACKEDSTRING
07700					  ELSE LADDR := READSTRING;
07800					IF SY = COLON
07900					 THEN BEGIN
08000					  INSYMBOL;
08100	(* 76 - allow set of break characters *)
08200					  VARIABLE(FSYS OR [COMMA,RPARENT,COLON]);
08300					  LOADADDRESS;
08400					  IF NOT COMPTYPES(INTPTR,GATTR.TYPTR)
08500					    THEN ERROR(458);
08600					  END
08700					 else begin
08800					  incrementregc;
08900					  MACRO3(201B%MOVEI\,REGC,0);
09000					  end;
09100					if sy = colon
09200					  then begin
09300					  insymbol;
09400					  expression(fsys or [comma,rparent],onfixedregc);
09500					  if gattr.typtr#nil
09600					    then if (gattr.typtr^.form = power)
09700					     then if comptypes(gattr.typtr^.elset, charptr)
09800					      then begin
09900					      load(gattr);
10000					      regc := regc-2;
10100					      end
10200					     else error(458)
10300					    else error(458)
10400					   end
10500					  else macro3(403B%SETZB\,regc+1,regc+2);
10600					END
10700				      ELSE ERROR(458)
10800				    ELSE ERROR(458);
10900			    END; {of TEXT file case}
11000	(* 171 - read into packed objects *)
11100			    REGC := LREGC;
11200			    if not (readrec or (laddr in [readstring,readpackedstring]))
11300			      then begin
11400	  {This is for reading single words, which may go into packed structures.
11500	   Note that we have to redo the ac allocation because the read routine
11600	   will return a value in AC 3, which quite likely is used as INDEXR or
11700	   BPADDR.  Since we are pushing the active AC's anyway, we might as well
11800	   pop them back into a different place.}
11900			      incrementregc;  {place that read will return the value}
12000			      if (lattr.indexr > regin) and (lattr.indexr <= 10B)
12100			        then begin
12200				macro3(261B%PUSH\,topp,lattr.indexr);
12300				incrementregc;
12400				lattr.indexr := regc;  {Place to put this value afterwards}
12500				end;
12600			      if (lattr.packfg = packk) and (lattr.bpaddr > regin)
12700						        and (lattr.bpaddr <= 10B)
12800				then begin
12900			        macro3(261B%PUSH\,topp,lattr.bpaddr);
13000				incrementregc;
13100				lattr.bpaddr := regc;
13200				end;
13300			      regc := lregc;  {restore regc}
13400			      support(laddr);
13500			      if (lattr.packfg = packk) and (lattr.bpaddr > regin) 
13600					          	and (lattr.bpaddr <= 10B)
13700			        then macro3(262B%POP\,topp,lattr.bpaddr);
13800			      if (lattr.indexr > regin) and (lattr.indexr <= 10B)
13900			        then macro3(262B%POP\,topp,lattr.indexr);
14000			      fetchbasis(lattr);   {Now do the store}
14100			      store(regc+1,lattr)
14200			      end
14300			     else SUPPORT(LADDR);
14400			   EXIT IF SY # COMMA;
14500			    INSYMBOL;
14600			   VARIABLE(FSYS OR [COMMA,COLON,RPARENT]); 
14700			   END;
14800			 IF LKEY = 8
14900			 THEN SUPPORT(GETLINE)
15000		       END %READREADLN\ ;
15100	
15200	(* 42 - move breakin to close *)
15300	(* 43 - add putx *)
15400		      procedure putx;
15500			begin
15600	(* 175 *)
15700			getfn(true);
15800	(* 61 - add delete *)
15900			case lkey of
16000			  37: support(putxfile);
16100			  41: support(delfile)
16200			  end;
16300			end;
16400	
16500		      PROCEDURE BREAK;
16600		       BEGIN
16700	(* 26 - allow non-text files *)
16800	(* 171 - PREDECL FILES ARE SPECIAL *)
16900			GETFILENAME(OUTFILE,FALSE,THISFILE,GOTARG,TRUE);
17000			IF GOTARG THEN ERROR(554);
17100			SUPPORT(BREAKOUTPUT) ;
17200		       END ;
17300	
17400	(* 10 - ADD CLOSE *)
17500	(* 15 - AND ALLOW OPT. PARAM FOR CLOSE BITS *)
17600	(* 42 - move breakin here, to allow param to suppress get *)
17700		      PROCEDURE CLOSE;
17800		       BEGIN
17900	(* 26 - allow non-text files *)
18000	(* 61 - rclose for tops20 *)
18100			if (lkey = 25) or (lkey = 42)
18200	(* 171 - PREDECL FILES ARE SPECIAL *)
18300	(* 204 - don't validity check CLOSE and RCLOSE *)
18400			  THEN GETFILENAME(OUTFILE,FALSE,THISFILE,GOTARG,FALSE)
18500			  else getfilename(INFILE,false,THISFILE,GOTARG,FALSE);
18600			IF GOTARG
18700			 THEN LOAD(GATTR)
18800			 ELSE BEGIN
18900			  INCREMENTREGC;
19000			  MACRO3(201B%MOVEI\,REGC,0)
19100			  END;
19200	(* 45 - add NEXTBLOCK *)
19300	(* 61 - add RCLOSE *)
19400			case lkey of
19500			  25: support(closefile);
19600			  34: support(breakinput);
19700			  39: support(nextblockf);
19800			  42: support(relfile)
19900			  end;
20000		       END;
20100	
20200	(* 14 - ADD DUMP MODE STUFF *)
20300	(* 42 - allow variable size *)
20400		     PROCEDURE DUMP;
20500			VAR FILEP:ATTR; s:integer;
20600		      BEGIN
20700	(* 175 *)
20800		      GETFN(TRUE);
20900		      FILEP:=GATTR;
21000		      IF SY=COMMA
21100		        THEN INSYMBOL
21200			ELSE ERROR(158);
21300		      EXPRESSION(FSYS OR[COMMA,RPARENT],ONFIXEDREGC);
21400		      LOADADDRESS;
21500		      if gattr.typtr#nil
21600		       then s:=gattr.typtr^.size;
21700		      if sy=comma
21800		       then
21900			begin
22000			insymbol;
22100			expression(fsys or [rparent],onfixedregc);
22200			if comptypes(intptr,gattr.typtr)
22300			 then load(gattr)
22400			 else error(458);
22500			if runtmcheck
22600			 then begin
22700			 macro3(303b%caile\,regc,s);
22800			 support(indexerror)
22900			 end
23000			end
23100	               else
23200			begin
23300		        INCREMENTREGC;
23400			MACRO3(201B%MOVEI\,REGC,GATTR.TYPTR^.SIZE)
23500		        end;
23600		      IF LKEY=30
23700			THEN SUPPORT(READDUMP)
23800			ELSE SUPPORT(WRITEDUMP)
23900		      END;
24000	
24100		    PROCEDURE USET;
24200			VAR FILEP:ATTR;
24300		      BEGIN
24400	(* 175 *)
24500		      GETFN(TRUE);
24600		      FILEP:=GATTR;
24700		      IF SY = COMMA
24800			THEN INSYMBOL
24900			ELSE ERROR(158);
25000	(* 43 - new optional arg for useti *)
25100		      EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
25200		      LOAD(GATTR);
25300		      IF GATTR.TYPTR=NIL
25400			THEN ERROR(458)
25500			ELSE IF GATTR.TYPTR#INTPTR
25600			  THEN ERROR(458);
25700	(* 44 - add SETPOS and SKIP *)
25800		      IF LKEY # 33
25900	(* 43 - new optional arg for useti *)
26000			then begin
26100			  if sy=comma
26200			    then begin
26300			    insymbol;
26400			    expression(fsys or [rparent],onfixedregc);
26500			    load(gattr);
26600			    end
26700			  else begin
26800			    incrementregc;
26900			    macro3(201b%movei\,regc,0)
27000			    end;
27100			  case lkey of
27200				32:support(setin);
27300				38:support(setposf)
27400				end
27500			  end
27600			ELSE SUPPORT(SETOUT)
27700		      END;
27800	
27900		      PROCEDURE WRITEWRITELN;
28000		      VAR
28100			LSP: STP; DEFAULT,REALFORMAT,WRITEOCT: BOOLEAN; LSIZE,LMIN,LMAX: INTEGER; LADDR: SUPPORTS;
28200	(* 171 - write records *)
28300			writerec: Boolean;
28400		       BEGIN
28500	(* 171 - PREDECL FILES ARE GLOBAL, ALSO ALLOW READ OF RECORD *)
28600	{First scan file name and see if binary file}
28700			IF LKEY = 10   {WRITE?}
28800			  THEN GETFILENAME(OUTFILE,FALSE,THISFILE,GOTARG,TRUE)  {Yes, might be binary}
28900			  ELSE GETFILENAME(OUTFILE,TRUE,THISFILE,GOTARG,TRUE);  {No, WRITELN not legal for binary files}
29000			IF (LKEY = 10) AND NOT GOTARG
29100			  THEN ERROR(554);
29200			WRITEREC := FALSE;
29300		        IF LKEY = 10   {Now see if it was a binary file}
29400			  THEN IF NOT COMPTYPES(CHARPTR,THISFILE^.FILTYPE)
29500			    THEN WRITEREC := TRUE;
29600			 IF GOTARG
29700			 THEN
29800			   LOOP
29900	(* 22 - INITIALIZE LADDR IN CASE OF ERRORS.  PREVENTS ILL MEM REF *)
30000	(* 206 - moved initialization below *)
30100			    LSP := GATTR.TYPTR; LSIZE := LGTH; WRITEOCT := FALSE;
30200			     IF LSP # NIL
30300			     THEN
30400	(* 206 - make non-text files work for constants *)
30500	{Note that the values of LADDR set here are used only for binary files.
30600	 LADDR is reset below for text files.  Only in case of error will these
30700	 values remain for a text file, and in that case having them prevents
30800	 an ill mem ref}
30900			       IF LSP^.FORM <= POWER
31000			       THEN BEGIN LOAD(GATTR); LADDR := WRITESCALAR END
31100			       ELSE
31200				 BEGIN
31300				   IF (GATTR.KIND = VARBL)
31400				    AND
31500				    (GATTR.INDEXR = TOPP)
31600				   THEN ERROR(458);
31700				  LOADADDRESS;
31800				  LADDR := WRITERECORD;
31900				 END;
32000	(* 206 - make non-text files work for constants *)
32100			     IF WRITEREC
32200			       THEN BEGIN {For binary files, make sure of type match}
32300			       IF GATTR.TYPTR#NIL
32400			         THEN IF NOT COMPTYPES(THISFILE^.FILTYPE,GATTR.TYPTR)
32500				   THEN ERROR(260);
32600			       END  {end binary}
32700			     ELSE BEGIN
32800			     IF SY = COLON
32900			     THEN
33000			       BEGIN
33100				INSYMBOL; EXPRESSION(FSYS OR [COMMA,COLON,RPARENT],ONFIXEDREGC);
33200				 IF GATTR.TYPTR # NIL
33300				 THEN
33400				   IF GATTR.TYPTR # INTPTR
33500				   THEN ERROR(458);
33600				LOAD(GATTR); DEFAULT := FALSE;
33700			       END
33800			     ELSE
33900			       BEGIN
34000				DEFAULT := TRUE; INCREMENTREGC %RESERVE REGISTER FOR DEFAULT VALUE\
34100			       END ;
34200			     IF LSP = INTPTR
34300			     THEN
34400			       BEGIN
34500				LADDR := WRITEINTEGER ; LSIZE := 12
34600			       END;
34700			     IF SY = COLON
34800			     THEN
34900			       BEGIN
35000				INSYMBOL;
35100				 IF (SY = IDENT) AND ((ID='O         ') OR (ID='H         '))
35200				 THEN
35300				   BEGIN
35400				     IF NOT COMPTYPES(LSP,INTPTR)
35500				     THEN ERROR(262);
35600				     IF ID = 'O         '
35700				     THEN LADDR := WRITEOCTAL
35800				     ELSE
35900				       BEGIN
36000					LADDR := WRITEHEXADECIMAL; LSIZE := 11
36100				       END;
36200				    INSYMBOL
36300				   END
36400				 ELSE
36500				   BEGIN
36600				    EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
36700				     IF GATTR.TYPTR # NIL
36800				     THEN
36900				       IF GATTR.TYPTR # INTPTR
37000				       THEN ERROR(458);
37100				     IF LSP # REALPTR
37200				     THEN ERROR(258);
37300				    LOAD(GATTR); REALFORMAT := FALSE
37400				   END
37500			       END
37600			     ELSE REALFORMAT := TRUE;
37700			     IF LSP = INTPTR
37800			     THEN GOTO 1;
37900			     IF LSP = CHARPTR
38000			     THEN
38100			       BEGIN
38200				LSIZE := 1; LADDR := WRITECHARACTER
38300			       END
38400			     ELSE
38500			       IF LSP = REALPTR
38600			       THEN
38700				 BEGIN
38800				  LSIZE := 16; LADDR := WRITEREAL;
38900				   IF REALFORMAT
39000				   THEN MACRO3(201B%MOVEI\,REGIN+4,123456B);
39100				 END
39200			       ELSE
39300				 IF LSP = BOOLPTR
39400				 THEN
39500				   BEGIN
39600				    LSIZE := 6; LADDR := WRITEBOOLEAN
39700				   END
39800				 ELSE
39900				   IF LSP # NIL
40000				   THEN
40100				     BEGIN
40200				       IF LSP^.FORM = SCALAR
40300				       THEN ERROR(169)
40400				       ELSE
40500					 IF STRING(LSP)
40600					 THEN
40700					   BEGIN
40800					     IF LSP^.INXTYPE#NIL
40900					     THEN
41000					       BEGIN
41100						GETBOUNDS(LSP^.INXTYPE,LMIN,LMAX);
41200						LSIZE := LMAX-LMIN+1;
41300					       END;
41400					    MACRO3(201B%MOVEI\,REGIN+4,LSIZE);
41500					     IF LSP^.ARRAYPF
41600					     THEN LADDR := WRITEPACKEDSTRING
41700					     ELSE LADDR := WRITESTRING ;
41800					   END
41900					 ELSE ERROR(458)
42000				     END;
42100	1:
42200			     IF DEFAULT
42300			     THEN MACRO3(201B%MOVEI\,REGIN+3,LSIZE);
42400			    END;  {of IF WRITEREC}
42500			    SUPPORT(LADDR);
42600			    REGC :=REGIN + 1;
42700			   EXIT IF SY # COMMA;
42800			    INSYMBOL;
42900	(* 206 - allow constants for records *)
43000			    EXPRESSION(FSYS OR [COMMA,COLON,RPARENT],ONFIXEDREGC);
43100			   END;
43200			 IF LKEY = 11
43300			 THEN SUPPORT(PUTLINE) ;
43400		       END %WRITE\ ;
43500	
43600	(* 6 - PACK and UNPACK have been rewritten to be as described in Jensen and Wirth *)
43700		      PROCEDURE PACK;
43800	
43900			% PACK(A,I,Z) MEANS:
44000			 FOR L := LMIN(Z) TO LMAX(Z) DO Z[L] := A[L-LMIN(Z)+I] \
44100	
44200		      VAR
44300			ARRAY1,OFFSET1,ARRAY2,OFFSET2: ATTR;
44400			LADDR,START,STOP,LMIN1,LMAX1,LMIN2,LMAX2: ADDRRANGE;
44500			LREGC: ACRANGE;
44600	
44700		       BEGIN
44800			LREGC := REGC; START := 0;
44900			VARIABLE(FSYS OR [COMMA,RPARENT]);
45000			LOADADDRESS;
45100			WITH GATTR DO
45200			 BEGIN
45300			  KIND := EXPR; REG := INDEXR;
45400	(* 135 prevent ill mem ref if not a variable *)
45500			   IF TYPTR = NIL
45600			   THEN TYPTR := UARRTYP
45700			   ELSE WITH TYPTR^ DO
45800			     IF FORM # ARRAYS
45900			     THEN ERROR(458)
46000			     ELSE
46100			       IF ARRAYPF
46200			       THEN ERROR(458)
46300			 END;
46400			ARRAY1 := GATTR;
46500			 IF SY = COMMA
46600			 THEN INSYMBOL
46700			 ELSE ERROR(158);
46800			EXPRESSION(FSYS OR [COMMA,RPARENT],ONREGC);
46900			 IF GATTR.TYPTR # NIL
47000			 THEN
47100			   IF GATTR.TYPTR^.FORM # SCALAR
47200			   THEN ERROR(458)
47300			   ELSE
47400			     IF NOT COMPTYPES(ARRAY1.TYPTR^.INXTYPE,GATTR.TYPTR)
47500			     THEN ERROR(458);
47600			OFFSET1 := GATTR;
47700			 IF SY = COMMA
47800			 THEN INSYMBOL
47900			 ELSE ERROR(158);
48000			VARIABLE(FSYS OR [RPARENT]);
48100			LOADADDRESS;
48200			WITH GATTR DO
48300			 BEGIN
48400			  KIND := EXPR; REG := INDEXR;
48500			   IF TYPTR # NIL
48600			   THEN WITH TYPTR^ DO
48700			     IF FORM # ARRAYS
48800			     THEN ERROR(458)
48900			     ELSE
49000			       IF NOT ARRAYPF
49100				OR
49200				NOT (COMPTYPES(AELTYPE,ARRAY1.TYPTR^.AELTYPE)
49300				     AND
49400				     COMPTYPES(INXTYPE,ARRAY1.TYPTR^.INXTYPE))
49500			       THEN ERROR(458)
49600			 END;
49700			ARRAY2 := GATTR;
49800	
49900			 IF NOT ERRORFLAG
50000			 THEN
50100			   BEGIN
50200			    GETBOUNDS(ARRAY1.TYPTR^.INXTYPE,LMIN1,LMAX1); LMAX1 := LMAX1 - LMIN1;
50300			    GETBOUNDS(ARRAY2.TYPTR^.INXTYPE,LMIN2,LMAX2); LMAX2 := LMAX2 - LMIN2;
50400			    WITH OFFSET2 DO  %MAKE OFFSET2 A CONST = LMAX2+1 \
50500				BEGIN
50600				TYPTR := INTPTR;
50700				KIND := CST;
50800				CVAL.IVAL := LMAX2 + 1
50900				END;
51000			     IF (OFFSET1.KIND = CST)
51100			     THEN
51200			       BEGIN
51300				STOP := OFFSET2.CVAL.IVAL;
51400				START := OFFSET1.CVAL.IVAL - LMIN1;
51500				 IF (START < 0) OR (START > (LMAX1+1-STOP))
51600				 THEN ERROR(263);
51700				MACRO3(505B%HRLI\,ARRAY1.REG,-STOP);
51800			       END
51900			     ELSE
52000			       BEGIN
52100				LOAD(OFFSET2);
52200				WITH OFFSET2 DO
52300				  MACRO3(210B%MOVN\,REG,REG);
52400				LOAD(OFFSET1);
52500				WITH OFFSET1 DO
52600				 BEGIN
52700				   IF LMIN1 > 0
52800				   THEN MACRO3(275B%SUBI\,REG,LMIN1)
52900				   ELSE
53000				     IF LMIN1 < 0
53100				     THEN MACRO3(271B%ADDI\,REG,-LMIN1);
53200				   IF RUNTMCHECK
53300				   THEN
53400				     BEGIN
53500				      MACRO3(301B%CAIL\,REG,0);
53600				      MACRO4(303B%CAILE\,REG,OFFSET2.REG,LMAX1+1);
53700				      SUPPORT(INDEXERROR)
53800				     END;
53900				  MACRO3(270B%ADD\,ARRAY1.REG,REG);
54000				  MACRO4(505B%HRLI\,ARRAY1.REG,OFFSET2.REG,0)
54100				 END
54200			       END;
54300			    INCREMENTREGC;
54400			    MACRO3(540B%HRR\,TAC,ARRAY2.REG);
54500			    MACRO3R(200B%MOVE\,REGC,ARRAY2.TYPTR^.ARRAYBPADDR);
54600			    LADDR := IC;
54700			    MACRO4(200B%MOVE\,HAC,ARRAY1.REG,START);
54800			    MACRO3(136B%IDPB\,HAC,REGC);
54900			    MACRO3R(253B%AOBJN\,ARRAY1.REG,LADDR)
55000			   END;
55100			REGC := LREGC
55200		       END;
55300	
55400		      PROCEDURE UNPACK;
55500	
55600			% UNPACK(Z,A,I) MEANS:
55700			 FOR L := LMIN(Z) TO LMAX(Z) DO A[L-LMIN(Z)+I] := Z[L] \
55800	
55900		      VAR
56000			ARRAY1,OFFSET1,ARRAY2,OFFSET2: ATTR;
56100			LADDR,START,STOP,LMIN1,LMAX1,LMIN2,LMAX2: ADDRRANGE;
56200			LREGC: ACRANGE;
56300	
56400		       BEGIN
56500			LREGC := REGC; START := 0;
56600			VARIABLE(FSYS OR [COMMA,RPARENT]);
56700			LOADADDRESS;
56800			WITH GATTR DO
56900			 BEGIN
57000			  KIND := EXPR; REG := INDEXR;
57100	(* 135 - prevent ill mem ref if not a variable *)
57200			   IF TYPTR = NIL
57300			   THEN TYPTR := UARRTYP
57400			   ELSE WITH TYPTR^ DO
57500			     IF FORM # ARRAYS
57600			     THEN ERROR(458)
57700			     ELSE
57800			       IF NOT ARRAYPF
57900			       THEN ERROR(458)
58000			 END;
58100			ARRAY1 := GATTR;
58200			 IF SY = COMMA
58300			 THEN INSYMBOL
58400			 ELSE ERROR(158);
58500			VARIABLE(FSYS OR [COMMA,RPARENT]);
58600			LOADADDRESS;
58700			WITH GATTR DO
58800			 BEGIN
58900			  KIND := EXPR; REG := INDEXR;
59000	(* 135 - prevent ill mem ref if not a variable *)
59100			   IF TYPTR = NIL
59200			   THEN TYPTR := UARRTYP
59300			   ELSE WITH TYPTR^ DO
59400			     IF FORM # ARRAYS
59500			     THEN ERROR(458)
59600			     ELSE
59700			       IF ARRAYPF
59800				OR
59900				NOT (COMPTYPES(AELTYPE,ARRAY1.TYPTR^.AELTYPE)
60000				     AND
60100				     COMPTYPES(INXTYPE,ARRAY1.TYPTR^.INXTYPE))
60200			       THEN ERROR(458)
60300			 END;
60400			ARRAY2 := GATTR;
60500			 IF SY = COMMA
60600			 THEN INSYMBOL
60700			 ELSE ERROR(158);
60800			EXPRESSION(FSYS OR [RPARENT],ONREGC);
60900			 IF GATTR.TYPTR # NIL
61000			 THEN
61100			   IF GATTR.TYPTR^.FORM # SCALAR
61200			   THEN ERROR(458)
61300			   ELSE
61400			     IF NOT COMPTYPES(ARRAY2.TYPTR^.INXTYPE,GATTR.TYPTR)
61500			     THEN ERROR(458);
61600			OFFSET2 := GATTR;
61700	
61800			 IF NOT ERRORFLAG
61900			 THEN
62000			   BEGIN
62100			    GETBOUNDS(ARRAY1.TYPTR^.INXTYPE,LMIN1,LMAX1); LMAX1 := LMAX1 - LMIN1;
62200			    GETBOUNDS(ARRAY2.TYPTR^.INXTYPE,LMIN2,LMAX2); LMAX2 := LMAX2 - LMIN2;
62300			    WITH OFFSET1 DO  %MAKE OFFSET1 A CONST = LMAX1+1 \
62400				BEGIN
62500				TYPTR := INTPTR;
62600				KIND := CST;
62700				CVAL.IVAL := LMAX1 + 1
62800				END;
62900			     IF (OFFSET2.KIND = CST)
63000			     THEN
63100			       BEGIN
63200				STOP := OFFSET1.CVAL.IVAL;
63300				START := OFFSET2.CVAL.IVAL - LMIN2;
63400				 IF (START < 0) OR (START > (LMAX2+1-STOP))
63500				 THEN ERROR(263);
63600				MACRO3(505B%HRLI\,ARRAY2.REG,-STOP);
63700			       END
63800			     ELSE
63900			       BEGIN
64000				LOAD(OFFSET1);
64100				WITH OFFSET1 DO
64200				  MACRO3(210B%MOVN\,REG,REG);
64300				LOAD(OFFSET2);
64400				WITH OFFSET2 DO
64500				 BEGIN
64600				   IF LMIN2 > 0
64700				   THEN MACRO3(275B%SUBI\,REG,LMIN2)
64800				   ELSE
64900				     IF LMIN2 < 0
65000				     THEN MACRO3(271B%ADDI\,REG,-LMIN2);
65100				   IF RUNTMCHECK
65200				   THEN
65300				     BEGIN
65400				      MACRO3(301B%CAIL\,REG,0);
65500				      MACRO4(303B%CAILE\,REG,OFFSET1.REG,LMAX2+1);
65600				      SUPPORT(INDEXERROR)
65700				     END;
65800				  MACRO3(270B%ADD\,ARRAY2.REG,REG);
65900				  MACRO4(505B%HRLI\,ARRAY2.REG,OFFSET1.REG,0)
66000				 END
66100			       END;
66200			    INCREMENTREGC;
66300			    MACRO3(540B%HRR\,TAC,ARRAY1.REG);
66400			    MACRO3R(200B%MOVE\,REGC,ARRAY1.TYPTR^.ARRAYBPADDR);
66500			    LADDR := IC;
66600			    MACRO3(134B%ILDB\,HAC,REGC);
66700			    MACRO4(202B%MOVEM\,HAC,ARRAY2.REG,START);
66800			    MACRO3R(253B%AOBJN\,ARRAY2.REG,LADDR)
66900			   END;
67000			REGC := LREGC
67100		       END;
67200	
67300	
67400		      PROCEDURE NEW;
67500		      CONST
67600			TAGFMAX=5;
67700		      VAR
67800	(* 42 - move GET and PUT here *)
67900	(* 47 - add GETX and RECSIZE - no other comments in body *)
68000			adr:supports; sizereg:acrange;
68100			LSP,LSP1: STP; VARTS,LMIN,LMAX: INTEGER;
68200			FIRSTLOAD:BOOLEAN;
68300			LSIZE,LSZ: ADDRRANGE; LVAL: VALU;
68400			LATTR: ATTR; I,TAGFC: INTEGER;
68500			TAGFSAV: ARRAY[0..TAGFMAX] OF RECORD
68600							TAGFVAL: INTEGER;
68700							TAGFADDR: ADDRRANGE;
68800							LPACKKIND:PACKKIND;
68900	(* 21 - KEEP FROM STORING TAG VALUE IF NO PLACE TO PUT IT *)
69000							TAGWITHID:BOOLEAN
69100						      END;
69200		       BEGIN
69300			FOR I:=0 TO TAGFMAX DO TAGFSAV[I].TAGWITHID := FALSE;
69400	(* 42 - move GET and PUT in here *)
69500	(* 73 - restructure to use GETFN for file names, to allow extern files *)
69600	(* 152 - DISPOSE *)
69700	(* 153 - repair AC usage in DISPOSE *)
69800			if lkey = 44 {dispose}
69900			  then begin
70000			       incrementregc; incrementregc;
70100			       sizereg := regc;
70200			       variable(fsys or [comma,colon,rparent]);
70300			       lattr := gattr;  {We have to use a local copy so that
70400						 if AC1 is loaded here, that fact is
70500						 not saved for the store later.}
70600			       fetchbasis(lattr);
70700			       with lattr do  {modelled after loadaddress}
70800				 macro(vrelbyte,200B%MOVE\,sizereg-1,indbit,indexr,dplmt);
70900			       end
71000	(* 162 - fix RECSIZE *)
71100			else if lkey in [14,35]
71200			  then begin   (* all except file names *)
71300			       incrementregc; sizereg := regc ;
71400			       VARIABLE(FSYS OR [COMMA,COLON,RPARENT]);
71500			       end
71600	(* 175 - validate files for get and put stuff, but not for RECSIZE,
71700		which seems OK even if the file isn't open yet *)
71800			else begin getfn(lkey in [1,3,40]); sizereg := regin+2 end;
71900			LSP := NIL; VARTS := 0; LSIZE := 0; TAGFC := -1;
72000			LATTR := GATTR;
72100			 IF GATTR.TYPTR # NIL
72200			 THEN
72300			  WITH GATTR.TYPTR^ DO
72400	(* 42 - move GET and PUT in here *)
72500	(* 152 - dispose *)
72600	(* 162 - fix RECSIZE *)
72700			   if (lkey in [14,35,44]) and (form=pointer) or
72800			      (lkey in [1,3,15,40]) and (form=files)
72900			   THEN
73000			     BEGIN  %WARNING: This code depends upon fact that ELTYPE and FILTYPE are in the same place\
73100			       IF ELTYPE # NIL
73200			       THEN
73300				 BEGIN
73400				  LSIZE := ELTYPE^.SIZE;
73500				   IF ELTYPE^.FORM = RECORDS
73600				   THEN
73700				     BEGIN
73800				      LSP := ELTYPE^.RECVAR;
73900				     END
74000				   ELSE
74100				     IF ELTYPE^.FORM = ARRAYS
74200				     THEN LSP := ELTYPE
74300				 END
74400			     END
74500			   ELSE ERROR(458);
74600			WHILE SY = COMMA DO
74700			 BEGIN
74800			  INSYMBOL; CONSTANT(FSYS OR [COMMA,COLON,RPARENT],LSP1,LVAL);
74900			  VARTS := VARTS + 1;
75000			  %CHECK TO INSERTADDR HERE: IS CONSTANT IN TAGFIELDTYPE RANGE\
75100			   IF LSP = NIL
75200			   THEN ERROR(408)
75300			   ELSE
75400			     IF STRING(LSP1) OR (LSP1=REALPTR)
75500			     THEN ERROR(460)
75600			     ELSE
75700			       BEGIN
75800				TAGFC := TAGFC + 1;
75900				 IF TAGFC > TAGFMAX
76000				 THEN
76100				   BEGIN
76200				    ERROR(409);TAGFC := TAGFMAX; GOTO 1
76300				   END;
76400				 IF LSP^.FORM = TAGFWITHID
76500				 THEN
76600				   BEGIN
76700				     IF LSP^.TAGFIELDP # NIL
76800				     THEN
76900				       IF COMPTYPES(LSP^.TAGFIELDP^.IDTYPE,LSP1)
77000				       THEN
77100					WITH TAGFSAV[TAGFC],LSP^.TAGFIELDP^ DO
77200					 BEGIN
77300					  TAGFVAL := LVAL.IVAL;
77400					  TAGFADDR:= FLDADDR;
77500					  LPACKKIND:= PACKF;
77600	(* 21 - KEEP FROM STORING TAG VALUE INTO NON-EXISTENT FIELD *)
77700					  TAGWITHID:=TRUE
77800					 END
77900				       ELSE
78000					 BEGIN
78100					  ERROR(458);GOTO 1
78200					 END
78300				   END
78400				 ELSE
78500				   IF LSP^.FORM=TAGFWITHOUTID
     
00100				   THEN
00200				     BEGIN
00300				       IF NOT COMPTYPES(LSP^.TAGFIELDTYPE,LSP1)
00400				       THEN
00500					 BEGIN
00600					  ERROR(458); GOTO 1
00700					 END
00800				     END
00900				   ELSE
01000				     BEGIN
01100				      ERROR(358);GOTO 1
01200				     END;
01300				LSP1 := LSP^.FSTVAR;
01400				WHILE LSP1 # NIL DO
01500				WITH LSP1^ DO
01600				 IF VARVAL.IVAL = LVAL.IVAL
01700				 THEN
01800				   BEGIN
01900				    LSIZE :=SIZE; LSP := SUBVAR; GOTO 1
02000				   END
02100				 ELSE LSP1:=NXTVAR;
02200				LSIZE := LSP^.SIZE; LSP := NIL
02300			       END;
02400	1:
02500			 END %WHILE\ ;
02600			 IF SY = COLON
02700			 THEN
02800			   BEGIN
02900			    INSYMBOL;
03000			    EXPRESSION(FSYS OR [RPARENT],ONREGC);
03100			     IF LSP = NIL
03200			     THEN ERROR(408)
03300			     ELSE
03400			       IF LSP^.FORM # ARRAYS
03500			       THEN ERROR(259)
03600			       ELSE
03700				 BEGIN
03800				   IF  NOT COMPTYPES(GATTR.TYPTR,LSP^.INXTYPE)
03900				   THEN
04000				    ERROR(458);
04100				  LSZ := 1; LMIN := 1;
04200				   IF LSP^.INXTYPE # NIL
04300				   THEN
04400				    GETBOUNDS(LSP^.INXTYPE,LMIN,LMAX);
04500				   IF LSP^.AELTYPE # NIL
04600				   THEN LSZ := LSP^.AELTYPE^.SIZE;
04700				  LOAD(GATTR);
04800	(* 47 - add bounds checking *)
04900				  if runtmcheck
05000				    then begin
05100				    macro3(301B%cail\,regc,lmin);
05200				    macro3(303B%caile\,regc,lmax);
05300				    support(indexerror)
05400				    end;
05500				   IF LSZ # 1
05600				   THEN
05700				    MACRO3(221B%IMULI\,REGC,LSZ);
05800				   IF LSP^.ARRAYPF
05900				   THEN
06000				     BEGIN
06100	(* 30 - added BITMAX DIV, per Nagel's instructions *)
06200	(* 47 - repair calculation, and adjust for LMIN *)
06300				      lsz := bitmax div lsp^.aeltype^.bitsize-1-(lmin-1);
06400				      if lsz > 0
06500					then macro3(271B%addi\,regc,lsz)
06600				      else if lsz < 0
06700					then macro3(275B%subi\,regc,-lsz);
06800				      INCREMENTREGC; REGC := REGC - 1;
06900				      %FOR TESTING BECAUSE IDIV WORKS ON AC+1 TOO\
07000				      MACRO3(231B%IDIVI\,REGC,BITMAX DIV LSP^.AELTYPE^.BITSIZE);
07100				      LSZ := LSIZE - LSP^.SIZE;
07200				     END
07300				   ELSE
07400				    LSZ := LSIZE - LSP^.SIZE - LSZ*(LMIN - 1);
07500	(* 42 - change for GET and PUT *)
07600				    MACRO4(201B%MOVEI\,SIZEREG,REGC,LSZ);
07700				 END
07800			   END
07900			 ELSE MACRO3(201B%MOVEI\,SIZEREG,LSIZE);
08000	(* 24 - DON'T ZERO CORE UNLESS CHECKING *)
08100	(* 25 - USE /ZERO NOW INSTEAD *)
08200	(* 27 - add NEWZ *)
08300	(* 42 - move get and put in here *)
08400			if lattr.typtr # nil
08500			  then begin
08600			  case lkey of
08700			    1:if comptypes(lattr.typtr^.filtype,charptr)
08800			        then adr := getcharacter
08900				else adr := getfile;
09000			    3:adr := putfile;
09100			    14:if zero
09200				then adr := clearalloc
09300				else adr := allocate;
09400			    15:with gattr do
09500				begin typtr:=intptr; reg:=sizereg;kind:=expr;regc:=sizereg end;
09600			    35:adr := clearallocate;
09700			    40:if comptypes(lattr.typtr^.filtype,charptr)
09800				then error(458)
09900				else adr:=getxf;
10000	(* 173 - internal files *)
10100			    44:if lattr.typtr^.eltype <> nil
10200				 then if lattr.typtr^.eltype^.hasfile
10300				        then adr := withfiledeallocate
10400				        else adr := deallocate
10500				 else adr := deallocate
10600			    end;
10700	{Perhaps this is premature optimization, but NEW and DISPOSE do not save any
10800	 ac's.  Hence any that are active here have to be saved by the caller.  Since
10900	 only ac's 1 to 6 are used by the NEW and DISPOSE, we save only things <= 6:
11000	   any WITH ac's <= 6  (a fairly rare case)
11100	   lattr.indexr, if it is <= 6.  This is used in cases such as
11200		new(a^.b^.c)
11300	     to save information needed to get to C again after the call.
11400	   ac 1 sometimes contains the display pointer for a higher-level block.
11500	     However by gerrymandering LATTR, we force this to be recomputed after
11600	     the call by FETCHBASIS, so it is not saved.
11700	}
11800	(* 154 - don't clobber With AC's *)
11900			  if (lkey in [14,35,44]) and (regcmax < 6)
12000			    then for i := 0 to withix do
12100			      with display[top-i] do
12200			        if (cindr#0) and (cindr <= 6)
12300				  then macro4(202B%MOVEM\,cindr,basis,clc);
12400	(* 153 - save AC's *)
12500	(* 154 - don't need to save WITH acs *)
12600	(* 171 - more AC saving *)
12700			  if (lkey in [14,35,44])
12800			   then begin
12900			   if (lattr.indexr > regin) and (lattr.indexr <= 6)
13000			     then macro3(261B%PUSH\,topp,lattr.indexr);
13100			   if (lattr.packfg = packk) and (lattr.bpaddr > regin)
13200						     and (lattr.bpaddr <= 6)
13300			     then macro3(261B%PUSH\,topp,lattr.bpaddr);
13400			   support(adr);
13500			   if (lattr.packfg = packk) and (lattr.bpaddr > regin)
13600						     and (lattr.bpaddr <= 6)
13700			     then macro3(262B%POP\,topp,lattr.bpaddr);
13800			   if (lattr.indexr > regin) and (lattr.indexr <= 6)
13900			     then macro3(262B%POP\,topp,lattr.indexr);
14000			   end
14100			  else if lkey#15
14200			   then support(adr);
14300	(* 154 - restore WITH ac's *)
14400			  if (lkey in [14,35,44]) and (regcmax < 6)
14500			    then for i := 0 to withix do
14600			      with display[top-i] do
14700			        if (cindr#0) and (cindr <= 6)
14800				  then macro4(200B%MOVE\,cindr,basis,clc);
14900			  end;
15000			if (lkey=14)or(lkey=35)
15100			then begin
15200			REGC := REGIN+1;
15300			FIRSTLOAD := TRUE;
15400			FOR I := 0 TO TAGFC DO
15500			WITH TAGFSAV[I] DO
15600	(* 21 - KEEP FROM STORING TAG VALUE INTO NON-EXISTENT FIELD *)
15700			IF TAGWITHID THEN
15800			 BEGIN
15900			  MACRO3(201B%MOVEI\,HAC,TAGFVAL);
16000			   CASE LPACKKIND OF
16100			    NOTPACK:  MACRO4(202B%MOVEM\,HAC,REGC,TAGFADDR);
16200			    HWORDR:MACRO4(542B%HRRM\,HAC,REGC,TAGFADDR);
16300			    HWORDL:MACRO4(506B%HRLM\,HAC,REGC,TAGFADDR);
16400			    PACKK :
16500				    BEGIN
16600				      IF FIRSTLOAD
16700				      THEN
16800					BEGIN
16900					 MACRO3(200B%MOVE\,TAC,REGC);
17000					 FIRSTLOAD := FALSE
17100					END;
17200				     MACRO3R(137B%DPB\,HAC,TAGFADDR)
17300				    END
17400			   END%CASE\
17500			 END;
17600			STORE(REGC,LATTR)
17700	(* 42 - move GET and PUT in here *)
17800			end
17900	(* 152 - DISPOSE *)
18000	(* 153 - make reg usage safer *)
18100		       else if lkey=44
18200			then begin
18300		        incrementregc;
18400		        macro3(201B%MOVEI\,regc,377777B%nil\);
18500			store(regc,lattr)
18600		        end
18700		       END %NEW\ ;
18800	
18900	(* 46 - major reorganization to handle all arg formats *)
19000		      PROCEDURE CALLI;
19100			type argform=(bareac,xwd,twowords,oneword);
19200			VAR LSP:STP; LVAL,acval:VALU;
19300			    LH,RH,BOOL,RESUL:ATTR;
19400			    arg:argform;
19500			BEGIN
19600			arg := xwd;  %default format\
19700			CONSTANT(FSYS OR [RPARENT,COMMA],LSP,LVAL);
19800			IF NOT(COMPTYPES(INTPTR,LSP))
19900			  THEN ERROR(458);
20000			IF SY = COMMA
20100			  THEN INSYMBOL
20200			  ELSE ERROR(158);
20300			if sy=comma %,,word\
20400			  then begin
20500			  insymbol;
20600			  arg := oneword;
20700			  expression(fsys or [rparent,comma],onregc);
20800			  load(gattr);
20900			  lh := gattr
21000			  end
21100			else if sy=colon  %:ac\
21200			  then begin
21300			  arg := bareac;
21400			  insymbol;
21500			  constant(fsys or [rparent,comma],lsp,acval);
21600			  if not(comptypes(intptr,lsp))
21700			    then error(458)
21800			  end
21900			else begin  %lh,rh   or w1:w2\
22000			EXPRESSION(FSYS OR [RPARENT,COMMA,COLON],ONREGC);
22100			LOAD(GATTR);
22200			LH := GATTR;
22300			IF SY = COMMA
22400			  THEN INSYMBOL
22500			else if sy=colon
22600			  then begin arg:=twowords; insymbol end
22700			else error(158);
22800			  EXPRESSION(FSYS OR [RPARENT,COMMA],ONREGC);
22900			  IF GATTR.TYPTR # NIL
23000			    THEN IF (GATTR.TYPTR^.FORM <= POWER) or (arg=twowords)
23100			      THEN LOAD(GATTR)
23200			      ELSE BEGIN
23300			      LOADADDRESS;
23400			      GATTR.KIND:=EXPR;
23500			      GATTR.REG:=GATTR.INDEXR
23600			      END;
23700			  RH := GATTR;
23800			  end  %of lh,rh and w1:w2\;
23900			IF SY = COMMA
24000			  THEN INSYMBOL
24100			  ELSE ERROR(158);
24200			VARIABLE(FSYS OR [RPARENT,COMMA]);
24300			IF GATTR.TYPTR = NIL
24400			  THEN ERROR(458)
24500			  ELSE IF NOT(GATTR.TYPTR^.FORM IN [SUBRANGE,SCALAR])
24600			    THEN ERROR(458)
24700			    ELSE LOADADDRESS;
24800			RESUL:=GATTR;
24900			IF SY = COMMA
25000			  THEN INSYMBOL
25100			  ELSE ERROR(158);
25200			VARIABLE(FSYS OR [RPARENT]);
25300			IF NOT COMPTYPES(BOOLPTR,GATTR.TYPTR)
25400			  THEN ERROR(158)
25500			  ELSE LOADADDRESS;
25600			BOOL := GATTR;
25700			IF NOT ERRORFLAG
25800			  THEN BEGIN
25900			  case arg of
26000			    bareac: regc := acval.ival;
26100			    xwd: begin regc := rh.reg; macro3(504B%hrl\,rh.reg,lh.reg) end;
26200			    oneword: regc := lh.reg;
26300			    twowords: begin
26400				      regc := lh.reg;
26500				      if (regc+1) # rh.reg
26600				        then macro3(200B%move\,regc+1,rh.reg)
26700				      end
26800			  end %case\;
26900			  macro3(201B%movei\,tac,1);
27000			  macro4(202B%movem\,tac,bool.indexr,0);
27100			  MACRO3(047B%CALLI\,REGC,LVAL.IVAL);
27200			  MACRO4(402B%SETZM\,0,BOOL.INDEXR,0);
27300			  MACRO4(202B%MOVEM\,REGC,RESUL.INDEXR,0)
27400			  END
27500			END;
27600	
27700	(* 61 - tops20 system version *)
27800		      procedure jsys;
27900			var
28000			lval:valu; lsp:stp; jsysnum,numrets,i:integer;
28100			retsave:attr; saveret,ercal,done1: Boolean;
28200			realregc:acrange;
28300	(* 133 - add variable to allow saving stuff in display *)
28400			savelc:addrrange;
28500		       procedure loadarg;
28600			(* Handles input args for jsys:
28700			    simple vars - use their values
28800			    sets - use LH word only
28900			    files - use jfn word
29000			    packed arrays - make byte ptr to it
29100			    other - make pointer to it
29200			*)
29300			 begin
29400			 expression (fsys or [rparent,comma,semicolon,colon],onfixedregc);
29500			 if gattr.typtr # nil
29600			  then if (gattr.typtr^.form < power)
29700				then load(gattr)
29800			       else if (gattr.typtr^.form = power)
29900				then begin
30000	(* 77 - can't treat as integer. have to load both words and throw away 2nd *)
30100				load(gattr);
30200				regc := regc-1;
30300				end
30400			       else if (gattr.typtr^.form = files)
30500				then begin
30600				loadaddress;
30700	(* 217 - file expressions *)
30800				if gattr.externctp <> nil
30900				  then begin gattr.externctp^.vaddr := ic-1;
31000				       code.information[cix] := 'E' end;
31100				macro4(200b%move\,regc,regc,filjfn)
31200				end
31300			       else if (gattr.typtr^.form = arrays) and gattr.typtr^.arraypf
31400				then begin
31500				loadaddress;
31600				macro3r(500b%hll\,regc,gattr.typtr^.arraybpaddr);
31700				macro3(621b%tlz\,regc,17b)
31800				end
31900			       else loadaddress
32000			 end;
32100		       procedure storearg;
32200			(* stores results of jsys.  As above, but error for
32300			   anything bigger than a word *)
32400			 begin
32500			 variable(fsys or [rparent,comma]);
32600			 if gattr.typtr # nil
32700			  then if (gattr.typtr^.form < power)
32800				then store(realregc,gattr)
32900			       else if (gattr.typtr^.form = power)
33000				then begin
33100				gattr.typtr := intptr;
33200				store(realregc,gattr)
33300				end
33400			       else if (gattr.typtr^.form = files)
33500				then begin
33600				loadaddress;  {addr of file now in REGC}
33700	(* 217 - file expressions *)
33800				if gattr.externctp <> nil
33900				   then begin gattr.externctp^.vaddr:=ic-1;
34000					code.information[cix] := 'E' end;
34100	(* 173 - internal files *)
34200	{We have to compile code to see if the file is initialized.  If not,
34300	 call INITB. to do so.  INITB. needs the file in AC 2.  Note that
34400	 the AC use here is such that REGC is always above 2, so the only
34500	 reason for 2 not to be free is that realregc is using it.  This is
34600	 certainly not the best possible code, but at this point I am going
34700	 for the last code in the compiler to implement it.}
34800				macro3(250b%exch\,2,regc);
34900				macro4(200b%move\,0,2,filtst);
35000				macro3(302b%caie\,0,314157B);
35100				support(initfileblock);
35200				if realregc = 2
35300				  then macro4(202b%movem\,regc,2,filjfn)
35400				  else macro4(202b%movem\,realregc,2,filjfn)
35500				end
35600			       else error(458)
35700			 end;
35800			begin (* jsys *)
35900			ercal := false; saveret := false; numrets := 0; done1 := false;
36000			constant(fsys or [rparent,comma,semicolon],lsp,lval);
36100			jsysnum := lval.ival;
36200			if not comptypes (intptr, lsp)
36300			  then error(458);
36400			if sy = comma
36500			  then begin (* return spec *)
36600			  insymbol;
36700			  constant(fsys or [rparent,comma,semicolon],lsp,lval);
36800			  if lval.ival < 0
36900			    then ercal := true;
37000			  numrets := abs(lval.ival);
37100			  if not comptypes (intptr, lsp)
37200			    then error(458);
37300			  if sy = comma
37400			    then begin (* return var *)
37500			    insymbol;
37600			    variable(fsys or [rparent,semicolon]);
37700			    if comptypes (intptr,gattr.typtr)
37800			      then begin saveret := true; retsave := gattr end
37900			      else error (459)
38000			    end
38100			  end; (* return spec *)
38200			if sy = semicolon
38300			  then begin (* prolog *)
38400			  insymbol;
38500			  regc := 1;
38600			  if sy # semicolon
38700			    then loop (* non-empty prolog *)
38800			    loadarg;
38900			    if sy = colon
39000			      then begin
39100			      insymbol;
39200			      realregc := regc;
39300			      loadarg;
39400			      macro3(504b%hrl\,realregc,realregc);
39500			      macro3(540b%hrr\,realregc,regc);
39600			      regc := realregc
39700			      end;
39800			    if not done1
39900			      then begin
40000	(* 133 - save in display instead of PUSH P, *)
40100			      {Here we prepared a place on the display to store the value}
40200			      savelc := lc;
40300			      lc := lc+1;
40400			      if lc > lcmax
40500				then lcmax := lc;
40600			      macro4(202B%movem\,2,basis,savelc);
40700			      done1 := true;
40800			      regc := 1
40900			      end;
41000			    exit if sy # comma;
41100			    insymbol
41200			    end (* non-empty prolog *)
41300			  end; (* prolog *)
41400			(* main call *)
41500			if done1
41600	(* 133 - save in display instead of POP P, *)
41700			  then begin
41800			  macro4(200B%move\,1,basis,savelc);
41900			  lc := savelc
42000			  end;
42100			if saveret
42200			  then macro3(201b%movei\,0,numrets+1);
42300			macro3(104b%jsys\,0,jsysnum);
42400			if ercal
42500			  then begin
42600			  macro3r(320b%jump\,16b,ic+numrets);
42700			  numrets := numrets -1
42800			  end;
42900			for i := 1 to numrets do
43000			  if saveret then
43100			    macro3(275b%subi\,0,1)
43200			    else macro3(255b%jfcl\,0,0);
43300			if sy = semicolon (* if epilog, save reg a over store *)
43400			  then begin
43500	(* 133 - use display instead of stack to save *)
43600			  {find a place in the display to save ac 2}
43700			  savelc := lc;
43800			  lc := lc + 1;
43900			  if lc > lcmax
44000			    then lcmax := lc;
44100			  macro4(202B%movem\,2,basis,savelc);
44200			  macro3(200b%move\,2,1);
44300			  done1 := true
44400			  end
44500			 else done1 := false;
44600			if saveret
44700			  then store(0,retsave);
44800			if sy = semicolon
44900			  then begin (* epilog *)
45000			  realregc := 1;
45100			  repeat
45200			    insymbol;
45300			    regc := 4; (* so temp ac's start at 5 *)
45400			    realregc := realregc + 1;
45500			    if realregc > 4
45600			      then error(458);
45700			    storearg;
45800			    if done1
45900			      then begin
46000	(* 133 - use display instead of stack to store ac 2 *)
46100			      macro4(200B%move\,2,basis,savelc);
46200			      lc := savelc;
46300			      realregc := 1;
46400			      done1 := false
46500			      end
46600			   until sy # comma
46700			  end (* epilog *)
46800			end; (* jsys *)
46900	
47000		      PROCEDURE MARK;
47100		       BEGIN
47200			VARIABLE(FSYS OR [RPARENT]);
47300			 IF COMPTYPES(INTPTR,GATTR.TYPTR)
47400			 THEN
47500	(* 12 - REWRITE FOR NEW DYNAMIC MEMORY *)
47600	(* 122 - retrofit KA code *)
47700	(* 132 - separate KA10 into NOVM and KACPU *)
47800			 if novm
47900			   then begin
48000			   loadaddress;
48100			   macro4(202B%movem\,newreg,gattr.indexr,0)
48200			   end
48300			  else
48400			   BEGIN
48500			   LOADADDRESS;
48600			   INCREMENTREGC;
48700		 	   MACRO3R(200B%MOVE\,REGC,LSTNEW);
48800			   LSTNEW:=IC-1;  %GLOBAL FIXUP\
48900			   MACRO4(202B%MOVEM\,REGC,GATTR.INDEXR,0)
49000			   END
49100			 ELSE ERROR(459)
49200		       END %MARK\ ;
49300	
49400		      PROCEDURE RELEASE;
49500		       BEGIN
49600			EXPRESSION(FSYS OR [RPARENT],ONREGC);
49700			 IF GATTR.TYPTR = INTPTR
49800			 THEN
49900			   BEGIN
50000	(* 12 - RECODE FOR NEW DYNAMIC MEMORY *)
50100			   LOAD(GATTR);
50200	(* 122 - retrofit for KA *)
50300	(* 132 - separate KA10 into NOVM and KACPU *)
50400			   if novm
50500			     then macro3(200B%move\,newreg,regc)
50600			     ELSE BEGIN
50700			     MACRO3R(202B%MOVEM\,REGC,LSTNEW);
50800			     LSTNEW := IC-1;  % GLOBAL FIXUP \
50900			     end
51000			   END
51100			 ELSE ERROR(458)
51200		       END %RELEASE\ ;
51300	
51400		      PROCEDURE GETLINENR;
51500		       BEGIN
51600	(* 33 - ALLOW GETFILENAME WITH NON-TEXT *)
51700	(* 171 - PREDECL FILES ARE SPECIAL *)
51800			GETFILENAME(INFILE,TRUE,THISFILE,GOTARG,TRUE);
51900			IF NOT GOTARG
52000			  THEN ERROR(554);
52100			IF GATTR.KIND <> VARBL
52200			 THEN ERROR(458)
52300			 ELSE IF  GATTR.TYPTR # NIL
52400			 THEN
52500			   IF COMPTYPES(CHARPTR,GATTR.TYPTR^.AELTYPE) AND (GATTR.TYPTR^.FORM = ARRAYS)
52600			   THEN
52700			     BEGIN
52800			      MACRO4(200B%MOVE\,REGC,REGC,FILLNR); STORE(REGC,GATTR)
52900			     END
53000			   ELSE ERROR(458);
53100		       END;
53200	
53300		      PROCEDURE GETINTEGERFILENAME(DEFAULTNAME : ALFA);
53400		      VAR
53500			LCP : CTP; LID : ALFA;
53600		       BEGIN
53700			LID := ID;
53800			ID := DEFAULTNAME; SEARCHID([VARS],LCP);
53900			SELECTOR(FSYS OR FACBEGSYS OR [COMMA], LCP); LOADADDRESS;
54000			WITH LCP^, IDTYPE^ DO
54100			 IF (FORM = FILES) AND (VLEV = 0) AND (NOT MAIN)
54200			 THEN
54300			   BEGIN
54400			    VADDR:= IC-1; CODE.INFORMATION[CIX] := 'E'
54500			   END;
54600			ID := LID
54700		       END;
54800	
54900		      PROCEDURE PUT8BITSTOTTY;
55000		       BEGIN
55100			EXPRESSION(FSYS OR [RPARENT],ONREGC) ;
55200			LOAD(GATTR);
55300			MACRO3(051B%TTCALL\,15B%IONEOU\,GATTR.REG)
55400		       END %PUT8BITSTOTTY\ ;
55500	
55600		      PROCEDURE PAGE;
55700		       BEGIN
55800	(* 33 - ALLOW GETFILENAME WITH NON-TEXT *)
55900	(* 171 - PREDECL FILES ARE SPECIAL *)
56000			GETFILENAME(OUTFILE,TRUE,THISFILE,GOTARG,TRUE);
56100			IF GOTARG
56200			  THEN ERROR(554);
56300			SUPPORT(PUTPAGE)
56400		       END;
56500	(* 63 - support for tops-20 time and runtime *)
56600		      procedure jsysf(jsysnum,hireg:integer);
56700			var i:integer;
56800			begin
56900			if hireg > regc
57000			  then hireg := regc;
57100			for i := 2 to hireg do
57200			  macro3(261B%push\,topp,i);
57300			if jsysnum = 15B
57400			  then macro3(211B%movni\,1,5);
57500			macro3(104B%jsys\,0,jsysnum);
57600			with gattr do
57700			  begin
57800			  incrementregc; typtr := intptr; reg := regc; kind := expr;
57900			  macro3(200B%move\,regc,1)
58000			  end;
58100			for i := hireg downto 2 do
58200			  macro3(262B%pop\,topp,i)
58300			end;
58400	
58500	
58600		      PROCEDURE RUNTIME;
58700		       BEGIN
58800	(* 63 - TOPS20 *)
58900		       IF TOPS10
59000			THEN WITH GATTR DO
59100			 BEGIN
59200			  INCREMENTREGC; TYPTR := INTPTR; REG := REGC; KIND := EXPR;
59300			  MACRO3(047B,REGC,30B%PJOB-UUO\);
59400			  MACRO3(047B,REGC,27B%RUNTIM-UUO\)
59500			 END
59600		        ELSE JSYSF(15B%RUNTM\,3)
59700		       END;
59800	
59900		      PROCEDURE ABS;
60000		       BEGIN
60100			WITH GATTR DO
60200			 IF (TYPTR = INTPTR) OR (TYPTR = REALPTR)
60300			 THEN
60400			  WITH CODE.INSTRUCTION[CIX] DO
60500			   IF INSTR = 200B%MOVE\
60600			   THEN INSTR := 214B%MOVM\
60700			   ELSE MACRO3(214B%MOVM\,REG,REG)
60800			 ELSE
60900			   BEGIN
61000			    ERROR(459); TYPTR:= INTPTR
61100			   END
61200		       END %ABS\ ;
61300	
61400		      PROCEDURE TIME;
61500		       BEGIN
61600	(* 63 - TOPS20 *)
61700			WITH GATTR DO
61800			 BEGIN
61900			  INCREMENTREGC; TYPTR := INTPTR; REG := REGC; KIND := EXPR;
62000			  if tops10
62100			    then MACRO3(047B,REGC,23B%MSTIME-UUO\)
62200			   else begin
62300			   support(getdaytime);
62400			   macro3(262B%POP\,17B,regc)
62500			   end
62600			 END
62700		       END;
62800	
62900		      PROCEDURE SQR;
63000		       BEGIN
63100			WITH GATTR DO
63200			 IF TYPTR = INTPTR
63300			 THEN MACRO3(220B%IMUL\,REG,REG)
63400			 ELSE
63500			   IF TYPTR = REALPTR
63600			   THEN MACRO3(164B%FMPR\,REG,REG)
63700			   ELSE
63800			     BEGIN
63900			      ERROR(459); TYPTR := INTPTR
64000			     END
64100		       END %SQR\ ;
64200	
64300		      PROCEDURE TRUNC;
64400			VAR INSTRUC:1..777;
64500		       BEGIN
64600			IF LKEY = 5
64700			  THEN INSTRUC := 122B%FIX\
64800			  ELSE INSTRUC := 126B%FIXR\;
64900			 IF GATTR.TYPTR # REALPTR
65000			 THEN ERROR(459)
65100			 ELSE
65200	(* 2 - hard code TRUNC using KI-10 op code *)
65300	(* 10 - ADD ROUND *)
65400	(* 101 - fix bad code generation for fix and fixr *)
65500	(* 122 - put back KA code *)	 
65600	(* 132 - separate KA10 into NOVM and KACPU *)
65700			 if kacpu
65800			   then begin
65900			   if lkey=5
66000			     then macro3(551B%hrrzi\,tac,gattr.reg)
66100			     else macro3(561B%hrroi\,tac,gattr.reg);
66200			   support(convertrealtointeger);
66300			   end
66400			  ELSE WITH CODE.INSTRUCTION[CIX] DO
66500			    IF (INSTR = 200B%MOVE\) AND (AC = GATTR.REG)
66600			      THEN INSTR := INSTRUC
66700			      ELSE MACRO3(INSTRUC,GATTR.REG,GATTR.REG);
66800			GATTR.TYPTR := INTPTR
66900		       END %TRUNC\ ;
67000	
67100		      PROCEDURE ODD;
67200		       BEGIN
67300			WITH GATTR DO
67400			 BEGIN
67500			   IF TYPTR # INTPTR
67600			   THEN ERROR(459);
67700			  MACRO3(405B%ANDI\,REG,1);
67800			  TYPTR := BOOLPTR
67900			 END
68000		       END %ODD\ ;
68100	
68200		      PROCEDURE ORD;
68300		       BEGIN
68400			 IF GATTR.TYPTR # NIL
68500			 THEN
68600			   IF GATTR.TYPTR^.FORM >= POWER
68700			   THEN ERROR(459);
68800			GATTR.TYPTR := INTPTR
68900		       END %ORD\ ;
69000	
69100		      PROCEDURE CHR;
69200		       BEGIN
69300			 IF GATTR.TYPTR # INTPTR
69400			 THEN ERROR(459);
69500			GATTR.TYPTR := CHARPTR
69600		       END %CHR\ ;
69700	
69800		      PROCEDURE PREDSUCC;
69900		      VAR
70000			LSTRPTR:STP; LATTR: ATTR;
70100		       BEGIN
70200			 IF GATTR.TYPTR # NIL
70300			 THEN
70400			   IF (GATTR.TYPTR^.FORM>SUBRANGE) OR (GATTR.TYPTR=REALPTR)
70500			   THEN ERROR(459)
70600			   ELSE
70700			     IF RUNTMCHECK
70800			     THEN
70900			       BEGIN
71000				LSTRPTR:=GATTR.TYPTR;
71100				 IF (LSTRPTR^.FORM=SUBRANGE) AND (LSTRPTR^.RANGETYPE #NIL)
71200				 THEN LSTRPTR:=LSTRPTR^.RANGETYPE;
71300				 IF LKEY=9
71400				 THEN
71500				   BEGIN
71600				     IF LSTRPTR=INTPTR
71700				     THEN
71800				       BEGIN
71900					MACRO3R(255B%JFCL\,10B,IC+1);
72000					MACRO3(275B%SUBI\,REGC,1  );
72100					MACRO3R(255B%JFCL\,10B,IC+2);
72200					MACRO3(334B%SKIPA\,0,0	  );
72300					SUPPORT(ERRORINASSIGNMENT)
72400				       END
72500				     ELSE%  CHAR OR DECLARED \
72600				       BEGIN
72700					MACRO3R(365B%SOJGE\,REGC,IC+2);
72800					SUPPORT(ERRORINASSIGNMENT)
72900				       END
73000				   END % LKEY = 9 \
73100				 ELSE % LKEY = 10 \
73200				   BEGIN
73300				     IF LSTRPTR=INTPTR
73400				     THEN
73500				       BEGIN
73600					MACRO3R(255B%JFCL \,10B,IC+1);
73700					MACRO3(271B%ADDI \,REGC,1  );
73800					MACRO3R(255B%JFCL \,10B,IC+2);
73900					MACRO3(334B%SKIPA\,0,0	   );
74000					SUPPORT(ERRORINASSIGNMENT)
74100				       END
74200				     ELSE %CHAR OR DECLARED\
74300				       BEGIN
74400					WITH LATTR DO
74500					 BEGIN
74600					  TYPTR := LSTRPTR; KIND := CST; CVAL.IVAL := 0;
74700					   IF LSTRPTR=CHARPTR
74800					   THEN CVAL.IVAL := 177B
74900					   ELSE
75000					     IF LSTRPTR^.FCONST # NIL
75100					     THEN CVAL.IVAL:=LSTRPTR^.FCONST^.VALUES.IVAL;
75200					  MAKECODE(311B%CAML\,REGC,LATTR);
75300					  SUPPORT(ERRORINASSIGNMENT);
75400					  MACRO3(271B%ADDI \,REGC,1 );
75500					 END
75600				       END
75700				   END % LKEY = 10 \;
75800			       END % RUNTMCHECK \
75900			     ELSE
76000			       IF LKEY = 9
76100			       THEN MACRO3(275B%SUBI\,REGC,1)
76200			       ELSE MACRO3(271B%ADDI\,REGC,1)
76300		       END %PREDSUCC\ ;
76400	
76500		      PROCEDURE EOFEOLN;
76600		       BEGIN
76700	(* 33 - USE GETFILENAME, SO DEFAULTS TO INPUT *)
76800	(* 171 - PREDECL FILES ARE SPECIAL *)
76900		       GETFILENAME(INFILE,FALSE,THISFILE,GOTARG,TRUE);
77000		       IF GOTARG
77100			 THEN ERROR(554);
77200			WITH GATTR DO
77300			 BEGIN
77400			  KIND := EXPR; REG := INDEXR;
77500			   IF LKEY=11
77600			   THEN
77700			     BEGIN
77800			      MACRO4(332B%SKIPE\,REG,REG,FILEOF) ;
77900			      MACRO3(201B%MOVEI\,REG,1) ;
78000			     END
78100			   ELSE MACRO4(200B%MOVE\,REG,REG,FILEOL);
78200			  TYPTR := BOOLPTR
78300			 END
78400		       END %EOF\ ;
78500	
78600		      PROCEDURE PROTECTION;
78700			(* FOR DETAILS SEE  DEC-SYSTEM-10 MONITOR CALLS MANUAL, 3.2.4 *)
78800		       BEGIN
78900			EXPRESSION ( FSYS OR [RPARENT], ONREGC );
79000			 IF GATTR.TYPTR = BOOLPTR
79100	(* 63 - TOPS20 *)
79200			 THEN IF TOPS10
79300			  THEN
79400			   BEGIN
79500			    LOAD(GATTR);
79600			    MACRO3(047B%CALLI\,REGC,36B%SETUWP\);
79700			    MACRO3(254B%HALT\,4,0)
79800			   END
79900			  ELSE
80000			 ELSE ERROR(458)
80100		       END;
80200	
80300		      PROCEDURE CALLNONSTANDARD;
80400		      VAR
80500			NXT,LNXT,LCP: CTP;
80600			LSP: STP;
80700	(* 33 - PROC PARAM.S*)
80800			PKIND,LKIND: IDKIND;	LB: BOOLEAN;
80900			SAVECOUNT,P,I,NOFPAR: INTEGER;
81000			TOPPOFFSET,OFFSET,PARLIST,ACTUALPAR,FIRSTPAR,LLC: ADDRRANGE;
81100			LREGC: ACRANGE;
81200	
81300	(* 111 - STRING, POINTER *)
81400			procedure paramfudge;
81500			  var lmin,lmax:integer;
81600			(* This is used to handle special parameter types with
81700			   reduced type checking, such as STRING, POINTER.  They
81800			   are always one of STRINGPTR, POINTERPTR, or POINTERREF.
81900			   STRINGPTR is for STRING, the other two for POINTER.
82000			   POINTERREF is for call by ref *)
82100			begin
82200			with gattr.typtr^ do
82300			  if lsp=stringptr
82400			    then if (form=arrays) and arraypf
82500			      then if comptypes(aeltype,charptr)
82600				then begin  (* STRING *)
82700				getbounds (gattr.typtr^.inxtype, lmin, lmax);
82800				loadaddress;
82900				incrementregc;
83000				macro3(201B%movei\,regc,lmax-lmin+1);
83100				end
83200			       else error(503)
83300			      else error(503)
83400			    else if form=pointer  {pointerptr or pointerref}
83500			      then if eltype <> nil
83600				then begin (* POINTER *)
83700	(* 202 - fix up pointer by ref *)
83800				if lsp = pointerptr
83900				  then load(gattr)
84000				  else loadaddress;
84100				incrementregc;
84200				macro3(201B%movei\,regc,eltype^.size)
84300				end
84400			       else  (* bad type decl - already have error *)
84500			      else error(503);
84600			gattr.typtr := lsp  (* so comptypes later succeeds *)
84700			end;
84800	
84900		       BEGIN
85000			NOFPAR:= 0; TOPPOFFSET := 0; PARLIST := 0; ACTUALPAR := 0;
85100			WITH FCP^ DO
85200			 BEGIN
85300			  NXT := NEXT; LKIND := PFKIND;
85400			   IF KLASS = FUNC
85500			   THEN FIRSTPAR := 2
85600			   ELSE FIRSTPAR := 1;
85700	(* 33 - PROC PARAM.S *)
85800			   IF LKIND = ACTUAL
85900			   THEN IF EXTERNDECL
86000			   THEN LIBRARY[LANGUAGE].CALLED:= TRUE;
86100			  SAVECOUNT := REGC - REGIN;
86200			   IF  SAVECOUNT > 0
86300			   THEN
86400			     BEGIN
86500			      LLC := LC ;
86600			      LC := LC + SAVECOUNT ;
86700			       IF LC > LCMAX
86800			       THEN  LCMAX := LC ;
86900			       IF SAVECOUNT > 3
87000			       THEN
87100				 BEGIN
87200				  MACRO3(505B%HRLI\,TAC,2);
87300				  MACRO4(541B%HRRI\,TAC,BASIS,LLC);
87400				  MACRO4(251B%BLT\,TAC,BASIS,LLC+SAVECOUNT-1)
87500				 END
87600			       ELSE FOR  I := 1 TO SAVECOUNT DO  MACRO4(202B%MOVEM\,REGIN+I,BASIS,LLC+I-1)
87700			     END;
87800			  LREGC:= REGC;
87900			  IF LKIND = FORMAL
88000			    THEN REGC := REGIN
88100			  ELSE IF LANGUAGE # PASCALSY
88200			    THEN REGC:= PARREGCMAX
88300			  ELSE REGC:= REGIN
88400			 END;
88500			 IF SY = LPARENT
88600			 THEN
88700			   BEGIN
88800			     REPEAT
88900			      LB := FALSE;  %DECIDE WHETHER PROC/FUNC MUST BE PASSED\
89000			       IF LKIND = ACTUAL
89100			       THEN
89200				 BEGIN
89300				   IF NXT = NIL
89400				   THEN ERROR(554)
89500				   ELSE LB := NXT^.KLASS IN [PROC,FUNC]
89600				 END
89700	(* 33 - PROC PARAM.S *)
89800			       ELSE LB := FALSE;
89900				%FOR FORMAL PROC/FUNC LB IS FALSE AND EXPRESSION
90000				 WILL BE CALLED, WHICH WILL ALLWAYS INTERPRET A PROC/FUNC ID
90100				 AT ITS BEGINNING AS A CALL RATHER THAN A PARAMETER PASSING.
90200				 IN THIS IMPLEMENTATION, PARAMETER PROCEDURES/FUNCTIONS
90300				 ARE THEREFORE NOT ALLOWED TO HAVE PROCEDURE/FUNCTION
90400				 PARAMETERS\
90500			      INSYMBOL;
90600			       IF LB
90700			       THEN   %PASS FUNCTION OR PROCEDURE\
90800				 BEGIN
90900				   IF SY # IDENT
91000				   THEN
91100				    ERRANDSKIP(209,FSYS OR [COMMA,RPARENT])
91200				   ELSE
91300				     BEGIN
91400				       IF NXT^.KLASS = PROC
91500				       THEN SEARCHID([PROC],LCP)
91600				       ELSE
91700					 BEGIN
91800					  SEARCHID([FUNC],LCP);
91900					   IF  NOT COMPTYPES(LCP^.IDTYPE,NXT^.IDTYPE)
92000					   THEN
92100					    ERROR(555)
92200					 END;
92300				      INSYMBOL;
92400				      IFERRSKIP(166,FSYS OR [COMMA,RPARENT])
92500				     END;
92600	(* 33 - PROC PARAM.S *)
92700				 WITH LCP^ DO
92800				  IF (PFDECKIND = STANDARD) OR (PFKIND = ACTUAL) AND (LANGUAGE # PASCALSY)
92900				    THEN ERROR (466)
93000				    ELSE BEGIN
93100				    INCREMENTREGC;
93200	(* 67 - fix proc param's *)
93300				   if pflev > 1
93400				     then p := level - pflev
93500				     else p := 0;
93600				    IF PFKIND = ACTUAL
93700				      THEN BEGIN
93800				      IF P = 0
93900					THEN MACRO3(514B%HRLZ\,REGC,BASIS)
94000				      ELSE IF P=1
94100					THEN MACRO4(514B%HRLZ\,REGC,BASIS,-1)
94200				      ELSE %P>1\
94300					BEGIN
94400					MACRO4(550B%HRRZ\,REGC,BASIS,-1);
94500					FOR I := 3 TO P DO MACRO4(550B%HRRZ\,REGC,REGC,-1);
94600					MACRO4(514B%HRLZ\,REGC,REGC,-1)
94700					END;
94800				    IF PFADDR = 0
94900				      THEN BEGIN
95000	(* 67 - fix typo: R in macro3r omitted *)
95100				      MACRO3R(541B%HRRI\,REGC,LINKCHAIN[P]);
95200				      LINKCHAIN[P] := IC - 1;
95300				      IF EXTERNDECL
95400					THEN CODE.INFORMATION[CIX] := 'E'
95500					ELSE CODE.INFORMATION[CIX] := 'F'
95600				      END
95700				     ELSE MACRO3R(541B%HRRI\,REGC,PFADDR);
95800				    END %OF PFKIND = ACTUAL \
95900				    ELSE %PFKIND = FORMAL \
96000				      IF P = 0
96100					THEN MACRO4(200B%MOVE\,REGC,BASIS,PFADDR)
96200					ELSE
96300					  BEGIN
96400					  MACRO4(200B%MOVE\,REGC,BASIS,-1);
96500					  FOR I := 2 TO P DO MACRO4(200B%MOVE\,REGC,REGC,-1);
96600					  MACRO4(200B%MOVE\,REGC,REGC,PFADDR)
96700					  END
96800				    END;
96900				 END %IF LB\
97000			       ELSE
97100				 BEGIN
97200				  EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
97300				   IF GATTR.TYPTR # NIL
97400				   THEN
97500	(* 33 - PROC PARAM.S *)
97600				       BEGIN
97700	%NOTE : WE TREAT ALL PARAM'S OF A FORMAL PROC AS ACTUAL\
97800					 IF (NXT # NIL) OR (LKIND = FORMAL)
97900					 THEN
98000					   BEGIN
98100	(*33 - PROC PARAM.S *)
98200					    IF LKIND = FORMAL
98300					      THEN BEGIN LSP := GATTR.TYPTR; PKIND := ACTUAL END
98400					      ELSE BEGIN LSP := NXT^.IDTYPE; PKIND := NXT^.VKIND END;
98500					     IF LSP # NIL
98600					     THEN
98700					       BEGIN
98800	(* 33 - PROC PARAM.S *)
98900	(* 161 - fix STRING,POINTER *)
99000						IF  (PKIND = ACTUAL)
99100						 THEN
99200						   IF LSP^.SIZE <= 2
99300						   THEN
99400						     BEGIN
99500	(* 104 - more range checking for subrange things *)
99600	(* 202 - pointer by ref *)
99700						       if (lsp = stringptr) or
99800							  (lsp = pointerptr) or
99900							  (lsp = pointerref)
     
00100							     then paramfudge
00200						       else if lsp^.form = subrange
00300							then loadsubrange(gattr,lsp)
00400						       else load(gattr);
00500						       IF COMPTYPES(REALPTR,LSP)
00600							AND (GATTR.TYPTR = INTPTR)
00700						       THEN MAKEREAL(GATTR)
00800						     END
00900						   ELSE
01000						     BEGIN
01100						      LOADADDRESS;
01200	(* 33 - PROC PARAM.S *)
01300						       IF (LKIND = ACTUAL) AND (FCP^.LANGUAGE # PASCALSY)
01400						       THEN CODE.INSTRUCTION[CIX].INSTR := 505B%HRLI\
01500						     END
01600						 ELSE
01700						   IF GATTR.KIND = VARBL
01800						   THEN LOADADDRESS
01900						   ELSE ERROR(463) ;
02000	(* 22 - ALLOW EXTERNAL FILE REFERENCES *)
02100						 IF GATTR.TYPTR#NIL
02200						  THEN IF GATTR.TYPTR^.FORM=FILES
02300	(* 217 - file expressions *)
02400						    THEN IF GATTR.EXTERNCTP <> NIL
02500						      THEN BEGIN GATTR.EXTERNCTP^.VADDR:=IC-1;
02600							   CODE.INFORMATION[CIX]:='E' END;
02700	(* 64 - fix proc param's that don't fit in ac's *)
02800						 IF  NOT COMPTYPES(LSP,GATTR.TYPTR)
02900						 THEN ERROR(503)
03000					       END
03100					   END
03200				       END
03300	(* 33 - PROC PARAM.S *)
03400				 END;
03500				 IF REGC>PARREGCMAX
03600				 THEN
03700	(* 33 - PROC PARAM.S *)
03800	(* NOTE: CURRENTLY WE PUNT IF ARG'S DON'T FIT IN AC'S IN FORMAL PROC*)
03900	(* 215 - keep from looping when NXT = NIL because of error *)
04000				 IF NXT <> NIL
04100				  THEN 
04200				  IF LKIND=FORMAL
04300				   THEN ERROR(413)
04400				   ELSE BEGIN
04500				     IF TOPPOFFSET = 0
04600				     THEN
04700				       BEGIN
04800					LNXT := FCP^.NEXT ;
04900					 IF FCP^.LANGUAGE = PASCALSY
05000	(* 62 - clean up offset *)
05100					 then toppoffset := fcp^.poffset + 1
05200					 ELSE
05300					   BEGIN
05400					    TOPPOFFSET := 1 + FIRSTPAR;
05500					     REPEAT
05600					      WITH LNXT^ DO
05700					       BEGIN
05800						NOFPAR := NOFPAR +1;
05900						TOPPOFFSET := TOPPOFFSET + 1;
06000						 IF VKIND = ACTUAL
06100						 THEN TOPPOFFSET := TOPPOFFSET + IDTYPE^.SIZE;
06200						 IF LKIND = ACTUAL
06300						 THEN LNXT := NEXT
     
00100					       END;
00200					     UNTIL LNXT = NIL;
00300					    PARLIST := 1 + FIRSTPAR;
00400					    ACTUALPAR := PARLIST + NOFPAR
00500					   END;
00600	(* 104 - TOPS20 DETECTION OF STACK OVERFLOW *)
00700	(* 115 - TENEX *)
00800					IF KLCPU AND NOT TOPS10
00900					  THEN MACRO3(105B%ADJSP\,TOPP,TOPPOFFSET)
01000					  ELSE MACRO3(271B%ADDI\,TOPP,TOPPOFFSET);
01100	(* 54 - keep track of how many loc's above stack are used *)
01200					stkoff := stkoff + toppoffset;
01300					if stkoff > stkoffmax
01400					  then stkoffmax := stkoff
01500				       END ;
01600				    WITH NXT^ DO
01700				     BEGIN
01800				       IF FCP^.LANGUAGE = PASCALSY
01900				       THEN
02000	(* 64 - fix parameter proc's that don't fit in ac's *)
02100				       if klass # vars
02200					 then macro4(202b%movem\,regc,topp,pfaddr+1-toppoffset)
02300					 ELSE BEGIN
02400	(* 52 - if VAR, size is always 1 *)
02500					   IF (VKIND=ACTUAL) AND (IDTYPE^.SIZE=2)
02600					   THEN
02700					     BEGIN
02800					      MACRO4(202B%MOVEM\,REGC,TOPP,VADDR+2-TOPPOFFSET);
02900					      REGC := REGC - 1
03000					     END;
03100	(* 201 - zero size things *)
03200					  IF (IDTYPE^.SIZE > 0) OR (VKIND <> ACTUAL)
03300					    THEN MACRO4(202B%MOVEM\,REGC,TOPP,VADDR+1-TOPPOFFSET)
03400					 END
03500				       ELSE
03600	(* 64 - proc param's that don't fit in ac's *)
03700					if klass # vars
03800					 then error(466)
03900					 ELSE BEGIN
04000					   IF VKIND = ACTUAL
04100					   THEN
04200					     BEGIN
04300					       IF IDTYPE^.SIZE <= 2
04400					       THEN
04500						 BEGIN
04600						   IF IDTYPE^.SIZE = 2
04700						   THEN
04800						     BEGIN
04900						      MACRO4(202B%MOVEM\,REGC,TOPP,ACTUALPAR+1-TOPPOFFSET);
05000						      REGC := REGC - 1
05100						     END;
05200	(* 201 - zero size objects *)
05300						  IF IDTYPE^.SIZE > 0
05400						    THEN MACRO4(202B%MOVEM\,REGC,TOPP,ACTUALPAR-TOPPOFFSET);
05500						  MACRO4(541B%HRRI\,REGC,TOPP,ACTUALPAR-TOPPOFFSET)
05600						 END
05700					       ELSE
05800						 BEGIN
05900						  MACRO4(541B%HRRI\,REGC,TOPP,ACTUALPAR-TOPPOFFSET);
06000						  MACRO4(251B%BLT\,REGC,TOPP,ACTUALPAR+IDTYPE^.SIZE-1-TOPPOFFSET);
06100	(* 52 - BLT may change REGC, so reset it since used below *)
06200						  MACRO4(541B%HRRI\,REGC,TOPP,ACTUALPAR-TOPPOFFSET)
06300						 END;
06400					      ACTUALPAR := ACTUALPAR + IDTYPE^.SIZE
06500					     END;
06600					  MACRO4(552B%HRRZM\,REGC,TOPP,PARLIST-TOPPOFFSET);
06700					  PARLIST := PARLIST + 1
06800					 END;
06900				      REGC := PARREGCMAX
07000				     END
07100				   END;
07200			       IF (LKIND = ACTUAL) AND (NXT # NIL)
07300			       THEN NXT := NXT^.NEXT
07400			     UNTIL SY # COMMA;
07500			     IF SY = RPARENT
07600			     THEN INSYMBOL
07700			     ELSE ERROR(152)
07800			   END %IF LPARENT\;
07900			FOR I := 0 TO WITHIX DO
08000			WITH DISPLAY[TOP-I] DO
08100			 IF (CINDR#0)  AND  (CINDR#BASIS)
08200			 THEN
08300			  MACRO4(202B%MOVEM\,CINDR,BASIS,CLC);
08400			WITH FCP^ DO
08500			 BEGIN
08600	(* 33 - PROC. PARAM.S *)
08700			   IF LKIND = FORMAL
08800			     THEN BEGIN END %TOPOFFSET=0 ALWAYS AT THE MOMENT\
08900			   ELSE IF  (LANGUAGE = PASCALSY) AND (TOPPOFFSET # 0)
09000	(* 54 - keep track of offsets above top of stack *)
09100	(* 62 - clean up offset *)
09200			     THEN STKOFF := STKOFF - TOPPOFFSET
09300			   ELSE IF (LANGUAGE # PASCALSY) AND (TOPPOFFSET = 0)
09400			     THEN
09500			     BEGIN
09600			      TOPPOFFSET:= FIRSTPAR+2;
09700	(* 104 - TOPS20 ADJSP *)
09800	(* 115 - TENEX *)
09900			      IF KLCPU AND NOT TOPS10
10000				THEN MACRO3(105B%ADJSP\,TOPP,TOPPOFFSET)
10100			        ELSE MACRO3(271B%ADDI\,TOPP,TOPPOFFSET);
10200	(* 54 - keep track of how many loc's above stack are used *)
10300			      STKOFF := STKOFF + TOPPOFFSET;
10400			      IF STKOFF > STKOFFMAX
10500			        THEN STKOFFMAX := STKOFF
10600			     END;
10700			   IF PFLEV > 1
10800			   THEN P := LEVEL - PFLEV
10900			   ELSE P:= 0;
11000			   IF LKIND = ACTUAL
11100			   THEN
11200			     BEGIN
11300			       IF NXT # NIL
11400			       THEN ERROR(554);
11500			       IF LANGUAGE # PASCALSY
11600			       THEN
11700				 BEGIN
11800				  MACRO3(515B%HRLZI\,HAC,-NOFPAR);
11900				  MACRO4(202B%MOVEM\,HAC,TOPP,FIRSTPAR-TOPPOFFSET);
12000				  MACRO4(202B%MOVEM\,BASIS,TOPP,-TOPPOFFSET);
12100				  MACRO4(201B%MOVEI\,BASIS,TOPP,FIRSTPAR-TOPPOFFSET+1);
12200				   IF NOFPAR = 0
12300				   THEN MACRO4(402B%SETZM\,0,TOPP,FIRSTPAR-TOPPOFFSET+1)
12400				 END;
12500			       IF PFADDR = 0
12600			       THEN
12700				 BEGIN
12800				  MACRO3R(260B%PUSHJ\,TOPP,LINKCHAIN[P]); LINKCHAIN[P]:= IC-1;
12900				   IF EXTERNDECL
13000				   THEN CODE.INFORMATION[CIX] := 'E'
13100				   ELSE CODE.INFORMATION[CIX] := 'F'
13200				 END
13300			       ELSE MACRO3R(260B%PUSHJ\,TOPP,PFADDR-P);
13400	(* 33 - PROC PARAM.S *)
13500			   IF LANGUAGE # PASCALSY
13600			   THEN
13700			     BEGIN
13800	(* 104 - TOPS20 ADJSP *)
13900			      IF KLCPU AND NOT TOPS10
14000				THEN MACRO3(105B%ADJSP\,TOPP,-TOPPOFFSET)
14100			        ELSE MACRO3(275B%SUBI\,TOPP,TOPPOFFSET);
14200	(* 54 - keep track of how many loc's above stack are used *)
14300			      STKOFF := STKOFF - TOPPOFFSET;
14400			       IF KLASS = FUNC
14500			       THEN
14600				 BEGIN
14700				  MACRO4(202B%MOVEM\,HAC,TOPP,2);
14800				   IF IDTYPE^.SIZE = 2
14900				   THEN MACRO4(202B%MOVEM\,TAC,TOPP,3)
15000				 END;
15100			      MACRO4(200B%MOVE\,BASIS,TOPP,0)
15200			     END
15300	(* 33 - PROC PARAM.S *)
15400			     END  (* OF LKIND = ACTUAL *)
15500			   ELSE
15600			     BEGIN
15700			     IF P = 0
15800			      THEN BEGIN
15900			       MACRO4(550B%HRRZ\,TAC,BASIS,PFADDR);
16000			       MACRO4(544B%HLR\,BASIS,BASIS,PFADDR)
16100			       END
16200			      ELSE BEGIN
16300			       MACRO4(550B%HRRZ\,TAC,BASIS,-1);
16400			       FOR I := 2 TO P DO MACRO4(550B%HRRZ\,TAC,TAC,-1);
16500			       MACRO4(544B%HLR\,BASIS,TAC,PFADDR);
16600			       MACRO4(550B%HRRZ\,TAC,TAC,PFADDR)
16700			       END;
16800			     MACRO4(260B%PUSHJ\,TOPP,TAC,0)
16900			     END
17000			 END;
17100			FOR I := 0 TO WITHIX DO
17200			WITH DISPLAY[TOP-I] DO
17300			 IF (CINDR#0)  AND  (CINDR#BASIS)
17400			 THEN MACRO4(200B%MOVE\,CINDR,BASIS,CLC) ;
17500			 IF  SAVECOUNT > 0
17600			 THEN
17700			   BEGIN
17800			     IF SAVECOUNT > 3
17900			     THEN
18000			       BEGIN
18100				MACRO4(505B%HRLI\,TAC,BASIS,LLC);
18200				MACRO3(541B%HRRI\,TAC,2);
18300				MACRO3(251B%BLT\,TAC,SAVECOUNT+1)
18400			       END
18500			     ELSE FOR  I := 1 TO SAVECOUNT  DO	MACRO4(200B%MOVE\,REGIN+I,BASIS,LLC+I-1) ;
18600			    LC := LLC
18700			   END ;
18800			GATTR.TYPTR := FCP^.IDTYPE; REGC := LREGC
18900		       END %CALLNONSTANDARD\ ;
19000	
19100		     BEGIN
19200		      %CALL\
19300		       IF FCP^.PFDECKIND = STANDARD
19400		       THEN
19500			 BEGIN
19600			  LKEY := FCP^.KEY;
19700			   IF FCP^.KLASS = PROC
19800			   THEN
19900			     BEGIN
20000	(* 26 - allow non-text files *)
20100	(* 61 - rclose *)
20200			       IF NOT (LKEY IN [7,8,9,10,11,17,19,25,34,39,42] )
20300			       THEN
20400				 IF SY = LPARENT
20500				 THEN INSYMBOL
20600				 ELSE ERROR(153);
20700	(* 45 - APPEND, UPDATE, RENAME, use REG5 and REG6 *)
20800			       IF (LKEY IN [5,6,7,8,10,11,27,29,36]) AND (REGCMAX <= 8)
20900			       THEN ERROR(317);
21000				%REGISTER USED BY RUNTIME SUPPORT FREE OR NOT  \
21100			       CASE LKEY OF
21200	(* 42 - move GET and PUT to NEW *)
21300				2,4,
21400	(* 14 - NEW DUMP MODE I/O *)
21500				5,6,27,28,29,36:  GETPUTRESETREWRITE;
21600				7,
21700				8:
21800				   BEGIN
21900				    READREADLN;
22000				     IF NORIGHTPARENT
22100				     THEN GOTO 9
22200				   END;
22300				9:
22400				   BEGIN
22500				    BREAK;
22600				     IF NORIGHTPARENT
22700				     THEN GOTO 9
22800				   END;
22900				10,
23000				11:
23100				    BEGIN
23200				     WRITEWRITELN;
23300				      IF NORIGHTPARENT
23400				      THEN GOTO 9
23500				    END;
23600				12:    PACK;
23700				13:    UNPACK;
23800	(* 27 - add NEWZ *)
23900	(* 42 - move GET and PUT to NEW *)
24000	(* 152 - add DISPOSE *)
24100				1,3,14,35,40,44:    NEW;
24200				15:    MARK;
24300				16:    RELEASE;
24400				17:    GETLINENR;
24500				18:    PUT8BITSTOTTY;
24600				19:
24700				    BEGIN
24800				     PAGE;
24900				      IF NORIGHTPARENT
25000				      THEN GOTO 9
25100				    END;
25200				21:    PROTECTION;
25300	(* 10 - ADD SETSTRING *)
25400				22,23:  SETSTRING;
25500				24:	GETINDEX;
25600	(* 26 - allow non-text files *)
25700	(* 42 - move breakin to close *)
25800	(* 61 - rclose *)
25900				25,34,39,42:	BEGIN CLOSE;IF NORIGHTPARENT THEN GOTO 9 END;
26000				26:CALLI;
26100	(* 14 - NEW DUMP MODE I/O *)
26200				30,31:DUMP;
26300				32,33,38:USET;
26400	(* 61 - delete *)
26500				37,41:PUTX;
26600	(* 61 - tops20 system version *)
26700			        43:JSYS
26800			       END
26900			     END
27000			   ELSE
27100			     BEGIN
27200			       IF NOT (LKEY IN [1,2,11,12])
27300			       THEN
27400				 BEGIN
27500				   IF SY = LPARENT
27600				   THEN INSYMBOL
27700				   ELSE ERROR(153);
27800				  if lkey#15
27900				    then EXPRESSION(FSYS OR [RPARENT],ONREGC);
28000				   IF NOT (LKEY IN [7,8,11,12,15])
28100				   THEN LOAD(GATTR)
28200				 END;
28300			       CASE LKEY OF
28400				1:    RUNTIME;
28500				2:    TIME;
28600				3:    ABS;
28700				4:    SQR;
28800				5,14:    TRUNC;
28900				6:    ODD;
29000				7:    ORD;
29100				8:    CHR;
29200				9,10:  PREDSUCC;
29300				11,12: BEGIN EOFEOLN; IF NORIGHTPARENT THEN GOTO 9 END;
29400				15: NEW
29500			       END;
29600			       IF LKEY < 3
29700			       THEN GOTO 9
29800			     END;
29900			   IF SY = RPARENT
30000			   THEN INSYMBOL
30100			   ELSE ERROR(152);
30200	9:
30300			 END %STANDARD PROCEDURES AND FUNCTIONS\
30400		       ELSE CALLNONSTANDARD
30500		     END %CALL\ ;
30600	
30700		    PROCEDURE EXPRESSION;
30800		    VAR
30900		      LATTR: ATTR; LOP: OPERATOR; LSIZE: ADDRRANGE; LOFFSET: INTEGER; DEFAULT,NEEDSHIFT: BOOLEAN;
31000		      BOOLREGC,TESTREGC:ACRANGE; LINSTR,LINSTR1: INSTRANGE; LREGC1,LREGC2: ACRANGE;
31100		      SETINCLUSION : BOOLEAN; JMPADRIFALLEQUAL : INTEGER;
31200	
31300		      PROCEDURE CHANGEBOOL(VAR FINSTR: INSTRANGE);
31400		       BEGIN
31500			 IF (FINSTR>=311B) AND (FINSTR<=313B)
31600			 THEN FINSTR := FINSTR+4  %CAML,CAME,CAMLE --> CAMGE,CAMN,CAMG\
31700			 ELSE
31800			   IF (FINSTR>=315B) AND (FINSTR<=317B)
31900			   THEN FINSTR := FINSTR-4  %SAME IN THE OTHER WAY\;
32000		       END;
32100	
32200		      PROCEDURE SEARCHCODE(FINSTR:INSTRANGE; FATTR: ATTR);
32300			PROCEDURE CHANGEOPERANDS(VAR FINSTR:INSTRANGE);
32400			 BEGIN
32500			   IF FINSTR=311B%CAML\
32600			   THEN FINSTR := 317B%CAMG\
32700			   ELSE
32800			     IF FINSTR = 313B%CAMLE\
32900			     THEN FINSTR := 315B%CAMGE\
33000			     ELSE
33100			       IF FINSTR=315B%CAMGE\
33200			       THEN FINSTR := 313B%CAMLE\
33300			       ELSE
33400				 IF FINSTR = 317B%CAMG\
33500				 THEN FINSTR := 311B%CAML\
33600				 ELSE
33700				   IF FINSTR = 420B%ANDCM\
33800				   THEN FINSTR := 410B%ANDCA\
33900				   ELSE
34000				     IF FINSTR = 410B%ANDCA\
34100				     THEN FINSTR := 420B%ANDCM\;
34200			 END;
34300	
34400		       BEGIN
34500			WITH GATTR DO
34600			 IF FATTR.KIND = EXPR
34700			 THEN
34800			   BEGIN
34900			    MAKECODE(FINSTR,FATTR.REG,GATTR); REG := FATTR.REG
35000			   END
35100			 ELSE
35200			   IF KIND = EXPR
35300			   THEN
35400			     BEGIN
35500			      CHANGEOPERANDS(FINSTR); MAKECODE(FINSTR,REG,FATTR)
35600			     END
35700			   ELSE
35800			     IF (KIND=VARBL) AND ((PACKFG#NOTPACK)
35900						  OR (INDEXR>REGIN) AND (INDEXR<=REGCMAX) AND
36000						  ((FATTR.INDEXR<=REGIN) OR (FATTR.INDEXR>REGCMAX)))
36100			     THEN
36200			       BEGIN
36300				LOAD(GATTR); CHANGEOPERANDS(FINSTR); MAKECODE(FINSTR,REG,FATTR)
36400			       END
36500			     ELSE
36600			       BEGIN
36700				LOAD(FATTR); MAKECODE(FINSTR,FATTR.REG,GATTR); REG := FATTR.REG
36800			       END;
36900		       END;
37000	
37100		      PROCEDURE SIMPLEEXPRESSION(FSYS: SETOFSYS);
37200		      VAR
37300			LATTR: ATTR; LOP: OPERATOR; SIGNED : BOOLEAN;
37400	(* 52 - new var needed to prevent clobbering CONST decl. *)
37500			NEWREALCSP: CSP;
37600	
37700			PROCEDURE TERM(FSYS: SETOFSYS);
37800			VAR
37900			  LATTR: ATTR; LOP: OPERATOR;
38000	
38100			  PROCEDURE FACTOR(FSYS: SETOFSYS);
38200			  VAR
38300			    LCP: CTP; LVP: CSP; VARPART: BOOLEAN;
38400			    CSTPART: SET OF 0..71; LSP: STP;
38500			    RANGEPART: BOOLEAN;LRMIN: INTEGER;
38600			   BEGIN
38700			     IF NOT (SY IN FACBEGSYS)
38800			     THEN
38900			       BEGIN
39000				ERRANDSKIP(173,FSYS OR FACBEGSYS);
39100				GATTR.TYPTR := NIL
39200			       END;
39300			     IF SY IN FACBEGSYS
39400			     THEN
39500			       BEGIN
39600				 CASE SY OF
39700				  %ID\	  IDENT:
39800						 BEGIN
39900						  SEARCHID([KONST,VARS,FIELD,FUNC],LCP);
40000						  INSYMBOL;
40100						   IF LCP^.KLASS = FUNC
40200						   THEN
40300						     BEGIN
40400						      CALL(FSYS,LCP);
40500						       IF LCP^.PFDECKIND=DECLARED
40600						       THEN
40700							 BEGIN
40800							  WITH LCP^,GATTR DO
40900							   BEGIN
41000							    TYPTR :=IDTYPE; KIND :=VARBL; PACKFG :=NOTPACK;
41100							    VRELBYTE := NO;
41200							    VLEVEL :=1; DPLMT :=2;
41300							    INDEXR := TOPP; INDBIT :=0;
41400							     IF TYPTR # NIL
41500							     THEN
41600							       IF TYPTR^.SIZE = 1
41700							       THEN LOAD(GATTR)
41800							   END
41900							 END
42000						     END
42100						   ELSE
42200						     IF LCP^.KLASS = KONST
42300						     THEN
42400						      WITH GATTR, LCP^ DO
42500						       BEGIN
42600							TYPTR := IDTYPE; KIND := CST;
42700							CVAL := VALUES
42800						       END
42900						     ELSE
43000						      SELECTOR(FSYS,LCP);
43100						   IF GATTR.TYPTR # NIL
43200						   THEN       %ELIM. SUBR. TYPES TO\
43300						    WITH GATTR, TYPTR^ DO	  %SIMPLIFY LATER TESTS\
43400						     IF FORM = SUBRANGE
43500						     THEN  TYPTR := RANGETYPE
43600						 END;
43700				  %CST\   INTCONST:
43800						    BEGIN
43900						     WITH GATTR DO
44000						      BEGIN
44100						       TYPTR := INTPTR; KIND := CST;
44200						       CVAL := VAL;
44300						      END;
44400						     INSYMBOL
44500						    END;
44600				  REALCONST:
44700					     BEGIN
44800					      WITH GATTR DO
44900					       BEGIN
45000						TYPTR := REALPTR; KIND := CST;
45100						CVAL := VAL
45200					       END;
45300					      INSYMBOL
45400					     END;
45500				  STRINGCONST:
45600					       BEGIN
45700						WITH GATTR DO
45800						 BEGIN
45900						  CONSTANT(FSYS,TYPTR,CVAL) ; KIND := CST ;
46000						 END;
46100					       END;
46200				  %(\	  LPARENT:
46300						   BEGIN
46400						    INSYMBOL; EXPRESSION(FSYS OR [RPARENT],ONREGC);
46500						     IF SY = RPARENT
46600						     THEN INSYMBOL
46700						     ELSE ERROR(152)
46800						   END;
46900				  % NOT \ NOTSY:
47000						 BEGIN
47100						  INSYMBOL; FACTOR(FSYS);
47200						   IF GATTR.TYPTR = BOOLPTR
47300						   THEN
47400						     BEGIN
47500						      LOAD(GATTR); MACRO3(411B%ANDCAI\,REGC,1)
47600						     END
47700						   ELSE
47800						     BEGIN
47900						      ERROR(359); GATTR.TYPTR := NIL
48000						     END;
48100						 END;
48200				  %[\	  LBRACK:
48300						  BEGIN
48400						   INSYMBOL; CSTPART := [ ]; VARPART := FALSE;
48500	(* 110 - MOVED RANGEPART INITIALIZATION INSIDE LOOP *)
48600						   NEWZ(LSP,POWER);
48700						   WITH LSP^ DO
48800						    BEGIN
48900						     ELSET:=NIL; SIZE:= 2
49000						    END;
49100						    IF SY = RBRACK
49200						    THEN
49300						      BEGIN
49400						       WITH GATTR DO
49500							BEGIN
49600							 TYPTR:=LSP; KIND:=CST;
49700							 NEWZ(LVP,PSET); LVP^.PVAL := CSTPART; CVAL.VALP := LVP
49800							END;
49900						       INSYMBOL
50000						      END
50100						    ELSE
50200						      BEGIN
50300	(* 110 - THIS ROUTINE LARGELY RECODED *)
50400	(* AC usage in the following is documented at the end.  In order to provide
50500	   any sanity at all, REGC has to be kept the same whatever the expression
50600	   types found.  Since an expression will advance REGC in most cases, we
50700	   have to be sure it gets advanced in others.  This means incrementregc
50800	   for constants and LOAD otherwise.  We don't LOAD constants because if
50900	   the other half of the range is also constant we will just remember it
51000	   as constant and not do a load at all. *)
51100							LOOP
51200			(* RANGEPART IS FLAG: 1ST EXPRESSION IS VARIABLE *)
51300							 RANGEPART := FALSE;
51400							 INCREMENTREGC; INCREMENTREGC;  (* FIRST EXPR *)
51500							 EXPRESSION(FSYS OR [COMMA,RBRACK,COLON],ONFIXEDREGC);
51600							  IF GATTR.TYPTR # NIL
51700							  THEN
51800							    IF GATTR.TYPTR^.FORM # SCALAR
51900							    THEN
52000							      BEGIN
52100							       ERROR(461); GATTR.TYPTR := NIL
52200							      END
52300							    ELSE
52400							      IF COMPTYPES(LSP^.ELSET,GATTR.TYPTR)
52500							      THEN
52600								BEGIN (* LOAD IF VAR, SAVE IN LRMIN IF CONST *)
52700								  IF GATTR.KIND = CST
52800								  THEN
52900								    BEGIN (* FIRST EXPR IS CONST *)
53000	(* 127 - fix reversed AC's *)
53100								    INCREMENTREGC;
53200	(* 137 - CHAR needs different test *)
53300								    IF (GATTR.CVAL.IVAL<0)
53400								      OR (GATTR.CVAL.IVAL>BASEMAX) AND (GATTR.TYPTR<>CHARPTR)
53500								      OR (GATTR.CVAL.IVAL>CHARMAX) AND (GATTR.TYPTR=CHARPTR)
53600								     THEN BEGIN ERROR(352) ; GATTR.CVAL.IVAL := 0 END;
53700								    IF GATTR.TYPTR=CHARPTR
53800								      THEN
53900	(* 7 - TREAT LOWER CASE AS UPPER IN SETS *)
54000	(* 105 - improve lower case mapping in sets *)
54100									GATTR.CVAL.IVAL := SETMAP[GATTR.CVAL.IVAL];
54200								    LRMIN := GATTR.CVAL.IVAL;
54300								    END
54400								  ELSE
54500								    BEGIN (* FIRST EXPR IS NOT A CONSTANT *)
54600								    RANGEPART := TRUE; (* SIGNAL VARIABLE *)
54700								    LOAD(GATTR);
54800	(* 112 - range check sets *)
54900								    if runtmcheck
55000								      then begin
55100	(* 137 - different range check for char *)
55200								      if gattr.typtr = charptr
55300									then macro3(307B%caig\,regc,charmax)
55400								        else macro3(307B%caig\,regc,basemax);
55500								      macro3(305B%caige\,regc,0);
55600								      support(errorinassignment)
55700								      end;
55800								    IF GATTR.TYPTR = CHARPTR
55900								       THEN BEGIN
56000	(* 105 - improve lower case mapping in sets *)
56100									    macro4r(200B%MOVE\,regc,regc,setmapchain);
56200									    code.information[cix] := 'E';
56300									    setmapchain := ic-1;
56400									    END;
56500								     END;
56600								  IF SY <> COLON
56700								   THEN (* ONLY ONE EXPR *)
56800								    IF NOT RANGEPART
56900								     THEN (* CONSTANT *)
57000								      BEGIN
57100								      CSTPART := CSTPART OR [LRMIN];
57200	(* 127 - fixed reversed AC's *)
57300								      REGC := REGC - 3;
57400								      END
57500								     ELSE (* ONE VARIABLE *)
57600								      BEGIN
57700								      IF GATTR.TYPTR = CHARPTR
57800									THEN CODE.INSTRUCTION[CIX].INSTR := 210B%MOVN\
57900								        ELSE MACRO3(210B%MOVN\,REGC,REGC);
58000								      REGC := REGC - 1;
58100								      MACRO3(515B%HRLZI\,REGC-1,400000B);
58200								      MACRO3(400B%SETZ\,REGC,0);
58300	(* 105 - more improvements for lower case mapping *)
58400								      MACRO4(246B%LSHC\,REGC-1,REGC+1,0);
58500								      IF VARPART
58600								      THEN
58700									BEGIN
58800									 MACRO3(434B%IOR\,REGC-3,REGC-1);
58900									 MACRO3(434B%IOR\,REGC-2,REGC);
59000									 REGC := REGC-2;
59100									END
59200								      ELSE VARPART := TRUE;
59300								      GATTR.KIND := EXPR; GATTR.REG := REGC
59400								      END
59500								   ELSE (* RANGE *)
59600								    BEGIN
59700								    INSYMBOL;
59800								    EXPRESSION(FSYS OR [COMMA,RBRACK],ONFIXEDREGC);
59900								    IF GATTR.TYPTR <> NIL (* 2ND EXPR *)
60000								     THEN
60100								      IF GATTR.TYPTR^.FORM <> SCALAR
60200								       THEN BEGIN
60300								       ERROR(461);
60400								       GATTR.TYPTR := NIL
60500								       END
60600								       ELSE
60700									IF COMPTYPES(LSP^.ELSET,GATTR.TYPTR)
60800									THEN
60900									 BEGIN
61000									 IF GATTR.KIND = CST
61100									   THEN BEGIN
61200	(* 137 - different test for CHAR, fix AC mess *)
61300									   INCREMENTREGC;
61400									   IF (GATTR.CVAL.IVAL < 0)
61500									      OR (GATTR.CVAL.IVAL > BASEMAX) AND (GATTR.TYPTR<>CHARPTR)
61600									      OR (GATTR.CVAL.IVAL > CHARMAX) AND (GATTR.TYPTR=CHARPTR)
61700									     THEN BEGIN ERROR(352); GATTR.CVAL.IVAL := 0 END;
61800									   IF GATTR.TYPTR = CHARPTR
61900									     THEN GATTR.CVAL.IVAL := SETMAP[GATTR.CVAL.IVAL]
62000									   END
62100	(* 137 - more AC confusion *)
62200									  ELSE LOAD(GATTR);
62300									 IF (GATTR.KIND = CST) AND (NOT RANGEPART)
62400									  THEN (* CONSTANT RANGE *)
62500									   BEGIN
62600									   WHILE(LRMIN <= GATTR.CVAL.IVAL) DO
62700									    BEGIN
62800									    CSTPART := CSTPART OR [LRMIN];
62900									    LRMIN := LRMIN+1
63000									    END;
63100	(* 127 - fix reversed AC's *)
63200	(* 137 - once again *)
63300									   REGC := REGC - 4
63400									   END
63500									  ELSE
63600									   BEGIN (* VARIABLE LIMITS ON RANGE *)
63700									   IF NOT RANGEPART (* FIRST PART IS CONSTANT *)
63800									    THEN
63900									     BEGIN (* SO NOT IN AC YET *)
64000	(* 127 - fix reversed AC's *)
64100	(* 137 - once again *)
64200									     MACRO3(201B%MOVEI\,REGC-1,LRMIN)
64300									     END;
64400									   if gattr.kind = cst  (* same for second *)
64500									     then macro3(201B%movei\,regc,gattr.cval.ival);
64600	(* 112 - range check sets *)
64700	(* 137 - different test needed for CHAR *)
64800									   if (gattr.kind <> cst) and runtmcheck
64900										then begin
65000										if gattr.typtr = charptr
65100										  then macro3(307B%caig\,regc,charmax)
65200										  else macro3(307B%caig\,regc,basemax);
65300										macro3(305B%caige\,regc,0);
65400										support(errorinassignment);
65500										end;
65600								           IF (GATTR.TYPTR=CHARPTR) AND (GATTR.KIND <> CST)
65700								            THEN BEGIN
65800	(* 105 - improve lower case mapping in sets *)
65900									    macro4r(200B%MOVE\,regc,regc,setmapchain);
66000									    code.information[cix] := 'E';
66100									    setmapchain := ic-1;
66200									    END;
66300			(* HERE IS WHAT IS IN THE AC'S:
66400				REGC    - RH LIMIT
66500				REGC-1	- LH LIMIT
66600				REGC-2  - DOUBLE WORD OF BITS
66700				REGC-3         "
66800			*)
66900									   MACRO3(477B%SETOB\,REGC-3,REGC-2);
67000									   MACRO4(246B%LSHC\,REGC-3,REGC-1,0);
67100									   MACRO3(275B%SUBI\,REGC,71);
67200									   MACRO3(210B%MOVN\,REGC,REGC);
67300									   MACRO3(270B%ADD\,REGC-1,REGC);
67400									   MACRO3(210B%MOVN\,REGC-1,REGC-1);
67500									   MACRO4(246B%LSHC\,REGC-3,REGC-1,0);
67600									   MACRO4(246B%LSHC\,REGC-3,REGC,0);
67700									   REGC := REGC -2;
67800								           IF VARPART
67900								            THEN
68000									     BEGIN
68100									     MACRO3(434B%IOR\,REGC-3,REGC-1);
68200									     MACRO3(434B%IOR\,REGC-2,REGC);
68300									     REGC := REGC-2;
68400									     END
68500								            ELSE VARPART := TRUE;
68600								           GATTR.KIND := EXPR; GATTR.REG := REGC
68700								           END
68800									 END
68900								    END;
     
00100								 LSP^.ELSET := GATTR.TYPTR;
00200								 GATTR.TYPTR :=LSP
00300								END
00400							      ELSE ERROR(360);
00500							EXIT IF NOT(SY IN [COMMA]);
00600							 INSYMBOL
00700							END;
00800							IF SY = RBRACK
00900							THEN INSYMBOL
01000							ELSE ERROR(155);
01100							IF VARPART
01200							THEN
01300							  BEGIN
01400							    IF CSTPART # [ ]
01500							    THEN
01600							      BEGIN
01700	(* 34 - BUG FIX FROM HAMBURG - NEEDED FOR PROGSTAT *)
01800								NEW(LVP,PSET);LVP^.PVAL := CSTPART;
01900								GATTR.KIND:=CST; GATTR.CVAL.VALP := LVP;
02000								MAKECODE(434B%IOR\,REGC,GATTR)
02100							      END
02200							  END
02300							ELSE
02400							  BEGIN
02500							   NEWZ(LVP,PSET); LVP^.PVAL := CSTPART; GATTR.CVAL.VALP := LVP
02600							  END
02700						      END;
02800						  END
02900				 END %CASE\ ;
03000				IFERRSKIP(166,FSYS)
03100			       END;
03200			      %IF SY IN FACBEGSYS\
03300			   END %FACTOR\ ;
03400	
03500			 BEGIN
03600			  %TERM\
03700			  FACTOR(FSYS OR [MULOP]);
03800			  WHILE SY = MULOP DO
03900			   BEGIN
04000			     IF OP IN [RDIV,IDIV,IMOD]
04100			     THEN LOAD(GATTR);	%BECAUSE OPERANDS ARE NOT
04200						 ALLOWED TO BE CHOSEN\
04300			    LATTR := GATTR; LOP := OP;
04400			    INSYMBOL; FACTOR(FSYS OR [MULOP]);
04500			     IF (LATTR.TYPTR # NIL) AND (GATTR.TYPTR # NIL)
04600			     THEN
04700			       CASE LOP OF
04800				%*\	  MUL:
04900					       IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
05000					       THEN SEARCHCODE(220B%IMUL\,LATTR)
05100	(* 21 - * with sets is and *)
05200					       ELSE IF (LATTR.TYPTR^.FORM=POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
05300						 THEN SEARCHCODE(404B%AND\,LATTR)
05400					       ELSE
05500						 BEGIN
05600						  MAKEREAL(LATTR);
05700						   IF (LATTR.TYPTR = REALPTR)
05800						    AND (GATTR.TYPTR = REALPTR)
05900						   THEN SEARCHCODE(164B%FMPR\,LATTR)
06000						   ELSE
06100						     BEGIN
06200						      ERROR(311); GATTR.TYPTR := NIL
06300						     END
06400						 END;
06500				%/\	  RDIV:
06600						BEGIN
06700						 MAKEREAL(LATTR);
06800						  IF (LATTR.TYPTR = REALPTR)
06900						   AND (GATTR.TYPTR = REALPTR)
07000						  THEN SEARCHCODE(174B%FDVR\,LATTR)
07100						  ELSE
07200						    BEGIN
07300						     ERROR(311); GATTR.TYPTR := NIL
07400						    END
07500						END;
07600				%DIV\	  IDIV:
07700						IF (LATTR.TYPTR = INTPTR)
07800						 AND (GATTR.TYPTR = INTPTR)
07900						THEN SEARCHCODE(230B%IDIV\,LATTR)
08000						ELSE
08100						  BEGIN
08200						   ERROR(311); GATTR.TYPTR := NIL
08300						  END;
08400				%MOD\	  IMOD:
08500						IF (LATTR.TYPTR = INTPTR)
08600						 AND (GATTR.TYPTR = INTPTR)
08700						THEN
08800						  BEGIN
08900						   SEARCHCODE(230B%IDIV\,LATTR);GATTR.REG := GATTR.REG+1
09000						  END
09100						ELSE
09200						  BEGIN
09300						   ERROR(311); GATTR.TYPTR := NIL
09400						  END;
09500				% AND \  ANDOP:
09600						IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
09700						 AND ( (LATTR.TYPTR^.FORM = POWER) OR (GATTR.TYPTR = BOOLPTR) )
09800						THEN SEARCHCODE(404B%AND\,LATTR)
09900						ELSE
10000						  BEGIN
10100						   ERROR(311); GATTR.TYPTR := NIL
10200						  END
10300			       END %CASE\
10400			     ELSE GATTR.TYPTR := NIL;
10500			    REGC:=GATTR.REG
10600			   END %WHILE\
10700			 END %TERM\ ;
10800	
10900		       BEGIN
11000			%SIMPLEEXPRESSION\
11100			SIGNED := FALSE;
11200			 IF (SY = ADDOP) AND (OP IN [PLUS,MINUS])
11300			 THEN
11400			   BEGIN
11500			    SIGNED := OP = MINUS; INSYMBOL
11600			   END;
11700			TERM(FSYS OR [ADDOP]);
11800			 IF SIGNED
11900			 THEN WITH GATTR DO
12000			   IF TYPTR # NIL
12100			   THEN
12200			     IF (TYPTR = INTPTR) OR (TYPTR = REALPTR)
12300			     THEN
12400			       IF KIND = CST
12500			       THEN
12600				 IF TYPTR = INTPTR
12700				 THEN CVAL.IVAL := - CVAL.IVAL
12800	(* 52 - have to put negated value in new place, since old one might be a CONST declaration used elsewhere *)
12900				 ELSE
13000				   BEGIN
13100				   NEW(NEWREALCSP);
13200				   NEWREALCSP^.CCLASS := REEL;
13300				   NEWREALCSP^.RVAL := -CVAL.VALP^.RVAL;
13400				   CVAL.VALP := NEWREALCSP
13500				   END
13600			       ELSE
13700				 BEGIN
13800				  LOAD(GATTR) ;
13900				  WITH CODE, INSTRUCTION[CIX] DO
14000				   IF INSTR=200B%MOVE\
14100				   THEN INSTR := 210B%MOVN\
14200				   ELSE MACRO3(210B%MOVN\,GATTR.REG,GATTR.REG)
14300				 END
14400			     ELSE
14500			       BEGIN
14600				ERROR(311) ; GATTR.TYPTR := NIL
14700			       END ;
14800			WHILE SY = ADDOP DO
14900			 BEGIN
15000			   IF OP=MINUS
15100			   THEN LOAD(GATTR); %BECAUSE OPD MAY NOT BE CHOSEN\
15200			  LATTR := GATTR; LOP := OP;
15300			  INSYMBOL; TERM(FSYS OR [ADDOP]);
15400			   IF (LATTR.TYPTR # NIL) AND (GATTR.TYPTR # NIL)
15500			   THEN
15600			     CASE LOP OF
15700			      %+\	PLUS:
15800					      IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
15900					      THEN
16000					       SEARCHCODE(270B%ADD\,LATTR)
16100	(* 21 - ALLOW + AS SET UNION *)
16200					      ELSE IF(LATTR.TYPTR^.FORM=POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
16300						THEN SEARCHCODE(434B%IOR\,LATTR)
16400					      ELSE
16500						BEGIN
16600						 MAKEREAL(LATTR);
16700						  IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR)
16800						  THEN SEARCHCODE(144B%FADR\,LATTR)
16900						  ELSE
17000						    BEGIN
17100						     ERROR(311); GATTR.TYPTR := NIL
17200						    END
17300						END;
17400			      %-\	MINUS:
17500					       IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
17600					       THEN
17700						SEARCHCODE(274B%SUB\,LATTR)
17800	(* 21 - ALLOW - AS SET DIFFERENCE *)
17900					       ELSE IF (LATTR.TYPTR^.FORM = POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
18000						 THEN SEARCHCODE(420B%ANDCM\,LATTR)
18100					       ELSE
18200						 BEGIN
18300						  MAKEREAL(LATTR);
18400						   IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR)
18500						   THEN SEARCHCODE(154B%FSBR\,LATTR)
18600						   ELSE
18700						     IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
18800						      AND (LATTR.TYPTR^.FORM = POWER)
18900						     THEN SEARCHCODE(420B%ANDCM\,LATTR)
19000						     ELSE
19100						       BEGIN
19200							ERROR(311); GATTR.TYPTR := NIL
19300						       END
19400						 END;
19500			      % OR \	OROP:
19600					      IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
19700					       AND ( (GATTR.TYPTR = BOOLPTR) OR (LATTR.TYPTR^.FORM = POWER) )
19800					      THEN SEARCHCODE(434B%IOR\,LATTR)
19900					      ELSE
20000						BEGIN
20100						 ERROR(311); GATTR.TYPTR := NIL
20200						END
20300			     END %CASE\
20400			   ELSE GATTR.TYPTR := NIL;
20500			  REGC:=GATTR.REG
20600			 END %WHILE\
20700		       END %SIMPLEEXPRESSION\ ;
20800	
20900		     BEGIN
21000		      %EXPRESSION\
21100		      TESTREGC := REGC+1;
21200		      SIMPLEEXPRESSION(FSYS OR [RELOP]);
21300		       IF SY = RELOP
21400		       THEN
21500			 BEGIN
21600			   IF FVALUE IN [ONREGC,ONFIXEDREGC]
21700			   THEN
21800			     BEGIN
21900			      INCREMENTREGC; MACRO3(201B%MOVEI\,REGC,1); BOOLREGC := REGC
22000			     END;
22100			   IF GATTR.TYPTR # NIL
22200			   THEN
22300	(* 24 - STRING IS ONLY STRUCTURE ALLOWED *)
22400			     IF STRING(GATTR.TYPTR)
22500			     THEN LOADADDRESS; LREGC1 := REGC;
22600			  LATTR := GATTR; LOP := OP;
22700			   IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC < BOOLREGC)
22800			   THEN REGC := BOOLREGC;
22900			  INSYMBOL; SIMPLEEXPRESSION(FSYS);
23000			   IF GATTR.TYPTR # NIL
23100			   THEN
23200	(* 24 - STRING IS ONLY STRUCTURE ALLOWED *)
23300			     IF STRING(GATTR.TYPTR)
23400			     THEN LOADADDRESS; LREGC2 := REGC;
23500			   IF (LATTR.TYPTR # NIL) AND (GATTR.TYPTR # NIL)
23600			   THEN
23700			     BEGIN
23800			       IF LOP = INOP
23900			       THEN
24000				 IF GATTR.TYPTR^.FORM = POWER
24100				 THEN
24200				   IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR^.ELSET)
24300				   THEN
24400				     BEGIN
24500				      LOAD(LATTR);
24600				       IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC < BOOLREGC)
24700				       THEN REGC := BOOLREGC;
24800				      LOAD(GATTR); REGC := GATTR.REG - 1;
24900				       IF LATTR.TYPTR=CHARPTR
25000				       THEN
25100	(* 7 - TREAT LOWER CASE AS UPPER IN SETS *)
25200					BEGIN
25300	(* 105 - improve lower case mapping in sets *)
25400					macro4r(200B%move\,lattr.reg,lattr.reg,setmapchain);
25500					code.information[cix] := 'E';
25600					setmapchain := ic-1;
25700					END;
25800				      MACRO4(246B%LSHC\,REGC,LATTR.REG,0);
25900				       IF FVALUE = TRUEJMP
26000				       THEN LINSTR := 305B%CAIGE\
26100				       ELSE LINSTR := 301B%CAIL\;
26200				      MACRO3(LINSTR,REGC,0);
26300				     END
26400				   ELSE
26500				     BEGIN
26600				      ERROR(260); GATTR.TYPTR := NIL
26700				     END
26800				 ELSE
26900				   BEGIN
27000				    ERROR(213); GATTR.TYPTR := NIL
27100				   END
27200			       ELSE
27300				 BEGIN
27400				   IF LATTR.TYPTR # GATTR.TYPTR
27500				   THEN
27600				    MAKEREAL(LATTR);
27700				   IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
27800				   THEN
27900				     BEGIN
28000				      LSIZE := LATTR.TYPTR^.SIZE;
28100				       CASE LATTR.TYPTR^.FORM OF
28200					POINTER:
28300						 IF LOP IN [LTOP,LEOP,GTOP,GEOP]
28400						 THEN ERROR (312);
28500					POWER:
28600					       IF LOP IN [LTOP,GTOP]
28700					       THEN ERROR(313);
28800					ARRAYS:
28900						IF  NOT STRING(LATTR.TYPTR)
29000	(* 24 - STRING IS ONLY STRUCT. ALLOWED *)
29100						THEN ERROR(312);
29200					RECORDS,
29300					FILES:
29400					      ERROR(314)
29500				       END;
29600				      WITH LATTR.TYPTR^ DO
29700				       BEGIN
29800					    DEFAULT := TRUE; LOFFSET := 3; SETINCLUSION := FALSE;
29900					     CASE LOP OF
30000					      LTOP:
30100						    BEGIN
30200						     LINSTR := 311B%CAML\; LINSTR1 := 313B
30300						    END;
30400					      LEOP:
30500						    IF FORM = POWER
30600						    THEN
30700						      BEGIN
30800						       SEARCHCODE(420B%ANDCM\,LATTR);
30900						       SETINCLUSION := TRUE
31000						      END
31100						    ELSE
31200						      BEGIN
31300						       LINSTR := 313B%CAMLE\; LINSTR1 := 313B
31400						      END;
31500					      GTOP:
31600						    BEGIN
31700						     LINSTR := 317B%CAMG\; LINSTR1 := 315B
31800						    END;
31900					      GEOP:
32000						    IF FORM = POWER
32100						    THEN
32200						      BEGIN
32300						       SEARCHCODE(410B%ANDCA\,LATTR);
32400						       SETINCLUSION := TRUE
32500						      END
32600						    ELSE
32700						      BEGIN
32800						       LINSTR := 315B%CAMGE\; LINSTR1 := 315B
32900						      END;
33000					      NEOP:
33100						    BEGIN
33200						     LINSTR := 316B%CAMN\;DEFAULT := FALSE
33300						    END;
33400					      EQOP:
33500						    BEGIN
33600						     LINSTR := 312B%CAME\; DEFAULT := FALSE; LOFFSET := 2
33700						    END
33800					     END;
33900					     IF FVALUE = TRUEJMP
34000					     THEN CHANGEBOOL(LINSTR);
34100	(* 24 - STRING IS ONLY STRUCTURE *)
34200					   IF FORM#ARRAYS THEN BEGIN
34300					     IF SIZE = 1
34400					     THEN SEARCHCODE(LINSTR,LATTR)
34500					     ELSE
34600					       IF SETINCLUSION
34700					       THEN
34800						 BEGIN
34900						  MACRO3(336B%SKIPN\,0,GATTR.REG);
35000						  MACRO3(332B%SKIPE\,0,GATTR.REG-1);
35100						   IF FVALUE = TRUEJMP
35200						   THEN
35300						    MACRO3R(254B%JRST\,0,IC+2)
35400						 END
35500					       ELSE
35600						 BEGIN
35700						  LOAD(LATTR);
35800						   IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC<BOOLREGC)
35900						   THEN
36000						    REGC := BOOLREGC;
36100						  LOAD(GATTR);
36200						   IF DEFAULT
36300						   THEN
36400						     BEGIN
36500						      MACRO3(LINSTR1,LATTR.REG-1,GATTR.REG-1);
36600						      MACRO3R(254B%JRST\,0,IC+4)	  %FALSE\
36700						     END;
36800						  MACRO3(312B%CAME\,LATTR.REG-1,GATTR.REG-1);
36900						  MACRO3R(254B%JRST\,0,IC+LOFFSET);
37000						  MACRO3(LINSTR,LATTR.REG,GATTR.REG)
37100						 END
37200					   END
37300					 ELSE
37400	(* 24 - THIS CODE IS NOW ONLY FOR STRINGS *)
37500					   BEGIN (*STRING*)
37600					   GETBOUNDS(INXTYPE,LOFFSET,LSIZE);
37700					   LSIZE:=LSIZE-LOFFSET+1;
37800	(* 40 - fix this code for unpacked strings, too *)
37900					 if arraypf
38000					  then begin
38100					   LOFFSET:=(LSIZE MOD 5)*700B;
38200					   LSIZE:=LSIZE DIV 5;
38300					   end
38400					  else loffset:=0;
38500					   IF (LSIZE=0) AND (LOFFSET=0)
38600					     THEN MACRO3(403B%SETZB\,TAC,HAC)
38700					   ELSE IF (LSIZE=0)
38800					     THEN BEGIN
38900					     MACRO3(505B%HRLI\,LREGC1,LOFFSET+440000B);
39000					     MACRO3(505B%HRLI\,LREGC2,LOFFSET+440000B);
39100					     MACRO3(134B%ILDB\,TAC,LREGC1);
39200					     MACRO3(134B%ILDB\,HAC,LREGC2)
39300					     END
39400					   ELSE
39500					     BEGIN
39600	(* 40 - fix for nonpacked arrays *)
39700					   if arraypf
39800					    then begin
39900					     MACRO3(505B%HRLI\,LREGC1,444300B);
40000					     MACRO3(505B%HRLI\,LREGC2,444300B);
40100					     end
40200					    else begin
40300					     macro3(505b%hrli\,lregc1,444400b);
40400					     macro3(505b%hrli\,lregc2,444400b)
40500					     end;
40600					     INCREMENTREGC;
40700					     IF LSIZE > 1
40800						THEN MACRO3(201B%MOVEI\,REGC,LSIZE);
40900					     MACRO3(134B%ILDB\,TAC,LREGC1);
41000					     MACRO3(134B%ILDB\,HAC,LREGC2);
41100					     IF (LOFFSET=0)
41200					       THEN BEGIN
41300					       IF LSIZE>1
41400						 THEN BEGIN
41500						 MACRO3(316B%CAMN\,TAC,HAC);
41600						 MACRO3R(367B%SOJG\,REGC,IC-3)
41700						 END
41800					       END
41900					      ELSE %OFFSET NOT 0\ BEGIN
42000					       MACRO3(312B%CAME\,TAC,HAC);
42100					       IF LSIZE>1
42200						 THEN BEGIN
42300						 MACRO3R(254B%JRST\,0,IC+6);
42400						 MACRO3R(367B%SOJG\,REGC,IC-4)
42500						 END
42600					        ELSE MACRO3R(254B%JRST\,0,IC+5);
42700					       MACRO3(505B%HRLI\,LREGC1,LOFFSET);
42800					       MACRO3(505B%HRLI\,LREGC2,LOFFSET);
42900					       MACRO3(134B%ILDB\,TAC,LREGC1);
43000					       MACRO3(134B%ILDB\,HAC,LREGC2)
43100					       END;
43200					     REGC:=REGC-1
43300					     END;
43400					   MACRO3(LINSTR,TAC,HAC);
43500					    REGC:=REGC-2
43600					   END
43700				       END
43800				     END
43900				   ELSE ERROR(260)
44000				 END;
44100			       IF FVALUE IN [ONREGC,ONFIXEDREGC]
44200			       THEN
44300				 BEGIN
44400				  MACRO3(400B%SETZ\,BOOLREGC,0); REGC := BOOLREGC
44500				 END
44600			       ELSE MACRO3(254B%JRST\,0,0);
44700			     END;
44800			    %(IF LATTR.TYPTR#NIL) AND (GATTR.TYPTR#NIL) THEN \
44900			  GATTR.TYPTR := BOOLPTR; GATTR.KIND := EXPR; GATTR.REG := REGC
45000			 END %SY = RELOP\
45100		       ELSE
45200			 IF FVALUE IN [TRUEJMP,FALSEJMP]
45300			 THEN
45400			   BEGIN
45500			    LOAD(GATTR);
45600			     IF GATTR.TYPTR#BOOLPTR
45700			     THEN ERROR (359);
45800			     IF FVALUE = TRUEJMP
45900			     THEN LINSTR := 326B%JUMPN\
46000			     ELSE LINSTR := 322B%JUMPE\;
46100			    MACRO3(LINSTR,GATTR.REG,0)
46200			   END
46300			 ELSE
46400			   IF GATTR.KIND=EXPR
46500			   THEN REGC := GATTR.REG;
46600		       IF GATTR.TYPTR # NIL
46700		       THEN
46800			WITH GATTR,TYPTR^ DO
46900	(* 141 - fix bollixed AC allocation in complex array calculations *)
47000	(* 143 - fixed code below for Tops-10 packed arrays *)
47100	{Warning to modifiers:  the following code depends upon the register
47200	 allocation in MAKECODE for the case where opcode=MOVE, and in
47300	 LOADADDRESS.  Please be sure to keep them consistent!}
47400	{Onfixedregc means we are in a context where the result has to go in
47500	 a particular AC.  So if we had a complex calculation that ended up
47600	 with it in a higher AC, we have to move it down.  That is for
47700	 KIND=EXPR.  For KIND=CST or VARBL (the only other cases), we have
47800	 to make sure REGC was not changed, as the caller will expect that.
47900	 It could be changed by an array with a complex subscript calculation.
48000	 Note that we in the case KIND=VARBL we may leave AC's set up with
48100	 info needed to access arrays (in the fieldS INDEXR and/or BPADDR).
48200	 So in that case this amounts to second-guessing LOAD and MAKECODE
48300	 to make sure that whichever place the result will be loaded
48400	 (usually INDEXR or BPADDR) is pointing to the fixed AC.}
48500	
48600			 IF FVALUE = ONFIXEDREGC
48700			 THEN
48800			   BEGIN
48900			     IF KIND=EXPR
49000			       THEN BEGIN
49100			       IF SIZE = 2
49200			         THEN TESTREGC := TESTREGC + 1;
49300			       IF TESTREGC # REGC
49400			         THEN BEGIN
49500			         IF SIZE = 2
49600				   THEN MACRO3(200B%MOVE\,TESTREGC-1,REGC-1);
49700			         MACRO3(200B%MOVE\,TESTREGC,REGC);
49800			         REG := TESTREGC; REGC := TESTREGC;
49900			         END
50000			       END
50100			     ELSE IF KIND=VARBL
50200			       THEN BEGIN
50300			       IF (PACKFG = PACKK) AND (BPADDR>REGIN) AND (BPADDR<=REGCMAX)
50400				 THEN IF (INDEXR <= REGIN) OR (BPADDR<INDEXR)
50500					THEN IF BPADDR<> TESTREGC
50600					       THEN BEGIN
50700					       MACRO3(200B%MOVE\,TESTREGC,BPADDR);
50800					       BPADDR := TESTREGC
50900					       END
51000					      ELSE
51100					ELSE IF INDEXR<>TESTREGC
51200					       THEN BEGIN
51300					       MACRO3(200B%MOVE\,TESTREGC,INDEXR);
51400					       INDEXR := TESTREGC
51500					       END
51600					      ELSE
51700			       ELSE IF (INDEXR>REGIN) AND (INDEXR<=REGCMAX) AND (INDEXR<>TESTREGC)
51800				 THEN BEGIN
51900				 MACRO3(200B%MOVE\,TESTREGC,INDEXR);
52000				 INDEXR := TESTREGC
52100				 END;
52200			       REGC := TESTREGC - 1;
52300			       END
52400			     ELSE REGC := TESTREGC-1
52500			   END
52600		     END %EXPRESSION\ ;
52700	
52800		    PROCEDURE ASSIGNMENT(FCP: CTP);
52900		    VAR
53000		      LATTR,SLATTR: ATTR;
53100		      SRMIN,SRMAX: INTEGER;
53200	
53300		      PROCEDURE STOREGLOBALS ;
53400		      TYPE
53500			WANDELFORM = (PTRW,INTW,REELW,PSETW,STRGW,INSTW) ;
53600		      VAR
53700			WANDEL : RECORD
53800				   CASE KW : WANDELFORM OF
53900					PTRW: (WPTR :GTP %TO ALLOW NIL\) ;
54000					INTW: (WINT : INTEGER ; WINT1 : INTEGER %TO PICK UP SECOND WORD OF SET\) ;
54100					REELW: (WREEL: REAL) ;
54200					PSETW: (WSET : SET OF 0..71) ;
54300					STRGW: (WSTRG: CHARWORD) ;
54400					INSTW: (WINST: PDP10INSTR)
54500				 END ;
54600			I,J : INTEGER ;
54700			PROCEDURE STOREWORD ;
54800			 BEGIN
54900			  CIX := CIX + 1 ;
55000			   IF CIX > CIXMAX
55100			   THEN
55200			     BEGIN
55300			      CIX := 0 ; ERRORWITHTEXT(356,'INITPROCD.')
55400			     END ;
55500			  WITH CGLOBPTR^ DO
55600			   BEGIN
55700			    CODE.INSTRUCTION[CIX] := WANDEL.WINST ;
55800			    LASTGLOB := LASTGLOB + 1 ;
55900			   END ;
56000			 END ;
56100			PROCEDURE GETNEWGLOBPTR ;
56200			VAR
56300			  LGLOBPTR : GTP ;
56400			 BEGIN
56500			  NEWZ(LGLOBPTR) ;
56600			  WITH LGLOBPTR^ DO
56700			   BEGIN
56800			    NEXTGLOBPTR := NIL ;
56900			    FIRSTGLOB	:= 0 ;
57000			   END ;
57100			   IF CGLOBPTR # NIL
57200			   THEN CGLOBPTR^.NEXTGLOBPTR := LGLOBPTR ;
57300			  CGLOBPTR := LGLOBPTR ;
57400			 END;
57500		       BEGIN
57600			%STOREGLOBALS\
57700			 IF FGLOBPTR = NIL
57800			 THEN
57900			   BEGIN
58000			    GETNEWGLOBPTR ;
58100			    FGLOBPTR := CGLOBPTR ;
58200	
58300			   END
58400			 ELSE
58500			   IF LATTR.DPLMT # CGLOBPTR^.LASTGLOB + 1
58600			   THEN GETNEWGLOBPTR ;
58700			WITH WANDEL,CGLOBPTR^,GATTR,CVAL DO
     
00100			 BEGIN
00200			   IF FIRSTGLOB = 0
00300			   THEN
00400			     BEGIN
00500			      FIRSTGLOB := LATTR.DPLMT ;
00600			      LASTGLOB := FIRSTGLOB - 1 ;
00700			      FCIX := CIX + 1 ;
00800			     END ;
00900			   CASE TYPTR^.FORM OF
01000			    SCALAR,
01100			    SUBRANGE:
01200			      BEGIN
01300	(* 174 30-Sep-80 Andy Hisgen, CMU,  Problems with xreal:=xinteger, 
01400	   				    and with subranges.
01500	The lines below used to read --
01600		        IF TYPTR = REALPTR
01700			THEN
01800			  IF LATTR.TYPTR=INTPTR
01900			  THEN WREEL := IVAL
02000			  ELSE WREEL := VALP^.RVAL
02100			ELSE WINT  := IVAL ;
02200	Unfortunately, that was testing to see if the RightHandSide (GATTR) was
02300	a real, and if so doing weird things.  For example, that let the
02400	assignment "x:=2", where x is a real, go thru, but without doing
02500	any conversion, thus x contained the bit pattern for the integer 2.
02600	The problem here seems to have been that the roles of LATTR and
02700	GATTR got reversed in the coder's mind.  Below, we have reversed
02800	them back.
02900	    A second unrelated problem was that subrange checking was not
03000	being done.  In the code below, we now handle this.
03100	*)
03200					IF lattr.typtr = realptr
03300					THEN
03400					  IF gattr.typtr = intptr
03500					  THEN WREEL := IVAL
03600					  ELSE WREEL := VALP^.RVAL
03700					ELSE BEGIN (*left isn't real*)
03800					      IF lattr.typtr^.form = subrange
03900					      THEN
04000						BEGIN (*left is subrange*)
04100						 getBounds(lattr.typtr,srmin,srmax);
04200						 IF NOT( (srmin <= ival) AND
04300						         (ival <= srmax) )
04400						 THEN error(367);
04500						END; (*left is subrange*)
04600					      WINT := IVAL;
04700					     END; (*left isn't real*)
04800	(*30-Sep-80 end of changes for xreal:=integer and for subranges*)
04900	
05000				       STOREWORD ;
05100				      END ;
05200			    POINTER:
05300				     BEGIN
05400				      WPTR := NIL ; STOREWORD
05500				     END ;
05600			    POWER   :
05700				      BEGIN
05800				       WSET := VALP^.PVAL ; STOREWORD ;
05900				       WINT := WINT1 %GET SECOND WORD OF SET\ ;
06000				       STOREWORD ;
06100				      END ;
06200			    ARRAYS   : WITH VALP^,WANDEL DO
06300				       BEGIN
06400					J := 0; WINT := 0;
06500					FOR I := 1 TO SLGTH DO
06600					 BEGIN
06700					  J := J + 1;
06800					  WSTRG[J] := SVAL[I];
06900					   IF J=5
07000					   THEN
07100					     BEGIN
07200					      J := 0;
07300					      STOREWORD; WINT := 0
07400					     END
07500					 END;
07600					 IF J#0
07700					 THEN STOREWORD
07800				       END;
07900	
08000			    RECORDS,
08100			    FILES    :	ERROR(411)
08200			   END %CASE\ ;
08300			 END % WITH \ ;
08400		       END % STOREGLOBALS \ ;
08500	
08600		     BEGIN
08700		      %ASSIGNMENT\
08800		      SELECTOR(FSYS OR [BECOMES],FCP);
08900		       IF SY = BECOMES
09000		       THEN
09100			 BEGIN
09200			  LATTR := GATTR;
09300			  INSYMBOL;
09400			  EXPRESSION(FSYS,ONREGC);
09500			   IF (LATTR.TYPTR # NIL) AND (GATTR.TYPTR # NIL)
09600			   THEN
09700			     IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) OR
09800			      (REALPTR=LATTR.TYPTR) AND (GATTR.TYPTR=INTPTR)
09900			     THEN
10000			       IF INITGLOBALS
10100			       THEN
10200				 IF GATTR.KIND = CST
10300				 THEN STOREGLOBALS
10400				 ELSE ERROR(504)
10500			       ELSE
10600				 IF (GATTR.KIND=CST) AND (GATTR.CVAL.IVAL=0)
10700				  AND (LATTR.PACKFG=NOTPACK)
10800				 THEN
10900				   BEGIN
11000				    FETCHBASIS(LATTR);
11100				    WITH LATTR DO
11200				     BEGIN
11300	(* 104 - check subranges *)
11400				      if lattr.typtr^.form = subrange
11500					then begin
11600					getbounds(lattr.typtr,srmin,srmax);
11700					if (0 < srmin) or (0 > srmax)
11800					  then error(367)
11900					end;
12000				      MACRO(VRELBYTE,402B%SETZM\,0,INDBIT,INDEXR,DPLMT)
12100				     END
12200				   END
12300				 ELSE
12400				   CASE LATTR.TYPTR^.FORM OF
12500				    SCALAR,
12600				    POINTER,
12700				    POWER:
12800					   BEGIN
12900					    LOAD(GATTR);
13000					     IF COMPTYPES(REALPTR,LATTR.TYPTR) AND (GATTR.TYPTR=INTPTR)
13100					     THEN
13200					      MAKEREAL(GATTR);
13300					    STORE(GATTR.REG,LATTR)
13400					   END;
13500				    SUBRANGE:
13600					      BEGIN
13700	(* 104 - moved code into procedure for use elsewhere *)
13800					       loadsubrange(gattr,lattr.typtr);
13900					       STORE(GATTR.REG,LATTR)
14000					      END;
14100	
14200				    ARRAYS,
14300				    RECORDS:
14400	(* 201 - zero size objects *)
14500					     IF GATTR.TYPTR^.SIZE = 0
14600					      THEN
14700					     ELSE IF GATTR.TYPTR^.SIZE = 1
14800					      THEN
14900					       BEGIN
15000						LOAD(GATTR) ; STORE(GATTR.REG,LATTR)
15100					       END
15200					     ELSE WITH LATTR DO
15300					       BEGIN
15400						LOADADDRESS ;
15500						CODE.INSTRUCTION[CIX].INSTR := 505B%HRLI\ ;
15600						FETCHBASIS(LATTR);
15700						MACRO(VRELBYTE,541B%HRRI\,REGC,INDBIT,INDEXR,DPLMT) ;
15800						 IF INDBIT=0
15900						 THEN MACRO5(VRELBYTE,251B%BLT \,REGC,INDEXR,DPLMT+TYPTR^.SIZE-1)
16000						 ELSE
16100						   BEGIN
16200						    INCREMENTREGC ;
16300						    MACRO3(200B%MOVE\,REGC,REGC-1);
16400						    MACRO4(251B%BLT \,REGC,REGC-1,TYPTR^.SIZE-1)
16500						   END;
16600					       END;
16700				    FILES: ERROR(361)
16800				   END
16900			     ELSE ERROR(260)
17000			 END %SY = BECOMES\
17100		       ELSE ERROR(159);
17200		     END %ASSIGNMENT\ ;
17300	
17400		    PROCEDURE GOTOSTATEMENT;
17500		    VAR
17600	(* 64 - non-local gotos *)
17700	(* 65 - remove exit labels *)
17800		      I,J,JJ:INTEGER; lcp:ctp;
17900		     BEGIN
18000			 IF SY = INTCONST
18100			 THEN
18200			   BEGIN
18300			    prterr := false;
18400			    searchid([labelt],lcp);
18500			    prterr := true;
18600			    if lcp # nil
18700			      then with lcp^ do
18800	(* See if the goto is out of the current block.  If so, handle
18900	 specially, since we have to restore the basis and topp.  Except
19000	 for the global level, we recover the basis by tracing the static
19100	 links.  Then we arranged for topp's RH to be stored in the LH
19200	 of word 0 of the display.  Global labels are odd because the
19300	 static link will be 0.  So the global topp and basis are stored
19400	 in special variables. *)
19500	(* 173 - As of this edit, we have to call GOTOC. in order to
19600	 close files in the blocks exited.  In order to prevent problems
19700	 if we are interrupted while this is happening, we can't really
19800	 change BASIS or TOPP until after the files are closed, else we
19900	 might be trying to close a file whose control block is above TOPP.
20000	 So we REGC is the new BASIS and REGC+1 is the new TOPP *)
20100			        if scope # level
20200				  then begin
20300				  incrementregc;
20400				  if scope = 1
20500				    then begin
20600				    macro3r(200B%move\,regc,globbasis);
20700				    macro3r(200B%move\,regc+1,globtopp)
20800				    end
20900				   else begin
21000				    macro4(504B%hrl\,regc,basis,-1);
21100				    macro3(544B%hlr\,regc,regc);
21200				    for i := scope to level - 2 do
21300				      macro4(507B%hrls\,regc,regc,-1);
21400				    macro4(544B%hlr\,regc+1,regc,0);
21500				    macro3(504B%hrl\,regc+1,regc+1);
21600				    end;
21700	(* 75 - following was macro3 due to typo *)
21800				  macro3r(201B%movei\,regc+2,gotochain);
21900				  gotochain := ic-1;
22000				  code.information[cix] := 'F';
22100				  nonlocgoto := true;
22200				  support(exitgoto);
22300				  goto 2
22400				  end;
22500			    FOR I:=1 TO LIX DO
22600			     BEGIN
22700			      WITH LABELS[I] DO
22800			       IF LABSVAL = VAL.IVAL
22900			       THEN
23000				 BEGIN
23100				  MACRO3R(254B%JRST\,0,LABSADDR);
23200				  GOTO 2
23300				 END
23400			     END;
23500			    MACRO3(254B%JRST\,0,0);
23600			    FOR I:=1 TO JIX DO
23700			     BEGIN
23800			      WITH GOTOS[I] DO
23900			       IF GOTOVAL = VAL.IVAL
24000			       THEN
24100				 BEGIN
24200				  J:= CODE.INSTRUCTION[GOTOADDR].ADDRESS;
24300				  JJ:= GOTOADDR;
24400				  WHILE J#0 DO
24500				   BEGIN
24600				    JJ:=J;
24700				    J:= CODE.INSTRUCTION[J].ADDRESS
24800				   END;
24900				  INSERTADDR(NO,JJ,CIX);
25000				  GOTO 2
25100				 END
25200			     END;
25300			    FOR I:=1 TO JIX DO
25400			     BEGIN
25500			      WITH GOTOS[I] DO
25600			       IF GOTOVAL = -1
25700			       THEN
25800				 BEGIN
25900				  GOTOVAL:=VAL.IVAL;
26000				  GOTOADDR:=CIX;
26100				  GOTO 2
26200				 END
26300			     END;
26400			    JIX :=JIX+1;
26500			     IF JIX > LABMAX
26600			     THEN
26700			       BEGIN
26800				ERROR(362);
26900				JIX := LABMAX
27000			       END;
27100			    WITH GOTOS[JIX] DO
27200			     BEGIN
27300			      GOTOVAL := VAL.IVAL;
27400			      GOTOADDR:=CIX
27500			     END;
27600	2:
27700			    INSYMBOL
27800			   END
27900			 ELSE ERROR(255)
28000		     END %GOTOSTATEMENT\ ;
28100	
28200		    PROCEDURE COMPOUNDSTATEMENT;
28300		     BEGIN
28400		       LOOP
28500			 REPEAT
28600			  STATEMENT(FSYS,STATENDS)
28700			 UNTIL	NOT (SY IN STATBEGSYS);
28800		       EXIT IF SY # SEMICOLON;
28900			INSYMBOL
29000		       END;
29100		       IF SY = ENDSY
29200		       THEN INSYMBOL
29300		       ELSE ERROR(163)
29400		     END %COMPOUNDSTATEMENET\ ;
29500	
29600		    PROCEDURE IFSTATEMENT;
29700		    VAR
29800		      LCIX1,LCIX2: CODERANGE;
29900		     BEGIN
30000		      EXPRESSION(FSYS OR [THENSY],FALSEJMP);
30100		      LCIX1 := CIX;
30200		       IF SY = THENSY
30300		       THEN INSYMBOL
30400		       ELSE ERROR(164);
30500		      STATEMENT(FSYS OR [ELSESY],STATENDS OR [ELSESY]);
30600		       IF SY = ELSESY
30700		       THEN
30800			 BEGIN
30900			  MACRO3(254B%JRST\,0,0); LCIX2 := CIX;
31000			  INSERTADDR(RIGHT,LCIX1,IC);
31100			  INSYMBOL; STATEMENT(FSYS,STATENDS);
31200			  INSERTADDR(RIGHT,LCIX2,IC)
31300			 END
31400		       ELSE INSERTADDR(RIGHT,LCIX1,IC)
31500		     END %IFSTATEMENT\ ;
31600	
31700		    PROCEDURE CASESTATEMENT;
31800		    TYPE
31900		      CIP = ^CASEINFO;
32000		      CASEINFO = PACKED
32100		      RECORD
32200			NEXT: CIP;
32300			CSSTART: ADDRRANGE;
32400			CSEND: CODERANGE;
32500			CSLAB: INTEGER
32600		      END;
32700		    VAR
32800		      LSP,LSP1: STP; FSTPTR,LPT1,LPT2,LPT3,OTHERSPTR: CIP; LVAL: VALU;
32900		      LIC,LADDR,JUMPADDR: ADDRRANGE; LCIX: CODERANGE; LMIN,LMAX: INTEGER;
33000	
33100		      PROCEDURE INSERTBOUND(FCIX:CODERANGE;FIC: ADDRRANGE;BOUND:INTEGER);
33200		      VAR
33300			LCIX1:CODERANGE; LIC1: ADDRRANGE;
33400			LATTR:ATTR;
33500		       BEGIN
33600			 IF BOUND>=0
33700			 THEN INSERTADDR(NO,FCIX,BOUND)
33800			 ELSE
33900			   BEGIN
34000			    LCIX1:=CIX; LIC1 := IC;
34100			    CIX:=FCIX; IC := FIC;
34200			    WITH LATTR DO
34300			     BEGIN
34400			      KIND:=CST;
34500			      CVAL.IVAL:=BOUND;
34600			      TYPTR:=NIL
34700			     END;
34800			    DEPCST(INT,LATTR);
34900			    CIX:=LCIX1; IC:= LIC1;
35000			    WITH CODE.INSTRUCTION[FCIX] DO
35100			    INSTR:=INSTR+10B  %CAILE-->CAMLE, CAIL-->CAML\
35200			   END
35300		       END;
35400	
35500		     BEGIN
35600		      OTHERSPTR:=NIL;
35700		      EXPRESSION(FSYS OR [OFSY,COMMA,COLON],ONREGC);
35800		      LOAD(GATTR);
35900		      MACRO3(301B%CAIL\,REGC,0);%<<<---------- LMIN IS INSERTED HERE\
36000		      MACRO3(303B%CAILE\,REGC,0);%<<<--------- LMAX IS INSERTED HERE\
36100		      MACRO3(254B%JRST\,0,0);%<<<------------- START OF "OTHERS" IS INSERTED HERE\
36200		      MACRO(NO,254B%JRST\,0,1,REGC,0);%<<<---- START OF JUMP TABLE IS INSERTED HERE\
36300		      LCIX := CIX; LIC := IC;
36400		      LSP := GATTR.TYPTR;
36500		       IF LSP # NIL
36600		       THEN
36700			 IF (LSP^.FORM # SCALAR) OR (LSP = REALPTR)
36800			 THEN
36900			   BEGIN
37000			    ERROR(315); LSP := NIL
37100			   END;
37200		       IF SY = OFSY
37300		       THEN INSYMBOL
37400		       ELSE ERROR(160);
37500	(* 65 - allow extra semicolon *)
37600		      while sy=semicolon do
37700			insymbol;
37800		      FSTPTR := NIL; LPT3 := NIL;
37900		       LOOP
38000			 LOOP
38100			  CONSTANT(FSYS OR [COMMA,COLON],LSP1,LVAL);
38200			   IF LSP # NIL
38300			   THEN
38400			     IF COMPTYPES(LSP,LSP1)
38500			     THEN
38600			       BEGIN
38700				LPT1 := FSTPTR; LPT2 := NIL;
38800				 IF ABS(LVAL.IVAL) > HWCSTMAX
38900				 THEN ERROR(316);
39000				WHILE LPT1 # NIL DO
39100				WITH LPT1^ DO
39200				 BEGIN
39300				   IF CSLAB <= LVAL.IVAL
39400				   THEN
39500				     BEGIN
39600				       IF CSLAB = LVAL.IVAL
39700				       THEN ERROR(261);
39800				      GOTO 1
39900				     END;
40000				  LPT2 := LPT1; LPT1 := NEXT
40100				 END;
40200	1:
40300				NEWZ(LPT3);
40400				WITH LPT3^ DO
40500				 BEGIN
40600				  NEXT := LPT1; CSLAB := LVAL.IVAL;
40700				  CSSTART := IC; CSEND := 0
40800				 END;
40900				 IF LPT2 = NIL
41000				 THEN FSTPTR := LPT3
41100				 ELSE LPT2^.NEXT := LPT3
41200			       END
41300			     ELSE ERROR(505);
41400			 EXIT IF SY # COMMA;
41500			  INSYMBOL
41600			 END;
41700			 IF SY = COLON
41800			 THEN INSYMBOL
41900			 ELSE ERROR(151);
42000			 REPEAT
42100			  STATEMENT(FSYS,STATENDS)
42200			 UNTIL	NOT (SY IN STATBEGSYS);
42300			 IF LPT3 # NIL
42400			 THEN
42500			   BEGIN
42600			    MACRO3(254B%JRST\,0,0); LPT3^.CSEND := CIX
42700			   END;
42800	(* 65 - allow extra semicolons *)
42900			while sy = semicolon
43000			  do insymbol;
43100		       exit if sy in (fsys or statends);
43200			 IF SY=OTHERSSY
43300			 THEN
43400			   BEGIN
43500			    INSYMBOL;
43600			     IF SY=COLON
43700			     THEN INSYMBOL
43800			     ELSE ERROR(151);
43900			    NEWZ(OTHERSPTR);
44000			    WITH OTHERSPTR^ DO
44100			     BEGIN
44200			      CSSTART:=IC;
44300			       REPEAT
44400				STATEMENT(FSYS,STATENDS)
44500			       UNTIL NOT(SY IN STATBEGSYS);
44600			      MACRO3(254B %JRST\,0,0);
44700			      CSEND:=CIX;
44800	(* 65 - allow extra semicolons *)
44900			      while sy=semicolon do
45000				insymbol;
45100			      GOTO 2
45200			     END
45300			   END
45400		       END;
45500	2:
45600		       IF FSTPTR # NIL
45700		       THEN
45800			 BEGIN
45900			  LMAX := FSTPTR^.CSLAB;
46000			  %REVERSE POINTERS\
46100			  LPT1 := FSTPTR; FSTPTR := NIL;
46200			   REPEAT
46300			    LPT2 := LPT1^.NEXT; LPT1^.NEXT := FSTPTR;
46400			    FSTPTR := LPT1; LPT1 := LPT2
46500			   UNTIL LPT1 = NIL;
46600			  LMIN := FSTPTR^.CSLAB;
46700			  INSERTBOUND(LCIX-2,LIC-2,LMAX);
46800			  INSERTBOUND(LCIX-3,LIC-3,LMIN);
46900	(* 164 - Polish fixups to avoid problem with LOADER *)
47000			  INSERTPOLISH(LIC-1,IC,-LMIN);  {put IC-LMIN at LIC-1}
47100			   IF LMAX - LMIN < CIXMAX-CIX
47200			   THEN
47300			     BEGIN
47400			      LADDR := IC + LMAX - LMIN + 1;
47500			       IF OTHERSPTR=NIL
47600			       THEN JUMPADDR:=LADDR
47700			       ELSE
47800				 BEGIN
47900				  INSERTADDR(RIGHT,OTHERSPTR^.CSEND,LADDR);
48000				  JUMPADDR:=OTHERSPTR^.CSSTART
48100				 END;
48200			      INSERTADDR(RIGHT,LCIX-1,JUMPADDR);
48300			       REPEAT
48400				WITH FSTPTR^ DO
48500				 BEGIN
48600				  WHILE CSLAB > LMIN DO
48700				   BEGIN
48800				    FULLWORD(RIGHT,0,JUMPADDR); LMIN := LMIN + 1
48900				   END;
49000				  FULLWORD(RIGHT,0,CSSTART);
49100				   IF CSEND # 0
49200				   THEN INSERTADDR(RIGHT,CSEND,LADDR);
49300				  FSTPTR := NEXT; LMIN := LMIN + 1
49400				 END
49500			       UNTIL FSTPTR = NIL
49600			     END
49700			   ELSE ERROR(363)
49800			 END;
49900		       IF SY = ENDSY
50000		       THEN INSYMBOL
50100		       ELSE ERROR(163)
50200		     END %CASESTATEMENT\ ;
50300	
50400		    PROCEDURE REPEATSTATEMENT;
50500		    VAR
50600		      LADDR: ADDRRANGE;
50700		     BEGIN
50800		      LADDR := IC;
50900		       LOOP
51000			 REPEAT
51100			  STATEMENT(FSYS OR [UNTILSY],STATENDS OR [UNTILSY])
51200			 UNTIL	NOT (SY IN STATBEGSYS);
51300		       EXIT IF SY # SEMICOLON;
51400			INSYMBOL
51500		       END;
51600		       IF SY = UNTILSY
51700		       THEN
51800			 BEGIN
51900			  INSYMBOL; EXPRESSION(FSYS,FALSEJMP); INSERTADDR(RIGHT,CIX,LADDR);
52000			 END
52100		       ELSE ERROR(202)
52200		     END %REPEATSTATEMENT\ ;
52300	
52400		    PROCEDURE WHILESTATEMENT;
52500		    VAR
52600		      LADDR: ADDRRANGE; LCIX: CODERANGE;
52700		     BEGIN
52800		      LADDR := IC;
52900		      EXPRESSION(FSYS OR [DOSY],FALSEJMP);
53000		      LCIX := CIX;
53100		       IF SY = DOSY
53200		       THEN INSYMBOL
53300		       ELSE ERROR(161);
53400		      STATEMENT(FSYS,STATENDS);
53500		      MACRO3R(254B%JRST\,0,LADDR);
53600		      INSERTADDR(RIGHT,LCIX,IC)
53700		     END %WHILESTATEMENT\ ;
53800	
53900		    PROCEDURE FORSTATEMENT;
54000		    VAR
54100	(* 104 - check subranges *)
54200		      LATTR,SATTR: ATTR; LSP: STP; LSY: SYMBOL;
54300		      LCIX: CODERANGE; LADDR,LDPLMT: ADDRRANGE; LINSTR: INSTRANGE;
54400		      LREGC,LINDREG: ACRANGE; LINDBIT: IBRANGE; LRELBYTE: RELBYTE;
54500		      ADDTOLC: INTEGER;
54600		     BEGIN
54700		       IF SY = IDENT
54800		       THEN
54900			 BEGIN
55000			  SEARCHID([VARS],LCP);
55100			  WITH LCP^, LATTR DO
     
00100			   BEGIN
00200			    TYPTR := IDTYPE; KIND := VARBL;
00300			     IF VKIND = ACTUAL
00400			     THEN
00500			       BEGIN
00600				VLEVEL := VLEV;
00700				 IF VLEV > 1
00800				 THEN VRELBYTE := NO
00900				 ELSE VRELBYTE := RIGHT;
01000				DPLMT := VADDR; INDEXR :=0; PACKFG := NOTPACK;
01100				INDBIT:=0
01200			       END
01300			     ELSE
01400			       BEGIN
01500				ERROR(364); TYPTR := NIL
01600			       END
01700			   END;
01800			   IF LATTR.TYPTR # NIL
01900			   THEN
02000			     IF COMPTYPES(REALPTR,LATTR.TYPTR) OR (LATTR.TYPTR^.FORM > SUBRANGE)
02100			     THEN
02200			       BEGIN
02300				ERROR(365); LATTR.TYPTR := NIL
02400			       END;
02500			  INSYMBOL
02600			 END
02700		       ELSE
02800			BEGIN
02900			 ERRANDSKIP(209,FSYS OR [BECOMES,TOSY,DOWNTOSY,DOSY]);
03000			 LATTR.TYPTR := NIL
03100			END;
03200		       IF SY = BECOMES
03300		       THEN
03400			 BEGIN
03500			  INSYMBOL; EXPRESSION(FSYS OR [TOSY,DOWNTOSY,DOSY],ONREGC);
03600			   IF GATTR.TYPTR # NIL
03700			   THEN
03800			     IF GATTR.TYPTR^.FORM # SCALAR
03900			     THEN ERROR(315)
04000			     ELSE
04100			       IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
04200	(* 104 - range check subranges *)
04300			       then begin
04400			       if lattr.typtr # nil
04500			       then if lattr.typtr^.form = subrange
04600				    then loadsubrange(gattr,lattr.typtr)
04700				    else load(gattr)
04800			       end
04900			       ELSE ERROR(556);
05000			  LREGC := GATTR.REG
05100			 END
05200		       ELSE ERRANDSKIP(159,FSYS OR [TOSY,DOWNTOSY,DOSY]);
05300		       IF SY IN [TOSY,DOWNTOSY]
05400		       THEN
05500			 BEGIN
05600			  LSY := SY; INSYMBOL; EXPRESSION(FSYS OR [DOSY],ONREGC);
05700			   IF GATTR.TYPTR # NIL
05800			   THEN
05900			     IF GATTR.TYPTR^.FORM # SCALAR
06000			     THEN ERROR(315)
06100			     ELSE
06200			       IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
06300			       THEN
06400				 BEGIN
06500				  ADDTOLC := 0 ;
06600				  WITH GATTR DO
06700	{This test checks for forms of upper bound that must be copied into a local
06800	 variable. Originally, they tried to use variables in place instead of
06900	 copying, to save the MOVE, MOVEM.  The problem is that if the user changes
07000	 the variable inside the loop, you have the wrong upper bound.  We
07100	 interpret the language spec as requiring the bound to be evaluated only
07200	 once, at the start.  The following test, commented out, was the original
07300	 test, to see whether the object could be used in place for a CAMGE, or
07400	 needed to be copied.  Now we copy all variables, as just discussed.}
07500	{IF ( (KIND = VARBL) AND ( (VLEVEL > 1) AND (VLEVEL < LEVEL) OR
07600	 (PACKFG # NOTPACK) OR (INDEXR > 0) AND (INDEXR <=   REGCMAX) ) ) OR
07700	 (KIND = EXPR) }
07800				  IF (KIND = VARBL) OR (KIND = EXPR)
07900				   THEN
08000				     BEGIN
08100	(* 104 - add range checking for subrange types *)
08200				      if lattr.typtr # nil
08300				      then if lattr.typtr^.form = subrange
08400					   then loadsubrange(gattr,lattr.typtr)
08500					   else load(gattr);
08600				      MACRO4(202B%MOVEM\,REGC,BASIS,LC); ADDTOLC := 1;
08700				      KIND := VARBL ; INDBIT := 0  ; INDEXR := BASIS ; VLEVEL := 1;
08800				      DPLMT := LC ; PACKFG := NOTPACK ; VRELBYTE := NO
08900				     END
09000				  else if lattr.typtr # nil
09100				       then if (lattr.typtr^.form = subrange) and runtmcheck
09200					    then begin
09300					     (* must copy, since otherwise at end of loop
09400					        makecode will think it is in an AC *)
09500					    sattr := gattr;
09600					    loadsubrange(sattr,lattr.typtr)
09700					    end;
09800				  FETCHBASIS(LATTR);
09900				  WITH LATTR DO
10000				   BEGIN
10100				     IF (INDEXR>0) AND (INDEXR<=REGCMAX)
10200				     THEN
10300				       BEGIN
10400					MACRO(NO,201B%MOVEI\,INDEXR,INDBIT,INDEXR,DPLMT);
10500					LINDBIT := 1; LDPLMT := LC+ADDTOLC; LINDREG := BASIS ;
10600					MACRO4(202B%MOVEM\,INDEXR,BASIS,LDPLMT);
10700					ADDTOLC := ADDTOLC + 1 ;
10800				       END
10900				     ELSE
11000				       BEGIN
11100					LINDBIT := INDBIT; LINDREG := INDEXR; LDPLMT := DPLMT
11200				       END;
11300				    LRELBYTE:= VRELBYTE
11400				   END;
11500				  MACRO(LRELBYTE,202B%MOVEM\,LREGC,LINDBIT,LINDREG,LDPLMT);
11600				   IF LSY = TOSY
11700				   THEN LINSTR := 313B%CAMLE\
11800				   ELSE LINSTR := 315B%CAMGE\;
11900				  LADDR := IC;
12000				  MAKECODE(LINSTR,LREGC,GATTR) ;
12100				 END
12200			       ELSE ERROR(556)
12300			 END
12400		       ELSE ERRANDSKIP(251,FSYS OR [DOSY]);
12500		      MACRO3(254B%JRST\,0,0); LCIX :=CIX;
12600		       IF SY = DOSY
12700		       THEN INSYMBOL
12800		       ELSE ERROR(161);
12900		      LC := LC + ADDTOLC;
13000		       IF LC > LCMAX
13100		       THEN LCMAX:=LC;
13200		      STATEMENT(FSYS,STATENDS);
13300		      LC := LC - ADDTOLC;
13400		       IF LSY = TOSY
13500		       THEN LINSTR  := 350B%AOS\
13600		       ELSE LINSTR := 370B%SOS\;
13700		      MACRO(LRELBYTE,LINSTR,LREGC,LINDBIT,LINDREG,LDPLMT);
13800		      MACRO3R(254B%JRST\,0,LADDR); INSERTADDR(RIGHT,LCIX,IC)
13900		     END %FORSTATEMENT\ ;
14000	
14100		    PROCEDURE LOOPSTATEMENT;
14200		    VAR
14300		      LADDR: ADDRRANGE; LCIX: CODERANGE;
14400		     BEGIN
14500		      LADDR := IC;
14600		       LOOP
14700			 REPEAT
14800			  STATEMENT(FSYS OR [EXITSY],STATENDS OR [EXITSY])
14900			 UNTIL	NOT (SY IN STATBEGSYS);
15000		       EXIT IF SY # SEMICOLON;
15100			INSYMBOL
15200		       END;
15300		       IF SY = EXITSY
15400		       THEN
15500			 BEGIN
15600			  INSYMBOL;
15700			   IF SY = IFSY
15800			   THEN
15900			     BEGIN
16000			      INSYMBOL; EXPRESSION(FSYS OR [SEMICOLON,ENDSY],TRUEJMP);
16100			     END
16200			   ELSE ERRANDSKIP(162,FSYS OR [SEMICOLON,ENDSY]);
16300			  LCIX := CIX;
16400			   LOOP
16500			     REPEAT
16600			      STATEMENT(FSYS,STATENDS)
16700			     UNTIL  NOT (SY IN STATBEGSYS);
16800			   EXIT IF SY # SEMICOLON;
16900			    INSYMBOL
17000			   END;
17100			  MACRO3R(254B%JRST\,0,LADDR); INSERTADDR(RIGHT,LCIX,IC)
17200			 END
17300		       ELSE ERROR(165);
17400		       IF SY = ENDSY
17500		       THEN INSYMBOL
17600		       ELSE ERROR(163)
17700		     END %LOOPSTATEMENT\ ;
17800	
17900		    PROCEDURE WITHSTATEMENT;
18000		    VAR
18100		      LCP: CTP; OLDLC: ADDRRANGE; LCNT1: DISPRANGE; OLDREGC: ACRANGE;
18200		     BEGIN
18300		      LCNT1 := 0; OLDREGC := REGCMAX; OLDLC := LC;
18400		       LOOP
18500			 IF SY = IDENT
18600			 THEN
18700			   BEGIN
18800			    SEARCHID([VARS,FIELD],LCP); INSYMBOL
18900			   END
19000			 ELSE
19100			   BEGIN
19200			    ERROR(209); LCP := UVARPTR
19300			   END;
19400			SELECTOR(FSYS OR [COMMA,DOSY],LCP);
19500			 IF GATTR.TYPTR # NIL
19600			 THEN
19700			   IF GATTR.TYPTR^.FORM = RECORDS
19800			   THEN
19900			     IF TOP < DISPLIMIT
20000			     THEN
20100			       BEGIN
20200				TOP := TOP + 1; LCNT1 := LCNT1 + 1; WITHIX := WITHIX + 1;
20300				DISPLAY[TOP].FNAME := GATTR.TYPTR^.FSTFLD;
20400				WITH DISPLAY[TOP],GATTR DO
20500				 BEGIN
20600				  OCCUR := CREC;
20700	(* 5 - create block name for CREF *)
20800				  BLKNAME := '.FIELDID. ';
20900				   IF INDBIT = 1
21000				   THEN GETPARADDR;
21100				  FETCHBASIS(GATTR);
21200				   IF (INDEXR#0) AND (INDEXR # BASIS)
21300				   THEN
21400				     BEGIN
21500				      MACRO3(200B%MOVE\,REGCMAX,INDEXR);
21600				      INDEXR := REGCMAX;
21700				      REGCMAX := REGCMAX-1;
21800				       IF REGCMAX<REGC
21900				       THEN
22000					 BEGIN
22100					  ERROR(317);
22200					  REGC := REGCMAX
22300					 END
22400				     END;
22500				  CLEV := VLEVEL; CRELBYTE := VRELBYTE;
22600				  CINDR := INDEXR; CINDB:=INDBIT;
22700				  CDSPL := DPLMT;
22800				  CLC := LC;
22900				   IF (CINDR#0)  AND  (CINDR#BASIS)
23000				   THEN
23100				     BEGIN
23200				      LC := LC + 1;
23300				       IF LC>LCMAX
23400				       THEN LCMAX := LC;
23500				     END
23600				 END
23700			       END
23800			     ELSE ERROR(404)
23900			   ELSE ERROR(308);
24000		       EXIT IF SY # COMMA;
24100			INSYMBOL
24200		       END;
24300		       IF SY = DOSY
24400		       THEN INSYMBOL
24500		       ELSE ERROR(161);
24600		      STATEMENT(FSYS,STATENDS);
24700		      REGCMAX:=OLDREGC;
24800		      TOP := TOP - LCNT1; LC := OLDLC; WITHIX := WITHIX - LCNT1;
24900		     END %WITHSTATEMENT\ ;
25000	
25100		   BEGIN
25200		    %STATEMENT\
25300		     IF SY = INTCONST
25400		     THEN %LABEL\
25500		       BEGIN
25600	(* 64 - non-loc gotos *)
25700			prterr := false;
25800			searchid([labelt],lcp);
25900			prterr := true;
26000			if lcp # nil
26100			  then with lcp^ do
26200			    if scope = level
26300			      then labeladdress := ic;
26400			FOR IX:=1 TO LIX DO
26500			 BEGIN
26600			  WITH LABELS[IX] DO
26700			   IF LABSVAL = VAL.IVAL
26800			   THEN
26900			     BEGIN
27000			      ERROR(211);
27100			      GOTO 1
27200			     END
27300			 END;
27400			LIX := LIX+1;
27500			 IF LIX > LABMAX
27600			 THEN
27700			   BEGIN
27800			    ERROR(362);
27900			    LIX:=LABMAX
28000			   END;
28100			WITH LABELS[LIX] DO
28200			 BEGIN
28300			  LABSVAL:=VAL.IVAL;
28400			  LABSADDR:=IC
28500			 END;
28600			FOR IX:=1 TO JIX DO
28700			 BEGIN
28800			  WITH GOTOS[IX] DO
28900			   IF GOTOVAL = VAL.IVAL
29000			   THEN
29100			     BEGIN
29200			      J:=CODE.INSTRUCTION[GOTOADDR].ADDRESS;
29300			      INSERTADDR(RIGHT,GOTOADDR,IC);
29400			      WHILE J#0 DO
29500			       BEGIN
29600				GOTOADDR:=J;
29700				J:=CODE.INSTRUCTION[GOTOADDR].ADDRESS;
29800				INSERTADDR(RIGHT,GOTOADDR,IC)
29900			       END;
30000			      GOTOVAL:=-1;
30100			      GOTO 1
30200			     END
30300			 END;
30400	1:
30500			INSYMBOL;
30600			 IF SY = COLON
30700			 THEN INSYMBOL
30800			 ELSE ERROR(151)
30900		       END;
31000		     IF DEBUG AND NOT INITGLOBALS
31100		     THEN PUTLINER;
31200		     IF  NOT (SY IN FSYS OR [IDENT])
31300		     THEN ERRANDSKIP(166,FSYS);
31400		     IF SY IN STATBEGSYS OR [IDENT]
31500		     THEN
31600		       BEGIN
31700			REGC:=REGIN ;
31800			 IF INITGLOBALS AND (SY # IDENT)
31900			 THEN ERROR(462)
32000			 ELSE
32100			   CASE SY OF
32200			    IDENT:
32300				   BEGIN
32400				    SEARCHID([VARS,FIELD,FUNC,PROC],LCP); INSYMBOL;
32500				     IF LCP^.KLASS = PROC
32600				     THEN
32700				       IF INITGLOBALS
32800				       THEN ERROR(462)
32900				       ELSE CALL(FSYS,LCP)
33000				     ELSE ASSIGNMENT(LCP)
33100				   END;
33200			    BEGINSY:
33300				     BEGIN
33400				      INSYMBOL; COMPOUNDSTATEMENT
33500				     END;
33600			    GOTOSY:
33700				    BEGIN
33800				     INSYMBOL; GOTOSTATEMENT
33900				    END;
34000			    IFSY:
34100				  BEGIN
34200				   INSYMBOL; IFSTATEMENT
34300				  END;
34400			    CASESY:
34500				    BEGIN
34600				     INSYMBOL; CASESTATEMENT
34700				    END;
34800			    WHILESY:
34900				     BEGIN
35000				      INSYMBOL; WHILESTATEMENT
35100				     END;
35200			    REPEATSY:
35300				      BEGIN
35400				       INSYMBOL; REPEATSTATEMENT
35500				      END;
35600			    LOOPSY:
35700				    BEGIN
35800				     INSYMBOL; LOOPSTATEMENT
35900				    END;
36000			    FORSY:
36100				   BEGIN
36200				    INSYMBOL; FORSTATEMENT
36300				   END;
36400			    WITHSY:
36500				    BEGIN
36600				     INSYMBOL; WITHSTATEMENT
36700				    END
36800			   END;
36900			SKIPIFERR(STATENDS,506,FSYS)
37000		       END;
37100		    REGC := REGIN  %RE-INITIALIZE REGISTER COUNTER TO AVOID OVERFLOW DURING SUBSEQUENT
37200				    EXPRESSION EVALUATIONS IN REPEATSTATEMENT OR LOOPSTATEMENT \  ;
37300		   END %STATEMENT\ ;
37400	
37500		 BEGIN
37600		  %BODY\
37700		  LIX:=0;JIX:=0;REGCMAX:=WITHIN;WITHIX := -1; FIRSTKONST := NIL;
37800	(* 164 - Polish fixups for CASE *)
37900		  FIRSTPOL := NIL;
38000		   IF NOT ENTRYDONE
38100		   THEN
38200		     BEGIN
38300		      ENTRYDONE:= TRUE;
38400		      WRITEMC(WRITEENTRY);
38500		      WRITEMC(WRITENAME);
38600		      WRITEMC(WRITEHISEG)
38700		     END;
38800		  CIX := -1 ;
38900		   IF INITGLOBALS
39000		   THEN
39100		     BEGIN
39200		      CGLOBPTR := NIL ;
39300		       LOOP
39400			 IF SY # ENDSY
39500			 THEN STATEMENT([SEMICOLON,ENDSY],[SEMICOLON,ENDSY]) ;
39600		       EXIT IF	SY # SEMICOLON ;
39700			INSYMBOL
39800		       END ;
39900		       IF SY = ENDSY
40000		       THEN INSYMBOL
40100		       ELSE ERROR(163) ;
40200		      WRITEMC(WRITEGLOBALS)
40300		     END
40400		   ELSE
40500		     BEGIN
40600		      %BODY PROPER\
40700		      ENTERBODY;
40800		       IF FPROCP # NIL
40900	(* 40 - fix print format *)
41000		       THEN FPROCP^.PFADDR:= PFSTART
41100		       ELSE LC:= 1;
41200		      LCMAX:=LC;
41300	(* 54 - keep track of how many loc's above stack are used *)
41400		      STKOFFMAX := 0;
41500		      STKOFF := 0;
41600		       IF MAIN OR (LEVEL > 1)
41700		       THEN
41800			 BEGIN
41900			   LOOP
42000			     REPEAT
42100			      STATEMENT(FSYS OR [SEMICOLON,ENDSY],[SEMICOLON,ENDSY])
42200			     UNTIL  NOT (SY IN STATBEGSYS);
42300			   EXIT IF SY # SEMICOLON;
42400			    INSYMBOL
42500			   END;
42600			   IF SY = ENDSY
42700			   THEN INSYMBOL
42800			   ELSE ERROR(163);
42900			  FOR IX:=1 TO JIX DO %TEST ON UNDEFINED LABELS\
43000			   BEGIN
43100			    WITH GOTOS[IX] DO
43200			     IF GOTOVAL # -1
43300			     THEN
43400			       BEGIN
43500				ERROR(215);
43600				NEWZ(ERRMPTR1,D);
43700				WITH ERRMPTR1^ DO
43800				 BEGIN
43900				  NUMBER := 215; INTVAL := GOTOVAL; NEXT := ERRMPTR
44000				 END;
44100				ERRMPTR := ERRMPTR1;
44200			       END
44300			   END
44400	
44500			    %	 WHILE FSTEXP # FEXP DO %TEST ON UNDEFINED EXIT LABELS\
44600	
44700			 END;
44800	
44900		      LEAVEBODY;
45000		       IF MAIN OR (LEVEL > 1)
45100	(* 53 - allocate core for loc's above stack *)
45200		       then
45300			 begin
45400	(* 104 - check for overflow of address space *)
45500			 if lcmax > 377777B (* else adjsp will see it negative *)
45600			   then error(266);
45700	(* 62 - clean up stack offsets *)
45800			 if fprocp # nil
45900			   then insertaddr(no,insertsize,lcmax-fprocp^.poffset)
46000			   else insertaddr(no,insertsize,lcmax);  %below the stack\
46100	(* 57 - coralloc only needed for tops10 *)
46200			 if tops10
46300			   then insertaddr(no,coralloc,stkoffmax+40B); %above the stack\
46400			 end;
46500		      WRITEMC(WRITECODE);
46600	(* 40 - fix print format *)
46700		      if fprocp # nil
46800		        then writemc(writeblk);
46900	(* 64 - Polish fixups for CASE *)
47000		      if firstpol # NIL
47100			then writemc(writepolish);
47200		       IF FIRSTKONST # NIL
47300		       THEN WRITEMC(WRITEINTERNALS)
47400		       ELSE
47500			 IF LOCALPFPTR # NIL
47600			 THEN
47700			   IF LOCALPFPTR^.PFLEV = LEVEL
47800			   THEN WRITEMC(WRITEINTERNALS)
47900	(* 114 - ALWAYS WRITE INTERNALS IF REF TO NON-LOC GOTO *)
48000			   ELSE IF LASTLABEL # NIL
48100			     THEN IF LASTLABEL^.SCOPE = LEVEL
48200				THEN WRITEMC(WRITEINTERNALS)
48300				ELSE
48400			     ELSE
48500		 	 ELSE  IF LASTLABEL # NIL
48600			   THEN IF LASTLABEL^.SCOPE = LEVEL
48700			     THEN WRITEMC(WRITEINTERNALS);
48800		       IF LEVEL = 1
48900		       THEN
49000			 BEGIN
49100			  WRITEMC(WRITESYMBOLS);
49200			  WRITEMC(WRITELIBRARY);
49300			  WRITEMC(WRITESTART);
49400			  WRITEMC(WRITEEND)
49500			 END
49600		     END % BODY PROPER\
49700		 END %BODY\ ;
49800	
49900	(* 56 - PROCEDURES FOR FILE SWITCHING *)
50000		PROCEDURE OPENALT;
50100		  BEGIN
50200		  REQFILE := TRUE;
50300	(* 136 - listing format *)
50400		  ORIGPAGECNT := PAGECNT; ORIGSUBPAGE := SUBPAGE; ORIGLINENR := LINENR;
50500		  ORIGPAGE := PAGER; ORIGLINECNT := LINECNT; ORIGCH := CH;
50600		  ENDSTUFF;
50700		  PUSHF(INPUT,VAL.VALP^.SVAL,VAL.VALP^.SLGTH);
50800	(* 107 - error check openning of subfile *)
50900		  if eof
51000		    then begin (* nb: on the 20, analys does not show the file name in most cases *)
51100	(* 136 - LISTING FORMAT *)
51200		    write('Failure to open INCLUDEd file: ',val.valp^.sval:val.valp^.slgth);
51300		    NEWLINE;
51400		    writeln(tty,'Failure to open INCLUDEd file: ',val.valp^.sval:val.valp^.slgth);
51500		    analys(input); writeln(tty);
51600		    rewrite(outputrel);
51700	(* 112 - clrbfi when error *)
51800		    clribf;
51900	(* 123 - restore input so close gets done by pasxit *)
52000		    close(input);
52100		    popf(input);
52200		    pasxit(input,output,outputrel)
52300		    end;
52400	(* 136 - listing format *)
52500		  PAGECNT := 1; SUBPAGE := 0; LINECNT := 1; CH := ' ';
52600		  READLN;  {because pushf does an interactive open}
52700		  GETLINENR(LINENR);
52800		  pagehead;
52900		  WRITE(VAL.VALP^.SVAL:VAL.VALP^.SLGTH);
53000		  newline; newline;
53100		  BEGSTUFF
53200		  END;
53300	
53400		PROCEDURE CLOSEALT;
53500		  BEGIN
53600		  ENDSTUFF;
53700		  POPF(INPUT);
53800	(* 136 - listing format *)
53900		  PAGECNT := ORIGPAGECNT; SUBPAGE := ORIGSUBPAGE + 1;
54000		  pagehead;
54100		  write('Main file continued'); newline; newline;
54200		  LINENR := ORIGLINENR; CH := ORIGCH;
54300		  PAGER := ORIGPAGE; LINECNT := ORIGLINECNT;
54400		  BEGSTUFF
54500		  END;
54600	
54700		PROCEDURE INCLUSION;
54800		  BEGIN
54900		  IF NOT (SY = STRINGCONST)
55000		    THEN BEGIN ERROR(212); REQFILE := FALSE END
55100		    ELSE BEGIN
55200		      OPENALT;
55300		      INSYMBOL
55400		      END
55500		  END;
55600	
55700	
55800	       BEGIN
55900		%BLOCK\
56000		MARK(HEAPMARK);
56100	(* 24 - testpacked no longer needed *)
56200	(* 55 - ALL 55 PATCHES ARE FOR REQUIRE FILES - INITIALIZE REQFILE *)
56300	(* 65 - remove exit labels *)
56400	(* 125 - reqfile init moved *)
56500	(* 173 - internal files *)
56600		FILEINBLOCK[LEVEL] := FALSE;
56700		DP := TRUE; FORWPTR := NIL; 
56800		 REPEAT
56900	(* 23 - be sure LCPAR is set even when no VAR part *)
57000		  LCPAR := LC;
57100	(* 56 - INCLUDE SYNTAX *)
57200	(* 126 - turn while into repeat for better to force check for BEGIN *)
57300		  REPEAT
57400	(* 56 - SCAN REQUIRE FILE SYNTAX *)
57500		   IF (SY=INCLUDESY) OR REQFILE
57600		     THEN BEGIN
57700		     INSYMBOL;
57800		     INCLUSION;
57900		     END;
58000	(* 55 - LABELS NOT LEGAL IN REQUIRE FILE *)
58100		     IF (SY = LABELSY) AND NOT REQFILE
58200		     THEN
58300		       BEGIN
58400			INSYMBOL; LABELDECLARATION
58500		       END;
58600		     IF SY = CONSTSY
58700		     THEN
58800		       BEGIN
58900			INSYMBOL; CONSTANTDECLARATION
59000		       END;
59100		     IF SY = TYPESY
59200		     THEN
59300		       BEGIN
59400			INSYMBOL; TYPEDECLARATION
59500		       END;
59600	(* 55 - NO VARIABLES OR INITPROC'S IN REQUIRE FILE *)
59700		    IF NOT REQFILE THEN BEGIN
59800		    LCPAR := LC;
59900		     IF SY = VARSY
60000		     THEN
60100		       BEGIN
60200			INSYMBOL; VARIABLEDECLARATION
60300		       END;
60400	(* 167 - resolve fwd type ref's *)
60500	{Note that FWDRESOLVE must be called after the VAR section because
60600	 ^FOO in the VAR section is treated as a forward reference to FOO.
60700	 We can't resolve this until after the end of the var section, 
60800	 since otherwise we might accept ^FOO where FOO is a type in an
60900	 outer block, but a local variable in the current block.  This seems
61000	 to be illegal}
61100		    FWDRESOLVE;
61200	(* 124 - detect initproc's when not at level 1 *)
61300		     WHILE SY = INITPROCSY DO
61400			 BEGIN
61500			  IF LEVEL # 1
61600			    THEN ERROR(557);
61700			  INSYMBOL ;
61800			   IF SY # SEMICOLON
61900			   THEN ERRANDSKIP(156,[BEGINSY])
62000			   ELSE INSYMBOL ;
62100			   IF SY = BEGINSY
62200			   THEN
62300			     BEGIN
62400			      MARK(GLOBMARK) ; INITGLOBALS := TRUE ;
62500			      INSYMBOL ; BODY(FSYS OR [SEMICOLON,ENDSY]) ;
62600			       IF SY = SEMICOLON
62700			       THEN INSYMBOL
62800			       ELSE ERROR(166) ;
62900			      INITGLOBALS := FALSE ; RELEASE(GLOBMARK) ;
63000			     END
63100			   ELSE ERROR(201) ;
63200			 END ;
63300		     IF LEVEL=1
63400		     THEN
63500			LCMAIN := LC;
63600		    END;
63700		    WHILE SY IN [PROCEDURESY,FUNCTIONSY] DO
63800		     BEGIN
63900		      LSY := SY; INSYMBOL; PROCEDUREDECLARATION(LSY)
64000		     END;
64100		    WHILE FORWPTR # NIL DO
64200		    WITH FORWPTR^ DO
64300		     BEGIN
64400		       IF FORWDECL
64500		       THEN ERRORWITHTEXT(465,NAME);
64600		      FORWPTR := TESTFWDPTR
64700		     END;
64800	(* 56 - REQ FILE ENDS IN PERIOD *)
64900		     IF (MAIN OR (LEVEL > 1)) AND NOT REQFILE
65000	(* 126 - TWEAK ERROR RECOVER AGAIN *)
65100		     THEN BEGIN IF SY # BEGINSY THEN ERROR(201) END
65200	(* 35 - fix error recovery, especially for /NOMAIN *)
65300			%This else is top level of /NOMAIN.  If anything is here
65400			 other than a period we have to turn on /MAIN, since otherwise
65500			 BODY will refuse to scan anything.\
65600		     ELSE IF SY # PERIOD
65700		       THEN BEGIN
65800		       ERROR(172);
65900	(* 56 - DON'T SET MAIN TO TRUE IN REQ FILE *)
66000		        IF NOT REQFILE
66100			  THEN MAIN := TRUE
66200		       END;
66300	(* 55 - CLOSE REQFILE *)
66400		   IF REQFILE
66500		     THEN BEGIN
66600	(* 136 - listing format *)
66700		     REQFILE := FALSE;
66800		     CLOSEALT;
66900		     INSYMBOL;
67000		     IF SY = SEMICOLON
67100		       THEN INSYMBOL
67200		     ELSE IF SY = COMMA
67300		       THEN REQFILE := TRUE
67400		     ELSE
67500		       ERROR(166);
67600		     END;
67700	(* 126 - make it an UNTIL to force always check for BEGIN, etc. *)
67800		   UNTIL NOT ( (SY IN BLOCKBEGSYS - [BEGINSY]) OR REQFILE);
67900		  DP := FALSE;
68000		     IF SY = BEGINSY
68100		     THEN INSYMBOL;
68200			%ELSE ERROR(201) REDUNDANT HERE - MSG PRINTED ABOVE\
68300		  BODY(FSYS OR [CASESY]);
68400		  SKIPIFERR(LEAVEBLOCKSYS,166,FSYS)
     
00100		 UNTIL SY IN LEAVEBLOCKSYS;
00200		RELEASE(HEAPMARK);
00300	       END %BLOCK\ ;
00400	
00500	
00600	
00700	      PROCEDURE ENTERSTDTYPES;
00800	      VAR
00900		LBTP: BTP; LSP: STP;
01000	       BEGIN
01100		%TYPE UNDERLIEING:\
01200		%*****************\
01300	
01400		NEWZ(INTPTR,SCALAR,STANDARD);	  %INTEGER\
01500		WITH INTPTR^ DO
01600		 BEGIN
01700		  SIZE := 1;BITSIZE := BITMAX; SELFSTP := NIL
01800		 END;
01900		NEWZ(REALPTR,SCALAR,STANDARD);	  %REAL\
02000		WITH REALPTR^ DO
02100		 BEGIN
02200		  SIZE := 1;BITSIZE := BITMAX; SELFSTP := NIL
02300		 END;
02400		NEWZ(CHARPTR,SCALAR,STANDARD);	  %CHAR\
02500		WITH CHARPTR^ DO
02600		 BEGIN
02700		  SIZE := 1;BITSIZE := 7; SELFSTP := NIL
02800		 END;
02900		NEWZ(BOOLPTR,SCALAR,DECLARED);	  %BOOLEAN\
03000		WITH BOOLPTR^ DO
03100		 BEGIN
03200		  SIZE := 1;BITSIZE := 1; SELFSTP := NIL
03300		 END;
03400		NEWZ(NILPTR,POINTER);		  %NIL\
03500		WITH NILPTR^ DO
03600		 BEGIN
03700		  ELTYPE := NIL; SIZE := 1; BITSIZE := 18; SELFSTP := NIL
03800		 END;
03900		NEWZ(TEXTPTR,FILES);					  %TEXT\
04000		WITH TEXTPTR^ DO
04100		 BEGIN
04200		  FILTYPE := CHARPTR; SIZE := SIZEOFFILEBLOCK + 1; BITSIZE := BITMAX;
04300		  FILEPF := FALSE; SELFSTP := NIL; HASFILE := TRUE;
04400		 END;
04500	(* 15 - ALLOW "FILE" AS TYPE IN PROC DECL - ANY TYPE OF FILE *)
04600	       NEWZ(ANYFILEPTR,FILES);
04700	      WITH ANYFILEPTR^ DO
04800		BEGIN
04900		 FILTYPE := NIL; SIZE := SIZEOFFILEBLOCK + 1; BITSIZE := BITMAX;
05000		 FILEPF := FALSE; SELFSTP := NIL; HASFILE := TRUE;
05100		END;
05200		NEWZ(LSP,SUBRANGE);
05300		WITH LSP^ DO
05400		 BEGIN
05500		  RANGETYPE := INTPTR; MIN.IVAL := 1; MAX.IVAL := 9; SELFSTP := NIL
05600		 END;
05700		NEWZ(DATEPTR,ARRAYS);
05800		WITH DATEPTR^ DO
05900		 BEGIN
06000		  ARRAYPF := TRUE; ARRAYBPADDR := 0;
06100		  SELFSTP := NIL; AELTYPE := CHARPTR; INXTYPE := LSP;
06200		  SIZE := 2; BITSIZE := 36
06300		 END;
06400		NEWZ(LBTP,ARRAYY);
06500		WITH LBTP^, BYTE DO
06600		 BEGIN
06700		  SBITS := 7; PBITS := BITMAX; DUMMYBIT := 0;
06800		  IBIT := 0; IREG := TAC; RELADDR := 0;
06900		  LAST := LASTBTP; LASTBTP := LBTP; ARRAYSP := DATEPTR
07000		 END;
07100		NEWZ(LSP,SUBRANGE);
07200		WITH LSP^ DO
07300		 BEGIN
07400		  RANGETYPE := INTPTR; MIN.IVAL := 1; MAX.IVAL := ALFALENG; SELFSTP := NIL
07500		 END;
07600		NEWZ(ALFAPTR,ARRAYS);
07700		WITH ALFAPTR^ DO
07800		 BEGIN
07900		  ARRAYPF := TRUE; ARRAYBPADDR := 0;
08000		  SELFSTP := NIL; AELTYPE := CHARPTR; INXTYPE := LSP;
08100		  SIZE := 2; BITSIZE := 36
08200		 END;
08300	(* 111 - STRING, POINTER *)
08400		NEWZ(STRINGPTR,ARRAYS);
08500		WITH STRINGPTR^ DO
08600		  BEGIN
08700		  ARRAYPF := TRUE; SELFSTP := NIL; AELTYPE := CHARPTR;
08800	(* 161 - fix string and pointer *)
08900		  INXTYPE := NIL; SIZE := 2; BITSIZE := 36
09000		  END;
09100		NEWZ(POINTERPTR,POINTER);
09200		WITH POINTERPTR^ DO
09300		  BEGIN
09400	(* 161 - fix string and pointer *)
09500		  ELTYPE := NIL; SIZE := 2; BITSIZE := 36; SELFSTP := NIL
09600		  END;
09700	(* 202 - fix VAR POINTER *)
09800		NEWZ(POINTERREF,POINTER);
09900	(* 203 - had done pointerref^ := pointerptr^ - This copied too much *)
10000		WITH POINTERREF^ DO
10100		  BEGIN
10200	(* 161 - fix string and pointer *)
10300		  ELTYPE := NIL; SIZE := 2; BITSIZE := 36; SELFSTP := NIL
10400		  END;
10500		NEWZ(LBTP,ARRAYY);
10600		WITH LBTP^, BYTE DO
10700		 BEGIN
10800		  SBITS := 7; PBITS := BITMAX; DUMMYBIT := 0;
10900		  IBIT := 0; IREG := TAC; RELADDR := 0;
11000		  LAST := LASTBTP; LASTBTP := LBTP; ARRAYSP := ALFAPTR
11100		 END;
11200	       END %ENTERSTDTYPES\ ;
11300	
11400	      PROCEDURE ENTERSTDNAMES;
11500	      VAR
11600		CP,CP1: CTP; I,J: INTEGER; LFILEPTR :FTP ;
11700	       BEGIN
11800		%NAME:\
11900		%*****\
12000	
12100		NEWZ(CP,TYPES);						  %INTEGER\
12200		WITH CP^ DO
12300		 BEGIN
12400	(* 116 - here and following: add next := nil for copyctp *)
12500		  NAME := 'INTEGER   '; IDTYPE := INTPTR; NEXT := NIL;
12600		 END;
12700		ENTERID(CP);
12800		NEWZ(CP,TYPES);						  %REAL\
12900		WITH CP^ DO
13000		 BEGIN
13100		  NAME := 'REAL      ';IDTYPE := REALPTR; NEXT := NIL;
13200		 END;
13300		ENTERID(CP);
13400		NEWZ(CP, TYPES); 					   %CHAR\
13500		WITH CP^ DO
13600		 BEGIN
13700		  NAME := 'CHAR      '; IDTYPE := CHARPTR; NEXT := NIL;
13800		 END;
13900		ENTERID(CP);
14000		NEWZ(CP,TYPES);						  %BOOLEAN\
14100		WITH CP^ DO
14200		 BEGIN
14300		  NAME := 'BOOLEAN   '; IDTYPE := BOOLPTR; NEXT := NIL;
14400		 END;
14500		ENTERID(CP);
14600		NEWZ(CP,TYPES);						  %TEXT\
14700		WITH CP^ DO
14800		 BEGIN
14900		  NAME := 'TEXT      '; IDTYPE := TEXTPTR; NEXT := NIL;
15000		 END;
15100		ENTERID(CP);
15200		NEWZ(CP,TYPES);
15300		WITH CP^ DO
15400		 BEGIN
15500		  NAME := 'ALFA      '; IDTYPE := ALFAPTR; NEXT := NIL;
15600		 END;
15700		ENTERID(CP);
15800	(* 111 - STRING, POINTER *)
15900		NEWZ(CP,PARAMS);
16000		WITH CP^ DO
16100		  BEGIN
16200		  NAME := 'STRING    ';  IDTYPE := STRINGPTR; NEXT := NIL;
16300		  END;
16400		ENTERID(CP);
16500		NEWZ(CP,PARAMS);
16600		WITH CP^ DO
16700		  BEGIN
16800		  NAME := 'POINTER   ';  IDTYPE := POINTERPTR; NEXT := NIL;
16900		  END;
17000		ENTERID(CP);
17100		NEWZ(CP,KONST);						  %NIL\
17200		WITH CP^ DO
17300		 BEGIN
17400		  NAME := 'NIL       '; IDTYPE := NILPTR;
17500		  NEXT := NIL; VALUES.IVAL := 377777B;
17600		 END;
17700		ENTERID(CP);
17800		NEWZ(CP,KONST);						  %ALFALENG\
17900		WITH CP^ DO
18000		 BEGIN
18100		  NAME := 'ALFALENG  ';  IDTYPE := INTPTR;
18200		  NEXT := NIL; VALUES.IVAL := 10;
18300		 END;
18400		ENTERID(CP);
18500	(* 112 - maxint *)
18600		newz(cp,konst);
18700		with cp^ do
18800		  begin
18900		  name := 'MAXINT    '; idtype := intptr;
19000		  next := nil; values.ival := 377777777777B;
19100		  end;
19200		enterid(cp);
19300		CP1 := NIL;
19400		FOR I := 1 TO 2 DO
19500		 BEGIN
19600		  NEWZ(CP,KONST);				    %FALSE,TRUE\
19700		  WITH CP^ DO
19800		   BEGIN
19900		    NAME := NA[I]; IDTYPE := BOOLPTR;
20000		    NEXT := CP1; VALUES.IVAL := I - 1;
20100		   END;
20200		  ENTERID(CP); CP1 := CP
20300		 END;
20400		BOOLPTR^.FCONST := CP;
20500		FOR I := 3 TO 6 DO
20600		 BEGIN
20700		  NEWZ(CP,VARS); 	    %INPUT,OUTPUT,TTY,TTYOUTPUT\
20800	(* 171 - treat files as special *)
20900	          case i of
21000		  3:infile := cp; 4:outfile := cp; 5:ttyfile := cp; 6:ttyoutfile := cp
21100		  end;
21200		  WITH CP^ DO
21300		   BEGIN
21400	(* 173 - no channels any more *)
21500		    NAME := NA[I]; IDTYPE := TEXTPTR; CHANNEL := I-2;
21600		    VKIND := ACTUAL; NEXT := NIL; VLEV := 0;
21700		    VADDR:= LC;
21800		    LC := LC + 1 %BUFFERSIZE FOR TYPE CHAR\ + SIZEOFFILEBLOCK;
21900		    NEWZ(LFILEPTR) ;
22000		    WITH LFILEPTR^ DO
22100		     BEGIN
22200		      NEXTFTP := FILEPTR ;
22300		      FILEIDENT := CP ;
22400		     END ;
22500		    FILEPTR := LFILEPTR ;
22600		   END;
22700		  ENTERID(CP)
22800		 END;
22900		SFILEPTR := FILEPTR;	   %REMEMBER TOP OF STANDARD FILES\
23000	(* 16 - ADD DATA AT ENTRY *)
23100		CCLSW := LC; LC := LC+5;
23200	(* 66 - nonloc gotos *)
23300		globtopp := lc; lc:=lc+1; globbasis := lc; lc:=lc+1;
23400	(* 61 - allow us to distinguish tops10 and tops20 specific ftns *)
23500		if tops10
23600		  then othermachine := t20name
23700		  else othermachine := t10name;
23800	
23900		% GET,GETLN,PUT,PUTLN,RESET,REWRITE,READ,READLN,
24000		 WRITE,WRITELN,PACK,UNPACK,NEW,MARK,RELEASE,GETLINR,
24100		 PUT8BITSTOTTY,PAGE\
24200	
24300		FOR I := 7 TO 25 DO
24400	(* 61 - restrict tops10 and tops20 specific *)
24500		 if machna[i] # othermachine then
24600		 BEGIN
24700		  NEWZ(CP,PROC,STANDARD);
24800		  WITH CP^ DO
24900		   BEGIN
25000		    NAME := NA[I]; IDTYPE := NIL;
25100		    NEXT := NIL; KEY := I - 6;
25200		   END;
25300	
25400		  ENTERID(CP)
25500		 END;
25600	(* 10 - ADD SETSTRING *)
25700	(* 14 - AND OTHERS *)
25800	
25900	(* 27 - add NEWZ *)
26000	(* 61 - restrict tops10 and tops20 defn's *)
26100	(* 152 - DISPOSE *)
26200		FOR I := 54 TO 76 DO
26300		 if machna[i] # othermachine then
26400		 BEGIN
26500		  NEWZ(CP,PROC,STANDARD);
26600		  WITH CP^ DO
26700		   BEGIN
26800		    NAME := NA[I]; IDTYPE := NIL;
26900		    NEXT := NIL; KEY := I - 32;
27000		   END;
27100	
27200		 ENTERID(CP)
27300		END;
27400	
27500	(* 44 - add curpos and its arg *)
27600	        (* arg for CURPOS *)
27700		newz(cp1,vars);
27800		with cp1^ do
27900		  begin
28000		  name:='          ';idtype:=anyfileptr;
28100		  vkind:=formal;next:=nil;vlev:=1;vaddr:=2
28200		  end;
28300	
28400		(* CURPOS *)
28500	(* 47 - more of this kind now *)
28600	(* 61 - tops10 and tops20 specific functions *)
28700		FOR I:=77 TO 79 DO
28800		if machna[i] # othermachine then
28900		begin
29000		newz(cp,func,declared,actual);
29100		with cp^ do
29200		  begin
29300		  name := na[i]; idtype:=intptr; next:=cp1; forwdecl:=false;
29400		  externdecl := true; pflev:=0; pfaddr:=0; pfchain:=externpfptr;
29500		  externpfptr:=cp; for j:=0 to maxlevel do linkchain[j]:=0; externalname:=na[i];
29600		  language:=pascalsy
29700		  end;
29800		enterid(cp);
29900		end;
30000	
30100		NEWZ(CP,FUNC,DECLARED,ACTUAL);
30200		WITH CP^ DO
30300		 BEGIN
30400		  NAME := NA[26]; IDTYPE := DATEPTR; NEXT := NIL; FORWDECL := FALSE;
30500		  EXTERNDECL := TRUE; PFLEV := 0; PFADDR := 0; PFCHAIN := EXTERNPFPTR;
30600		  EXTERNPFPTR := CP; FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0; EXTERNALNAME := NA[26];
30700		  LANGUAGE := FORTRANSY
30800		 END;
30900		ENTERID(CP);
31000	
31100		% RUNTIME,TIME,ABS,SQR,TRUNC,ODD,ORD,CHR,PRED,SUCC,EOF,EOLN \
31200	
31300		FOR I := 27 TO 38 DO
31400		 BEGIN
31500		  NEWZ(CP,FUNC,STANDARD);
31600		  WITH CP^ DO
31700		   BEGIN
31800		    NAME := NA[I]; IDTYPE := NIL;
31900		    NEXT := NIL; KEY := I - 26;
32000		   END;
32100		  ENTERID(CP)
32200		 END;
32300	
32400		FOR I := 80 TO 81 DO
32500		 BEGIN
32600		  NEWZ(CP,FUNC,STANDARD);
32700		  WITH CP^ DO
32800		   BEGIN
32900		    NAME := NA[I]; IDTYPE := NIL;
33000		    NEXT := NIL; KEY := I - 66;
33100		   END;
33200		  ENTERID(CP)
33300		 END;
33400		NEWZ(CP,VARS); %PARAMETER OF PREDECLARED FUNCTIONS\
33500		WITH CP^ DO
33600		 BEGIN
33700		  NAME := '          '; IDTYPE := REALPTR;
33800		  VKIND := ACTUAL; NEXT := NIL; VLEV := 1; VADDR := 2
33900		 END;
34000	
34100		% SIN,COS,EXP,SQRT,ALOG,ATAN,ALOG10,
34200		 SIND,COSD,SINH,COSH,TANH,ASIN,ACOS,RAN \
34300	
34400		FOR I := 39 TO 53 DO
34500		 BEGIN
34600		  NEWZ(CP1,FUNC,DECLARED,ACTUAL);
34700		  WITH CP1^ DO
34800		   BEGIN
34900		    NAME := NA[I]; IDTYPE := REALPTR; NEXT := CP;
35000		    FORWDECL := FALSE; EXTERNDECL := TRUE; PFLEV := 0; PFADDR := 0;
35100		    PFCHAIN:= EXTERNPFPTR; EXTERNPFPTR:= CP1; EXTERNALNAME := EXTNA[I];
35200		    FOR J := 0 TO MAXLEVEL DO LINKCHAIN[J] := 0; LANGUAGE := EXTLANGUAGE[I]
35300		   END;
35400		  ENTERID(CP1)
35500		 END;
35600		LCMAIN := LC;
35700	       END %ENTERSTDNAMES\ ;
35800	
35900	      PROCEDURE ENTERUNDECL;
36000	      VAR
36100		I: INTEGER;
36200	       BEGIN
36300		NEWZ(UTYPPTR,TYPES);
36400		WITH UTYPPTR^ DO
36500		 BEGIN
36600		  NAME := '          '; IDTYPE := NIL; NEXT := NIL;
36700		 END;
36800		NEWZ(UCSTPTR,KONST);
36900		WITH UCSTPTR^ DO
37000		 BEGIN
37100		  NAME := '          '; IDTYPE := NIL; NEXT := NIL;
37200		  VALUES.IVAL := 0
37300		 END;
37400		NEWZ(UVARPTR,VARS);
37500		WITH UVARPTR^ DO
37600		 BEGIN
37700		  NAME := '          '; IDTYPE := NIL; VKIND := ACTUAL;
37800		  NEXT := NIL; VLEV := 0; VADDR := 0
37900		 END;
38000	(* 135 - UARRPTR is needed as dummy to prevent ill mem ref in PACK/UNPACK *)
38100		NEWZ(UARRTYP,ARRAYS);
38200		WITH UARRTYP^ DO
38300		  BEGIN
38400		  ARRAYPF := FALSE; SELFSTP := NIL; AELTYPE := NIL;
38500		  INXTYPE := NIL; SIZE := 777777B; BITSIZE := 36
38600		  END;
38700		NEWZ(UFLDPTR,FIELD);
38800		WITH UFLDPTR^ DO
38900		 BEGIN
39000		  NAME := '          '; IDTYPE := NIL; NEXT := NIL; FLDADDR := 0;
39100		  PACKF := NOTPACK
39200		 END;
39300		NEWZ(UPRCPTR,PROC,DECLARED,ACTUAL);
39400		WITH UPRCPTR^ DO
39500		 BEGIN
39600		  NAME := '          '; IDTYPE := NIL; FORWDECL := FALSE;
39700		  FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0;
39800		  NEXT := NIL; EXTERNDECL := FALSE; PFLEV := 0; PFADDR := 0
39900		 END;
40000		NEWZ(UFCTPTR,FUNC,DECLARED,ACTUAL);
40100		WITH UFCTPTR^ DO
40200		 BEGIN
40300		  NAME := '          '; IDTYPE := NIL; NEXT := NIL;
40400		  FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0;
40500		  FORWDECL := FALSE; EXTERNDECL := FALSE; PFLEV := 0; PFADDR := 0
40600		 END;
40700	(* 64 - non-loc gotos *)
40800		newz(ulblptr,labelt);
40900		with ulblptr^ do
41000		  begin
41100		  name := '          '; idtype := nil; next := nil;
41200		  scope := 0; gotochain := 0; labeladdress := 0;
41300		  end;
41400	       END %ENTERUNDECL\ ;
41500	
41600	      PROCEDURE ENTERDEBNAMES;
41700	      VAR
41800		CP:CTP;
41900	       BEGIN
42000		NEWZ(CP,PROC,STANDARD);
42100		WITH CP^ DO
42200		 BEGIN
42300		  NAME := 'PROTECTION';
42400		  IDTYPE := NIL; NEXT := NIL; KEY:= 21
42500		 END;
42600		ENTERID(CP);
42700	       END;
42800	
42900	(* 4 - replace file name scanner with call to SCAN *)
43000	(* 11 - new definition of PASPRM *)
43100	     FUNCTION PASPRM(VAR I,O:TEXT;VAR R:INTFILE):RPGPT; EXTERN;
43200	
43300	(* 104 - improved error detection in tops10 *)
43400	(* 107 - moved declaration of analys earlier *)
43500	
43600	     BEGIN
43700	      %ENTER STANDARD NAMES AND STANDARD TYPES:\
43800	      %****************************************\
43900	
44000	(* 41 - make restartable *)
44100	      reinit;
44200	
44300	      RTIME := RUNTIME; DAY := DATE;
44400	      LEVEL := 0; TOP := 0;
44500	      WITH DISPLAY[0] DO
44600	       BEGIN
44700	(* 5 - create block name for CREF *)
44800		FNAME := NIL; OCCUR := BLCK; BLKNAME := '.PREDEFIN.';
44900	       END;
45000	      ENTERSTDTYPES; ENTERSTDNAMES; ENTERUNDECL; ENTERDEBNAMES;
45100	
45200	      TOP := 1; LEVEL := 1;
45300	      WITH DISPLAY[1] DO
45400	       BEGIN
45500	(* 5 - create block name for CREF *)
45600		FNAME := NIL; OCCUR := BLCK; BLKNAME := '.GLOBAL.  ';
45700	       END;
45800	
45900	      %OPEN COMPILER FILES\
46000	      %*******************\
46100	
46200	(* 4 - here we open the files that SCAN gave us *)
46300	      REWRITE(TTYOUTPUT);
46400	      SCANDATA := PASPRM(INPUT,OUTPUT,OUTPUTREL);
46500	      WITH SCANDATA ^ DO
46600	       BEGIN
46700	(* 33 - VERSION NO *)
46800	       VERSION.WORD := VERVAL;
46900	(* I haven't figured out what to do about lookup blocks.  Commented out for now *)
47000	(* 104 - fix error detection on tops10 *)
47100	       if tops10 
47200	         then reset(input,'',true,lookblock,40000B,4000B)  {tag for SOS}
47300	 	 else reset(input,'',0,0,0,20B);  {see EOL char's}
47400	       if eof		{tag for SOS}
47500		 then begin
47600		 analys(input);
47700		 pasxit(input,output,outputrel);
47800		 end;
47900	       get(input);		     {tag for SOS}
48000	       IF VERSION.WORD = 0 THEN VERSION.WORD := LOOKBLOCK[6];
48100	       LOOKBLOCK[6] := VERSION.WORD;
48200	       FOR I := 1 TO 5 DO LOOKBLOCK[I] := 0;
48300	       REWRITE(OUTPUT,'',0,LOOKBLOCK);  {tag for SOS}
48400	       FOR I := 1 TO 5 DO LOOKBLOCK[I] := 0;
48500	       REWRITE(OUTPUTREL,'',0,LOOKBLOCK);  {tag for SOS}
48600	       FILENAME := RELNAME;
48700	(* 34 - DON'T NEED ENTRY NOW *)
48800	       IF FILENAME = '          '
48900	         THEN FILENAME := '.NONAM    '; %A BLANK ENTRY NAME IS BAD NEWS\
49000	       LISTCODE := LSW;
49100	       TTYINUSE := TSW;
49200	       MAIN := MSW;
49300	       RUNTMCHECK := CSW;
49400	(* 160 - compiler switch /ARITHCHECK *)
49500	       ARITHCHECK := ASW;
49600	       DEBUGSWITCH := DSW;
49700	       CREF:=CRSW;
49800	       DEBUG := DSW;
49900	       RPGENTRY := RPGSW;
50000	(* 7 - ADD /HEAP SWITCH *)
50100	(* 12 - /heap no longer needed *)
50200	(* 24 - /HEAP AND /STACK NOW USED FOR START ADDR *)
50300		
50400	       HEAP := HEAPVAL;
50500	       STACK := STACKVAL;
50600	(* 25 - /ZERO *)
50700	       ZERO := ZSW
50800	       END;
50900	
51000	      %WRITE HEADER\
51100	      %************\
51200	
51300	(* 136 - listing format *)
51400	      pagehead;
51500	      %NEW LINE FOR ERROR MESSAGES OR PROCEDURENAMES\
51600	      GETNEXTLINE;     %GETS FIRST LINENUMBER IF ANY\
51700	      CH := ' '; INSYMBOL; RESETFLAG := FALSE;
51800	       IF NOT MAIN
51900	       THEN
52000		 BEGIN
52100		  LC := PROGRST; LCMAIN := LC;
52200		  WHILE SFILEPTR # NIL DO
52300		  WITH SFILEPTR^, FILEIDENT^ DO
52400		   BEGIN
52500		    VADDR:= 0; SFILEPTR:= NEXTFTP
52600		   END;
52700		  SFILEPTR := FILEPTR;
52800		 END;
52900	
53000		%COMPILE:\
53100		%********\
53200	
53300	(* 5 - CREF *)
53400	      IF CREF
53500	        THEN WRITE(CHR(15B),CHR(10),'.GLOBAL.  ');
53600	
53700	      FOR I := 1 TO CHCNTMAX DO ERRLINE[I] := ' '; RELBLOCK.COUNT:= 0;
53800	      FOR SUPPORTIX := FIRSTSUPPORT TO LASTSUPPORT DO RNTS.LINK[SUPPORTIX] := 0;
53900	
54000	(* 6 - allow PROGRAM statement *)
54100	      PROGSTAT;
54200	(* 13 - PRINT HEADER NOW THAT HAD PROG STATEMENT SCANNED *)
54300	      IF RPGENTRY
54400	       THEN WRITELN(TTY,'PASCAL:',CHR(11B),FILENAME:6);
54500	(* 41 - Don't print header *)
54600	(* 26 - break not needed for TTY *)
54700	      BLOCK(NIL,BLOCKBEGSYS OR STATBEGSYS-[CASESY],[PERIOD]);
54800	
54900	(* 104 - detect programs that don't fit in address space *)
55000	(* 216 - settable highseg start *)
55100	      if (highestcode > maxaddr) or (lcmain >= highstart)
55200		then error(266);
55300	
55400	(* 5 - CREF *)
55500	      IF CREF
55600	        THEN WRITE(CHR(16B),CHR(10),'.GLOBAL.  ');
55700	
55800	(* 16 - EOF *)
55900	      ENDOFLINE(TRUE);
56000	(* 5 - CREF *)
56100	      if cref and not eof(input)
56200		then write(chr(177B),'A'); %balances <ro>B from ENDOFLINE\
56300	(* 136 - LISTING FORMAT *)
56400	      NEWLINE ; NEWLINE ;
56500	       IF NOT ERRORFLAG
56600	       THEN
56700		 BEGIN
56800	(* 4 - Make us look normal if called by COMPIL *)
56900		  WRITE('No ') ; IF NOT RPGENTRY THEN WRITE(TTY,'No ')
57000		 END
57100	       ELSE WRITE(TTY,'?');
57200	(* 136 - LISTING FORMAT *)
57300	      WRITE('error detected') ; NEWLINE;
57400	      IF (NOT RPGENTRY) OR ERRORFLAG 
57500	        THEN
57600	(* 26 - break not needed for TTY *)
57700	          WRITELN(TTY,'error detected');
57800	       IF ERRORFLAG
57900	(* 112 - clrbfi when error *)
58000		THEN BEGIN
58100		REWRITE(OUTPUTREL);
58200	        clribf;
58300	        end
58400	       ELSE IF NOT RPGENTRY THEN
     
00100		 BEGIN
00200	(* 136 - LISTING FORMAT *)
00300		  WRITELN(TTY); NEWLINE;
00400	(* 216 - allow start of high seg other than 400000 *)
00500		  I := (HIGHESTCODE - HIGHSTART + 1023) DIV 1024;
00600		  WRITELN(TTY,'Highseg: ',I:3,'K'); WRITELN('Highseg: ',I:3,'K');
00700		  I := (LCMAIN + 1023) DIV 1024;
00800		  WRITELN(TTY,'Lowseg : ',I:3,'K'); WRITELN('Lowseg : ',I:3,'K');
00900		 END;
01000	(* 4 - Make us look normal if called by COMPIL *)
01100	      IF  NOT RPGENTRY THEN BEGIN
01200	      RTIME := RUNTIME - RTIME;
01300	      WRITE(TTY,'Runtime: ',(RTIME DIV 60000):3,':');
01400	      RTIME := RTIME MOD 60000;
01500	      WRITE(TTY,(RTIME DIV 1000):2,'.');
01600	      RTIME := RTIME MOD 1000;
01700	      WRITELN(TTY,RTIME:3)
01800	(* 4 - get back to SCAN if appropriate *)
01900	      END;
02000	     PASXIT(INPUT,OUTPUT,OUTPUTREL)
02100	     END.