Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-07 - 43,50433/pascmp.pas
There are 4 other files named pascmp.pas in the archive. Click here to see a list.
00100	  %$L-,C-,D-,T-,V:001200000214B\
00200	program pascmp;
00300	 include 'pasprm.pas';   (* set up tops10 and tops20 *)
00400	  %*********************************************************
00500	   *							   *
00600	   *							   *
00700	   *	 STEP-WISE DEVELOPMENT OF A PASCAL COMPILER	   *
00800	   *	 ******************************************	   *
00900	   *							   *
01000	   *							   *
01100	   *	 STEP 5:   SYNTAX ANALYSIS INCLUDING ERROR	   *
01200	   *		   HANDLING; CHECKS BASED ON DECLARA-	   *
01300	   *	 15/3/73   TIONS; ADDRESS AND CODE GENERATION	   *
01400	   *		   FOR A HYPOTHETICAL STACK COMPUTER	   *
01500	   *							   *
01600	   *							   *
01700	   *	 AUTHOR:   URS AMMANN				   *
01800	   *		   FACHGRUPPE COMPUTERWISSENSCHAFTEN	   *
01900	   *		   EIDG. TECHNISCHE HOCHSCHULE		   *
02000	   *	   CH-8006 ZUERICH				   *
02100	   *							   *
02200	   *	 CODE GENERATION FOR DECSYSTEM 10 BY		   *
02300	   *	 C.-O. GROSSE-LINDEMANN, F.-W. LORENZ,		   *
02400	   *	 H.-H. NAGEL, P.J. STIRL			   *
02500	   *							   *
02600	   *	 MODIFICATIONS TO GENERATE RELOCATABLE OBJECT CODE *
02700	   *	 BY E. KISICKI (DEC 74) 			   *
02800	   *							   *
02900	   *	 DEBUG SYSTEM BY P. PUTFARKEN (DEC 74)		   *
03000	   *							   *
03100	   *	 INSTITUT FUER INFORMATIK, D-2 HAMBURG 13,	   *
03200	   *	 SCHLUETERSTRASSE 70 / GERMANY			   *
03300	   *							   *
03400	   *							   *
03500	   *********************************************************\
03600	
03700	
03800	
03900	  %	  HOW  TO  GENERATE  A	NEW  PASCAL  COMPILER
04000	
04100	   SOURCES:
04200	   A) ASCII:	  PASREL.PAS
04300			  RUNTIM.MAC
04400			  DEBSUP.MAC
04500			  DEBUG .PAS
04600	   B) BINARY:	  PASREL.SHR
04700			  PASREL.LOW
04800			  PASLIB.REL (CHECK INITPROCEDURE "SEARCH LIBRARIES")
04900	
05000	   !              IF THE NEW COMPILER SHOULD NOT BE MADE AVAILABLE FOR GENERAL USE ON SYS,
05100	   !		  ENTER THE APPROPIATE DIRECTORY SPECIFICATIONS IN INITPROCEDURE "SEARCH LIBRARIES"
05200	
05300	
05400	  STEP			  ACTION
05500	
05600	  0	  SAVE ALL SOURCE FILES ON DECTAPES!!
05700	  1	  .COPY PASLBN.REL=PASLIB.REL
05800	  2	  IF THERE ARE NO CHANGES TO RUNTIM.MAC, DEBSUP.MAC, OR DEBUG.PAS
05900		  THEN GOTO STEP 9
06000	  3	  UPDATE RUNTIM.MAC
06100	  4	  ASSEMBLE   "		  -->	  RUNTIM.REL
06200	  5	  UPDATE DEBSUP.MAC
06300	  6	  ASSEMBLE   "		  -->	  DEBSUP.REL
06400	  7	  UPDATE DEBUG.PAS
06500		  .RUN PASREL
06600		  *DEBUG.PAS		  -->	  DEBUG.REL
06700	  8	  .R FUDGE2
06800		  *PASLBN.REL=PASLBN.REL<RUNSP>,RUNTIM.REL<RUNSP>(R)$
06900		  *PASLBN.REL=PASLBN.REL<DEBSP>,DEBSUP.REL<DEBSP>(R)$
07000		  *PASLBN.REL=PASLBN.REL<DEBUG>,DEBUG.REL<DEBUG>(R)$
07100		  *^C
07200					  -->	  PASLBN.REL
07300	  9	  UPDATE PASREL.PAS
07400		  UPDATE "HEADER" IN PASREL.PAS
07500		  IF THERE ARE NEW ENTRIES TO RUNSP OR DEBSP
07600		  CHECK
07700		  INITPROCEDURE "RUNTIME-, DEBUG-SUPPORTS", "SUPPORTS"
07800		    AND
07900		  PROCEDURE "SUPPORT"
08000	  10		.RUN PASREL
08100		      	*PASREL.PAS	      -->     PASREL.REL
08200	  11      	.LOAD PASREL,/SEARCH PASLBN.REL
08300	      		.SSAVE PASREL 36      -->     PASREL.SHR
08400	      					      PASREL.LOW
08500	
08600				      36 K CORE ONLY IF NO RUNTIMECHECK (C-) AND NO DEBUG OPTION (D-) , OTHERWISE MORE !
08700	
08800	  12      	.RENAME PAS1.PAS=PASREL.PAS
08900	  13      	.RUN PASREL
09000	      		*PAS1.PAS 	      -->     PAS1.REL
09100	  14      	.LOAD PAS1,/SEARCH PASLBN.REL
09200	      		.SSAVE PAS1 36	      -->     PAS1.SHR
09300	      					      PAS1.LOW
09400	  14.1    	.RENAME PAS2.PAS=PAS1.PAS
09500	  14.2    	.RUN PAS1
09600	      		*PAS2.PAS 	      -->      PAS2.REL
09700	  14.3    	.LOAD PAS2,/SEARCH PASLBN.REL
09800	      		.SSAVE PAS2 36	      -->      PAS2.SHR
09900	      				      -->      PAS2.LOW
10000	  15      	.R FILCOM
10100	      		*TTY:=PAS2.LOW,PAS1.LOW
10200	      		NO DIFFERENCES ENCOUNTERED
10300	      		*TTY:=PAS2.SHR,PAS1.SHR
10400	      		FILE 1) DSK:PAS2.SHR  CREATED: XXX
10500	      		FILE 2) DSK:PAS1.SHR  CREATED: XXX
10600	      		400005  604163 XXXXXX   604163 XXXXXX	     XXXXXX
10700	      		%FILES ARE DIFFERENT
10800	
10900	  16      	.DELETE PASREL.*,PAS1.*,PAS2.REL,PASLIB.REL
11000	       		.PRINT PAS2.LST
11100	       		.RENAME PASREL.*=PAS2.*
11200			.RENAME PASLIB.REL=PASLBN.REL
11300	
11400	
11500	  *******************************************************************\
11600	
11700	       %HINTS FOR INTERPRETING ABBREVIATED IDENTIFIERS
11800	       BRACK  : BRACKET "[ ]"	       IX  : INDEX
11900	       C  : CURRENT		       L  : LOCAL
12000	       C  : COUNTER		       L  : LEFT
12100	       CST  : CONSTANT		       PARENT  : "( )"
12200	       CTP  : IDENTIFIER POINTER       P/PTR  : POINTER
12300	       EL  : ELEMENT		       P/PROC  : PROCEDURE
12400	       F  : FORMAL		       R  : RIGHT
12500	       F  : FIRST		       S  : STRING
12600	       F  : FILE		       SY  : SYMBOL
12700	       F/FUNC  : FUNCTION	       V  : VARIABLE
12800	       G  : GLOBAL		       V  : VALUE
12900	       ID  : IDENTIFIER
13000	       REL  : RELATIVE		       REL  : RELOCATION\
13100	
13200	(*LOCAL CHANGE HISTORY
13300		1	CLEAN UP COMMENT SCANNING AND ALLOW /* */ BRACKETS.
13400			NOTE THAT THIS \ WOULD HAVE TERMINATED THIS COMMENT
13500			PRIOR TO FIX.
13600		2	INCREASE STACKANDHEAP, GET CORE IF NEEDED ON PROGRAM
13700			ENTRY, FIX PARAMETER PASSING BUG, LOAD PASREL FROM
13800			SYS: INSTEAD OF DSK:, GENERATE FLOAT AND FIX INLINE.
13900			(FROM HEDRICK)
14000		NB:	RUNTIM has now been modified to pass all characters,
14100			including control characters as well as lower case.
14200			It no longer turns tabs into spaces.  Thus it was
14300			necessary to put this file through a program that
14400			expanded tabs into spaces when they were in strings.
14500			Thus FILCOM with the old version should specify /S
14600			or lots of irrelevant differences will be found.
14700		3	MAP LOWER CASE TO UPPER EXCEPT IN STRINGS.  (DOESN'T
14800			SOLVE THE PROBLEM ABOUT SETS, THOUGH.)  HEDRICK.
14900		4	use SCAN for file spec's, and fix to be called by
15000			COMPIL.  Hedrick.
15100		5	add /CREF switch.  Hedrick.
15200		6	allow PROGRAM statement.  Syntax check but ignore it.
15300			fix bug that caused lower case char. after a string to put compiler in loop
15400			allow <> for #
15500			allow LABEL declaration.  Syntax check bug ignore it.
15600			with /CREF/OBJ put only 3 instructions per line (4
15700			  overflow a LPT line)
15800			use standard PACK and UNPACK
15900			catch illegal characters
16000		7	add /HEAP switch for size of stack and heap
16100			treat lower case as upper in sets
16200		10	Add STRSET and STRWRITE - equivalent to RESET and
16300			REWRITE, but sets I/O into string
16400			also GETINDEX, CLOSE, ROUND, CALLI
16500			ALSO REDID RESET/REWRITE TO TAKE GOOD FILE NAMES
16600		11	Modify compiler to use new RESET/REWRITE.
16700		12	Make PASCAL programs self-expanding
16800		13	ADD DDT SYMBOL NAMES FOR ROUTINES(BLOCK-STRUCTURED)
16900			use PROGRAM name as module and entry name
17000			allow strset/write on non-TEXT files
17100			add opt. 4th arg to strset/write: limit
17200		14	allow read of string - gets rest of line
FIX ILL MEM REF IN READREADLN
21500			ADD ERR MSG FOR ASSIGN TO FTN NAME OUTSIDE BODY
21600		32	add APPEND
21700		33	full implementation of PROGRAM statement
21800			version numbering of output files and program
21900			allow proc and func as parameters
22000			remove LOC (subsumed by above)
22100			add $V directive for version number
22200		34	allow list of entry points in PROGRAM statement
22300		35	fix error recovery in BLOCK, especially for /NOMAIN
22400		36	ALLOW DEBUGGING MULTIPLE FILES
22500			remove T- option
22600			NB: I have not removed the variables for T-, and also
22700			  supports exist for indeb. and exdeb., though they
22800			  are no longer used in PASCMP.
22900		37	fix bug in static link for level one proc's
23000		40	use RESDEV as external name for DISMISS
23100			by default put request for PASLIB before FORLIB
23200			improve format of /OBJECT listing
23300			fix arg's to predefined functions
23400			fix comparison of unpacked strings
23500		41	make it restartable
23600			change kludge for file OUTPUT
23700		42	allow variable records for GET,PUT,and DUMPx
23800			Currently DUMPx implemented in kludgey way.
23900		43	add 5 locations to file block for new runtimes
24000			add PUTX
24100			add optional arg to useti
24200			allow 12 digit octal number
24300		44	Add SETPOS and CURPOS to compiler
24400		45	Add NEXTBLOCK to compiler and make check for
24500			AC overlap with APPEND,UPDATE
24600		46	Repair CALLI to use 1 for true, and accept all
24700			 possible argument formats.
24800		47	Add some more functions
24900			Repair calculations for NEW with packed arrays
25000		50	Generate correct code for 400000,,0
25100			Reinitialize file ctl blocks at start
25200			Don't open INPUT or OUTPUT unless asked
25300		51	Allow mismatch of byte size for SETSTRING
25400			Fix GETLINENR
25500		52	Fixes from CMU:
25600			To CALLNONSTANDARD: when depositing directly into
25700			  display, moved 2 ac's for all arg's of size 2,
25800			  without checking to see if VAR.  Assumed AC was
25900			  unchanged by BLT.
26000			To SIMPLEEXPRESSION: optimization sometimes negated
26100			  a real constant.  If had been declared by CONST,
26200			  future ref's were to the negated quantity!
26300		53	Problems with dynamic memory expansion:
26400			Arbitrarily asked for 40b more locations above
26500			  end of stack (for runtimes).  But some odd
26600			  procedure calls use more.  Need to figure out
26700			  how much memory is used.
26800			CORERR just allocated memory up to (P).  Should
26900			  be 40(P), or however much is really needed.
27000			So add STKOFFMAX, to keep track of how much
27100			  really needed.  CORALLOC is addr of the test for
27200			  sufficient memory, fixed up.
27300		54	More dynamic memory: Need to accumulate offsets
27400			  above top of stack, in case of
27500			  x(1,2,3,4,5,f(1,2,3,4,5,6)), etc., though an
27600			  actual problem seems a bit unlikely.
27700		55	Add require source file feature
27800		56	Clean up syntax for require file
27900		57	add tops20 version
28000		60	make tops20 strings work more like tops10
28100		61	add jsys pseudo-runtime
28200			add tops20 runtimes and restrict runtimes that work only on one system
28300			add +*@ after file name to control gtfjn in tops20
28400		62	make sure there is never data above the stack pointer
28500		63	convert time, runtime, setuwp for tops20
28600		64	input:/ for tops-20
28700			empty entry in record
28800			non-local goto's
28900			fix procedure param's if not in ac's
29000		65	allow extra semicolon in case
29100			remove references to exit labels
29200		66	speed up non-local goto's
29300		67	fix external proc's as proc param's
29400		70	fix ill mem ref if certain errors in type decl
29500		71	make file name in fcb be 7 bit for tops20
29600		72	make two fixup chains for 2 word constants, to
29700			prevent giving LINK an ill mem ref
29800		73	make new use getfn for file names, to get EXTERN files
29900		74	allow new init. so tops10 version can work with emulator
30000		75	fix non-loc goto's - typo made goto chain bad
30100		76	allow a set in reset/rewrite to specify bits.
30200			allow break char set in read/readln
30300		77	fix jsys and reset set arguments
30400		100	fix ac usage in readreadln from strings
30500	        101	fix fltr and fix code generation
30600		102	Add klcpu - put improved packed array code under it
30700		103	Fix pointer to global symbol table in case that level
30800			has already been output by some inner procedure
30900		104	Check stack overflow
31000			Check to be sure structures aren't too big
31100			Range check subranges in for loop and value parameters
31200		105	Use tables instead of -40B to convert from lower case
31300		106	Make subranges of reals illegal
31400		107	Abort creation of .REL file on all errors
31500		110	Allow [x..y] set construct
31600		111	Allow STRING and POINTER parameters to EXTERN proc's
31700		112	Clrbfi when error detected.  Bounds check sets [a..b]
31800		113	Make real number reader handle exact things exactly
31900			Don't demand foward type ref's resolved at end of require file
32000		114	Write local fixups even if only non-loc gotos
32100			Make CREF not say .FIELDID. for local gotos
32200			maxint = 377777777777B
32300		115	Make tops10=false, kl=false work (tenex)
32400		116	IDRECSIZE entries for param, labelt type
32500			Make NEXT NIL instead of 0 when not used, for COPYCTP
32600		117	Fix enumerated type in record
32700		120	Make initialization routine use JSP, for T20/Tenex so
32800			don't have ill mem ref if emulator present
32900		121	Initialize CODEARRAY: fix bollixed INITPROC's
33000		122	KA's.  This includes fixing COPYSTP so it doesn't
33100			 try to follow NIL pointers.  Harmless if 377777 is a
33200			 legal address, but it isn't for KA's.
33300		123	Do POPF when can't find included file, so close gets done.
33400		124	Limit initprocedures to top level.
33500			Initialize CREF off
33600		125	Do POPF when expected eof inside included file.
33700		126	Detect procedures not beginning with BEGIN
33800		127	INit CREF to FALSE, fix [const..var] set construct
33900		130	Fix KA bug wherein random word in core image is garbage
34000		131	Move cixmax to pasprm.pas so tops20 can use big value
34100		132	Replace KA10 with KACPU for op codes and NOVM for old
34200			memory allocation.
34300		133	Fix JSYS to allow functions within it.  Garbaged stack.
34400		134	Allow DELETE in Tops-10, too.
34500		135	Fix LOG2 for big numbers.  Prevent ill mem ref's in
34600			PACK and UNPACK with syntax errors.
34700		136	Add header line at top of each page with pg. number
34800		137	Reset line no. to 1 at start of page.
34900			Fix bug in set constructors for CHAR
35000		140	Chnage order of SETMAP to closer to ASCII collating seq.
35100		141	Fix problem where REGC gets messed up by array subscript
35200			 calculations when ONFIXEDREGC is in effect.
35300			Detect overflow in number scanning with JFCL.
35400		142	Make real number scanner scan anything legitimate
35500		143	Redo I/O to string in Tops-10 for new runtimes and fix
35600			 onfixedregc code for packed arrays
35700		144	Allow :/ in program and :@ in reset for Tops-10
35800		145	Change external name of GET to GET. for Wharton
35900		146	Reinit count in putrelcode to avoid garbage in .REL file
36000		147	Lines start with 2 on new pages.
36100		150	Fix bug in forward type references,
36200			error recovery in fieldlist if garbage case type
36300			symbol table in forward proc's for debugger
36400		151	Fix reversed args in I,J:INTEGER in procedure decl.
36500		152	Add DISPOSE
36600		153	Fix some reg usage problems with DISPOSE
36700		154	More reg usage problems with DISPOSE
36800		155	Source file name in DEBUG block
36900		156	Detect FTNNAME^.field := value.  Only bare ftn name
37000			allowed on LHS of assignment.
37100		157	Add $A- to turn off arith check
37200		160	Add compiler switch /ARITHCHECK
37300		161	fix STRINg and POINTER
37400		162	fix REGSIZE
37500		163	fix TIME for Tops-20
37600		164	use Polish fixups in CASE
37700		165	in type decl, make sure ^THING gets local defn of THING,
37800			even if it happens later and there is a higher level defn.
37900			(This requires treating ^THING as forward always.)
38000		166	make assignment to func id from inner func work
38100			initialize frecvar in fieldlist, to prevent ill mem ref
38200			  with null record decl.
38300		167	improvements to edit 165
38400		170	more improvements to 165 (this time to error handling)
38500		171	allow read into packed objects
38600			allow read and write of binary files
38700			make sure default file names don't use user-declared INPUT,
38800			   and OUTPUT
38900			fix NEW of pointer that is part of packed array
39000		172	option string as third arg of RESET, etc.
39100			evaluate upper bound of FOR statement only once
39200		173	allow files in any context; internal files
39300		174	fix to initprocedures from Hisgen
39400		175	make getfn take a param telling runtime validity check
39500			needed.  SETSTRING, etc., do not
39600		176	better unterminated-comment error messages
39700		177	fix AC allocation in GETFILENAME
39800		200	fix addressing problem in loading file pointers
39900		201	make most manipulation of zero size objects be no-op.
40000			Previously one might stomp on the next variable.
40100		202	insufficient initialization before RESET(TTY), etc.
40200			fix POINTER passed by ref
40300		203	fix glitch in edit 202
40400		204	don't validity check the FCB for CLOSE, RCLOSE, and DISMISS
40500		205	fix AC in RENAME
40600		206	allow constants in WRITE statements for FILE OF INTEGER, etc.
40700		207	fix AC in GETFILENAME (again...)
40800		210	Allow 9 digit HEX numbers
40900		211	Fix output of string constants in .REL file
41000		212	Better error message if INPUT or OUTPUT redefined
41100		213	Fix procedure exit code if there is local variable
41200		214	Make debugger see locals of forward declared proc's
41300	*)
41400	
41500	    CONST
41600	      HEADER = 'PASCAL %12(214)';
41700	
41800	      DISPLIMIT = 20; MAXLEVEL = 8;
41900	      STRGLGTH = 120; BITMAX = 36;
42000	(* 43 - longer file block for new runtimes *)
42100	      SIZEOFFILEBLOCK=43B ;  {plus size of component}
42200	      OFFSET=40B;	%FUER SETVERARBEITUNG DER ASCIICHARACTER\
42300	      CHCNTMAX = 132;	%MAXIMUM OF CHARACTERS IN ONE LINE\
42400	      LEFT = 2;RIGHT = 1;BOTH = 3;NO = 0;
42500	
42600	      %KONSTANTEN VON BODY: \
42700	      %*********************\
42800	
42900	(* move cixmax to param file *)
43000	      HWCSTMAX = 377777B;		  LABMAX = 20;
43100	(* 2 - increase default stack space *)
43200	(* 7 - stackandheap now set by switch *)
43300	(* 137 - fix set constructor for CHAR *)
43400	      MAXERR = 4;		  BASEMAX = 71;		CHARMAX = 177B;
43500	
43600	      %ADDRESSES:
43700	       **********\
43800	
43900	      HAC=0;		%HILFSREGISTER\
44000	      TAC=1;		%HILFSREGISTER AUCH FUER BYTEPOINTER\
44100	      REGIN=1;		%INITIALISE REGC\
44200	      PARREGCMAX=6;	%HIGHEST REGISTER USED FOR PARAMETERS\
44300	      WITHIN=12;	%FIRST REGISTER FOR WITHSTACK\
44400	      NEWREG=13;	%LAST PLACE OF NEW-STACK\
44500	      BASIS=14; 	%BASIS ADDRESS STACK\
44600	      TOPP=15;		%FIRST FREE PLACE IN DATASTACK\
44700	      PROGRST = 145B;	%LOC 140B..144B RESERVED FOR DEBUG-PROGR.\
44800	      HIGHSTART=400000B;
44900	      MAXADDR=777777B;
45000	
45100	
45200	
45300	
45400	
45500	    TYPE
45600	      %DESCRIBING:\
45700	      %***********\
45800	
45900	
46000	      %BASIC SYMBOLS\
46100	      %*************\
46200	
46300	      SYMBOL = (IDENT,INTCONST,REALCONST,STRINGCONST,NOTSY,MULOP,ADDOP,RELOP,
46400			LPARENT,RPARENT,LBRACK,RBRACK,COMMA,SEMICOLON,PERIOD,ARROW,
46500			COLON,BECOMES,LABELSY,CONSTSY,TYPESY,VARSY,VALUESY,FUNCTIONSY,
46600	(* 6 - add PROGRAM statement *)
46700	(* 56 - ADD INCLUDE *)
46800			PROCEDURESY,SETSY,PACKEDSY,ARRAYSY,RECORDSY,FILESY,FORWARDSY,PROGRAMSY,INCLUDESY,
46900			BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITHSY,LOOPSY,
47000			GOTOSY,EXITSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY,
47100			EXTERNSY,PASCALSY,FORTRANSY,ALGOLSY,COBOLSY,
47200			THENSY,OTHERSY,INITPROCSY,OTHERSSY);
47300	
47400	      OPERATOR = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,LTOP,LEOP,GEOP,GTOP,
47500			  NEOP,EQOP,INOP,NOOP);
47600	
47700	      SETOFSYS = SET OF SYMBOL;
47800	
47900	(* 23 - check for bad pointer *)
48000	(* 24 - ONLY CLEAR NEW WHEN TYPECHECKING *)
48100	(* 104 - new tops10 stackoverflow *)
48200	(* 152 - DISPOSE *)
48300	      SUPPORTS = (FIRSTSUPPORT,STACKOVERFLOW,DEBSTACK,BADPOINT,ALLOCATE,CLEARALLOC,DEALLOCATE,
48400	(* 173 - internal files *)
48500			  WITHFILEDEALLOCATE,
48600	(* 43 - add PUTX *)
48700	(* 64 - non-loc goto *)
48800			  EXITGOTO,EXITPROGRAM,GETLINE,GETFILE,PUTLINE,PUTFILE,PUTXFILE,
48900	(* 57 - Add strset and strwrite external routines *)
49000			  RESETFILE,REWRITEFILE,RESETSTRING,REWRITESTRING,GETCHARACTER,PUTPAGE,ERRORINASSIGNMENT,
49100	(* 173 - internal files *)
49200			  FILEUNINITIALIZED,INITFILEBLOCK,
49300			  WRITEPACKEDSTRING,WRITESTRING,WRITEBOOLEAN,READCHARACTER,READINTEGER,READREAL,
49400	(* 171 - RECORD READ/WRITE *)
49500	(* 206 - extend for constants *)
49600			  READRECORD,WRITERECORD,WRITESCALAR,
49700			  BREAKOUTPUT,OPENTTY,INITIALIZEDEBUG,ENTERDEBUG,INDEXERROR,WRITEOCTAL,WRITEINTEGER,WRITEREAL,
49800	(* 10 add CLOSE *)
49900			  WRITEHEXADECIMAL,WRITECHARACTER,CONVERTINTEGERTOREAL,
50000	(* 14 and lots more *)
50100	(* 33 - PROGRAM statement *)
50200			  CONVERTREALTOINTEGER,CLOSEFILE,READSTRING,READPACKEDSTRING,READFILENAME,
50300			  NAMEFILE,DISFILE,UPFILE,APFILE,READDUMP,WRITEDUMP,SETIN,SETOUT,BREAKINPUT,
50400	(* 74 - tops20 routines *)
50500			  SETPOSF,CURPOSF,NEXTBLOCKF,SPACELEFTF,GETXF,DELFILE,RELFILE,INITMEM,INITFILES,
50600	(* 163 - tops20 TIME function *)
50700			  GETDAYTIME,LASTSUPPORT);
50800	
50900	      %CONSTANTS\
51000	      %*********\
51100	
51200	      CSTCLASS = (INT,REEL,PSET,STRD,STRG);
51300	      CSP = ^ CONSTNT;
51400	(* 55 - add require files *)
51500	      STRGARR = PACKED ARRAY[1..STRGLGTH] OF CHAR;
51600	      CONSTNT = RECORD
51700			  SELFCSP: CSP; NOCODE: BOOLEAN;
51800			  CASE CCLASS: CSTCLASS OF
51900			       INT : (INTVAL: INTEGER; INTVAL1:INTEGER %TO ACCESS SECOND WORD OF PVAL\ );
52000			       REEL: (RVAL: REAL);
52100			       PSET: (PVAL: SET OF 0..71);
52200			       STRD,
52300			       STRG: (SLGTH: 0..STRGLGTH;
58500					ARRAYY : (ARRAYSP: STP)
58600				 END;
58700	      GLOBPTR = RECORD
58800			  NEXTGLOBPTR: GTP ;
58900			  FIRSTGLOB,
59000			  LASTGLOB   : ADDRRANGE ;
59100			  FCIX	     : CODERANGE
59200			END ;
59300	
59400	      FILBLCK = PACKED RECORD
59500				 NEXTFTP : FTP ;
59600				 FILEIDENT : CTP
59700			       END ;
59800	
59900	      %NAMES\
60000	      %*****\
60100	
60200	(* 64 - non-loc goto *)
60300	(* 111 - STRING, POINTER *)
60400		(* PARAMS is a special kind of TYPES.  It is used only for
60500		   predeclared identifiers describing kludgey types that are
60600		   valid only in procedure parameter lists. *)
60700	      IDCLASS = (TYPES,KONST,VARS,FIELD,PROC,FUNC,LABELT,PARAMS);
60800	      SETOFIDS = SET OF IDCLASS;
60900	      IDKIND = (ACTUAL,FORMAL);
61000	      PACKKIND = (NOTPACK,PACKK,HWORDR,HWORDL);
61100	      CHARWORD = PACKED ARRAY [1..5] OF CHAR;
61200	      %ALFA = PACKED ARRAY [1..ALFALENG] OF CHAR;\
61300	
61400	      IDENTIFIER = PACKED RECORD
61500				    NAME: ALFA;
61600				    LLINK, RLINK: CTP;
61700				    IDTYPE: STP; NEXT: CTP;
61800				    SELFCTP: CTP; NOCODE: BOOLEAN;
61900				    CASE KLASS: IDCLASS OF
62000					 KONST: (VALUES: VALU);
62100					 VARS:	(VKIND: IDKIND; VLEV: LEVRANGE;
62200						 CHANNEL: ACRANGE; VDUMMY: 0..31; VADDR: ADDRRANGE);
62300					 FIELD: (PACKF: PACKKIND; FDUMMY: 0..7777B;
62400						 FLDADDR: ADDRRANGE);
62500					 %IF PACKF=PACKK THEN FLDADDR CONTAINS THE
62600					  ABSOLUTE ADDRESS OF THE CORRESPONDING BYTEPOINTER
62700					  -----> ENTERBODY\
62800					 PROC,
62900					 FUNC:	(PFCHAIN: CTP; CASE PFDECKIND: DECLKIND OF
63000								    STANDARD: (KEY: 1..44);
63100								    DECLARED: (PFLEV: LEVRANGE; PFADDR: ADDRRANGE;
63200									       CASE PFKIND: IDKIND OF
63300										    ACTUAL: (FORWDECL: BOOLEAN; TESTFWDPTR: CTP;
63400											     EXTERNDECL: BOOLEAN; LANGUAGE: SYMBOL;
63500											     EXTERNALNAME: ALFA;
63600											     LINKCHAIN: PACKED ARRAY[LEVRANGE] OF ADDRRANGE;
63700	(* 62 - clean of stack offsets *)
63800											     POFFSET:ADDRRANGE)));
63900	(* 66 - non-local goto's *)
64000				         LABELT: (SCOPE:LEVRANGE;NONLOCGOTO:BOOLEAN;
64100						  GOTOCHAIN:ADDRRANGE;LABELADDRESS:ADDRRANGE)
64200				  END;
64300	
64400	
64500	      DISPRANGE = 0..DISPLIMIT;
64600	      WHERE = (BLCK,CREC);
64700	(* 61 - new type to separate tops10 and tops20 ftns *)
64800	      machine = (okname,t10name,t20name);
64900	
65000	      %RELOCATION\
65100	      %**********\
65200	
65300	      RELBYTE = 0..3B %(NO,RIGHT,LEFT,BOTH)\;
65400	
65500	      RELWORD = PACKED ARRAY[0..17] OF RELBYTE;
65600	
65700	      %EXPRESSIONS\
65800	      %***********\
65900	
66000	      ATTRKIND = (CST,VARBL,EXPR);
66100	
66200	      ATTR = RECORD
66300		       TYPTR: STP;
66400		       CASE KIND: ATTRKIND OF
66500			    CST:   (CVAL: VALU);
66600			    VARBL: (PACKFG: PACKKIND; INDEXR: ACRANGE; INDBIT: IBRANGE;
66700				    VLEVEL: LEVRANGE; BPADDR,DPLMT: ADDRRANGE; VRELBYTE: RELBYTE; SUBKIND: STP);
66800			    EXPR:  (REG:ACRANGE)
66900		     END;
67000	
67100	      TESTP = ^ TESTPOINTER;
67200	      TESTPOINTER = PACKED RECORD
67300				     ELT1,ELT2: STP;
67400				     LASTTESTP: TESTP
67500				   END;
67600	
67700	(* 65 - remove exit labels *)
67800	
67900	      %TYPES FROM BODY \
68000	      %****************\
68100	
68200	(* 13 - ADD WRITEBLOCK FOR DDT SYMBOLS *)
68300	      WRITEFORM = (WRITEENTRY,WRITENAME,WRITEHISEG,WRITEGLOBALS,WRITECODE,WRITEINTERNALS,
68400	(* 164 - add Polish fixups *)
68500			   WRITEPOLISH,WRITELIBRARY,
68600	(* 173 - remove writefileblock *)
68700			   WRITESYMBOLS,WRITEBLK,WRITESTART,WRITEEND);
68800	
68900	      UPDATEFORM = (C,D);
69000	      ETP = ^ ERRORUPDATE;
69100	      ERRORUPDATE = PACKED RECORD
69200				     NUMBER: INTEGER;
69300				     NEXT: ETP;
69400				     CASE FORM: UPDATEFORM OF
69500					  C:  (STRING: ALFA);
69600					  D: (INTVAL: INTEGER)
69700				   END;
69800	
69900	      KSP = ^ KONSTREC;
70000	      KONSTREC = PACKED RECORD
70100	(* 72 - two fixup chains for 2 word consts *)
70200				  ADDR, ADDR1, KADDR: ADDRRANGE;
70300				  CONSTPTR: CSP;
70400				  NEXTKONST: KSP
70500				END;
70600	(* 164 - Polish fixups for CASE *)
70700	      POLPT = ^ POLREC;
70800	{This record indicates a Polish fixup to be done at address WHERE in
70900	 the code.  The RH of WHERE is to get the BASE (assumed relocatable),
71000	 adjusted by OFFSET (a constant).  This is needed because the loader
71100	 assumes that any address < 400000B is in the lowseg.  So to get the
71200	 virtual start of the CASE statement branch table we need to use
71300	 this to adjust the physical start of the table by the first case
71400	 index}
71500	      POLREC = PACKED RECORD
71600				  WHERE: ADDRRANGE;
71700				  BASE:  ADDRRANGE;
71800				  OFFSET: INTEGER;
71900				  NEXTPOL: POLPT
72000				END;
72100	
72200	      PDP10INSTR = PACKED RECORD
72300				    INSTR   : INSTRANGE ;
72400				    AC	    : ACRANGE;
72500				    INDBIT  : IBRANGE;
72600				    INXREG  : ACRANGE;
72700				    ADDRESS : ADDRRANGE
72800				  END ;
72900	
73000	      HALFS = PACKED RECORD
73100			       LEFTHALF: ADDRRANGE;
73200			       RIGHTHALF: ADDRRANGE
73300			     END;
73400	
73500	      PAGEELEM = PACKED RECORD
73600				  WORD1: PDP10INSTR;
73700				  LHALF: ADDRRANGE; RHALF: ADDRRANGE
73800				END;
73900	      DEBENTRY = RECORD
74000	(* 36 - ALLOW MULTIPLE MODULES *)
74100			   NEXTDEB: INTEGER;  %WILL BE PTR TO NEXT ENTRY\
74200			   LASTPAGEELEM: PAGEELEM;
74300	(* 103 - fix global id tree *)
74400			   GLOBALIDTREE: CTP;
74500			   STANDARDIDTREE: CTP;
74600			   INTPOINT:  STP;
74700			   REALPOINT: STP;
74800			   CHARPOINT: STP;
74900			   MODNAME: ALFA;
75000	(* 155 - add source information *)
75100			   SOURCE: PACKED ARRAY[1..167]OF CHAR;
75200			 END;
75300	
75400	(* 4 - add data structure for SCAN to return *)
75500	(* 11 - modify structure and add type for the REL file *)
75600	INTFILE = FILE OF INTEGER;
75700	RPGDATA = RECORD
75800	(* 7 - add /HEAP switch *)
75900		RELNAME:ALFA;
76000	(* 24 - allow user to set first loc of stack and heap *)
76100		STACKVAL:INTEGER;
76200		HEAPVAL:INTEGER;
76300	(* 33 - version no. *)
76400		VERVAL:INTEGER;
76500	(* 25 - add /ZERO *)
76600	(* 160 - add /ARITHCHECK *)
76700		ASW,ZSW,LSW,TSW,MSW,CSW,DSW,CRSW,RPGSW:BOOLEAN
76800		END;
76900	RPGPT = ^ RPGDATA;
77000	(* 33 - PROGRAM statement *)
77100	(* 61 - allow +* in tops20 *)
77200	PROGFILE = PACKED RECORD
77300		FILID:ALFA;
77400		NEXT:^PROGFILE;
77500	(* 64 - INPUT:/ *)
77600		wild,newgen,oldfile,interact,seeeol:Boolean
77700		END;
77800	(* 157 - See if we need INITTTY *)
77900	PROGFILEPT = ^ PROGFILE;
78000	
78100	      %------------------------------------------------------------------------------\
78200	
78300	
78400	    VAR
78500	      %RETURNED BY SOURCE PROGRAM SCANNER INSYMBOL:\
78600	      %********************************************\
78700	
78800	      SY: SYMBOL;		      %LAST SYMBOL\
78900	      OP: OPERATOR;		      %CLASSIFICATION OF LAST SYMBOL\
79000	      VAL: VALU;		      %VALUE OF LAST CONSTANT\
79100	      LGTH: INTEGER;		      %LENGTH OF LAST STRING CONSTANT\
79200	      ID: ALFA; 		      %LAST IDENTIFIER (POSSIBLY TRUNCATED)\
79300	      CH: CHAR; 		      %LAST CHARACTER\
79400	
79500	
79600	      %COUNTERS:\
79700	      %*********\
79800	
79900	      RTIME,
80000	      I: INTEGER;
80100	      SUPPORTIX: SUPPORTS;
80200	      LANGUAGEIX: SYMBOL;
80300	      CHCNT: 0..132;		      %CHARACTER COUNTER\
80400	      CODEEND,			      %FIRST LOCATION NOT USED FOR INSTRUCTIONS\
80500	      LCMAIN,
80600	(* 5 - some new variables for CREF *)
80700	      LC,IC,BEGLC,BEGIC: ADDRRANGE; 	      %DATA LOCATION AND INSTRUCTION COUNTER\
80800	(* 176 - new vars for unterminated comment *)
80900	      comment_page, comment_line: integer;
81000	
81100	      %SWITCHES:\
81200	      %*********\
81300	
81400	(* 25 - ADD /ZERO *)
81500	      ZERO,				%ON TO INITIALIZE LOCAL VAR'S\
81600	(* 4 - variable for COMPIL linkage *)
81700	      RPGENTRY,				%ON IF CALLED CALLED BY COMPIL\
81800	(* 5 - new variables for CREF *)
81900	      CREF,				%ON IF CREF LISTING BEING MADE\
82000	      DP,BEGDP,			      %DECLARATION PART\
82100	      RESETFLAG,		      %TO IGNORE SWITCHES WHICH MUST NOT BE RESET\
82200	      PRTERR,			      %TO ALLOW FORWARD REFERENCES IN POINTER TYPE
82300					       DECLARATION BY SUPPRESSING ERROR MESSAGE\
82400	      MAIN,			      %IF FALSE COMPILER PRODUCES EXTERNAL PROCEDURE OR FUNCTION\
82500	      doinitTTY,		      %TTYOPEN needed\
82600	      TTYINUSE, 		      %no longer used ?\
82700	      TTYSEEEOL,		      %TTY:# in program state\
82800	      DEBUG,			      %ENABLE DEBUGGING\
82900	      DEBUGSWITCH,		      %INSERT DEBUGINFORMATION\
83000	      LISTCODE, 		      %LIST MACRO CODE\
83100	      INITGLOBALS,		      %INITIALIZE GLOBAL VARIABLES\
83200	      LOADNOPTR,		      %TRUE IF NO POINTERVARIABLE SHALL BE LOADED\
83300	(* 157 - separate control for arith overflow *)
83400	      ARITHCHECK,		      %SWITCH FOR DETECTING ARITH ERRORS\
83500	      RUNTMCHECK: BOOLEAN;	      %SWITCH FOR RUNTIME-TESTS\
83600	(* 24 - ALLOW USER TO SET FIRST LOC OF STACK AND HEAP *)
83700	      STACK,HEAP: ADDRRANGE;		%FIRST ADDR OF STACK AND HEAP\
83800	(* 12 - stackandheap no longer needed *)
83900	(* 33 - VERSION NO. *)
84000	      version:packed record			%version no. for output\
84100		case boolean of
84200		  true:(word:integer);
84300		  false:(who:0..7B;major:0..777B;minor:0..77B;edit:0..777777B)
84400		end;
84500	
84600	
84700	      %POINTERS:\
84800	      %*********\
84900	
85000	      LOCALPFPTR, EXTERNPFPTR: CTP;   %PTRS TO LOCAL/EXTERNAL PROC/FUNC-CHAIN\
85100	(* 111 - STRING, POINTER *)
85200	(* 202 - POINTER by ref *)
85300	      INTPTR,REALPTR,CHARPTR,ANYFILEPTR,STRINGPTR,POINTERPTR,POINTERREF,
85400	      BOOLPTR,NILPTR,TEXTPTR: STP;    %POINTERS TO ENTRIES OF STANDARD IDS\
85500	(* 135 - ill mem ref in PACK, UNPACK *)
85600	      UARRTYP:STP;
85700	      UTYPPTR,UCSTPTR,UVARPTR,
85800	      UFLDPTR,UPRCPTR,UFCTPTR,	      %POINTERS TO ENTRIES FOR UNDECLARED IDS\
85900	(* 64 - non-loc goto *)
86000	      ulblptr,
86100	      FWPTR: CTP;		      %HEAD OF CHAIN OF FORW DECL TYPE IDS\
86200	      ERRMPTR,ERRMPTR1: ETP;	      %TO CHAIN ERROR-UPDATES\
86300	(* 65 - remove exit labels *)
86400	      LASTBTP: BTP;		      %HEAD OF BYTEPOINTERTABLE\
86500	      SFILEPTR,
86600	      FILEPTR: FTP;
86700	      FIRSTKONST: KSP;
86800	(* 164 - Polish fixups for CASE *)
86900	      FIRSTPOL: POLPT;
87000	      ALFAPTR, DATEPTR: STP;
87100	      FGLOBPTR,CGLOBPTR : GTP ;       %POINTER TO FIRST AND CURRENT GLOBAL INITIALISATION RECORD\
87200	      GLOBTESTP : TESTP ;	      %POINTER TO LAST PAIR OF POINTERTYPES\
87300	(* 4 - Here is the main structure for the SCAN linkage *)
87400	      SCANDATA : RPGPT ;		%DATA FROM SCAN OF FILE NAMES\
87500	(* 33 - PROGRAM STATEMENT *)
87600	      NPROGFILE,			%NEW FILE NAME\
87700	      LPROGFILE,			%LAST FILE NAME IN LIST\
87800	      FPROGFILE:PROGFILEPT;		%FIRST FILE NAME IN LIST\
87900	(* 64 - non-loc goto *)
88000	      lastlabel:ctp;
88100	(* 171 - treat file names as special *)
88200	      infile,outfile,ttyfile,ttyoutfile:ctp;    {Pointers to ID's for 
88300		INPUT, OUTPUT, TTY,    TTYOUT}
88400	
88500	      %BOOKKEEPING OF DECLARATION LEVELS:\
88600	      %**********************************\
88700	
88800	(* 5 - new variable for CREF *)
88900	      LEVEL,BEGLEVEL: LEVRANGE;		      %CURRENT STATIC LEVEL\
89000	      DISX,			      %LEVEL OF LAST ID SEARCHED BY SEARCHID\
89100	      TOP: DISPRANGE;		      %TOP OF DISPLAY\
89200	
89300	      DISPLAY:				    %WHERE:   MEANS:\
89400	      ARRAY[DISPRANGE] OF
89500	      PACKED RECORD
89600		       %=BLCK:	 ID IS VARIABLE ID\
89700	(* 5 - new variable for CREF *)
89800		       BLKNAME: ALFA;		    %NAME OF BLOCK\
89900		       FNAME: CTP;		    %=CREC:   ID IS FIELD ID IN RECORD WITH\
90000		       CASE OCCUR: WHERE OF	    %	      CONSTANT ADDRESS\
90100			    CREC: (CLEV: LEVRANGE;  %=VREC:   ID IS FIELD ID IN RECORD WITH\
90200				   CINDR: ACRANGE;  %	      VARIABLE ADDRESS\
90300				   CINDB: IBRANGE;
90400				   CRELBYTE: RELBYTE;
90500				   CDSPL,
90600				   CLC	: ADDRRANGE)
90700		     END;
90800	
90900	
     
00100	      %ERROR MESSAGES:\
00200	      %***************\
00300	
00400	      ERRORFLAG: BOOLEAN;	      %TRUE IF SYNTACTIC ERRORS DETECTED\
00500	      ERRINX: 0..MAXERR ;	      %NR OF ERRORS IN CURRENT SOURCE LINE\
00600	      ERRLIST:
00700	      ARRAY [1..MAXERR] OF
00800	      PACKED RECORD
00900		       ARW : 1..4;
01000		       POS: 1..CHCNTMAX;
01100		       NMR: 1..600;
01200		       TIC: CHAR
01300		     END;
01400	
01500	      ERRMESS15 : ARRAY [1..24] OF PACKED ARRAY [1..15] OF CHAR;
01600	(* 6 - add error msg for illegal character *)
01700	      ERRMESS20 : ARRAY [1..16] OF PACKED ARRAY [1..20] OF CHAR;
01800	(* 104 - error message for too much data for address space *)
01900	      ERRMESS25 : ARRAY [1..16] OF PACKED ARRAY [1..25] OF CHAR;
02000	      ERRMESS30 : ARRAY [1..17] OF PACKED ARRAY [1..30] OF CHAR;
02100	(* 156 - ftnname^ := *)
02200	      ERRMESS35 : ARRAY [1..18] OF PACKED ARRAY [1..35] OF CHAR;
02300	(* 31 - ADD MESSAGE  FOR BAD ASSIGN TO FTN. NAME *)
02400	      ERRMESS40 : ARRAY [1..13] OF PACKED ARRAY [1..40] OF CHAR;
02500	(* 24 - NEW ERROR MSG FOR LOC *)
02600	      ERRMESS45 : ARRAY [1..16] OF PACKED ARRAY [1..45] OF CHAR;
02700	(* 33 - PROGRAM STATEMENT *)
02800	      ERRMESS50 : ARRAY [1.. 9] OF PACKED ARRAY [1..50] OF CHAR;
02900	(* 124 - bad initprocedure *)
03000	      ERRMESS55 : ARRAY [1.. 7] OF PACKED ARRAY [1..55] OF CHAR;
03100	      ERRORINLINE,
03200	      FOLLOWERROR : BOOLEAN;
03300	      ERRLINE,
03400	      BUFFER: ARRAY [1..CHCNTMAX] OF CHAR;
03500	(* 136 - listing format *)
03600	      PAGECNT,SUBPAGE,CURLINE,
03700	      LINECNT: INTEGER;
03800	      LINENR: PACKED ARRAY [1..5] OF CHAR;
03900	
04000	
04100	
04200	
04300	      %EXPRESSION COMPILATION:\
04400	      %***********************\
04500	
04600	      GATTR: ATTR;		      %DESCRIBES THE EXPR CURRENTLY COMPILED\
04700	(* 105 - character mapping from lower case *)
04800	      charmap,setmap:array[0..177B]of integer;	%fast mapping to upper case\
04900	      setmapchain:addrrange;		%for external reference to runtime version of setmap\
05000	
05100	
05200	      %COUNTERS FOR TESTS:\
05300	      %*******************\
05400	
05500	
05600	
05700	      %DEBUG-SYSTEM:\
05800	      %*************\
05900	
06000	      LASTSTOP: ADDRRANGE;	      %LAST BREAKPOINT\
06100	      LASTLINE, 		      %LINENUMBER FOR BREAKPOINTS\
06200	      LINEDIFF, 		      %DIFFERENCE BETWEEN ^ AND LINECNT\
06300	      LASTPAGE:INTEGER; 	      %LAST PAGE THAT CONTAINS A STOP\
06400	      PAGEHEADADR,		      %OVERGIVE TO DEBUG.PAS\
06500	      LASTPAGER: ADDRRANGE;	      %POINTS AT LAST PAGERECORD\
06600	      PAGER: PAGEELEM;		      %ACTUAL PAGERECORD\
06700	      DEBUGENTRY: DEBENTRY;
06800	      IDRECSIZE: ARRAY[IDCLASS] OF INTEGER;
06900	      STRECSIZE: ARRAY[STRUCTFORM] OF INTEGER;
07000	
07100	
07200	
07300	      %STRUCTURED CONSTANTS:\
07400	      %*********************\
07500	
07600	      LETTERSORDIGITS,LETTERS,DIGITS,LETTERSDIGITSORLEFTARROW,HEXADIGITS: SET OF CHAR;
07700	      CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS,BLOCKBEGSYS,SELECTSYS,FACBEGSYS,
07800	      LANGUAGESYS,STATBEGSYS,TYPEDELS: SETOFSYS;
07900	(* 6 - add PROGRAM statement *)
08000	(* 56 - ADD INCLUDE *)
08100	      RW:  ARRAY [1..45%NR. OF RES. WORDS\] OF ALFA;
08200	      FRW: ARRAY [1..11%ALFALENG+1\] OF 1..46%NR. OF RES. WORDS + 1\;
08300	      RSY: ARRAY [1..45%NR. OF RES. WORDS\] OF SYMBOL;
08400	      SSY: ARRAY [' '..'_'] OF SYMBOL;
08500	      ROP: ARRAY [1..45%NR. OF RES. WORDS\] OF OPERATOR;
08600	      SOP: ARRAY [' '..'_'] OF OPERATOR;
08700	(* 10 make room for 12 more proc's, 8 more ftn's *)
08800	      NA:  ARRAY [1..81] OF ALFA;
08900	(* 61 - new array to declare which are tops10 and tops20 *)
09000	      machna: array[1..81] of machine;
09100	      othermachine: machine;
09200	      EXTNA: ARRAY[39..53] OF ALFA;
09300	      EXTLANGUAGE: ARRAY[39..53] OF SYMBOL;
09400	      MNEMONICS : ARRAY[1..45] OF PACKED ARRAY[1..60] OF CHAR ;
09500	
09600	
09700	      %VARIABLES FROM BODY\
09800	      %*******************\
09900	
10000	
10100	(* 173 - internal files *)
10200	{Chantab is very strange.  It is used as a kludge because we need
10300	 two global request chains for each of INPUT, OUTPUT, TTY, and TTYOUTPUT.
10400	 So the second one is stored here.  From an identifier record, you can
10500	 look at CHANNEL to find which of these corresponds to that one.}
10600	      CHANTAB:ARRAY[1..4] OF ADDRRANGE;
10700	      FILEINBLOCK:ARRAY[LEVRANGE]OF BOOLEAN;   {True is there is a local file}
10800	(* 12 - VAR'S FOR GLOBAL REF TO RUNTIMES. FOR DYNAMIC ALLOC *)
10900	      LSTNEW,NEWBND: ADDRRANGE;	%references to these global variables\
11000	(* 13 - ADD DATA FOR DDT SYMBOLS *)
11100	      PFPOINT,PFDISP:ADDRRANGE;	%ADDRESS OF FIRST CODE IN PROCEDURE\
11200	      RELBLOCK: PACKED RECORD
11300				 CASE BOOLEAN OF
11400				      TRUE: (COMPONENT: ARRAY[1..20] OF INTEGER);
11500				      FALSE: (ITEM: ADDRRANGE; COUNT: ADDRRANGE;
11600					      RELOCATOR: RELWORD;
11700					      CODE: ARRAY[0..17] OF INTEGER)
11800			       END;
11900	
12000	      RNTS: RECORD
12100		      NAME: ARRAY[SUPPORTS] OF ALFA;
12200		      LINK: PACKED ARRAY[SUPPORTS] OF ADDRRANGE
12300		    END;
12400	
12500	      CODE: PACKED RECORD
12600			     RELOCATION:  PACKED ARRAY[CODERANGE] OF RELBYTE;
12700			     INFORMATION: PACKED ARRAY[CODERANGE] OF CHAR;
12800			     CASE INTEGER OF
12900				  1: (INSTRUCTION: PACKED ARRAY[CODERANGE] OF PDP10INSTR);
13000				  2: (WORD:	   PACKED ARRAY[CODERANGE] OF INTEGER);
13100				  3: (HALFWORD:    PACKED ARRAY[CODERANGE] OF HALFS)
13200			   END;
13300	
13400	      LABELS: ARRAY [1:LABMAX] OF
13500	      RECORD
13600		LABSVAL,LABSADDR: INTEGER
13700	      END;
13800	      GOTOS: ARRAY [1:LABMAX] OF
13900	      RECORD
14000		GOTOVAL,GOTOADDR: INTEGER
14100	      END;
14200	
14300	      REGC,				%TOP OF REGISTERSTACK\
14400	      REGCMAX: ACRANGE; 		%MAXIMUM OF REGISTERS FOR EXPRESSION STACK\
14500	      LIX,JIX,CIX,
14600	      INSERTSIZE,			%TOO INSERT LCMAX IN ENTRYCODE\
14700	      PFSTART: INTEGER; 		%START OF NORMAL ENTRYCODE OF EACH FUNC. OR PROC.\
14800	      IX: INTEGER;
14900	(* 54 - var's needed to keep track of stack space needed *)
15000	      STKOFF, STKOFFMAX, CORALLOC: INTEGER;	%STACK SPACE NEEDED ABOVE LOCALS\
15100	      LCMAX: ADDRRANGE; LCP: CTP;
15200	      OUTPUTREL: FILE OF INTEGER;	%RELOCATABLE BINARY OUTPUT\
15300	      WITHIX,				%TOP OF WITH-REG STACK\
15400	      HIGHESTCODE,			%MAXIMUM OF HIGH SEGMENTS ADDRESS\
15500	      MAINSTART,			%FIRST CODE OF BODY OF MAIN\
15600	(* 16 - add CCLSW set by entry with offset=1 *)
15700	      CCLSW,
15800	(* 66 - nonloc goto's *)
15900	      globtopp,globbasis,
16000	      STARTADDR: INTEGER;		%STARTADDRESSE\
16100	
16200	(* 33 - VERSION NO. *)
16300	      LOOKBLOCK: ARRAY[0..6] OF INTEGER;
16400	      LST,REL: PACKED ARRAY[1..3] OF CHAR ;
16500	(* 34 - entry no longer needed *)
16600	      FILENAME: ALFA;
16700	      DAY: PACKED ARRAY[1..9] OF CHAR;
16800	(* 125 - moved to global so insymbol can see it *)
16900	      REQFILE,ENTRYDONE: BOOLEAN;
17000	(* 171 - read/write of records *)
17100	      THISFILE: STP;
17200	      GOTARG: BOOLEAN;
17300	
17400	      LIBIX: INTEGER;
17500	      LIBORDER: PACKED ARRAY[1..4] OF SYMBOL;
17600	      LIBRARY: ARRAY[PASCALSY..COBOLSY] OF RECORD
17700						     INORDER, CALLED: BOOLEAN;
17800						     NAME: ALFA;
17900						     PROJNR: ADDRRANGE;
18000						     PROGNR: ADDRRANGE;
18100						     DEVICE: ALFA
18200						   END;
18300	
18400	      %------------------------------------------------------------------------------\
18500	
18600	      INITPROCEDURE ;
18700	       BEGIN
18800	
18900	(* 33 - VERSION NO. *)
19000	(* 34 - using filename instead of entry *)
19100		LST:= 'LST'  ;	REL:= 'REL'  ;	FILENAME:= '          '  ;  LOOKBLOCK[0] := 6;
19200	
19300		MNEMONICS[ 1] := '***001***002***003***004***005***006***007***010***011***012' ;
19400		MNEMONICS[ 2] := '***013***014***015***016***017***020***021***022***023***024' ;
19500		MNEMONICS[ 3] := '***025***026***027***030***031***032***033***034***035***036' ;
19600		MNEMONICS[ 4] := '***037CALL  INIT  ***042***043***044***045***046CALLI OPEN  ' ;
19700		MNEMONICS[ 5] := 'TTCALL***052***053***054RENAMEIN    OUT   SETSTSSTATO STATUS' ;
19800		MNEMONICS[ 6] := 'STATZ INBUF OUTBUFINPUT OUTPUTCLOSE RELEASMTAPE UGETF USETI ' ;
19900	(* 133 - add mnemonics for ADJSP and JSYS *)
20000		MNEMONICS[ 7] := 'USETO LOOKUPENTER UJEN  ***101***102***103JSYS  ADJSP ***106' ;
20100		MNEMONICS[ 8] := '***107***110***111***112***113***114***115***116***117***120' ;
20200	(* 2 - add mnemonics for KI-10, since we are using some of them *)
20300		MNEMONICS[ 9] := '***121FIX   ***123***124***125FIXR  FLTR  UFA   DFN   FSC   ' ;
20400		MNEMONICS[10] := 'IBP   ILDB  LDB   IDPB  DPB   FAD   FADL  FADM  FADB  FADR  ' ;
20500		MNEMONICS[11] := 'FADRI FADRM FADRB FSB   FSBL  FSBM  FSBB  FSBR  FSBRI FSBRM ' ;
20600		MNEMONICS[12] := 'FSBRB FMP   FMPL  FMPM  FMPB  FMPR  FMPRI FMPRM FMPRB FDV   ' ;
20700		MNEMONICS[13] := 'FDVL  FDVM  FDVB  FDVR  FDVRI FDVRM FDVRB MOVE  MOVEI MOVEM ' ;
20800		MNEMONICS[14] := 'MOVES MOVS  MOVSI MOVSM MOVSS MOVN  MOVNI MOVNM MOVNS MOVM  ' ;
20900		MNEMONICS[15] := 'MOVMI MOVMM MOVMS IMUL  IMULI IMULM IMULB MUL   MULI  MULM  ' ;
21000		MNEMONICS[16] := 'MULB  IDIV  IDIVI IDIVM IDIVB DIV   DIVI  DIVM  DIVB  ASH   ' ;
21100		MNEMONICS[17] := 'ROT   LSH   JFFO  ASHC  ROTC  LSHC  ***247EXCH  BLT   AOBJP ' ;
21200		MNEMONICS[18] := 'AOBJN JRST  JFCL  XCT   ***257PUSHJ PUSH  POP   POPJ  JSR   ' ;
21300		MNEMONICS[19] := 'JSP   JSA   JRA   ADD   ADDI  ADDM  ADDB  SUB   SUBI  SUBM  ' ;
21400		MNEMONICS[20] := 'SUBB  CAI   CAIL  CAIE  CAILE CAIA  CAIGE CAIN  CAIG  CAM   ' ;
21500		MNEMONICS[21] := 'CAML  CAME  CAMLE CAMA  CAMGE CAMN  CAMG  JUMP  JUMPL JUMPE ' ;
21600		MNEMONICS[22] := 'JUMPLEJUMPA JUMPGEJUMPN JUMPG SKIP  SKIPL SKIPE SKIPLESKIPA ' ;
21700		MNEMONICS[23] := 'SKIPGESKIPN SKIPG AOJ   AOJL  AOJE  AOJLE AOJA  AOJGE AOJN  ' ;
21800		MNEMONICS[24] := 'AOJG  AOS   AOSL  AOSE  AOSLE AOSA  AOSGE AOSN  AOSG  SOJ   ' ;
21900		MNEMONICS[25] := 'SOJL  SOJE  SOJLE SOJA  SOJGE SOJN  SOJG  SOS   SOSL  SOSE  ' ;
22000		MNEMONICS[26] := 'SOSLE SOSA  SOSGE SOSN  SOSG  SETZ  SETZI SETZM SETZB AND   ' ;
22100		MNEMONICS[27] := 'ANDI  ANDM  ANDB  ANDCA ANDCAIANDCAMANDCABSETM  SETMI SETMM ' ;
22200		MNEMONICS[28] := 'SETMB ANDCM ANDCMIANDCMMANDCMBSETA  SETAI SETAM SETAB XOR   ' ;
22300		MNEMONICS[29] := 'XORI  XORM  XORB  IOR   IORI  IORM  IORB  ANDCB ANDCBIANDCBM' ;
22400		MNEMONICS[30] := 'ANDCBBEQV   EQVI  EQVM  EQVB  SETCA SETCAISETCAMSETCABORCA  ' ;
22500		MNEMONICS[31] := 'ORCAI ORCAM ORCAB SETCM SETCMISETCMMSETCMBORCM  ORCMI ORCMM ' ;
22600		MNEMONICS[32] := 'ORCMB ORCB  ORCBI ORCBM ORCBB SETO  SETOI SETOM SETOB HLL   ' ;
22700		MNEMONICS[33] := 'HLLI  HLLM  HLLS  HRL   HRLI  HRLM  HRLS  HLLZ  HLLZI HLLZM ' ;
22800		MNEMONICS[34] := 'HLLZS HRLZ  HRLZI HRLZM HRLZS HLLO  HLLOI HLLOM HLLOS HRLO  ' ;
22900		MNEMONICS[35] := 'HRLOI HRLOM HRLOS HLLE  HLLEI HLLEM HLLES HRLE  HRLEI HRLEM ' ;
23000		MNEMONICS[36] := 'HRLES HRR   HRRI  HRRM  HRRS  HLR   HLRI  HLRM  HLRS  HRRZ  ' ;
23100		MNEMONICS[37] := 'HRRZI HRRZM HRRZS HLRZ  HLRZI HLRZM HLRZS HRRO  HRROI HRROM ' ;
23200		MNEMONICS[38] := 'HRROS HLRO  HLROI HLROM HLROS HRRE  HRREI HRREM HRRES HLRE  ' ;
23300		MNEMONICS[39] := 'HLREI HLREM HLRES TRN   TLN   TRNE  TLNE  TRNA  TLNA  TRNN  ' ;
23400		MNEMONICS[40] := 'TLNN  TDN   TSN   TDNE  TSNE  TDNA  TSNA  TDNN  TSNN  TRZ   ' ;
23500		MNEMONICS[41] := 'TLZ   TRZE  TLZE  TRZA  TLZA  TRZN  TLZN  TDZ   TSZ   TDZE  ' ;
23600		MNEMONICS[42] := 'TSZE  TDZA  TSZA  TDZN  TSZN  TRC   TLC   TRCE  TLZE  TRCA  ' ;
23700		MNEMONICS[43] := 'TLCA  TRCN  TLCN  TDC   TSC   TDCE  TSCE  TDCA  TSCA  TDCN  ' ;
23800		MNEMONICS[44] := 'TSCN  TRO   TLO   TROE  TLOE  TROA  TLOA  TRON  TLON  TDO   ' ;
23900		MNEMONICS[45] := 'TSO   TDOE  TSOE  TDOA  TSOA  TDON  TSON  ***700            ' ;
24000	       END;
24100	
24200	      INITPROCEDURE %SEARCH LIBRARIES\ ;
24300	       BEGIN
24400		LIBRARY[PASCALSY].INORDER   := FALSE;
24500		LIBRARY[FORTRANSY].INORDER  := FALSE;
24600		LIBRARY[ALGOLSY].INORDER    := FALSE;
24700		LIBRARY[COBOLSY].INORDER    := FALSE;
24800		LIBRARY[PASCALSY].CALLED    := FALSE;
24900		LIBRARY[FORTRANSY].CALLED   := FALSE;
25000		LIBRARY[ALGOLSY].CALLED     := FALSE;
25100		LIBRARY[COBOLSY].CALLED     := FALSE;
25200	(* 57 - Make library a parameter *)
25300		LIBRARY[PASCALSY].NAME	    := PASLIB;
25400		LIBRARY[FORTRANSY].NAME     := 'FORLIB    ';
25500		LIBRARY[ALGOLSY].NAME	    := 'ALGLIB    ';
25600		LIBRARY[COBOLSY].NAME	    := 'LIBOL     ';
25700	(* 2 - library now on SYS: *)
25800	(* 57 *)
25900		LIBRARY[PASCALSY].DEVICE    := PASDEV;
26000		LIBRARY[FORTRANSY].DEVICE   := 'SYS       ';
26100		LIBRARY[ALGOLSY].DEVICE     := 'SYS       ';
26200		LIBRARY[COBOLSY].DEVICE     := 'SYS       ';
26300	(* 57 *)
26400		LIBRARY[PASCALSY].PROJNR    := PASPROJ;
26500		LIBRARY[FORTRANSY].PROJNR   := 0;
26600		LIBRARY[ALGOLSY].PROJNR     := 0;
26700		LIBRARY[COBOLSY].PROJNR     := 0;
26800	(* 57 *)
26900		LIBRARY[PASCALSY].PROGNR    := PASPROG;
27000		LIBRARY[FORTRANSY].PROGNR   := 0;
27100		LIBRARY[ALGOLSY].PROGNR     := 0;
27200		LIBRARY[COBOLSY].PROGNR     := 0;
27300	       END %SEARCH LIBRARIES\ ;
27400	
27500	      INITPROCEDURE %STANDARDNAMES\ ;
27600	       BEGIN
27700		NA[ 1] := 'FALSE     '; NA[ 2] := 'TRUE      '; NA[ 3] := 'INPUT     ';
27800		NA[ 4] := 'OUTPUT    '; NA[ 5] := 'TTY       '; NA[ 6] := 'TTYOUTPUT ';
27900		NA[ 7] := 'GET       '; NA[ 8] := 'GETLN     '; NA[ 9] := 'PUT       ';
28000		NA[10] := 'PUTLN     '; NA[11] := 'RESET     '; NA[12] := 'REWRITE   ';
28100		NA[13] := 'READ      '; NA[14] := 'READLN    '; NA[15] := 'BREAK     ';
28200		NA[16] := 'WRITE     '; NA[17] := 'WRITELN   '; NA[18] := 'PACK      ';
28300		NA[19] := 'UNPACK    '; NA[20] := 'NEW       '; NA[21] := 'MARK      ';
28400		NA[22] := 'RELEASE   '; NA[23] := 'GETLINENR '; NA[24] := 'PUT8BITSTO';
28500		NA[25] := 'PAGE      '; NA[26] := 'DATE      '; NA[27] := 'RUNTIME   ';
28600		NA[28] := 'TIME      '; NA[29] := 'ABS       '; NA[30] := 'SQR       ';
28700		NA[31] := 'TRUNC     '; NA[32] := 'ODD       '; NA[33] := 'ORD       ';
28800		NA[34] := 'CHR       '; NA[35] := 'PRED      '; NA[36] := 'SUCC      ';
28900		NA[37] := 'EOF       '; NA[38] := 'EOLN      '; NA[39] := 'SIN       ';
29000		NA[40] := 'COS       '; NA[41] := 'EXP       '; NA[42] := 'SQRT      ';
29100		NA[43] := 'LN        '; NA[44] := 'ARCTAN    '; NA[45] := 'LOG       ';
29200		NA[46] := 'SIND      '; NA[47] := 'COSD      '; NA[48] := 'SINH      ';
29300		NA[49] := 'COSH      '; NA[50] := 'TANH      '; NA[51] := 'ARCSIN    ';
29400		NA[52] := 'ARCCOS    '; NA[53] := 'RANDOM    ';
29500	(* 10 make room for 12 more proc's, 8 more ftn's *)
29600		NA[54] := 'STRSET    '; NA[55] := 'STRWRITE  ';
29700		NA[56] := 'GETINDEX  '; NA[57] := 'CLOSE     ';
29800		NA[58] := 'CALLI     '; NA[59] := 'RENAME    ';
29900		NA[60] := 'DISMISS   '; NA[61] := 'UPDATE    ';
30000		NA[62] := 'DUMPIN    '; NA[63] := 'DUMPOUT   ';
30100		NA[64] := 'USETI     '; NA[65] := 'USETO     ';
30200	(* 27 - add NEWZ *)
30300		NA[66] := 'BREAKIN   '; NA[67] := 'NEWZ      ';
30400		NA[68] := 'APPEND    '; NA[69] := 'PUTX      ';
30500	(* 44 - SETPOS,CURPOS, SKIP *)
30600		NA[70] := 'SETPOS    '; NA[71] := 'NEXTBLOCK ';
30700	(* 61 - tops20 system version *)
30800		na[72] := 'GETX      '; na[73] := 'DELETE    ';
30900		na[74] := 'RCLOSE    '; na[75] := 'JSYS      ';
31000	(* 152 - add DISPOSE *)
31100		na[76] := 'DISPOSE   '; na[77] := 'NEXTFILE  ';
31200		na[78] := 'CURPOS    '; na[79] := 'SPACELEFT ';
31300		na[80] := 'ROUND     '; na[81] := 'RECSIZE   ';
31400		machna[24] := t10name; machna[58] := t10name;
31500		machna[62] := t10name; machna[63] := t10name;
31600		machna[64] := t10name; machna[65] := t10name;
31700	(* 134 - remove t20name entry for DELETE *)
31800		machna[71] := t10name; 
31900		machna[74] := t20name; machna[75] := t20name;
32000		machna[77] := t20name; machna[79] := t10name;
32100	       END %STANDARDNAMES\ ;
32200	
32300	      INITPROCEDURE %EXTERNAL NAMES\;
32400	       BEGIN
32500		EXTNA[39] := 'SIN       '; EXTLANGUAGE[39] := FORTRANSY;
32600		EXTNA[40] := 'COS       '; EXTLANGUAGE[40] := FORTRANSY;
32700		EXTNA[41] := 'EXP       '; EXTLANGUAGE[41] := FORTRANSY;
32800		EXTNA[42] := 'SQRT      '; EXTLANGUAGE[42] := FORTRANSY;
32900		EXTNA[43] := 'ALOG      '; EXTLANGUAGE[43] := FORTRANSY;
33000		EXTNA[44] := 'ATAN      '; EXTLANGUAGE[44] := FORTRANSY;
33100		EXTNA[45] := 'ALOG10    '; EXTLANGUAGE[45] := FORTRANSY;
33200		EXTNA[46] := 'SIND      '; EXTLANGUAGE[46] := FORTRANSY;
33300		EXTNA[47] := 'COSD      '; EXTLANGUAGE[47] := FORTRANSY;
33400		EXTNA[48] := 'SINH      '; EXTLANGUAGE[48] := FORTRANSY;
33500		EXTNA[49] := 'COSH      '; EXTLANGUAGE[49] := FORTRANSY;
33600		EXTNA[50] := 'TANH      '; EXTLANGUAGE[50] := FORTRANSY;
33700		EXTNA[51] := 'ASIN      '; EXTLANGUAGE[51] := FORTRANSY;
33800		EXTNA[52] := 'ACOS      '; EXTLANGUAGE[52] := FORTRANSY;
33900		EXTNA[53] := 'RAN       '; EXTLANGUAGE[53] := FORTRANSY;
34000	
34100	       END %EXTERNAL NAMES\;
34200	
34300	      INITPROCEDURE %RUNTIME-, DEBUG-SUPPORTS\ ;
34400	       BEGIN
34500	
34600		RNTS.NAME[STACKOVERFLOW]	     := 'CORERR    ';
34700	(* 104 - new tops10 stackoverflow for better checking *)
34800		RNTS.NAME[DEBSTACK]		     := 'DCORER    ';
34900	(* 23 - check for bad pointer *)
35000	        RNTS.NAME[BADPOINT]		     := 'PTRER.    ';
35100		RNTS.NAME[ALLOCATE]		     := 'NEW       ';
35200		RNTS.NAME[CLEARALLOC]		     := 'NEWCL.    ';
35300	(* 152 - DISPOSE *)
35400		RNTS.NAME[DEALLOCATE]		     := 'DISPOS    ';
35500	(* 173 - internal file *)
35600		RNTS.NAME[WITHFILEDEALLOCATE]	     := 'DISPF.    ';
35700	(* 64 - non-loc goto *)
35800		rnts.name[exitgoto]		     := 'GOTOC.    ';
35900		RNTS.NAME[EXITPROGRAM]		     := 'END       ';
36000		RNTS.NAME[GETLINE]		     := 'GETLN     ';
36100		RNTS.NAME[GETFILE]		     := 'GET.      ';
36200		RNTS.NAME[PUTLINE]		     := 'PUTLN     ';
36300		RNTS.NAME[PUTFILE]		     := 'PUT       ';
36400	(* 43 - add PUTX *)
36500		RNTS.NAME[PUTXFILE]		     := 'PUTX      ';
36600		RNTS.NAME[RESETFILE]		     := 'RESETF    ';
36700		RNTS.NAME[REWRITEFILE]		     := 'REWRIT    ';
36800	(* 57 - do strset and strwrite at runtime *)
36900		RNTS.NAME[RESETSTRING]		     := 'STSET.    ';
37000		RNTS.NAME[REWRITESTRING]	     := 'STWR.     ';
37100		RNTS.NAME[WRITEOCTAL]		     := 'WRTOCT    ';
37200		RNTS.NAME[WRITEHEXADECIMAL]	     := 'WRTHEX    ';
37300		RNTS.NAME[WRITEINTEGER] 	     := 'WRTINT    ';
37400		RNTS.NAME[WRITECHARACTER]	     := 'WRITEC    ';
37500		RNTS.NAME[WRITEREAL]		     := 'WRTREA    ';
37600		RNTS.NAME[WRITEBOOLEAN] 	     := 'WRTBOL    ';
37700		RNTS.NAME[WRITESTRING]		     := 'WRTUST    ';
37800		RNTS.NAME[WRITEPACKEDSTRING]	     := 'WRTPST    ';
EDURE %INITSCALARS\ ;
42900	       BEGIN
43000		CHANTAB[1] := 0; CHANTAB[2] := 0; CHANTAB[3] := 0; CHANTAB[4] := 0;
43100	(* 65 - remove exit labels *)
43200		FWPTR := NIL; LASTBTP := NIL;  FGLOBPTR := NIL ; FILEPTR := NIL ;
43300		LOCALPFPTR:=NIL; EXTERNPFPTR:= NIL; GLOBTESTP := NIL; ERRMPTR := NIL;
43400	(* 24 - INITIALZE HEAP AND STACK *)
43500		HEAP := 0; STACK := 0;
43600	
43700		LISTCODE := FALSE; LOADNOPTR := TRUE; INITGLOBALS := FALSE ; RUNTMCHECK := TRUE;
43800	(* 157 - separate control for arith error *)
43900		ARITHCHECK := TRUE;
44000		TTYINUSE := TRUE; FOLLOWERROR := FALSE; ERRORINLINE := FALSE; RESETFLAG := TRUE;
44100	(* 172 *)
44200		TTYSEEEOL := FALSE;
44300		DP := TRUE; PRTERR := TRUE; ERRORFLAG := FALSE ; MAIN := TRUE;
44400		ENTRYDONE := FALSE; DEBUG := FALSE; DEBUGSWITCH := FALSE; 
44500	(* 176 *)
44600		comment_page := 0;
44700	(* 33 - PROGRAM *)
44800		FPROGFILE := NIL; LPROGFILE := NIL;
44900	(* 64 - non-loc goto *)
45000		lastlabel := nil;
45100	
45200		IC := HIGHSTART;     %START OF HIGHSEGMENT\
45300		LC := PROGRST;	     %START OF LOWSEGMENT AVAILABLE TO PROGRAM\
45400	(* 136 - listing format *)
45500		CHCNT := 0; LINECNT := 1; PAGECNT := 1; SUBPAGE := 0; 
45600		LASTLINE := -1; LASTPAGE := 0;
45700	(* 12 - initialize new variables for dynamic core *)
45800		LIBIX := 0; ERRINX := 0; LSTNEW := 0; NEWBND := 0;
45900	       END %INITSCALARS\ ;
46000	
46100	      INITPROCEDURE %INITSETS\ ;
46200	       BEGIN
46300		DIGITS := ['0'..'9'];
46400		LETTERS := ['A'..'Z'];
46500		HEXADIGITS := ['0'..'9','A'..'F'];
46600		LETTERSORDIGITS := [ '0'..'9','A'..'Z'];
46700		LETTERSDIGITSORLEFTARROW := ['0'..'9','A'..'Z','_'];
46800		LANGUAGESYS := [FORTRANSY,ALGOLSY,COBOLSY,PASCALSY];
46900		CONSTBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT];
47000		SIMPTYPEBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT] ;
47100		TYPEBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,ARROW,PACKEDSY,ARRAYSY,RECORDSY,SETSY,FILESY] ;
47200		TYPEDELS := [ARRAYSY,RECORDSY,SETSY,FILESY];
47300	(* 56 - add require files *)
47400		BLOCKBEGSYS := [INCLUDESY,LABELSY,CONSTSY,TYPESY,VARSY,INITPROCSY,PROCEDURESY,FUNCTIONSY,BEGINSY];
47500		SELECTSYS := [ARROW,PERIOD,LBRACK];
47600		FACBEGSYS := [INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,LBRACK,NOTSY];
47700		STATBEGSYS := [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,LOOPSY,FORSY,WITHSY,CASESY]
47800	       END %INITSETS\ ;
47900	
48000	      INITPROCEDURE %RESWORDS\ ;
48100	       BEGIN
48200		RW[ 1] := 'IF        '; RW[ 2] := 'DO        '; RW[ 3] := 'OF        ';
48300		RW[ 4] := 'TO        '; RW[ 5] := 'IN        '; RW[ 6] := 'OR        ';
48400		RW[ 7] := 'END       '; RW[ 8] := 'FOR       '; RW[ 9] := 'VAR       ';
48500		RW[10] := 'DIV       '; RW[11] := 'MOD       '; RW[12] := 'SET       ';
48600		RW[13] := 'AND       '; RW[14] := 'NOT       '; RW[15] := 'THEN      ';
48700		RW[16] := 'ELSE      '; RW[17] := 'WITH      '; RW[18] := 'GOTO      ';
48800		RW[19] := 'LOOP      '; RW[20] := 'CASE      '; RW[21] := 'TYPE      ';
48900		RW[22] := 'FILE      '; RW[23] := 'EXIT      '; RW[24] := 'BEGIN     ';
49000		RW[25] := 'UNTIL     '; RW[26] := 'WHILE     '; RW[27] := 'ARRAY     ';
49100		RW[28] := 'CONST     '; RW[29] := 'LABEL     '; RW[30] := 'ALGOL     ';
49200		RW[31] := 'COBOL     '; RW[32] := 'EXTERN    '; RW[33] := 'PASCAL    ';
49300		RW[34] := 'RECORD    '; RW[35] := 'DOWNTO    '; RW[36] := 'PACKED    ';
49400		RW[37] := 'OTHERS    '; RW[38] := 'REPEAT    '; RW[39] := 'FORTRAN   ';
49500	(* 6 - add PROGRAM statement *)
49600	(* 56 - ADD INCLUDE *)
49700		RW[40] := 'FORWARD   '; RW[41] := 'PROGRAM   '; RW[42] := 'INCLUDE   ';
49800	        RW[43] := 'FUNCTION  '; RW[44] := 'PROCEDURE ';
49900		RW[45] := 'INITPROCED';
50000		FRW[1] :=  1; FRW[2] :=  1; FRW[3] :=  7; FRW[4] := 15; FRW[5] := 24;
50100		FRW[6] := 32; FRW[7] := 39; FRW[8] := 43; FRW[9] := 44; FRW[10] := 45;
50200		FRW[11] := 46;
50300	       END %RESWORDS\ ;
50400	
50500	      INITPROCEDURE %SYMBOLS\ ;
50600	       BEGIN
50700		RSY[1] := IFSY; RSY[2] := DOSY; RSY[3] := OFSY; RSY[4] := TOSY;
50800		RSY[5] := RELOP; RSY[6] := ADDOP; RSY[7] := ENDSY; RSY[8] := FORSY;
50900		RSY[9] := VARSY; RSY[10] := MULOP; RSY[11] := MULOP; RSY[12] := SETSY;
51000		RSY[13] := MULOP; RSY[14] := NOTSY; RSY[15] := THENSY;
51100		RSY[16] := ELSESY; RSY[17] := WITHSY; RSY[18] := GOTOSY;
51200		RSY[19] := LOOPSY; RSY[20] := CASESY; RSY[21] := TYPESY;
51300		RSY[22] := FILESY; RSY[23] := EXITSY; RSY[24] := BEGINSY;
51400		RSY[25] := UNTILSY; RSY[26] := WHILESY; RSY[27] := ARRAYSY;
51500		RSY[28] := CONSTSY; RSY[29] := LABELSY;
51600		RSY[30] := ALGOLSY; RSY[31] := COBOLSY;
51700		RSY[32] := EXTERNSY; RSY[33] := PASCALSY; RSY[34] := FORTRANSY;
51800		RSY[34] := RECORDSY; RSY[35]:= DOWNTOSY; RSY[36] := PACKEDSY;
51900		RSY[37] := OTHERSSY; RSY[38]:= REPEATSY; RSY[39] := FORTRANSY;
52000	(* 6 - add PROGRAM statement *)
52100	(* 56 - ADD INCLUDE *)
52200		RSY[40] := FORWARDSY; RSY[41] := PROGRAMSY; RSY[42] := INCLUDESY; RSY[43] := FUNCTIONSY;
52300		RSY[44] := PROCEDURESY; RSY[45] := INITPROCSY;
52400	
52500		SSY['A'] := OTHERSY; SSY['B'] := OTHERSY; SSY['C'] := OTHERSY;
52600		SSY['D'] := OTHERSY; SSY['E'] := OTHERSY; SSY['F'] := OTHERSY;
52700		SSY['G'] := OTHERSY; SSY['H'] := OTHERSY; SSY['I'] := OTHERSY;
52800		SSY['J'] := OTHERSY; SSY['K'] := OTHERSY; SSY['L'] := OTHERSY;
52900		SSY['M'] := OTHERSY; SSY['N'] := OTHERSY; SSY['O'] := OTHERSY;
53000		SSY['P'] := OTHERSY; SSY['Q'] := OTHERSY; SSY['R'] := OTHERSY;
53100		SSY['S'] := OTHERSY; SSY['T'] := OTHERSY; SSY['U'] := OTHERSY;
53200		SSY['V'] := OTHERSY; SSY['W'] := OTHERSY; SSY['X'] := OTHERSY;
53300		SSY['Y'] := OTHERSY; SSY['Z'] := OTHERSY; SSY['0'] := OTHERSY;
53400		SSY['1'] := OTHERSY; SSY['2'] := OTHERSY; SSY['3'] := OTHERSY;
53500		SSY['4'] := OTHERSY; SSY['5'] := OTHERSY; SSY['6'] := OTHERSY;
53600		SSY['7'] := OTHERSY; SSY['8'] := OTHERSY; SSY['9'] := OTHERSY;
53700		SSY['_'] := OTHERSY;
53800		SSY['+'] := ADDOP;   SSY['-'] := ADDOP;   SSY['*'] := MULOP;
53900		SSY['/'] := MULOP;   SSY['('] := LPARENT; SSY[')'] := RPARENT;
54000		SSY['$'] := OTHERSY; SSY['='] := RELOP;   SSY[' '] := OTHERSY;
54100		SSY[','] := COMMA;   SSY['.'] := PERIOD;  SSY[''''] := OTHERSY;
54200		SSY['['] := LBRACK;  SSY[']'] := RBRACK;  SSY[':'] := COLON;
54300		SSY['#'] := RELOP;   SSY['%'] := OTHERSY; SSY['!'] := ADDOP;
54400		SSY['&'] := MULOP;   SSY['^'] := ARROW;   SSY['\'] := OTHERSY;
54500		SSY['<'] := RELOP;   SSY['>'] := RELOP;   SSY['@'] := RELOP;
54600		SSY['"'] := RELOP;   SSY['?'] := NOTSY;   SSY[';'] := SEMICOLON;
54700	       END %SYMBOLS\ ;
54800	
54900	      INITPROCEDURE %OPERATORS\ ;
55000	       BEGIN
55100		ROP[ 1] := NOOP; ROP[ 2] := NOOP; ROP[ 3] := NOOP; ROP[ 4] := NOOP;
55200		ROP[ 5] := INOP; ROP[ 6] := OROP; ROP[ 7] := NOOP; ROP[ 8] := NOOP;
55300		ROP[ 9] := NOOP; ROP[10] := IDIV; ROP[11] := IMOD; ROP[12] := NOOP;
55400		ROP[13] :=ANDOP; ROP[14] := NOOP; ROP[15] := NOOP; ROP[16] := NOOP;
55500		ROP[17] := NOOP; ROP[18] := NOOP; ROP[19] := NOOP; ROP[20] := NOOP;
55600		ROP[21] := NOOP; ROP[22] := NOOP; ROP[23] := NOOP; ROP[24] := NOOP;
55700		ROP[25] := NOOP; ROP[26] := NOOP; ROP[27] := NOOP; ROP[28] := NOOP;
55800		ROP[29] := NOOP; ROP[30] := NOOP; ROP[31] := NOOP; ROP[32] := NOOP;
55900		ROP[33] := NOOP; ROP[34] := NOOP; ROP[35] := NOOP; ROP[36] := NOOP;
56000		ROP[37] := NOOP; ROP[38] := NOOP; ROP[39] := NOOP; ROP[40] := NOOP;
56100	(* 6 - add PROGRAM statement *)
56200	(* 56 - ADD INCLUDE *)
56300		ROP[41] := NOOP; ROP[42] := NOOP; ROP[43] := NOOP; ROP[44] := NOOP; ROP[45] := NOOP;
56400	
56500		SOP['+'] := PLUS; SOP['-'] := MINUS; SOP['*'] := MUL;  SOP['/'] := RDIV;
56600		SOP['='] := EQOP; SOP['#'] := NEOP;  SOP['!'] := OROP; SOP['&'] := ANDOP;
56700		SOP['<'] := LTOP; SOP['>'] := GTOP;  SOP['@'] := LEOP; SOP['"'] := GEOP;
56800		SOP[' '] := NOOP; SOP['$'] := NOOP; SOP['%'] := NOOP; SOP['('] := NOOP;
56900		SOP[')'] := NOOP; SOP[','] := NOOP; SOP['.'] := NOOP; SOP['0'] := NOOP;
57000		SOP['1'] := NOOP; SOP['2'] := NOOP; SOP['3'] := NOOP; SOP['4'] := NOOP;
57100		SOP['5'] := NOOP; SOP['6'] := NOOP; SOP['7'] := NOOP; SOP['8'] := NOOP;
57200		SOP['9'] := NOOP; SOP[':'] := NOOP; SOP[';'] := NOOP; SOP['?'] := NOOP;
57300		SOP['A'] := NOOP; SOP['B'] := NOOP; SOP['C'] := NOOP; SOP['D'] := NOOP;
57400		SOP['E'] := NOOP; SOP['F'] := NOOP; SOP['G'] := NOOP; SOP['H'] := NOOP;
57500		SOP['I'] := NOOP; SOP['J'] := NOOP; SOP['K'] := NOOP; SOP['L'] := NOOP;
57600		SOP['M'] := NOOP; SOP['N'] := NOOP; SOP['O'] := NOOP; SOP['P'] := NOOP;
57700		SOP['Q'] := NOOP; SOP['R'] := NOOP; SOP['S'] := NOOP; SOP['T'] := NOOP;
57800		SOP['U'] := NOOP; SOP['V'] := NOOP; SOP['W'] := NOOP; SOP['X'] := NOOP;
57900		SOP['Y'] := NOOP; SOP['Z'] := NOOP; SOP['['] := NOOP; SOP['\'] := NOOP;
58000		SOP[']'] := NOOP; SOP['^'] := NOOP; SOP['_'] := NOOP; SOP[''''] := NOOP;
58100	       END %OPERATORS\ ;
58200	
58300	      INITPROCEDURE %RECORDSIZES\;
58400	       BEGIN
58500		IDRECSIZE[TYPES]  := 5;
58600		IDRECSIZE[KONST]  := 6;
58700		IDRECSIZE[VARS]   := 6;
58800		IDRECSIZE[FIELD]  := 6;
58900		IDRECSIZE[PROC]   := 5;
59000		IDRECSIZE[FUNC]   := 8;
59100	(* 116 - define size of the new types for copyctp *)
59200		IDRECSIZE[PARAMS] := 5;
59300		IDRECSIZE[LABELT] := 6;
59400		STRECSIZE[SCALAR] := 2;
59500		STRECSIZE[SUBRANGE]:=4;
59600		STRECSIZE[POINTER]:= 2;
59700		STRECSIZE[POWER]  := 2;
59800		STRECSIZE[ARRAYS] := 3;
59900		STRECSIZE[RECORDS]:= 3;
60000		STRECSIZE[FILES]  := 2;
60100		STRECSIZE[TAGFWITHID]:=3;
60200		STRECSIZE[TAGFWITHOUTID] := 3;
60300		STRECSIZE[VARIANT] :=4
60400	       END;
60500	
60600	      INITPROCEDURE %ERRORMESSAGES\ ;
60700	       BEGIN
60800		ERRMESS15[ 1] := '":" expected   ';
60900		ERRMESS15[ 2] := '")" expected   ';
61000		ERRMESS15[ 3] := '"(" expected   ';
61100		ERRMESS15[ 4] := '"[" expected   ';
61200		ERRMESS15[ 5] := '"]" expected   ';
61300		ERRMESS15[ 6] := '";" expected   ';
61400		ERRMESS15[ 7] := '"=" expected   ';
61500		ERRMESS15[ 8] := '"," expected   ';
61600		ERRMESS15[ 9] := '":=" expected  ';
61700		ERRMESS15[10] := '"OF" expected  ';
61800		ERRMESS15[11] := '"DO" expected  ';
61900		ERRMESS15[12] := '"IF" expected  ';
62000		ERRMESS15[13] := '"END" expected ';
62100		ERRMESS15[14] := '"THEN" expected';
62200		ERRMESS15[15] := '"EXIT" expected';
62300		ERRMESS15[16] := 'Illegal symbol ';
62400		ERRMESS15[17] := 'No sign allowed';
62500		ERRMESS15[18] := 'Number expected';
62600		ERRMESS15[19] := 'Not implemented';
62700		ERRMESS15[20] := 'Error in type  ';
62800	(* 35 - new error - no longer need old one, so we replaced*)
62900		ERRMESS15[21] := 'Compiler error ';
63000		ERRMESS15[22] := '"." expected   ';
63100		ERRMESS15[23] := 'Error in factor';
63200		ERRMESS15[24] := 'Too many digits';
63300	
63400		ERRMESS20[ 1] := '"BEGIN" expected    ';
63500		ERRMESS20[ 2] := '"UNTIL" expected    ';
63600		ERRMESS20[ 3] := 'Error in options    ';
63700		ERRMESS20[ 4] := 'Constant too large  ';
63800		ERRMESS20[ 5] := 'Digit must follow   ';
63900		ERRMESS20[ 6] := 'Exponent too large  ';
64000		ERRMESS20[ 7] := 'Constant expected   ';
64100		ERRMESS20[ 8] := 'Simple type expected';
64200		ERRMESS20[ 9] := 'Identifier expected ';
64300		ERRMESS20[10] := 'Realtype not allowed';
64400		ERRMESS20[11] := 'Multidefined label  ';
64500		ERRMESS20[12] := 'Filename expected   ';
64600		ERRMESS20[13] := 'Set type expected   ';
64700		ERRMESS20[14] := 'Undeclared exitlabel';
64800		ERRMESS20[15] := 'Undeclared label    ';
64900	(* 6 - add error msg for illegal character *)
65000		ERRMESS20[16] := 'Illegal character   ';
65100	
65200		ERRMESS25[ 1] := '"TO"/"DOWNTO" expected   ';
65300		ERRMESS25[ 2] := '8 OR 9 in octal number   ';
65400		ERRMESS25[ 3] := 'Identifier not declared  ';
65500		ERRMESS25[ 4] := 'File not allowed here    ';
     
00100		ERRMESS25[ 5] := 'Integer constant expected';
00200		ERRMESS25[ 6] := 'Error in parameterlist   ';
00300		ERRMESS25[ 7] := 'Already forward declared ';
00400		ERRMESS25[ 8] := 'This format for real only';
00500		ERRMESS25[ 9] := 'Varianttype must be array';
00600		ERRMESS25[10] := 'Type conflict of operands';
00700		ERRMESS25[11] := 'Multidefined case label  ';
00800		ERRMESS25[12] := 'Octal for integer only   ';
00900		ERRMESS25[13] := 'Array index out of bounds';
01000	(* 26 - two new error messages for reset/rewrite/update *)
01100		ERRMESS25[14] := 'Must be array or record  ';
01200		ERRMESS25[15] := 'Must be at least 5 words ';
01300	(* 104 - error message for too much data for address space *)
01400		ERRMESS25[16] := 'Data won''t fit in memory ';
01500	
01600		ERRMESS30[ 1] := 'String constant is too long   ';
01700		ERRMESS30[ 2] := 'Identifier already declared   ';
01800		ERRMESS30[ 3] := 'Subrange bounds must be scalar';
01900		ERRMESS30[ 4] := 'Incompatible subrange types   ';
02000		ERRMESS30[ 5] := 'Incompatible with tagfieldtype';
02100		ERRMESS30[ 6] := 'Index type may not be integer ';
02200		ERRMESS30[ 7] := 'Type of variable is not array ';
02300		ERRMESS30[ 8] := 'Type of variable is not record';
02400		ERRMESS30[ 9] := 'No such field in this record  ';
02500		ERRMESS30[10] := 'Expression too complicated    ';
02600		ERRMESS30[11] := 'Illegal type of operand(s)    ';
02700		ERRMESS30[12] := 'Tests on equality allowed only';
02800		ERRMESS30[13] := 'Strict inclusion not allowed  ';
02900	(* 24 - CAN'T COMPARE RECORDS OR ARRAYS NOW *)
03000		ERRMESS30[14] := 'Structure comparison illegal  ';
03100		ERRMESS30[15] := 'Illegal type of expression    ';
03200		ERRMESS30[16] := 'Value of case label too large ';
03300		ERRMESS30[17] := 'Too many nested withstatements';
03400	
03500		ERRMESS35[ 1] := 'String constant contains "<CR><LF>"';
03600		ERRMESS35[ 2] := 'Basetype requires more than 72 bits';
03700		ERRMESS35[ 3] := 'Basetype must be scalar or subrange';
03800		ERRMESS35[ 4] := 'More than 12 files declared by user';
03900		ERRMESS35[ 5] := 'File as value parameter not allowed';
04000		ERRMESS35[ 6] := 'Procedure too long (too much code) ';
04100		ERRMESS35[ 7] := 'No packed structure allowed here   ';
04200		ERRMESS35[ 8] := 'Variant must belong to tagfieldtype';
04300		ERRMESS35[ 9] := 'Type of operand(s) must be boolean ';
04400		ERRMESS35[10] := 'Set element types not compatible   ';
04500		ERRMESS35[11] := 'Assignment to files not allowed    ';
04600		ERRMESS35[12] := 'Too many labels in this procedure  ';
04700		ERRMESS35[13] := 'Too many cases in case statement   ';
04800		ERRMESS35[14] := 'Control variable may not be formal ';
04900		ERRMESS35[15] := 'Illegal type of for-controlvartandard function is not allowed    ';
09000		ERRMESS50[ 3] := 'Parameter type does not agree with declaration    ';
09100		ERRMESS50[ 4] := 'Initialisation only by assignment of constants    ';
09200		ERRMESS50[ 5] := 'Label type incompatible with selecting expression ';
09300		ERRMESS50[ 6] := 'Statement must end with ";","END","ELSE"or"UNTIL" ';
09400		ERRMESS50[ 7] := 'Not allowed in initprocedures (packed structure?) ';
09500	(* 33 - PROGRAM *)
09600	        ERRMESS50[ 8] := 'File mentioned in PROGRAM statement not declared  ';
09700	(* 211 - better err msg *)
09800		ERRMESS50[ 9] := 'Variable mentioned in PROGRAM statement not a file';
09900	
10000		ERRMESS55[ 1] := 'Function result type must be scalar,subrange or pointer';
10100		ERRMESS55[ 2] := 'Forward decl. func:repetition of resulttype not allowed';
10200		ERRMESS55[ 3] := 'Forward decl.: repetition of parameter list not allowed';
10300		ERRMESS55[ 4] := 'Number of parameters does not agree with declaration   ';
10400		ERRMESS55[ 5] := 'Resulttype of parameter func. does not agree with decl.';
10500		ERRMESS55[ 6] := 'Selected expression must have type of control variable ';
10600	(* 124 - detect bad initproc *)
10700		ERRMESS55[ 7] := 'INITPROCEDURE can''t be within a procedure or function  ';
10800	       END %ERROR MESSAGES\ ;
10900	
11000	(* 105 - new mapping from lower case *)
11100	     initprocedure  %character mapping tables\ ;
11200		begin
11300		charmap[0B] := 0B;	charmap[1B] := 1B;	charmap[2B] := 2B;	charmap[3B] := 3B;
11400		charmap[4B] := 4B;	charmap[5B] := 5B;	charmap[6B] := 6B;	charmap[7B] := 7B;
11500		charmap[10B] := 10B;	charmap[11B] := 11B;	charmap[12B] := 12B;	charmap[13B] := 13B;
11600		charmap[14B] := 14B;	charmap[15B] := 15B;	charmap[16B] := 16B;	charmap[17B] := 17B;
11700		charmap[20B] := 20B;	charmap[21B] := 21B;	charmap[22B] := 22B;	charmap[23B] := 23B;
11800		charmap[24B] := 24B;	charmap[25B] := 25B;	charmap[26B] := 26B;	charmap[27B] := 27B;
11900		charmap[30B] := 30B;	charmap[31B] := 31B;	charmap[32B] := 32B;	charmap[33B] := 33B;
12000		charmap[34B] := 34B;	charmap[35B] := 35B;	charmap[36B] := 36B;	charmap[37B] := 37B;
12100		charmap[40B] := 40B;	charmap[41B] := 41B;	charmap[42B] := 42B;	charmap[43B] := 43B;
12200		charmap[44B] := 44B;	charmap[45B] := 45B;	charmap[46B] := 46B;	charmap[47B] := 47B;
12300		charmap[50B] := 50B;	charmap[51B] := 51B;	charmap[52B] := 52B;	charmap[53B] := 53B;
12400		charmap[54B] := 54B;	charmap[55B] := 55B;	charmap[56B] := 56B;	charmap[57B] := 57B;
12500		charmap[60B] := 60B;	charmap[61B] := 61B;	charmap[62B] := 62B;	charmap[63B] := 63B;
12600		charmap[64B] := 64B;	charmap[65B] := 65B;	charmap[66B] := 66B;	charmap[67B] := 67B;
12700		charmap[70B] := 70B;	charmap[71B] := 71B;	charmap[72B] := 72B;	charmap[73B] := 73B;
12800		charmap[74B] := 74B;	charmap[75B] := 75B;	charmap[76B] := 76B;	charmap[77B] := 77B;
12900		charmap[100B] := 100B;	charmap[101B] := 101B;	charmap[102B] := 102B;	charmap[103B] := 103B;
13000		charmap[104B] := 104B;	charmap[105B] := 105B;	charmap[106B] := 106B;	charmap[107B] := 107B;
13100		charmap[110B] := 110B;	charmap[111B] := 111B;	charmap[112B] := 112B;	charmap[113B] := 113B;
13200		charmap[114B] := 114B;	charmap[115B] := 115B;	charmap[116B] := 116B;	charmap[117B] := 117B;
13300		charmap[120B] := 120B;	charmap[121B] := 121B;	charmap[122B] := 122B;	charmap[123B] := 123B;
13400		charmap[124B] := 124B;	charmap[125B] := 125B;	charmap[126B] := 126B;	charmap[127B] := 127B;
13500		charmap[130B] := 130B;	charmap[131B] := 131B;	charmap[132B] := 132B;	charmap[133B] := 133B;
13600		charmap[134B] := 134B;	charmap[135B] := 135B;	charmap[136B] := 136B;	charmap[137B] := 137B;
13700		charmap[140B] := 140B;	charmap[141B] := 101B;	charmap[142B] := 102B;	charmap[143B] := 103B;
13800		charmap[144B] := 104B;	charmap[145B] := 105B;	charmap[146B] := 106B;	charmap[147B] := 107B;
13900		charmap[150B] := 110B;	charmap[151B] := 111B;	charmap[152B] := 112B;	charmap[153B] := 113B;
14000		charmap[154B] := 114B;	charmap[155B] := 115B;	charmap[156B] := 116B;	charmap[157B] := 117B;
14100		charmap[160B] := 120B;	charmap[161B] := 121B;	charmap[162B] := 122B;	charmap[163B] := 123B;
14200		charmap[164B] := 124B;	charmap[165B] := 125B;	charmap[166B] := 126B;	charmap[167B] := 127B;
14300		charmap[170B] := 130B;	charmap[171B] := 131B;	charmap[172B] := 132B;	charmap[173B] := 173B;
14400		charmap[174B] := 174B;	charmap[175B] := 175B;	charmap[176B] := 176B;	charmap[177B] := 177B;
14500	(* 140 - redid numbers to make it come in the same order as ASCII *)
14600		setmap[0B] := 0B;	setmap[1B] := 0B;	setmap[2B] := 0B;	setmap[3B] := 0B;
14700		setmap[4B] := 0B;	setmap[5B] := 0B;	setmap[6B] := 0B;	setmap[7B] := 0B;
14800		setmap[10B] := 0B;	setmap[11B] := 1B;	setmap[12B] := 0B;	setmap[13B] := 0B;
14900		setmap[14B] := 0B;	setmap[15B] := 0B;	setmap[16B] := 0B;	setmap[17B] := 0B;
15000		setmap[20B] := 0B;	setmap[21B] := 0B;	setmap[22B] := 0B;	setmap[23B] := 0B;
15100		setmap[24B] := 0B;	setmap[25B] := 0B;	setmap[26B] := 0B;	setmap[27B] := 0B;
15200		setmap[30B] := 0B;	setmap[31B] := 0B;	setmap[32B] := 0B;	setmap[33B] := 0B;
15300		setmap[34B] := 0B;	setmap[35B] := 0B;	setmap[36B] := 0B;	setmap[37B] := 0B;
15400		setmap[40B] := 2B;	setmap[41B] := 3B;	setmap[42B] := 4B;	setmap[43B] := 5B;
15500		setmap[44B] := 6B;	setmap[45B] := 7B;	setmap[46B] := 10B;	setmap[47B] := 11B;
15600		setmap[50B] := 12B;	setmap[51B] := 13B;	setmap[52B] := 14B;	setmap[53B] := 15B;
15700		setmap[54B] := 16B;	setmap[55B] := 17B;	setmap[56B] := 20B;	setmap[57B] := 21B;
15800		setmap[60B] := 22B;	setmap[61B] := 23B;	setmap[62B] := 24B;	setmap[63B] := 25B;
15900		setmap[64B] := 26B;	setmap[65B] := 27B;	setmap[66B] := 30B;	setmap[67B] := 31B;
16000		setmap[70B] := 32B;	setmap[71B] := 33B;	setmap[72B] := 34B;	setmap[73B] := 35B;
16100		setmap[74B] := 36B;	setmap[75B] := 37B;	setmap[76B] := 40B;	setmap[77B] := 41B;
16200		setmap[100B] := 42B;	setmap[101B] := 43B;	setmap[102B] := 44B;	setmap[103B] := 45B;
16300		setmap[104B] := 46B;	setmap[105B] := 47B;	setmap[106B] := 50B;	setmap[107B] := 51B;
16400		setmap[110B] := 52B;	setmap[111B] := 53B;	setmap[112B] := 54B;	setmap[113B] := 55B;
16500		setmap[114B] := 56B;	setmap[115B] := 57B;	setmap[116B] := 60B;	setmap[117B] := 61B;
16600		setmap[120B] := 62B;	setmap[121B] := 63B;	setmap[122B] := 64B;	setmap[123B] := 65B;
16700		setmap[124B] := 66B;	setmap[125B] := 67B;	setmap[126B] := 70B;	setmap[127B] := 71B;
16800		setmap[130B] := 72B;	setmap[131B] := 73B;	setmap[132B] := 74B;	setmap[133B] := 75B;
16900		setmap[134B] := 76B;	setmap[135B] := 77B;	setmap[136B] := 100B;	setmap[137B] := 101B;
17000		setmap[140B] := 102B;	setmap[141B] := 43B;	setmap[142B] := 44B;	setmap[143B] := 45B;
17100		setmap[144B] := 46B;	setmap[145B] := 47B;	setmap[146B] := 50B;	setmap[147B] := 51B;
17200		setmap[150B] := 52B;	setmap[151B] := 53B;	setmap[152B] := 54B;	setmap[153B] := 55B;
17300		setmap[154B] := 56B;	setmap[155B] := 57B;	setmap[156B] := 60B;	setmap[157B] := 61B;
17400		setmap[160B] := 62B;	setmap[161B] := 63B;	setmap[162B] := 64B;	setmap[163B] := 65B;
17500		setmap[164B] := 66B;	setmap[165B] := 67B;	setmap[166B] := 70B;	setmap[167B] := 71B;
17600		setmap[170B] := 72B;	setmap[171B] := 73B;	setmap[172B] := 74B;	setmap[173B] := 103B;
17700		setmap[174B] := 104B;	setmap[175B] := 105B;	setmap[176B] := 106B;	setmap[177B] := 107B;
17800		end; %character mapping tables\
17900	
18000	      %-------------------------------------------------------------------------------\
18100	
18200	(* 40 - make it restartable *)
18300	      procedure reinit;
18400		begin
18500		CHANTAB[1] := 0; CHANTAB[2] := 0; CHANTAB[3] := 0; CHANTAB[4] := 0;
18600	(* 65 - remove exit labels *)
18700		FWPTR := NIL; LASTBTP := NIL;  FGLOBPTR := NIL ; FILEPTR := NIL ;
18800		LOCALPFPTR:=NIL; EXTERNPFPTR:= NIL; GLOBTESTP := NIL; ERRMPTR := NIL;
18900	(* 24 - INITIALZE HEAP AND STACK *)
19000		HEAP := 0; STACK := 0;
19100	(* 124 - initialize CREF *)
19200	(* 125 - and REQFILE *)
19300		CREF := false;  reqfile := false;
19400	
19500		LISTCODE := FALSE; LOADNOPTR := TRUE; INITGLOBALS := FALSE ; RUNTMCHECK := TRUE;
19600	(* 157 - separate check for arith error *)
19700		ARITHCHECK := TRUE;
19800		TTYINUSE := TRUE; FOLLOWERROR := FALSE; ERRORINLINE := FALSE; RESETFLAG := TRUE;
19900	(* 172 - end of line *)
20000		TTYSEEEOL := FALSE;
20100		DP := TRUE; PRTERR := TRUE; ERRORFLAG := FALSE ; MAIN := TRUE;
20200		ENTRYDONE := FALSE; DEBUG := FALSE; DEBUGSWITCH := FALSE;
20300	(* 176 *)
20400	        comment_page := 0;
20500	(* 33 - PROGRAM *)
20600		FPROGFILE := NIL; LPROGFILE := NIL;
20700	
20800		IC := HIGHSTART;     %START OF HIGHSEGMENT\
20900		LC := PROGRST;	     %START OF LOWSEGMENT AVAILABLE TO PROGRAM\
21000	(* 136 - listing format *)
21100		CHCNT := 0; LINECNT := 1; PAGECNT := 1; SUBPAGE := 0; CURLINE := 1;
21200		LASTLINE := -1; LASTPAGE := 0;
21300	(* 12 - initialize new variables for dynamic core *)
21400		LIBIX := 0; ERRINX := 0; LSTNEW := 0; NEWBND := 0;
21500		with pager.word1 do
21600		  begin instr:=0;ac:=0;indbit:=0;inxreg:=0;address:=0 end;
21700		pager.lhalf := 0; pager.rhalf := 0;
21800		debugentry.lastpageelem := pager;
21900		laststop := 0; lastpager := 0;
22000	(* 103 - changed type for idtree's *)
22100		debugentry.standardidtree := nil;
22200		debugentry.globalidtree := nil;
22300		filename := '          ';
22400		LIBRARY[PASCALSY].INORDER   := FALSE;
22500		LIBRARY[FORTRANSY].INORDER  := FALSE;
22600		LIBRARY[ALGOLSY].INORDER    := FALSE;
22700		LIBRARY[COBOLSY].INORDER    := FALSE;
22800		LIBRARY[PASCALSY].CALLED    := FALSE;
22900		LIBRARY[FORTRANSY].CALLED   := FALSE;
23000		LIBRARY[ALGOLSY].CALLED     := FALSE;
23100		LIBRARY[COBOLSY].CALLED     := FALSE;
23200	(* 105 - map lower case better *)
23300		setmapchain := 0;
23400		end;
23500	
23600	(* 136 - new listing format *)
23700	
23800	      procedure pagehead;
23900		  begin
24000		  page;
24100		  write(header,'  ',day,'     ',scandata^.relname);
24200		  if reqfile
24300		    then write('  ****Included file****');
24400		  write('     Page ',pagecnt:0);
24500		  if subpage > 0
24600		    then write('-',subpage:0);
24700		  writeln;
24800		  writeln;
24900		  curline := 1;
25000		  end;
25100	
25200	      procedure newline;
25300		begin
25400		writeln;	
25500		curline := curline+1;
25600		if curline > 53
25700		  then begin
25800		  subpage := subpage + 1;
25900		  pagehead;
26000		  end
26100		end;
26200	
26300	      PROCEDURE NEWPAGER;
26400	       BEGIN
26500		WITH PAGER, WORD1 DO
26600		 BEGIN
26700		  AC := PAGECNT DIV 16;
26800		  INXREG := PAGECNT MOD 16; ADDRESS := LASTPAGER;
26900		  LHALF := LASTLINE; RHALF := LASTSTOP;
27000		  LASTLINE := -1
27100		 END
27200	       END;
27300	
27400	(* 5 - reorganized printing somewhat for CREF *)
27500	(* The FILCOM is a bit misleading here, as global changes have been made *)
27600	      PROCEDURE BEGOFLINE;
27700		BEGIN
27800		IF CREF THEN WRITE(CHR(177B),'A');
27900		IF CHCNT > CHCNTMAX THEN CHCNT := CHCNTMAX;
28000		 IF LISTCODE
28100		 THEN
28200		   BEGIN
28300	(* 5 - more of the CREF change *)
28400		     IF BEGDP
28500		     THEN
28600		       BEGIN
28700			WRITE(BEGLC:6:O);
28800			 IF (BEGLC < PROGRST) OR (BEGLEVEL > 1)
28900			 THEN WRITE(' ')
29000			 ELSE WRITE('''')
29100		       END
29200		     ELSE WRITE(BEGIC:6:O,'''');
29300		    WRITE(' ':2)
29400		   END;
29500		 IF LINENR='-----'
29600		 THEN  WRITE(LINECNT:5)
29700		 ELSE  WRITE(LINENR) ;
29800		WRITE(' ':3);
29900	        END;
30000	
30100	      PROCEDURE WRITEBUFFER;
30200	       BEGIN
30300		 IF LISTCODE
30400		 THEN
30500		   BEGIN
30600	(* 5 - more CREF *)
30700		   IF CREF THEN WRITE(CHR(177B),'B'); BEGOFLINE;
30800	(* 136 - listing format *)
30900		    WRITE(BUFFER:CHCNT); FOR CHCNT := 1 TO 17 DO BUFFER[CHCNT] := ' '; CHCNT := 17;
31000		   newline;
31100		   END
31200	       END;
31300	
31400	      PROCEDURE GETNEXTLINE;
31500	       BEGIN
31600		 LOOP
31700		  GETLINENR(LINENR);
31800	         EXIT IF INPUT^ # CHR(14B);    %TEST END OF PAGE\
31900		   IF DEBUG AND (LASTLINE > -1)
32000		   THEN NEWPAGER;
32100	(* 136 - listing format *)
32200		  PAGECNT := PAGECNT + 1; SUBPAGE := 0;
32300		  pagehead;
32400	(* 137 - reset line to 1 on each page *)
32500		  linecnt := 1;
32600		  READLN;  %TO OVERREAD SECOND CARRIAGE RETURN IN PAGE MARK\
32700		 END;
32800		 IF CREF
32900		   THEN WRITE(CHR(177B),'B');
33000		 BEGIC:=IC;BEGLC:=LC;BEGDP:=DP;BEGLEVEL:=LEVEL;
33100	       END;
33200	
33300	(* 56 - needed for file switch *)
33400	      PROCEDURE BEGSTUFF;
33500		BEGIN
33600		IF CREF
33700		  THEN WRITE(CHR(177B),'B');
33800		BEGIC:=IC;BEGLC:=LC;BEGDP:=DP;BEGLEVEL:=LEVEL;
33900		CHCNT:=0
34000		END;
34100	
34200	(* 16 - DETECT UNEXPECTED EOF *)
34300	(* 41 - make restartable *)
34400	     PROCEDURE PASXIT(VAR A,B,C:FILE); EXTERN;
34500	(* 55 - ADD PROC'S FOR REQUIRE FILES *)
34600	     PROCEDURE PUSHF(VAR F:FILE;S:STRGARR;L:INTEGER); EXTERN;
34700	     PROCEDURE POPF(VAR F:FILE); EXTERN;
34800	(* 107 - moved declaration of analys so can be used several places *)
34900	     procedure analys(var f:file); extern;
35000	(* 112 - clrbfi when error detected *)
35100	     procedure clribf; extern;
35200	(* 141 - better detection of number overflow *)
35300	     function overflow:Boolean; extern;
35400	(* 155 - source file name *)
35500	     procedure curname(var f:file;var s:string); extern;
35600	
35700	(* 56 - SEPARATE OUT STUFF NEEDED FOR FILE SWITCH *)
35800	      PROCEDURE ENDSTUFF;
35900	      VAR
36000		I,K: INTEGER;
36100	       BEGIN
36200	(* 5 - more CREF *)
36300		BEGOFLINE;
36400	(* 136 - listing format *)
36500		WRITE(BUFFER:CHCNT); NEWLINE;
36600		 IF ERRORINLINE
36700		 THEN  %OUTPUT ERROR MESSAGES\
36800		   BEGIN
36900		     IF LISTCODE
37000		     THEN K := 11
37100		     ELSE K := 2;
37200		    WRITE(' ':K,'***** '); LISTCODE := FALSE;
37300		     IF LINENR = '-----'
37400		     THEN WRITE(TTY,LINECNT:5)
37500		     ELSE WRITE(TTY,LINENR);
37600		    WRITELN(TTY,' ':3,BUFFER:CHCNT); WRITE(TTY,'P*',PAGECNT:3,'** ');
37700	(* 5 - more CREF *)
37800		    FOR K:=1 TO CHCNT DO
37900		     IF BUFFER[K] = CHR(11B)
38000		      THEN ERRLINE[K] := CHR(11B);
38100	(* 136 - LISTING FORMAT *)
38200		    WRITE(ERRLINE :  CHCNT); WRITELN(TTY,ERRLINE : CHCNT); NEWLINE;
38300		    FOR K := 1 TO ERRINX DO
38400		    WITH ERRLIST[K] DO
38500		     BEGIN
38600		      WRITE(' ':15,ARW:1,'.',TIC,':  '); WRITE(TTY,ARW:1,'.',TIC,':  ');
38700		       IF ERRMPTR # NIL
38800		       THEN
38900			 BEGIN
39000			  ERRMPTR1 := ERRMPTR;
39100			  WHILE ERRMPTR1 # NIL DO
39200			  WITH ERRMPTR1^ DO
39300			   BEGIN
39400			     IF NMR = NUMBER
39500			     THEN
39600			       BEGIN
39700				 CASE FORM OF
39800				  C:
39900				     BEGIN
40000				      WRITE(STRING:10,' --> ');WRITE(TTY,STRING:10,' --> ')
40100				     END;
40200				  D:
40300				     BEGIN
40400				      WRITE(INTVAL:5,' --> ');WRITE(TTY,INTVAL:5,' --> ')
40500				     END
40600				 END;
40700				NUMBER := 0; ERRMPTR1 := NIL
40800			       END
40900			     ELSE ERRMPTR1 := NEXT
41000			   END
41100			 END;
41200		      I := NMR MOD 50;
41300		       CASE NMR DIV 50 OF
41400			3:
41500			   BEGIN
41600			    WRITE(ERRMESS15[I]); WRITE(TTY,ERRMESS15[I])
41700			   END;
41800			4:
41900			   BEGIN
42000			    WRITE(ERRMESS20[I]); WRITE(TTY,ERRMESS20[I])
42100			   END;
42200			5:
42300			   BEGIN
42400			    WRITE(ERRMESS25[I]); WRITE(TTY,ERRMESS25[I])
42500			   END;
42600			6:
42700			   BEGIN
42800			    WRITE(ERRMESS30[I]); WRITE(TTY,ERRMESS30[I])
42900			   END;
43000			7:
43100			   BEGIN
43200			    WRITE(ERRMESS35[I]); WRITE(TTY,ERRMESS35[I])
43300			   END;
43400			8:
43500			   BEGIN
43600			    WRITE(ERRMESS40[I]); WRITE(TTY,ERRMESS40[I])
43700			   END;
43800			9:
43900			   BEGIN
44000			    WRITE(ERRMESS45[I]); WRITE(TTY,ERRMESS45[I])
44100			   END;
44200			10:
44300			    BEGIN
44400			     WRITE(ERRMESS50[I]); WRITE(TTY,ERRMESS50[I])
44500			    END;
44600			11:
44700			    BEGIN
44800			     WRITE(ERRMESS55[I]); WRITE(TTY,ERRMESS55[I])
44900			    END
45000		       END;
45100	(* 136 - LISTING FORMAT *)
45200		      newline; WRITELN(TTY)
45300		     END;
45400	(* 26 - break not needed for TTY *)
45500		    ERRINX := 0; ERRORINLINE := FALSE;
45600		    FOR I := 1 TO CHCNT DO ERRLINE [I] := ' ';
45700		    ERRMPTR := NIL
45800		   END;
45900	(* 56 -SEPARATE OUT STUFF NEEDED FOR FILE SWITCH *)
46000	        END;
46100	
46200	      PROCEDURE ENDOFLINE(OKEOF:BOOLEAN);
46300		BEGIN
46400		ENDSTUFF;
46500	(* 16 - DETECT UNEXPECTED EOF *)
46600	        IF EOF(INPUT) AND NOT OKEOF
46700		  THEN BEGIN
46800	(* 136 - LISTING FORMAT *)
46900		  WRITE('Unexpected end of file'); NEWLINE;
47000		  WRITELN(TTY,'?  Unexpected end of file');
47100	(* 176 - error for unexpected EOF in a comment *)
47200	          if comment_page <> 0 then	(* we're in a comment *)
47300	                 begin
47400	                    write('Unterminated Comment at ',comment_page:0,
47500				  '/',comment_line:0); NEWLINE;
47600	                    writeln(tty,'?  Unterminated Comment at ',comment_page:0,
47700				    '/',comment_line:0)
47800			 end;
47900	(* 41 - make restartable *)
48000	(* 107 - abort creation of rel file on error *)
48100		  rewrite(outputrel);
48200	(* 112 - clrbfi when error *)
48300		  clribf;
48400	(* 125 - popf to be sure we get main file closed in reqfile *)
48500		  if reqfile
48600		    then begin
48700		    close(input);
48800		    popf(input)
48900		    end;
49000		  PASXIT(INPUT,OUTPUT,OUTPUTREL)
49100		  END;
49200		READLN;
49300	(* 147 - move incr linecnt here so first line of new page is 1 *)
49400		LINECNT := LINECNT + 1;
49500		 IF NOT EOF(INPUT)
49600		 THEN GETNEXTLINE;
49700	(* 136 - listing format *)
49800	        CHCNT := 0
49900	       END  %ENDOFLINE\ ;
50000	
50100	      PROCEDURE ERROR(FERRNR: INTEGER);
50200	      VAR
50300		LPOS,LARW : INTEGER;
50400	       BEGIN
50500		 IF NOT FOLLOWERROR
50600		 THEN
50700		   BEGIN
50800		    ERRORFLAG := TRUE ;
50900		     IF ERRINX >= MAXERR
51000		     THEN
51100		       BEGIN
51200			ERRLIST[MAXERR].NMR := 410; ERRINX := MAXERR
51300		       END
51400		     ELSE
51500		       BEGIN
51600			ERRINX := ERRINX + 1;
51700		        WITH ERRLIST[ERRINX] DO BEGIN NMR := FERRNR; TIC := '^' END
51800		       END;
51900		    FOLLOWERROR := TRUE; ERRORINLINE := TRUE;
52000		    IF (FERRNR # 215)
52100		    AND (FERRNR # 356)
52200		    AND (FERRNR # 405)
52300		    AND (FERRNR # 464)
52400		    THEN
52500		     IF EOLN(INPUT)
52600		     THEN ERRLINE [CHCNT] := '^'
52700		     ELSE ERRLINE [CHCNT-1] := '^'
52800		    ELSE ERRLIST[ERRINX].TIC := ' ';
52900		     IF ERRINX > 1
53000		     THEN
53100		      WITH ERRLIST [ ERRINX-1] DO
53200		       BEGIN
53300			LPOS := POS; LARW := ARW
53400		       END;
53500		    WITH ERRLIST [ERRINX] DO
53600		     BEGIN
53700		      POS := CHCNT;
53800		       IF ERRINX = 1
53900		       THEN ARW := 1
54000		       ELSE
54100			 IF LPOS = CHCNT
54200			 THEN ARW := LARW
54300			 ELSE ARW := LARW + 1
54400		     END;
54500		   END;
54600	       END %ERROR\ ;
54700	
54800	      PROCEDURE ERRORWITHTEXT ( FERRNR: INTEGER; FTEXT: ALFA ) ;
54900	       BEGIN
55000		ERROR(FERRNR); NEWZ(ERRMPTR1,C);
55100		WITH ERRMPTR1^ DO
55200		 BEGIN
55300		  NUMBER := FERRNR; STRING := FTEXT;
55400		  NEXT := ERRMPTR
55500		 END;
55600		ERRMPTR := ERRMPTR1
55700	       END %ERROR WITH TEXT\ ;
55800	
55900	      PROCEDURE INSYMBOL;
56000		%READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS
56100		 DESCRIPTION IN THE GLOBAL VARIABLES SY, OP, ID, VAL AND LGTH\
56200	(* 114 - prevent recursive comment scanning *)
56300	      LABEL 2;
56400	      CONST
56500	(* 210 - allow 9 digit hex numbers *)
56600		hexmax = 9;
56700		DIGMAX = 12; MAX8 =  37777777777B;
56800		TEST8 =  40000000000B;
56900		MIN8 = 400000000000B;
57000	(* 142 - better real number scanning *)
57100		MAX10 = 3435973836; {maximum number, sans last digit}
57200		MAX16 = 17777777777B;
57300		MAXEXP = 35;
57400	      type
57500	(* 43 - allow 12 digit octal no. *)
57600		numconv=record case Boolean of
57700			true:(oct:packed array[1:digmax]of 0..7);
57800			false:(int:integer)
57900			       end;
58000	(* 210 - allow 9 digit hex numbers *)
58100		hexconv=record case Boolean of
58200			true:(hex:packed array[1..hexmax] of 0..15);
58300			false:(int:integer)
58400			       end;
58500	      VAR
58600	(* 133 - make real numbers be read exactly *)
58700		I,K,ASCALE,SCALE,EXP,IVAL: INTEGER;
58800		RVAL,R,FAC: REAL; STRINGTOOLONG,SIGN: BOOLEAN;
58900		DIGIT: ARRAY [1..DIGMAX] OF 0..9;
59000		STRING: ARRAY [1..STRGLGTH] OF CHAR;
59100		LVP: CSP;
59200	(* 43 - allow 12 digit octal no. *)
59300		nc:numconv;
59400	(* 210 - allow 9 digit hex numbers *)
59500		hc:hexconv;
59600	
59700		PROCEDURE NEXTCH;
59800		 BEGIN
59900		   IF EOLN(INPUT)
60000		   THEN CH := ' '
60100		   ELSE
60200		     BEGIN
60300		      %READ(CH);\  CH := INPUT^; GET(INPUT); %THIS CHANGE SAVES 3 INSTRUCTIONS AT RUN-TIME\
60400		      CHCNT := CHCNT + 1;
60500		       IF CHCNT <= CHCNTMAX
60600		       THEN BUFFER[CHCNT] := CH
60700	(* 3 - map lower case to upper.  Need separate NEXTCH for strings now,
60800	       since we don't do mapping there. *)
60900		     END;
61000	(* 105 - improve lower case mapping *)
61100		   ch := chr(charmap[ord(ch)]);
61200		 END;
61300	
61400		PROCEDURE NEXTSTRCH;
61500		 BEGIN
61600		   IF EOLN(INPUT)
61700		   THEN CH := ' '
61800		   ELSE
61900		     BEGIN
62000		      CH := INPUT^; GET(INPUT);
62100		      CHCNT := CHCNT + 1;
62200		       IF CHCNT <= CHCNTMAX
62300		       THEN BUFFER[CHCNT] := CH
62400		     END
62500		 END;
62600	
62700		PROCEDURE OPTIONS;
62800		VAR
62900		  LCH : CHAR; LSWITCH : BOOLEAN;
63000		 BEGIN
63100		   REPEAT
63200		    NEXTCH; LCH := CH;
63300		     IF NOT (CH IN ['\','*'])
63400		     THEN NEXTCH;
63500		     IF NOT (CH IN ['+','-'])
63600	(* 24 - S AND H FOR STACK AND HEAP *)
63700	(* 33 - version *)
63800		     THEN IF (LCH IN ['H','S','V']) AND (CH = ':')
63900			THEN BEGIN
64000			     NEXTCH;
64100			     INSYMBOL;
64200			     IF SY # INTCONST
64300				THEN ERROR(203)
64400	(* 24 - S AND H FOR STACK AND HEAP *)
64500				ELSE BEGIN
64600	(* 33 - version *)
64700				IF LCH IN ['H','S']
64800				  THEN BEGIN
64900				  IF (VAL.IVAL MOD 1000B) = 0
65000				    THEN VAL.IVAL := VAL.IVAL -1;
65100				  VAL.IVAL := (VAL.IVAL DIV 1000B)*1000B + 777B;
65200				  END;
65300			          IF LCH = 'S'
65400			            THEN STACK := VAL.IVAL
65500	(* 33 - version *)
65600				  ELSE IF LCH = 'H'
65700				    THEN HEAP := VAL.IVAL
65800				  ELSE VERSION.WORD := VAL.IVAL
65900				  END
66000			     END
66100			ELSE ERROR(203)
66200		     ELSE
66300		       BEGIN
66400			LSWITCH := CH = '+';
66500	(* 157 - use CASE instead of IF nest *)
66600			CASE LCH OF
66700			  'L':  LISTCODE := LSWITCH;
66800			  'T':  IF RESETFLAG THEN TTYINUSE := LSWITCH;
66900			  'M':  IF RESETFLAG THEN MAIN := LSWITCH;
67000			  'C':  BEGIN RUNTMCHECK := LSWITCH; ARITHCHECK := LSWITCH END;
67100			  'A':  ARITHCHECK := LSWITCH;
67200			  'Z':  ZERO := LSWITCH;
67300			  'D':  BEGIN
67400				    DEBUGSWITCH := LSWITCH;
67500	(* 36 - allow us to reset debug at beginning *)
67600				    if resetflag
67700				      then debug := lswitch
67800				      else IF LSWITCH
67900				        THEN DEBUG := TRUE
68000				END
68100			  END
68200		       END;
68300		     IF EOLN(INPUT)
68400	(* 16 - EOF *)
68500		     THEN ENDOFLINE(FALSE);
68600		     IF NOT ((CH IN ['\','*']) OR (LCH = 'H'))
68700		     THEN NEXTCH
68800		   UNTIL CH # ','
68900		 END   %OPTIONS\ ;
69000	
69100	(* 1 - reorganized a bit here, mainly to improve comment scanning *)
69200		PROCEDURE NEWCH;
69300		BEGIN
69400	(* 16 - EOF *)
69500		  IF EOLN(INPUT) THEN ENDOFLINE(FALSE);
69600		  NEXTCH
69700		END;
69800	
69900		PROCEDURE SCANCOMMENT(STOPCH:CHAR);
70000		BEGIN
70100	(* 176 - error for unexpected EOF in a comment *)
70200		  comment_page := pagecnt; { pagecnt had better not be 0 }
70300		  comment_line := linecnt;
70400		  NEWCH;
70500		  IF CH='$' THEN OPTIONS;
70600	(* 105 - curly brackets are now comments *)
70700		  if (stopch = '\') or (stopch = '}')
70800		    then while ch # stopch do newch
70900		  ELSE REPEAT WHILE CH#'*' DO NEWCH; NEXTCH UNTIL CH=STOPCH;
71000	(* 176 - error for unexpected EOF in a comment *)
71100		  comment_page := 0;
71200	(* 114 - prevent deep recursion in comment scanning *)
71300		  NEWCH;
71400		END;
71500	
71600	       BEGIN    2:
71700		%INSYMBOL\
71800	          WHILE (CH = ' ') OR (ORD(CH) = 11B) DO
71900		   BEGIN
72000		     IF EOLN(INPUT)
72100	(* 16 - EOF *)
72200		     THEN ENDOFLINE(FALSE);
72300		    NEXTCH;
72400		   END;
72500	(* 1 - code removed here for comments.  Handled better elsewhere *)
72600		 CASE CH OF
72700		  'A','B','C','D','E','F','G','H','I',
72800		  'J','K','L','M','N','O','P','Q','R',
72900		  'S','T','U','V','W','X','Y','Z':
73000						   BEGIN
73100						    K := 0 ; ID := '          ';
73200						     REPEAT
73300						       IF K < ALFALENG
73400						       THEN
73500							 BEGIN
73600							  K := K + 1; ID[K] := CH
73700							 END ;
73800						      NEXTCH
73900						     UNTIL  NOT (CH IN LETTERSDIGITSORLEFTARROW);
74000						    FOR I := FRW[K] TO FRW[K+1] - 1 DO
74100						     IF RW[I] = ID
74200						     THEN
74300						       BEGIN
74400							SY := RSY[I]; OP := ROP[I]; GOTO 1
74500						       END;
74600						    SY := IDENT; OP := NOOP;
74700	1:
74800						   END;
74900		  '0','1','2','3','4','5','6','7','8','9':
75000							   BEGIN
75100	(* 141 - better way to check overflow *)
75200							    if overflow then; {clear old errors}
75300							    SY := INTCONST; OP := NOOP;
75400	(* 64 - non-loc goto *)
75500							    id := '          ';
75600							    I := 0;
75700							     REPEAT
75800							      I := I + 1;
75900							      if i <= alfaleng
76000								then id[i] := ch;
76100							       IF I <= DIGMAX
76200	(* 142 - better real scanning *)
76300							       THEN DIGIT[I] := ORD(CH) - ORD('0');
76400							      NEXTCH
76500							     UNTIL  NOT (CH IN DIGITS);
76600							    IVAL := 0;
76700							     IF CH = 'B'
76800							     THEN
76900							       BEGIN
77000	(* 43 - allow 12 digit octal no. *)
77100	(* 142 - better real number scanning *)
77200								if i > digmax
77300								  then begin
77400								  error(174);
77500								  i := digmax
77600								  end;
77700								nc.int:=0;
77800								FOR K := 1 TO I DO
77900								     IF DIGIT[K] IN [8,9]
78000								     THEN ERROR(252)
78100								     else nc.oct[k+digmax-i]:=digit[k];
78200								val.ival := nc.int;
78300								NEXTCH
78400							       END
78500							     ELSE
78600							       BEGIN
78700	(* 142 - better real number scanning *)
78800							       scale := 0;
78900								FOR K := 1 TO I DO
79000								  if scale > 0
79100								    then scale := scale + 1
79200								  else if ival < max10
79300								    then ival := 10*ival + digit[k]
79400								  else if (ival = max10) and (digit[k] <= 7)
79500								    then ival := 10*ival + digit[k]
79600								  else scale := scale + 1;
79700								 IF CH = '.'
79800								 THEN
79900								   BEGIN
80000								    NEXTCH;
80100								     IF CH = '.'
80200								     THEN CH := ':'
80300								     ELSE
     
00100								       BEGIN
00200	(* 142 - better real scanning *)
00300									 SY := REALCONST;
00400									 IF  NOT (CH IN DIGITS)
00500									 THEN ERROR(205)
00600									 ELSE
00700									   REPEAT
00800								           if scale > 0
00900								             then scale := scale + 1
01000								           else if ival < max10
01100								             then ival := 10*ival + (ord(ch)-ord('0'))
01200								           else if (ival = max10) and (ch <= '7')
01300								             then ival := 10*ival + (ord(ch)-ord('0'))
01400								           else scale := scale + 1;
01500									    SCALE := SCALE - 1; NEXTCH
01600									   UNTIL  NOT (CH IN DIGITS);
01700								       END
01800								   END;
01900								 IF CH = 'E'
02000								 THEN
02100								   BEGIN
02200	(* 142 - better real scan *)
02300								    sy := realconst;
02400								    NEXTCH;
02500								    SIGN := CH='-';
02600								     IF (CH='+') OR (CH='-')
02700								     THEN NEXTCH;
02800								    EXP := 0;
02900								     IF  NOT (CH IN DIGITS)
03000								     THEN ERROR(205)
03100								     ELSE
03200								       REPEAT
03300									EXP := 10*EXP + (ORD(CH) - ORD('0'));
03400									NEXTCH
03500								       UNTIL  NOT (CH IN DIGITS);
03600								     IF SIGN
03700								     THEN SCALE := SCALE - EXP
03800								     ELSE SCALE := SCALE + EXP;
03900								   END;
04000	(* 142 - better real scan *)
04100								 if sy = realconst
04200								 then begin
04300								 rval := ival;
04400								 IF SCALE # 0
04500								 THEN
04600								   BEGIN
04700	(* 113 - reorganized to handle exact fractions exactly *)
04800								    FAC := 10.0;
04900								    ASCALE := ABS(SCALE);
05000	(* 141 - prevent overflow for exp > 32 *)
05100								     LOOP
05200								       IF ODD(ASCALE)
05300								       THEN if scale > 0
05400									 then rval := rval*FAC
05500									 else rval := rval/fac;
05600								      ASCALE := ASCALE DIV 2;
05700								     EXIT IF ASCALE=0;
05800								      FAC := SQR(FAC);
05900								     END;
06000	(* 141 - better overflow error handling *)
06100								   IF OVERFLOW
06200								     THEN BEGIN
06300								     ERROR(206);
06400								     RVAL := 0.0
06500								     END;
06600								   END;
06700	(* 142 - better real scanning *)
06800								 newz(lvp,reel);
06900								 lvp^.rval := rval;
07000								 val.valp := lvp
07100								 end {real}
07200								else {integer}
07300								 if scale = 0
07400								   then VAL.IVAL := IVAL
07500								   else begin
07600								     error(204);
07700								     val.ival := 0
07800								     end;
07900							       END
08000							   END;
08100		  '"':
08200		       BEGIN
08300			SY := INTCONST; OP := NOOP; IVAL := 0; I := 0; hc.int := 0;
08400			NEXTCH;
08500			WHILE CH IN HEXADIGITS DO
08600			 BEGIN
08700			     i := i + 1;
08800			     if i <= hexmax then
08900				 IF CH IN DIGITS
09000				     THEN  digit[i] := 16*IVAL + ORD(CH) - ORD('0')
09100				     ELSE  digit[i] := 16*IVAL + ORD(CH) - 67B;
09200			     NEXTCH
09300			 END;
09400			if i > hexmax then
09500			    begin
09600				error(174);
09700				i := hexmax
09800			    end;
09900			for k := 1 to i do
10000			    hc.hex[k+hexmax-i] := digit[k];
10100			VAL.IVAL := hc.int;
10200		       END;
10300		  '''':
10400			BEGIN
10500			 LGTH := 0; SY := STRINGCONST;	OP := NOOP;STRINGTOOLONG := FALSE;
10600			  REPEAT
10700			    REPEAT
10800	(* 3 - different NEXTCH so don't map lower case, etc. *)
10900			     NEXTSTRCH;
11000			      IF LGTH < STRGLGTH
11100			      THEN
11200				BEGIN
11300				 LGTH := LGTH + 1; STRING[LGTH] := CH
11400				END
11500			      ELSE STRINGTOOLONG := TRUE
11600			    UNTIL (EOLN(INPUT)) OR (CH = '''');
11700			    IF STRINGTOOLONG
11800			    THEN ERROR(301);
11900			    IF EOLN(INPUT)  AND  (CH#'''')
12000			    THEN ERROR(351)
12100	(* 3 - different NEXTCH so don't map lower case, etc. *)
12200	(* 6 - don't use nextstrch for char after end of string[caused loop] *)
12300			    ELSE NEXTCH  %this is embedded ' or char after string\
12400			  UNTIL CH # '''';
12500			 LGTH := LGTH - 1;   %NOW LGTH = NR OF CHARS IN STRING\
12600			  IF LGTH = 1
12700			  THEN VAL.IVAL := ORD(STRING[1])
12800			  ELSE
12900			    BEGIN
13000			     NEWZ(LVP,STRG:LGTH);
13100			     WITH LVP^ DO
13200			      BEGIN
13300			       SLGTH := LGTH;
13400			       FOR I := 1 TO LGTH DO SVAL[I] := STRING[I]
13500			      END;
13600			     VAL.VALP := LVP
13700			    END
13800			END;
13900		  ':':
14000		       BEGIN
14100			OP := NOOP; NEXTCH;
14200			 IF CH = '='
14300			 THEN
14400			   BEGIN
14500			    SY := BECOMES; NEXTCH
14600			   END
14700			 ELSE SY := COLON
14800		       END;
14900		  '.':
15000		       BEGIN
15100			OP := NOOP; NEXTCH;
15200			 IF CH = '.'
15300			 THEN
15400			   BEGIN
15500			    SY := COLON; NEXTCH
15600			   END
15700			 ELSE SY := PERIOD
15800		       END;
15900		  '?','*','&','+','-','!','\',
16000	(* 1 - / now handled elsewhere *)
16100		  '@','#','=',
16200		  ')','[',']',',',';','^','_','$':
16300						   BEGIN
16400						    SY := SSY[CH]; OP := SOP[CH];
16500						    NEXTCH
16600						   END;
16700	
16800		  '(':
16900		       BEGIN
17000			NEXTCH;
17100	(* 1 - improved comment scanning *)
17200			IF CH='*' THEN BEGIN SCANCOMMENT(')'); GOTO 2 END
17300			ELSE BEGIN SY := LPARENT; OP := NOOP END
17400		       END;
17500	
17600	
17700		  '{':
17800		        BEGIN SCANCOMMENT('}'); GOTO 2 END;
17900		  '%':
18000			BEGIN SCANCOMMENT('\'); GOTO 2 END;
18100	
18200		  '/':
18300			BEGIN
18400			  NEXTCH;
18500			  IF CH='*' THEN BEGIN SCANCOMMENT('/'); GOTO 2 END
18600			  ELSE BEGIN SY := MULOP; OP := RDIV END
18700			END;
18800	
18900	
19000		  '<','>':
19100			   BEGIN
19200			    SY := SSY[CH]; OP := SOP[CH]; NEXTCH;
19300			     IF CH = '='
19400			     THEN
19500			       BEGIN
19600				 IF OP = LTOP
19700				 THEN OP := LEOP
19800				 ELSE OP := GEOP;
19900				NEXTCH
20000			       END
20100	(* 6 - allow <> for not equals *)
20200			     ELSE IF (CH = '>') AND (OP = LTOP)
20300			       THEN
20400				BEGIN
20500				OP := NEOP;
20600				NEXTCH
20700				END
20800			   END;
20900	(* 6 - add error msg in case of illegal character *)
21000		  OTHERS:
21100			BEGIN
21200			ERROR(216);
21300			NEWCH;
21400			INSYMBOL
21500			END
21600		 END %CASE\
21700	       END %INSYMBOL\ ;
21800	
21900	      PROCEDURE ENTERID(FCP: CTP);
22000		%ENTER ID POINTED AT BY FCP INTO THE NAME-TABLE,
22100		 WHICH ON EACH DECLARATION LEVEL IS ORGANISED AS
22200		 AN UNBALANCED BINARY TREE\
22300	      VAR
22400		NAM: ALFA; LCP, LCP1: CTP; LLEFT: BOOLEAN;
22500	       BEGIN
22600		NAM := FCP^.NAME;
22700	(* 5 - CREF *)
22800	        IF CREF
22900		  THEN WRITE(CHR(1B),CHR(21),NAM,' ',DISPLAY[TOP].BLKNAME,CHR(2B));
23000		LCP := DISPLAY[TOP].FNAME;
23100		 IF LCP = NIL
23200		 THEN
23300		  DISPLAY[TOP].FNAME := FCP
23400		 ELSE
23500		   BEGIN
23600		     REPEAT
23700		      LCP1 := LCP;
23800		       IF LCP^.NAME <= NAM
23900		       THEN
24000			 BEGIN
24100			   IF LCP^.NAME = NAM
24200			   THEN ERROR(302) %NAME CONFLICT\;
24300			  LCP := LCP^.RLINK; LLEFT := FALSE
24400			 END
24500		       ELSE
24600			 BEGIN
24700			  LCP := LCP^.LLINK; LLEFT := TRUE
24800			 END
24900		     UNTIL LCP = NIL;
25000		     IF LLEFT
25100		     THEN LCP1^.LLINK := FCP
25200		     ELSE LCP1^.RLINK := FCP
25300		   END;
25400		WITH FCP^ DO
25500		 BEGIN
25600		  LLINK := NIL; RLINK := NIL; SELFCTP := NIL
25700		 END
25800	       END %ENTERID\ ;
25900	
26000	      PROCEDURE SEARCHSECTION(FCP: CTP; VAR FCP1: CTP);
26100		%TO FIND RECORD FIELDS AND FORWARD DECLARED PROCEDURE ID'S
26200		 --> PROCEDURE PROCEDUREDECLARATION
26300		 --> PROCEDURE SELECTOR\
26400	       BEGIN
26500		WHILE FCP # NIL DO
26600		WITH FCP^ DO
26700		 BEGIN
26800		   IF NAME = ID
26900		   THEN GOTO 1;
27000		   IF NAME < ID
27100		   THEN FCP := RLINK
27200		   ELSE FCP := LLINK
27300		 END;
27400	1:
27500		FCP1 := FCP
27600	       END %SEARCHSECTION\ ;
27700	
27800	      PROCEDURE SEARCHID(FIDCLS: SETOFIDS; VAR FCP: CTP);
27900	      VAR
28000		LCP: CTP;
28100	       BEGIN
28200		FOR DISX := TOP DOWNTO 0 DO
28300		 BEGIN
28400		  LCP := DISPLAY[DISX].FNAME;
28500		  WHILE LCP # NIL DO
28600		  WITH LCP^ DO
28700		   IF NAME = ID
28800		   THEN
28900		     IF KLASS IN FIDCLS
29000		     THEN GOTO 1
29100		     ELSE
29200		       BEGIN
29300			 IF PRTERR
29400			 THEN ERROR(401);
29500	(* 170 - fix error handling for forwards *)
29600			GOTO 2
29700		       END
29800		   ELSE
29900		     IF NAME < ID
30000		     THEN
30100		      LCP := RLINK
30200		     ELSE LCP := LLINK
30300		 END;
30400	2:	 LCP := NIL;  {Use NIL if don't find something better below}
30500	(* 5 - save some info for so CREF will know the block name *)
30600		 DISX := TOP; %IF FORWARD, WILL BE IN THIS BLOCK\
30700	(* 114 - use only real block names *)
30800	(* 116 - more elegant way to do this *)
30900	         WHILE DISPLAY[DISX].OCCUR <> BLCK DO
31000		   DISX := DISX - 1;
31100		%SEARCH NOT SUCCSESSFUL; SUPPRESS ERROR MESSAGE IN CASE
31200		 OF FORWARD REFERENCED TYPE ID IN POINTER TYPE DEFINITION
31300		 --> PROCEDURE SIMPLETYPE\
31400		 IF PRTERR
31500		 THEN
31600		   BEGIN
31700		    ERROR(253);
31800		    %TO AVOID RETURNING NIL, REFERENCE AN ENTRY
31900		     FOR AN UNDECLARED ID OF APPROPRIATE CLASS
32000		     --> PROCEDURE ENTERUNDECL\
32100		     IF TYPES IN FIDCLS
32200		     THEN LCP := UTYPPTR
32300		     ELSE
32400		       IF VARS IN FIDCLS
32500		       THEN LCP := UVARPTR
32600		       ELSE
32700			 IF FIELD IN FIDCLS
32800			 THEN LCP := UFLDPTR
32900			 ELSE
33000			   IF KONST IN FIDCLS
33100			   THEN LCP := UCSTPTR
33200			   ELSE
33300			     IF PROC IN FIDCLS
33400			     THEN LCP := UPRCPTR
33500	(* 64 - non-loc gotos *)
33600			     ELSE IF FUNC IN FIDCLS
33700				THEN LCP := UFCTPTR
33800				ELSE LCP := ULBLPTR;
33900		   END;
34000	1:
34100	(* 5 - CREF *)
34200		IF CREF
34300		  THEN WRITE(CHR(1B),CHR(21),ID,' ',DISPLAY[DISX].BLKNAME);
34400		FCP := LCP
34500	       END %SEARCHID\ ;
34600	
34700	      PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN,FMAX: INTEGER);
34800		%GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE\
34900		%ASSUME (FSP # NIL) AND (FSP^.FORM <= SUBRANGE) AND (FSP # INTPTR)
35000		 AND  NOT COMPTYPES(REALPTR,FSP)\
35100	       BEGIN
35200		WITH FSP^ DO
35300		 IF FORM = SUBRANGE
35400		 THEN
35500		   BEGIN
35600		    FMIN := MIN.IVAL; FMAX := MAX.IVAL
35700		   END
35800		 ELSE
35900		   BEGIN
36000		    FMIN := 0;
36100		     IF FSP = CHARPTR
36200		     THEN FMAX := 177B
36300		     ELSE
36400		       IF FCONST # NIL
36500		       THEN
36600			FMAX := FCONST^.VALUES.IVAL
36700		       ELSE FMAX := 0
36800		   END
36900	       END %GETBOUNDS\ ;
37000	
37100	(* 6 - move error stuff outside BLOCK so PROGSTAT can use it *)
37200		PROCEDURE SKIPIFERR(FSYINSYS:SETOFSYS; FERRNR:INTEGER; FSKIPSYS: SETOFSYS);
37300		VAR
37400		  I,OLDCHCNT,OLDLINECNT : INTEGER;
37500		 BEGIN
37600		   IF NOT (SY IN FSYINSYS)
37700		   THEN
37800		     BEGIN
37900		      ERROR(FERRNR);
38000		      OLDLINECNT := LINECNT; OLDCHCNT := CHCNT;
38100		      WHILE NOT (SY IN FSKIPSYS OR FSYINSYS) DO
38200		       BEGIN
38300			 IF OLDLINECNT # LINECNT
38400			 THEN OLDCHCNT := 1;
38500			FOR I := OLDCHCNT TO CHCNT-1 DO
38600			 IF I <= CHCNTMAX
38700			 THEN ERRLINE [I] := '*';
38800			OLDCHCNT := CHCNT; OLDLINECNT := LINECNT; ERRORINLINE := TRUE;
38900			INSYMBOL
39000		       END;
39100		      %SKIP INPUT STRING UNTIL RELEVANT SYMBOL FOUND\
39200		     END;
39300		  FOLLOWERROR := FALSE
39400		 END;
39500	
39600		PROCEDURE IFERRSKIP(FERRNR: INTEGER; FSYS: SETOFSYS);
39700		 BEGIN
39800		  SKIPIFERR(FSYS,FERRNR,FSYS)
39900		 END;
40000	
40100		PROCEDURE ERRANDSKIP(FERRNR: INTEGER; FSYS: SETOFSYS);
40200		 BEGIN
40300		  SKIPIFERR([ ],FERRNR,FSYS)
40400		 END;
40500	
40600	(* 6 - add PROGRAM statement *)
40700	      PROCEDURE PROGSTAT;
40800	(* 34 - allow list of entry point names *)
40900		  VAR STSYM,ENDSYM:SYMBOL;
41000	        BEGIN
41100		IF SY=PROGRAMSY
41200		  THEN
41300		    BEGIN
41400	(* 34 - allow entry point names *)
41500		    IF MAIN
41600		      THEN BEGIN STSYM:=LPARENT; ENDSYM := RPARENT END
41700		      ELSE BEGIN STSYM:=COMMA; ENDSYM := SEMICOLON END;
41800		    INSYMBOL;
41900		    IF SY # IDENT THEN ERROR(209);
42000	(* 33 NO LONGER NEED ENTRY *)
42100		    FILENAME := ID;
42200		    INSYMBOL;
42300	(* 34 - DIFFERENT SYNTAX FOR ENTRY POINTS *)
42400		    IF SY = STSYM
42500		     THEN BEGIN
42600		      REPEAT
42700		      INSYMBOL;
42800		      IF NOT (SY = IDENT)
42900			THEN ERROR(209);
43000	(* 33 - USE FILE NAMES *)
43100		      NEWZ(NPROGFILE);
43200		      NPROGFILE^.FILID := ID;
43300		      NPROGFILE^.NEXT := NIL;
43400		      IF FPROGFILE = NIL
43500			THEN BEGIN
43600			FPROGFILE := NPROGFILE;
43700			LPROGFILE := NPROGFILE
43800			END
43900		       ELSE BEGIN
44000			LPROGFILE^.NEXT := NPROGFILE;
44100			LPROGFILE := NPROGFILE
44200			END;
44300		      INSYMBOL;
44400	(* 61 - allow +* in tops20 *)
44500	(* 144 - allow this stuff in tops10, too *)
44600		      if (sy=colon) and main
44700			then begin
44800			insymbol;
44900			while sy in [addop,mulop,relop] do
45000			  begin
45100			  if (op = mul) and (not tops10)
45200			    then nprogfile^.wild := true
45300			  else if op = plus
45400			    then nprogfile^.newgen := true
45500			  else if op = minus
45600			    then nprogfile^.oldfile := true
45700	(* 64 - input:/ *)
45800			  else if op = rdiv
45900			    then nprogfile^.interact := true
46000	(* 172 - new EOLN treatment *)
46100			  else if op = neop
46200			    then nprogfile^.seeeol := true
46300			  else error(158);
46400			  insymbol
46500			  end;
46600			end;
46700	(* 34 - DIFFERENT SYNTAX FOR ENTRY POINTS *)
46800		      IFERRSKIP(158,[ENDSYM,COMMA])
46900		      UNTIL SY=ENDSYM;
47000		     IF MAIN THEN INSYMBOL
47100		     END;
47200	(* 21 - Allow null file list in prog. statement *)
47300		    IFERRSKIP(156,[SEMICOLON]);
47400		    INSYMBOL
47500		    END
47600		END;
47700	
47800	      PROCEDURE BLOCK(FPROCP: CTP; FSYS,LEAVEBLOCKSYS: SETOFSYS);
47900	      VAR
48000	(* 56 - add reqfile for require files *)
48100	(* 125 - reqfile moved *)
48200	(* 65 - remove exit labels *)
48300		LSY: SYMBOL;
48400	(* 136 - listing format *)
48500		ORIGLINENR:PACKED ARRAY[1:5]OF CHAR;
48600		ORIGPAGECNT,ORIGSUBPAGE,ORIGLINECNT:INTEGER; 
48700		ORIGPAGE:PAGEELEM; ORIGCH:CHAR;
48800	(* 24 - testpacked no longer needed *)
48900		LCPAR: ADDRRANGE;%SAVES LOCATION FROM WHERE
49000				  LOCAL AREAS ARE SET TO ZERO\
49100		HEAPMARK,GLOBMARK: INTEGER;
49200		FORWPTR : CTP;		 %TEST FOR FORWORD DECLARED PROCEDURES\
49300	
49400	
49500		PROCEDURE CONSTANT(FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU);
49600		VAR
49700		  LSP,LSP1: STP; LCP: CTP; SIGN: (NONE,POS,NEG);
49800		 BEGIN
49900		  LSP := NIL; FVALU.IVAL := 0;
50000		  SKIPIFERR(CONSTBEGSYS,207,FSYS);
50100		   IF SY IN CONSTBEGSYS
50200		   THEN
50300		     BEGIN
50400		       IF SY = STRINGCONST
50500		       THEN
50600			 BEGIN
50700			   IF LGTH = 1
50800			   THEN LSP := CHARPTR
50900			   ELSE
51000			     IF LGTH = ALFALENG
51100			     THEN LSP := ALFAPTR
51200			     ELSE
51300			       BEGIN
51400				NEWZ(LSP,ARRAYS); NEWZ(LSP1,SUBRANGE);
51500				WITH LSP^ DO
51600				 BEGIN
51700				  AELTYPE := CHARPTR; INXTYPE := LSP1;
51800				  SIZE := (LGTH+4) DIV 5; ARRAYPF := TRUE;
51900	(* 211 - make PASDDT able to see this *)
52000				  BITSIZE := BITMAX; SELFSTP := NIL
52100				 END;
52200				WITH LSP1^ DO
52300				 BEGIN
52400				  SIZE := 1; BITSIZE := BITMAX;
52500				  MIN.IVAL := 1; MAX.IVAL := LGTH; RANGETYPE  := NIL
52600				 END
52700			       END;
52800			  FVALU := VAL; INSYMBOL
52900			 END
53000		       ELSE
53100			 BEGIN
53200			  SIGN := NONE;
53300			   IF (SY = ADDOP) AND (OP IN [PLUS,MINUS])
53400			   THEN
53500			     BEGIN
53600			       IF OP = PLUS
53700			       THEN SIGN := POS
53800			       ELSE SIGN := NEG;
53900			      INSYMBOL
54000			     END;
54100			   IF SY = IDENT
54200			   THEN
54300			     BEGIN
54400			      SEARCHID([KONST],LCP);
54500			      WITH LCP^ DO
54600			       BEGIN
54700				LSP := IDTYPE; FVALU := VALUES
54800			       END;
54900			       IF SIGN # NONE
55000			       THEN
55100				 IF LSP = INTPTR
55200				 THEN
55300				   BEGIN
55400				     IF SIGN = NEG
55500				     THEN FVALU.IVAL := -FVALU.IVAL
55600				   END
55700				 ELSE
55800				   IF LSP = REALPTR
55900				   THEN
56000				     BEGIN
56100				       IF SIGN = NEG
56200				       THEN
56300					FVALU.VALP^.RVAL := -FVALU.VALP^.RVAL
56400				     END
56500				   ELSE ERROR(167);
56600			      INSYMBOL;
56700			     END
56800			   ELSE
56900			     IF SY = INTCONST
57000			     THEN
57100			       BEGIN
57200				 IF SIGN = NEG
57300				 THEN VAL.IVAL := -VAL.IVAL;
57400				LSP := INTPTR; FVALU := VAL; INSYMBOL
57500			       END
57600			     ELSE
57700			       IF SY = REALCONST
57800			       THEN
57900				 BEGIN
58000				   IF SIGN = NEG
58100				   THEN VAL.VALP^.RVAL := -VAL.VALP^.RVAL;
58200				  LSP := REALPTR; FVALU := VAL; INSYMBOL
58300				 END
58400			       ELSE ERRANDSKIP(168,FSYS)
58500			 END;
58600		      IFERRSKIP(166,FSYS);
58700		     END;
58800		  FSP := LSP
58900		 END %CONSTANT\ ;
59000	
59100		FUNCTION COMPTYPES(FSP1,FSP2: STP) : BOOLEAN;
59200		  %DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND FSP2 ARE COMPATIBLE\
59300		VAR
59400		  NXT1,NXT2: CTP; COMP: BOOLEAN; LMIN,LMAX,I: INTEGER;
59500		  LTESTP1,LTESTP2: TESTP;
59600		 BEGIN
59700		   IF FSP1 = FSP2
59800		   THEN COMPTYPES := TRUE
59900		   ELSE
60000		     IF (FSP1 # NIL) AND (FSP2 # NIL)
60100		     THEN
60200		       IF FSP1^.FORM = FSP2^.FORM
60300		       THEN
60400			 CASE FSP1^.FORM OF
60500			  SCALAR:
60600				 COMPTYPES := FALSE;
60700				 % IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE
60800				  NOT RECOGNIZED TO BE COMPATIBLE\
60900			  SUBRANGE:
61000				   COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2^.RANGETYPE);
61100			  POINTER:
61200				   BEGIN
61300				    COMP := FALSE; LTESTP1 := GLOBTESTP; LTESTP2 := GLOBTESTP;
61400				    WHILE LTESTP1 # NIL DO
61500				    WITH LTESTP1^ DO
61600				     BEGIN
61700				       IF (ELT1 = FSP1^.ELTYPE) AND (ELT2 = FSP2^.ELTYPE)
61800				       THEN COMP := TRUE;
61900				      LTESTP1 := LASTTESTP
62000				     END;
62100				     IF NOT COMP
62200				     THEN
62300				       BEGIN
62400					NEWZ(LTESTP1);
62500					WITH LTESTP1^ DO
62600					 BEGIN
62700					  ELT1 := FSP1^.ELTYPE;
62800					  ELT2 := FSP2^.ELTYPE;
62900					  LASTTESTP := GLOBTESTP
63000					 END;
63100					GLOBTESTP := LTESTP1; COMP := COMPTYPES(FSP1^.ELTYPE,FSP2^.ELTYPE)
63200				       END;
63300				    COMPTYPES := COMP; GLOBTESTP := LTESTP2
63400				   END;
63500			  POWER:
     
00100				COMPTYPES := COMPTYPES(FSP1^.ELSET,FSP2^.ELSET);
00200			  ARRAYS:
00300				  BEGIN
00400				   GETBOUNDS (FSP1^.INXTYPE,LMIN,LMAX);
00500				   I := LMAX-LMIN;
00600				   GETBOUNDS (FSP2^.INXTYPE,LMIN,LMAX);
00700				   COMPTYPES := COMPTYPES(FSP1^.AELTYPE,FSP2^.AELTYPE)
00800				   AND (FSP1^.ARRAYPF = FSP2^.ARRAYPF) AND ( I = LMAX - LMIN ) ;
00900				  END;
01000				 %ALTERNATIVES: -- ADD A THIRD BOOLEAN TERM: INDEXTYPE MUST
01100				  BE COMPATIBLE. MAY GIVE TROUBLE FOR ASSIGNMENT OF STRINGCONSTANTS
01200				  -- ADD A FOURTH BOOLEAN TERM: LOWBOUNDS MUST
01300				  BE THE SAME\
01400			  RECORDS:
01500				   BEGIN
01600				    NXT1 := FSP1^.FSTFLD; NXT2 := FSP2^.FSTFLD; COMP := TRUE;
01700				    WHILE (NXT1 # NIL) AND (NXT2 # NIL) DO
01800				     BEGIN
01900				      COMP := COMPTYPES(NXT1^.IDTYPE,NXT2^.IDTYPE) AND COMP;
02000				      NXT1 := NXT1^.NEXT; NXT2 := NXT2^.NEXT
02100				     END;
02200				    COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL)
02300				    AND (FSP1^.RECVAR = NIL) AND (FSP2^.RECVAR = NIL)
02400				   END;
02500				  %IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE
02600				   IFF NO VARIANTS OCCUR\
02700			  FILES:
02800				COMPTYPES := COMPTYPES(FSP1^.FILTYPE,FSP2^.FILTYPE)
02900			 END %CASE\
03000		       ELSE %FSP1^.FORM # FSP2^.FORM\
03100			 IF FSP1^.FORM = SUBRANGE
03200			 THEN
03300			  COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2)
03400			 ELSE
03500			   IF FSP2^.FORM = SUBRANGE
03600			   THEN
03700			    COMPTYPES := COMPTYPES(FSP1,FSP2^.RANGETYPE)
03800			   ELSE COMPTYPES := FALSE
03900		     ELSE COMPTYPES := TRUE
04000		 END %COMPTYPES\ ;
04100	
04200		FUNCTION STRING(FSP: STP) : BOOLEAN;
04300		 BEGIN
04400		  STRING := FALSE;
04500		   IF FSP # NIL
04600		   THEN
04700		     IF FSP^.FORM = ARRAYS
04800		     THEN
04900		       IF COMPTYPES(FSP^.AELTYPE,CHARPTR)
05000		       THEN STRING := TRUE
05100		 END %STRING\ ;
05200	
05300		PROCEDURE TYP(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE;
05400			      VAR FBITSIZE: BITRANGE);
05500		VAR
05600	(* 173 - internal files *)
05700		  FHASFILE,LHASFILE:BOOLEAN;
05800		  LSP,LSP1,LSP2: STP; OLDTOP: DISPRANGE; LCP: CTP;
05900		  LSIZE,DISPL: ADDRRANGE; I,LMIN,LMAX: INTEGER;
06000		  PACKFLAG: BOOLEAN; LBITSIZE: BITRANGE;
06100		  LBTP: BTP; BITCOUNT:INTEGER;
06200	
06300	(* 104 - check structure sizes *)
06400		  function checksize(i:addrrange):addrrange;
06500		    begin
06600		    if abs(i) <= 377777B
06700		      then checksize := i
06800		      else begin
06900		      error(266);
07000		      checksize := 0
07100		      end
07200		    end;
07300	
07400		  FUNCTION LOG2(FVAL: INTEGER): BITRANGE;
07500		  VAR
07600		    E: BITRANGE; H: INTEGER;
07700		   BEGIN
07800		    E :=0;
07900		    H := 1;
08000	(* 135 - numbers > 200 000 000 000B didn't work. *)
08100		      {There are two complicating issues here:
08200			1 - 200 000 000 000 is the highest power of 2, so the
08300			  loop below goes forever for them
08400			2 - the caller has often added 1, thus making 377 777 777 777
08500			  into 400 000 000 000, which is negative!!
08600			In both of these cases we want to return 35}
08700		    IF (FVAL-1) >= 200000000000B 
08800		      THEN E := 35
08900		      ELSE REPEAT
09000		        E := E + 1; H := H * 2
09100		       UNTIL FVAL <= H;
09200		    LOG2 := E
09300		   END %LOG2\;
09400	
09500		  PROCEDURE SIMPLETYPE(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE;
09600				       VAR FBITSIZE: BITRANGE);
09700		  VAR
09800		    LSP,LSP1: STP; LCP,LCP1: CTP; TTOP: DISPRANGE;
09900		    LCNT: INTEGER; LVALU: VALU; LBITSIZE: BITRANGE;
10000		   BEGIN
10100		    FSIZE := 1;
10200		    SKIPIFERR(SIMPTYPEBEGSYS,208,FSYS);
10300		     IF SY IN SIMPTYPEBEGSYS
10400		     THEN
10500		       BEGIN
10600			 IF SY = LPARENT
10700			 THEN
10800			   BEGIN
10900			    TTOP := TOP;   %DECL. CONSTS LOCAL TO INNERMOST BLOCK\
11000			    WHILE DISPLAY[TOP].OCCUR # BLCK DO TOP := TOP - 1;
11100			    NEWZ(LSP,SCALAR,DECLARED);
11200			    LSP^.SIZE := 1;
11300			    LCP1 := NIL; LCNT := 0;
11400			     REPEAT
11500			      INSYMBOL;
11600			       IF SY = IDENT
11700			       THEN
11800				 BEGIN
11900				  NEWZ(LCP,KONST);
12000				  WITH LCP^ DO
12100				   BEGIN
12200				    NAME := ID; IDTYPE := LSP; NEXT := LCP1;
12300				    VALUES.IVAL := LCNT;
12400				   END;
12500				  ENTERID(LCP);
12600				  LCNT := LCNT + 1;
12700				  LCP1 := LCP; INSYMBOL
12800				 END
12900			       ELSE ERROR(209);
13000			      IFERRSKIP(166,FSYS OR [COMMA,RPARENT])
13100			     UNTIL SY # COMMA;
13200			    TOP := TTOP;
13300			    WITH LSP^ DO
13400			     BEGIN
13500			      SELFSTP := NIL; FCONST := LCP1; BITSIZE := LOG2(LCNT)
13600			     END;
13700			     IF SY = RPARENT
13800			     THEN INSYMBOL
13900			     ELSE ERROR(152)
14000			   END
14100			 ELSE
14200			   BEGIN
14300			     IF SY = IDENT
14400			     THEN
14500			       BEGIN
14600				SEARCHID([TYPES,KONST],LCP);
14700				INSYMBOL;
14800				 IF LCP^.KLASS = KONST
14900				 THEN
15000				   BEGIN
15100				    NEWZ(LSP,SUBRANGE);
15200				    WITH LSP^, LCP^ DO
15300				     BEGIN
15400				      SELFSTP := NIL; RANGETYPE := IDTYPE;
15500				       IF STRING(RANGETYPE)
15600				       THEN
15700					 BEGIN
15800					  ERROR(303); RANGETYPE := NIL
15900					 END;
16000				      MIN := VALUES; SIZE := 1
16100				     END;
16200				     IF SY = COLON
16300				     THEN INSYMBOL
16400				     ELSE ERROR(151);
16500				    CONSTANT(FSYS,LSP1,LVALU);
16600				    WITH LSP^ DO
16700				     BEGIN
16800				      MAX := LVALU;
16900				       IF MIN.IVAL<0
17000				       THEN BITSIZE := BITMAX
17100				       ELSE BITSIZE := LOG2(MAX.IVAL + 1);
17200				       IF RANGETYPE # LSP1
17300				       THEN ERROR(304)
17400				     END;
17500				   END
17600				 ELSE
17700				   BEGIN
17800				    LSP := LCP^.IDTYPE;
17900				     IF LSP # NIL
18000				     THEN FSIZE := LSP^.SIZE;
18100				   END
18200			       END %SY = IDENT\
18300			     ELSE
18400			       BEGIN
18500				NEWZ(LSP,SUBRANGE);
18600				CONSTANT(FSYS OR [COLON],LSP1,LVALU);
18700				 IF STRING(LSP1)
18800				 THEN
18900				   BEGIN
19000				    ERROR(303); LSP1 := NIL
19100				   END;
19200				WITH LSP^ DO
19300				 BEGIN
19400				  RANGETYPE := LSP1; MIN := LVALU; SIZE := 1
19500				 END;
19600				 IF SY = COLON
19700				 THEN INSYMBOL
19800				 ELSE ERROR(151);
19900				CONSTANT(FSYS,LSP1,LVALU);
20000				WITH LSP^ DO
20100				 BEGIN
20200				  SELFSTP := NIL; MAX := LVALU;
20300				   IF MIN.IVAL<0
20400				   THEN BITSIZE := BITMAX
20500				   ELSE BITSIZE := LOG2(MAX.IVAL + 1);
20600				   IF RANGETYPE # LSP1
20700				   THEN ERROR(304)
20800				 END
20900			       END;
21000			     IF LSP # NIL
21100			     THEN
21200			      WITH LSP^ DO
21300			       IF FORM = SUBRANGE
21400			       THEN
21500				 IF RANGETYPE # NIL
21600				 THEN
21700				   IF RANGETYPE = REALPTR
21800				   THEN
21900	(* 106 - make subranges of real illegal *)
22000				     error(210)
22100				   ELSE
22200				     IF MIN.IVAL > MAX.IVAL
22300				     THEN ERROR(451)
22400			   END;
22500			FSP := LSP;
22600			 IF LSP#NIL
22700			 THEN FBITSIZE := LSP^.BITSIZE
22800			 ELSE FBITSIZE := 0;
22900			IFERRSKIP(166,FSYS)
23000		       END
23100		     ELSE
23200		       BEGIN
23300			FSP := NIL; FBITSIZE := 0
23400		       END
23500		   END %SIMPLETYPE\ ;
23600	
23700	(* 173 - internal files *)
23800		  PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FRECVAR: STP; VAR FFIRSTFIELD: CTP; VAR FHASFILE:BOOLEAN);
23900		  VAR
24000		    LHASFILE:BOOLEAN;
24100		    LCP,LCP1,NXT,NXT1: CTP; LSP,LSP1,LSP2,LSP3,LSP4,TAGSP: STP;
24200		    MINSIZE,MAXSIZE,LSIZE: ADDRRANGE; LVALU: VALU;
24300		    LBITSIZE: BITRANGE;
24400		    LBTP: BTP; MINBITCOUNT:INTEGER;
24500		    LID : ALFA ;
24600	
24700		    PROCEDURE RECSECTION( VAR FCP: CTP; FSP: STP );
24800		     BEGIN
24900		       IF NOT PACKFLAG OR (LSIZE > 1)  OR  (LBITSIZE = 36)
25000		       THEN
25100			 BEGIN
25200			   IF BITCOUNT > 0
25300			   THEN
25400			     BEGIN
25500			      DISPL := DISPL + 1; BITCOUNT := 0
25600			     END;
25700			  WITH FCP^ DO
25800			   BEGIN
25900			    IDTYPE := FSP; FLDADDR := DISPL;
26000			    PACKF := NOTPACK; FCP := NEXT;
26100			    DISPL := DISPL + LSIZE
26200			   END
26300			 END
26400		       ELSE %PACK RECORD-SECTION\
26500	
26600			 BEGIN
26700			  BITCOUNT := BITCOUNT + LBITSIZE;
26800			   IF BITCOUNT>BITMAX
26900			   THEN
27000			     BEGIN
27100			      DISPL := DISPL + 1;
27200			      BITCOUNT := LBITSIZE
27300			     END;
27400			   IF (LBITSIZE = 18)  AND  (BITCOUNT IN [18,36])
27500			   THEN
27600			     BEGIN
27700			      WITH FCP^ DO
27800			       BEGIN
27900				IDTYPE := FSP;
28000				FLDADDR := DISPL;
28100				 IF BITCOUNT = 18
28200				 THEN PACKF := HWORDL
28300				 ELSE PACKF := HWORDR;
28400				FCP := NEXT
28500			       END
28600			     END
28700			   ELSE
28800			     BEGIN
28900			      NEWZ(LBTP,RECORDD);
29000			      WITH LBTP^.BYTE DO
29100			       BEGIN
29200				SBITS := LBITSIZE;
29300				PBITS := BITMAX - BITCOUNT;
29400				RELADDR := DISPL;
29500				DUMMYBIT := 0;
29600				IBIT := 0;
29700				IREG := TAC
29800			       END;
29900			      WITH LBTP^ DO
30000			       BEGIN
30100				LAST := LASTBTP; FIELDCP := FCP
30200			       END;
30300			      LASTBTP := LBTP;
30400			      WITH FCP^ DO
30500			       BEGIN
30600				IDTYPE := FSP;
30700				PACKF := PACKK;
30800				FCP := NEXT
30900			       END
31000			     END
31100			 END
31200		     END % RECSECTION \ ;
31300		   BEGIN
31400	(* 173 - internal files *)
31500	(* 166 - In case of null record declaration, FRECVAR was getting junk.
31600		I don't understand the logic of this routine, but initializing
31700		it to NIL seems safe enough *)
31800		    NXT1 := NIL; LSP := NIL; FRECVAR := NIL; FHASFILE := FALSE;
31900	(* 21 - Allow null fieldlist (added FSYS OR to next statement) *)
32000	(* 65 - allow extra semicolons *)
32100		    while sy=semicolon do
32200			insymbol;
32300		    SKIPIFERR(FSYS OR [IDENT,CASESY],452,FSYS);
32400		    WHILE SY = IDENT DO
32500		     BEGIN
32600		      NXT := NXT1;
32700		       LOOP
32800			 IF SY = IDENT
32900			 THEN
33000			   BEGIN
33100			    NEWZ(LCP,FIELD);
33200			    WITH LCP^ DO
33300			     BEGIN
33400			      NAME := ID; IDTYPE := NIL; NEXT := NXT
33500			     END;
33600			    NXT := LCP;
33700			    ENTERID(LCP);
33800			    INSYMBOL
33900			   END
34000			 ELSE ERROR(209);
34100			SKIPIFERR([COMMA,COLON],166,FSYS OR [SEMICOLON,CASESY]);
34200		       EXIT IF SY # COMMA;
34300			INSYMBOL
34400		       END;
34500		       IF SY = COLON
34600		       THEN INSYMBOL
34700		       ELSE ERROR(151);
34800		      TYP(FSYS OR [CASESY,SEMICOLON],LSP,LSIZE,LBITSIZE);
34900		       IF LSP # NIL
35000		       THEN
35100	(* internal files *)
35200			 IF (LSP^.FORM = FILES) OR LSP^.HASFILE
35300			 THEN FHASFILE := TRUE;
35400		      WHILE NXT # NXT1 DO    RECSECTION(NXT,LSP); %RESERVES SPACE FOR ONE RECORDSECTION \
35500		      NXT1 := LCP;
35600	(* 64 - allow null entry *)
35700		       WHILE SY = SEMICOLON DO
35800			 BEGIN
35900			  INSYMBOL;
36000			  SKIPIFERR(FSYS OR [IDENT,CASESY,SEMICOLON],452,FSYS)
36100			 END
36200		     END %WHILE\;
36300		    NXT := NIL;
36400		    WHILE NXT1 # NIL DO
36500		    WITH NXT1^ DO
36600		     BEGIN
36700		      LCP := NEXT; NEXT := NXT; NXT := NXT1; NXT1 := LCP
36800		     END;
36900		    FFIRSTFIELD := NXT;
37000		     IF SY = CASESY
37100		     THEN
37200		       BEGIN
37300			LCP:=NIL;  %POSSIBILITY OF NO TAGFIELDIDENTIFIER\
37400			INSYMBOL;
37500			 IF SY = IDENT
37600			 THEN
37700			   BEGIN
37800			    LID := ID ;
37900			    INSYMBOL ;
38000			     IF (SY#COLON) AND (SY#OFSY)
38100			     THEN
38200			       BEGIN
38300				ERROR(151) ;
38400				ERRANDSKIP(160,FSYS OR [LPARENT])
38500			       END
38600			     ELSE
38700			       BEGIN
38800				 IF SY = COLON
38900				 THEN
39000				   BEGIN
39100				    NEWZ(LSP,TAGFWITHID);
39200				    NEWZ(LCP,FIELD) ;
39300				    WITH LCP^ DO
39400				     BEGIN
39500				      NAME := LID ; IDTYPE := NIL ; NEXT := NIL
39600				     END ;
39700				    ENTERID(LCP) ;
39800				    INSYMBOL ;
39900				     IF SY # IDENT
40000				     THEN
40100				       BEGIN
40200					ERRANDSKIP(209,FSYS OR [LPARENT]) ; GOTO 1
40300				       END
40400				     ELSE
40500				       BEGIN
40600					LID := ID ;
40700					INSYMBOL ;
40800					 IF SY # OFSY
40900					 THEN
41000					   BEGIN
41100					    ERRANDSKIP(160,FSYS OR [LPARENT]) ; GOTO 1
41200					   END
41300				       END
41400				   END
41500				 ELSE NEWZ(LSP,TAGFWITHOUTID) ;
41600				WITH LSP^ DO
41700				 BEGIN
41800				  SIZE:= 0 ; SELFSTP := NIL ;
41900				  FSTVAR := NIL;
42000				   IF FORM=TAGFWITHID
42100				   THEN TAGFIELDP:=NIL
42200				   ELSE TAGFIELDTYPE := NIL
42300				 END;
42400				FRECVAR := LSP;
42500				ID := LID ;
42600				SEARCHID([TYPES],LCP1) ;
42700				TAGSP := LCP1^.IDTYPE;
42800				 IF TAGSP # NIL
42900				 THEN
43000				   IF (TAGSP^.FORM <= SUBRANGE) OR STRING(TAGSP)
43100				   THEN
43200				     BEGIN
43300				       IF COMPTYPES(REALPTR,TAGSP)
43400				       THEN ERROR(210)
43500				       ELSE
43600					 IF STRING(TAGSP)
43700					 THEN ERROR(169);
43800				      WITH LSP^ DO
43900				       BEGIN
44000					BITSIZE := TAGSP^.BITSIZE;
44100					 IF FORM = TAGFWITHID
44200					 THEN TAGFIELDP := LCP
44300					 ELSE TAGFIELDTYPE := TAGSP;
44400				       END;
44500				       IF LCP # NIL
44600				       THEN
44700					 BEGIN
44800					  LBITSIZE :=TAGSP^.BITSIZE;
44900					  LSIZE := TAGSP^.SIZE;
45000					  RECSECTION(LCP,TAGSP); %RESERVES SPACE FOR THE TAGFIELD \
45100					   IF BITCOUNT > 0
45200	(* 104 - check structure sizes *)
45300					   THEN LSP^.SIZE:=CHECKSIZE(DISPL + 1)
45400					   ELSE LSP^.SIZE:= CHECKSIZE(DISPL);
45500					 END
45600				     END
45700				   ELSE ERROR(402);
45800	
45900				INSYMBOL;
46000			       END
46100			   END
46200	(* 150 - fix ill mem ref trying to follow tagsp if not set *)
46300			 ELSE BEGIN TAGSP := NIL; ERRANDSKIP(209,FSYS OR [LPARENT]) END ;
46400	1:
46500			LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL; MINBITCOUNT:=BITCOUNT;
46600	(* 65 - allow extra semicolons *)
46700			while sy=semicolon do
46800			 insymbol;
46900			 LOOP
47000			  LSP2 := NIL;
47100			   LOOP
47200			    CONSTANT(FSYS OR [COMMA,COLON,LPARENT],LSP3,LVALU);
47300			     IF  NOT COMPTYPES(TAGSP,LSP3)
47400			     THEN ERROR(305);
47500			    NEWZ(LSP3,VARIANT);
47600			    WITH LSP3^ DO
47700			     BEGIN
47800			      NXTVAR := LSP1; SUBVAR := LSP2; VARVAL := LVALU;
47900			      BITSIZE := LSP^.BITSIZE; SELFSTP := NIL
48000			     END;
48100			    LSP1 := LSP3; LSP2 := LSP3;
48200			   EXIT IF SY # COMMA;
48300			    INSYMBOL;
48400			   END;
48500			   IF SY = COLON
48600			   THEN INSYMBOL
48700			   ELSE ERROR(151);
48800			   IF SY = LPARENT
48900			   THEN INSYMBOL
49000			   ELSE ERROR(153);
49100	(* 173 - internal files *)
49200			  FIELDLIST(FSYS OR [RPARENT,SEMICOLON],LSP2,LCP,LHASFILE);
49300			  FHASFILE := FHASFILE OR LHASFILE;
49400			   IF DISPL > MAXSIZE
49500			   THEN MAXSIZE := DISPL;
49600			  WHILE LSP3 # NIL DO
49700			   BEGIN
49800			    LSP4 := LSP3^.SUBVAR; LSP3^.SUBVAR := LSP2; LSP3^.FIRSTFIELD := LCP;
49900	(* 20 - deleted if bitcount>0 use displ+1 - done in fieldlist *)
50000	(* 104 - check structure sizes *)
50100			     LSP3^.SIZE := CHECKSIZE(DISPL) ;
50200			    LSP3 := LSP4
50300			   END;
50400			   IF SY = RPARENT
50500			   THEN
50600			     BEGIN
50700			      INSYMBOL;
50800			      IFERRSKIP(166,FSYS OR [SEMICOLON])
50900			     END
51000			   ELSE ERROR(152);
51100	(* 65 - allow extra semicolons *)
51200			  while sy=semicolon
51300			   do insymbol;
51400			 exit if sy in fsys;
51500			  DISPL := MINSIZE;
51600			  BITCOUNT:=MINBITCOUNT; %RESTAURATION \
51700			 END;
51800			DISPL := MAXSIZE;
51900			LSP^.FSTVAR := LSP1;
52000		       END  %IF SY = CASESY\
52100		     ELSE
52200		       IF LSP # NIL
52300		       THEN
52400			 IF LSP^.FORM = ARRAYS
52500			 THEN FRECVAR := LSP
52600			 ELSE FRECVAR := NIL;
52700	(* 20 - fix packed records - from CMU *)
52800		   IF BITCOUNT > 0 THEN
52900		     BEGIN DISPL:=DISPL+1; BITCOUNT := 0 END
53000		   END %FIELDLIST\ ;
53100	
53200		 BEGIN
53300		  %TYP\
53400	(* 173 - internal files *)
53500		  FHASFILE := FALSE;
53600		  SKIPIFERR(TYPEBEGSYS,170,FSYS);
53700		  PACKFLAG := FALSE;
53800		   IF SY IN TYPEBEGSYS
53900		   THEN
54000		     BEGIN
54100		       IF SY IN SIMPTYPEBEGSYS
54200		       THEN SIMPLETYPE(FSYS,FSP,FSIZE,FBITSIZE)
54300		       ELSE
54400			%^\
     
00100			 IF SY = ARROW
00200			 THEN
00300			   BEGIN
00400			    NEWZ(LSP,POINTER); FSP := LSP;
00500			    LBITSIZE := 18;
00600			    WITH LSP^ DO
00700			     BEGIN
00800			      SELFSTP := NIL;  ELTYPE := NIL; SIZE := 1; BITSIZE := LBITSIZE
00900			     END;
01000			    INSYMBOL;
01100			     IF SY = IDENT
01200			     THEN
01300			       BEGIN
01400	(* 165 - fix scoping problem with pointer ref's *)
01500	{All declarations of the form ^THING must be treated as forward references.
01600	 The problem is that we want to use the local declaration of THING if there
01700	 is any.  So we have to wait til we have seen all type declarations before
01800	 we can look up pointer references.}
01900				NEWZ(LCP,TYPES);
02000				WITH LCP^ DO
02100				  BEGIN
02200				   NAME := ID; IDTYPE := LSP;
02300				   NEXT := FWPTR
02400				  END;
02500				FWPTR := LCP;
02600				INSYMBOL;
02700				FBITSIZE:=18
02800			       END
02900			     ELSE ERROR(209);
03000			   END
03100			 ELSE
03200			   BEGIN
03300			     IF SY = PACKEDSY
03400			     THEN
03500			       BEGIN
03600				INSYMBOL;
03700				SKIPIFERR(TYPEDELS,170,FSYS);
03800				PACKFLAG := TRUE
03900			       END;
04000			      %ARRAY\
04100			     IF SY = ARRAYSY
04200			     THEN
04300			       BEGIN
04400				INSYMBOL;
04500				 IF SY = LBRACK
04600				 THEN INSYMBOL
04700				 ELSE ERROR(154);
04800				LSP1 := NIL;
04900				 LOOP
05000				  NEWZ(LSP,ARRAYS);
05100				  WITH LSP^ DO
05200				   BEGIN
05300				    AELTYPE := LSP1; INXTYPE := NIL; SELFSTP := NIL;
05400				    ARRAYPF := PACKFLAG; SIZE := 1
05500				   END;
05600				  LSP1 := LSP;
05700				  SIMPLETYPE(FSYS OR [COMMA,RBRACK,OFSY],LSP2,LSIZE,LBITSIZE);
05800				   IF LSP2 # NIL
05900				   THEN
06000				     IF LSP2^.FORM <= SUBRANGE
06100				     THEN
06200				       BEGIN
06300					 IF LSP2 = REALPTR
06400					 THEN
06500					   BEGIN
06600					    ERROR(210); LSP2 := NIL
06700					   END
06800					 ELSE
06900					   IF LSP2 = INTPTR
07000					   THEN
07100					     BEGIN
07200					      ERROR(306); LSP2 := NIL
07300					     END;
07400					LSP^.INXTYPE := LSP2
07500				       END
07600				     ELSE
07700				       BEGIN
07800					ERROR(403); LSP2 := NIL
07900				       END;
08000				 EXIT IF SY # COMMA;
08100				  INSYMBOL
08200				 END;
08300				 IF SY = RBRACK
08400				 THEN INSYMBOL
08500				 ELSE ERROR(155);
08600				 IF SY = OFSY
08700				 THEN INSYMBOL
08800				 ELSE ERROR(160);
08900				TYP(FSYS,LSP,LSIZE,LBITSIZE);
09000				 IF  LSP # NIL
09100				 THEN
09200	(* 173 - internal files *)
09300				   IF  (LSP^.FORM = FILES) OR (LSP^.HASFILE)
09400				   THEN  FHASFILE := TRUE;
09500				 REPEAT
09600				  WITH LSP1^ DO
09700				   BEGIN
09800				    LSP2 := AELTYPE; AELTYPE := LSP;
09900				     IF INXTYPE # NIL
10000				     THEN
10100				       BEGIN
10200					GETBOUNDS(INXTYPE,LMIN,LMAX);
10300	(* 104 - check structure sizes *)
10400					lmin := checksize(lmin);
10500					lmax := checksize(lmax);
10600					I := LMAX - LMIN + 1;
10700					 IF ARRAYPF AND (LBITSIZE<=18)
10800					 THEN
10900					   BEGIN
11000					    NEWZ(LBTP,ARRAYY);
11100					    WITH LBTP^,BYTE DO
11200					     BEGIN
11300					      SBITS := LBITSIZE;
11400					      PBITS := BITMAX; DUMMYBIT := 0;
11500					      IBIT := 0; IREG := TAC; RELADDR := 0;
11600					      LAST := LASTBTP; LASTBTP := LBTP;
11700					      ARRAYSP := LSP1;
11800					     END;
11900					    LSIZE := (I+(BITMAX DIV LBITSIZE)-1) DIV (BITMAX DIV LBITSIZE);
12000					   END
12100					 ELSE
12200					   BEGIN
12300					    LSIZE := LSIZE * I;
12400					    ARRAYPF := FALSE
12500					   END;
12600					LBITSIZE := BITMAX;
12700					BITSIZE := LBITSIZE;
12800	(* 104 - check structure sizes *)
12900					SIZE := CHECKSIZE(LSIZE);
13000				       END
13100				   END;
13200				  LSP := LSP1; LSP1 := LSP2
13300				 UNTIL LSP1 = NIL
13400			       END
13500			     ELSE
13600			      %RECORD\
13700			       IF SY = RECORDSY
13800			       THEN
13900				 BEGIN
14000				  INSYMBOL;
14100				  OLDTOP := TOP;
14200				   IF TOP < DISPLIMIT
14300				   THEN
14400				     BEGIN
14500	(* 5 - save block name for CREF *)
14600				      TOP := TOP + 1; DISPLAY[TOP].FNAME := NIL;
14700				     DISPLAY[TOP].BLKNAME := '.FIELDID. ';
14800	(* 117 - fix enumerated types in record *)
14900				     DISPLAY[TOP].OCCUR := CREC
15000				     END
15100				   ELSE ERROR(404);
15200				  DISPL := 0;
15300				  BITCOUNT:=0;
15400	(* 173 - internal files *)
15500				  FIELDLIST(FSYS-[SEMICOLON] OR [ENDSY],LSP1,LCP,LHASFILE);
15600				  FHASFILE := FHASFILE OR LHASFILE;
15700				  
15800				  LBITSIZE := BITMAX;
15900				  NEWZ(LSP,RECORDS);
16000				  WITH LSP^ DO
16100				   BEGIN
16200				    SELFSTP := NIL;
16300				    FSTFLD := %LCP;\ DISPLAY[TOP].FNAME;
16400				    RECVAR := LSP1;
16500	(* 20 - FIX PACKED RECORDS - FROM CMU - DELETED CODE NOW IN FIELDLIST *)
16600	(* 104 - check structure sizes *)
16700				     SIZE := CHECKSIZE(DISPL);
16800				    BITSIZE := LBITSIZE; RECORDPF := PACKFLAG;
16900				   END;
17000				  TOP := OLDTOP;
17100				   IF SY = ENDSY
17200				   THEN INSYMBOL
17300				   ELSE ERROR(163)
17400				 END
17500			       ELSE
17600				%SET\
17700				 IF SY = SETSY
17800				 THEN
17900				   BEGIN
18000				    INSYMBOL;
18100				     IF SY = OFSY
18200				     THEN INSYMBOL
18300				     ELSE ERROR(160);
18400				    SIMPLETYPE(FSYS,LSP1,LSIZE,LBITSIZE);
18500				     IF LSP1 # NIL
18600				     THEN
18700				      WITH LSP1^ DO
18800				       CASE FORM OF
18900					SCALAR:
19000						IF (LSP1=REALPTR) OR (LSP1=INTPTR)
19100						THEN ERROR(352)
19200						ELSE
19300						  IF SCALKIND =DECLARED
19400						  THEN
19500						    IF FCONST^.VALUES.IVAL > BASEMAX
19600						    THEN ERROR(352);
19700					SUBRANGE:
19800						  IF ( RANGETYPE = REALPTR )
19900						   OR ( ( RANGETYPE # CHARPTR ) AND ((MAX.IVAL > BASEMAX) OR (MIN.IVAL < 0) ) )
20000						  THEN ERROR(352);
20100					OTHERS:
20200						BEGIN
20300						 ERROR(353); LSP1 := NIL
20400						END
20500				       END;
20600				    LBITSIZE := BITMAX;
20700				    NEWZ(LSP,POWER);
20800				    WITH LSP^ DO
20900				     BEGIN
21000				      SELFSTP := NIL; ELSET := LSP1; SIZE:=2; BITSIZE := LBITSIZE
21100				     END;
21200				   END
21300				 ELSE
21400				  %FILE\
21500				   IF SY = FILESY
21600				   THEN
21700				     BEGIN
21800				      FHASFILE := TRUE;
21900				      INSYMBOL;
22000				       IF SY = OFSY
22100				       THEN INSYMBOL
22200				       ELSE ERROR(160);
22300				      TYP(FSYS,LSP1,LSIZE,LBITSIZE);
22400				      NEWZ(LSP,FILES);
22500				      LBITSIZE := BITMAX;
22600				      WITH LSP^ DO
22700				       BEGIN
22800					SELFSTP := NIL;
22900	(* 104 - check structure sizes *)
23000					FILTYPE := LSP1; 
23100	(* 173 - internal files *)
23200					SIZE := CHECKSIZE(LSIZE) + SIZEOFFILEBLOCK;
23300					FILEPF := PACKFLAG; BITSIZE := LBITSIZE
23400				       END;
23500				       IF LSP1 # NIL
23600				       THEN
23700					 IF (LSP1^.FORM = FILES) OR (LSP1^.HASFILE)
23800					 THEN
23900					   BEGIN
24000					    ERROR(254); LSP^.FILTYPE := NIL
24100					   END;
24200	(* 70 - fix ill mem ref if type error *)
24300				     END
24400				   ELSE LSP := NIL;
24500			    FSP := LSP; FBITSIZE := LBITSIZE
24600			   END;
24700		      IFERRSKIP(166,FSYS)
24800		     END
24900		   ELSE FSP := NIL;
25000		   IF FSP = NIL
25100		   THEN
25200		     BEGIN
25300		      FSIZE := 1;FBITSIZE := 0
25400		     END
25500	(* 173 - internal files *)
25600		   ELSE BEGIN
25700		   FSIZE := FSP^.SIZE;
25800		   FSP^.HASFILE := FHASFILE
25900		   END
26000		 END %TYP\ ;
26100	
26200		PROCEDURE LABELDECLARATION;
26300		VAR
26400	(* 64 - NON-LOCAL GOTOS *)
26500		  lcp:ctp;
26600		 BEGIN
26700	(* 6 - remove error message. Allow LABEL declaration but ignore it *)
26800		   LOOP
26900		     IF SY = INTCONST
27000		     THEN
27100		       BEGIN
27200			newz(lcp,labelt);
27300			with lcp^ do
27400			  begin
27500			  scope := level; name := id; idtype := nil;
27600			  next := lastlabel; lastlabel := lcp;
27700			  gotochain := 0; labeladdress := 0
27800			  end;
27900			enterid(lcp);
28000	1:
28100			INSYMBOL
28200		       END
28300		     ELSE ERROR(255);
28400		    IFERRSKIP(166,FSYS OR [COMMA,SEMICOLON]);
28500		   EXIT IF SY # COMMA;
28600		    INSYMBOL
28700		   END;
28800		   IF SY = SEMICOLON
28900		   THEN INSYMBOL
29000		   ELSE ERROR(156)
29100		 END %LABELDECLARATION\ ;
29200	
29300		PROCEDURE CONSTANTDECLARATION;
29400		VAR
29500		  LCP: CTP; LSP: STP; LVALU: VALU;
29600		 BEGIN
29700		  SKIPIFERR([IDENT],209,FSYS);
29800		  WHILE SY = IDENT DO
29900		   BEGIN
30000		    NEWZ(LCP,KONST);
30100		    WITH LCP^ DO
30200		     BEGIN
30300		      NAME := ID; IDTYPE := NIL; NEXT := NIL
30400		     END;
30500		    INSYMBOL;
30600		     IF (SY = RELOP) AND (OP = EQOP)
30700		     THEN INSYMBOL
30800		     ELSE ERROR(157);
30900	(* 56 - REQ FILE SYNTAX *)
31000		    CONSTANT(FSYS OR [SEMICOLON,PERIOD],LSP,LVALU);
31100		    ENTERID(LCP);
31200		    LCP^.IDTYPE := LSP; LCP^.VALUES := LVALU;
31300		     IF SY = SEMICOLON
31400		     THEN
31500		       BEGIN
31600			INSYMBOL;
31700			IFERRSKIP(166,FSYS OR [IDENT])
31800		       END
31900	(* 56 - REQ FILE SYNTAX *)
32000		     ELSE IF NOT ((SY=PERIOD) AND REQFILE)
32100		       THEN ERROR(156)
32200		   END
32300		 END %CONSTANTDECLARATION\ ;
32400	
32500		PROCEDURE TYPEDECLARATION;
32600		VAR
32700		  LCP,LCP1,LCP2: CTP; LSP: STP; LSIZE: ADDRRANGE;
32800		  LBITSIZE: BITRANGE;
32900		 BEGIN
33000		  SKIPIFERR([IDENT],209,FSYS);
33100		  WHILE SY = IDENT DO
33200		   BEGIN
33300		    NEWZ(LCP,TYPES);
33400		    WITH LCP^ DO
33500		     BEGIN
33600	(* 116 - be sure NEXT is NIL when unused, for COPYCTP *)
33700		      NAME := ID; IDTYPE := NIL; NEXT := NIL;
33800		     END;
33900		    INSYMBOL;
34000		     IF (SY = RELOP) AND (OP = EQOP)
34100		     THEN INSYMBOL
34200		     ELSE ERROR(157);
34300	(* 56 - REQ FILE SYNTAX *)
34400		    TYP(FSYS OR [SEMICOLON,PERIOD],LSP,LSIZE,LBITSIZE);
34500		    ENTERID(LCP);
34600		    WITH LCP^ DO
34700		     BEGIN
34800		      IDTYPE := LSP;
34900	(* 165 - fix scoping for pointer ref's *)
35000		     END;
35100		     IF SY = SEMICOLON
35200		     THEN
35300		       BEGIN
35400			INSYMBOL;
35500			IFERRSKIP(166,FSYS OR [IDENT]);
35600		       END
35700	(* 56 - REQ FILE SYNTAX *)
35800		     ELSE IF NOT ((SY=PERIOD) AND REQFILE)
35900		       THEN ERROR(156)
36000		   END;
36100	(* 113 - don't check for forw. ref's satisfied in req. file *)
36200		 END %TYPEDECLARATION\ ;
36300	
36400	(* 166 - must resolve forwards separately, in case of TYPE section
36500	         in required file but none in main *)
36600		PROCEDURE FWDRESOLVE;
36700		  BEGIN
36800	{For each forward request, look up the variable requested.  If
36900	 you find the request, use it.  Note that all declarations of
37000	 the form ^THING produce forward requests.  This is to force
37100	 THING to be looked up after all type declarations have been
37200	 processed, so we get the local definition if there is one.}
37300		  WHILE FWPTR # NIL DO
37400	 	    BEGIN
37500	(* 165 - fix scoping problem with pointers *)
37600		     ID := FWPTR^.NAME;
37700		     PRTERR := FALSE;   %NO ERROR IF SEARCH NOT SUCCESSFUL\
37800		     SEARCHID([TYPES],LCP); PRTERR := TRUE;
37900		     IF LCP <> NIL
38000		       THEN IF LCP^.IDTYPE # NIL
38100			      THEN IF LCP^.IDTYPE^.FORM = FILES
38200				     THEN ERROR(254)
38300				     ELSE FWPTR^.IDTYPE^.ELTYPE := LCP^.IDTYPE
38400			      ELSE
38500		       ELSE ERRORWITHTEXT(405,FWPTR^.NAME);
38600		     FWPTR := FWPTR^.NEXT
38700		    END
38800		 END %FWDRESOLVE\ ;
38900	
39000		PROCEDURE VARIABLEDECLARATION;
39100		VAR
39200		  LCP,NXT: CTP; LSP: STP; LSIZE: ADDRRANGE;
39300		  LBITSIZE: BITRANGE; II: INTEGER;
39400	(* 173 - removed lfileptr *)
39500		 BEGIN
39600		  NXT := NIL;
39700		   REPEAT
39800		     LOOP
39900		       IF SY = IDENT
40000		       THEN
40100			 BEGIN
40200			  NEWZ(LCP,VARS);
40300			  WITH LCP^ DO
40400			   BEGIN
40500			    NAME := ID; NEXT := NXT;
40600			    IDTYPE := NIL; VKIND := ACTUAL; VLEV := LEVEL
40700			   END;
40800			  ENTERID(LCP);
40900			  NXT := LCP;
41000			  INSYMBOL;
41100			 END
41200		       ELSE ERROR(209);
41300		      SKIPIFERR(FSYS OR [COMMA,COLON] OR TYPEDELS,166,[SEMICOLON]);
41400		     EXIT IF SY # COMMA;
41500		      INSYMBOL
41600		     END;
41700		     IF SY = COLON
41800		     THEN INSYMBOL
41900		     ELSE ERROR(151);
42000		    TYP(FSYS OR [SEMICOLON] OR TYPEDELS,LSP,LSIZE,LBITSIZE);
42100	(* 24 - testpacked no longer needed *)
42200	(* 173 - internal files *)
42300		    IF LSP <> NIL
42400		      THEN IF (LSP^.FORM = FILES) OR LSP^.HASFILE
42500			THEN FILEINBLOCK[LEVEL] := TRUE;
42600		    WHILE NXT # NIL DO
42700		    WITH  NXT^ DO
42800		     BEGIN
42900		      IDTYPE := LSP; VADDR := LC;
43000		      LC := LC + LSIZE ;
43100	(* 173 - internal files - removed file code here *)
43200		      NXT := NEXT ;
43300		     END;
43400		     IF SY = SEMICOLON
43500		     THEN
43600		       BEGIN
43700			INSYMBOL;
43800			IFERRSKIP(166,FSYS OR [IDENT])
43900		       END
44000		     ELSE ERROR(156)
44100		   UNTIL (SY # IDENT) AND  NOT (SY IN TYPEDELS);
44200	(* 167 - code removed from here.  It is now part of FWDRESOLVE,
44300		which is called right after this procedure *)
44400		 END %VARIABLEDECLARATION\ ;
44500	
44600		PROCEDURE PROCEDUREDECLARATION(FSY: SYMBOL);
44700		VAR
44800		  OLDLEV: 0..MAXLEVEL; LSY: SYMBOL; LCP,LCP1: CTP; LSP: STP;
44900		  FORW: BOOLEAN; OLDTOP: DISPRANGE; LNXT: CTP;
45000	(* 62 - clean up stack offsets *)
45100		  LLC,LCM: ADDRRANGE;  TOPPOFFSET: ADDRRANGE;
45200	
45300		  PROCEDURE PARAMETERLIST(FSY: SETOFSYS; VAR FPAR: CTP; VAR TOPPOFFSET: ADDRRANGE);
45400		  VAR
45500		    LCP,LCP1,LCP2,LCP3: CTP; LSP: STP; LKIND: IDKIND;
45600	(* 62 - clean up stack offset *)
45700		    REGC:INTEGER;
45800		   BEGIN
45900		    LCP1 := NIL; REGC := REGIN+1;
46000		    SKIPIFERR(FSY OR [LPARENT],256,FSYS);
46100		     IF SY = LPARENT
46200		     THEN
46300		       BEGIN
46400			 IF FORW
46500			 THEN ERROR(553);
46600			INSYMBOL;
46700			SKIPIFERR([IDENT,VARSY,PROCEDURESY,FUNCTIONSY],256,FSYS OR [RPARENT]);
46800			WHILE SY IN [IDENT,VARSY,PROCEDURESY,FUNCTIONSY] DO
46900			 BEGIN
47000			   IF SY = PROCEDURESY
47100			   THEN
47200			     BEGIN
47300	(* 33 - PROC PARAM.S *)
47400			       REPEAT
47500				INSYMBOL;
47600				 IF SY = IDENT
47700				 THEN
47800				   BEGIN
47900				    NEWZ(LCP,PROC,DECLARED,FORMAL);
48000				    WITH LCP^ DO
48100				     BEGIN
48200				      NAME := ID; IDTYPE := NIL; NEXT := LCP1;
48300				      PFLEV := LEVEL; PFADDR := LC
48400				     END;
48500				    ENTERID(LCP);
48600	(* 62 - clean up stack offset *)
48700				    LCP1 := LCP; LC := LC + 1; REGC := REGC+1;
48800				    INSYMBOL
48900				   END
49000				 ELSE ERROR(209);
49100				IFERRSKIP(256,FSYS OR [COMMA,SEMICOLON,RPARENT])
49200			       UNTIL SY # COMMA
49300			     END
49400			   ELSE
49500			     IF SY = FUNCTIONSY
49600			     THEN
49700			       BEGIN
49800	(* 33 - PROC PARAM.S *)
49900				LCP2 := NIL;
     
00100				 REPEAT
00200				  INSYMBOL;
00300				   IF SY = IDENT
00400				   THEN
00500				     BEGIN
00600				      NEWZ(LCP,FUNC,DECLARED,FORMAL);
00700				      WITH LCP^ DO
00800				       BEGIN
00900					NAME := ID; IDTYPE := NIL; NEXT := LCP2;
01000					PFLEV := LEVEL; PFADDR := LC
01100				       END;
01200				      ENTERID(LCP);
01300	(* 62 - clean up stack offset *)
01400				      LCP2 := LCP; LC := LC + 1; REGC := REGC+1;
01500				      INSYMBOL;
01600				     END;
01700				   IF  NOT (SY IN [COMMA,COLON] OR FSYS)
01800				   THEN
01900				    ERRANDSKIP(256,FSYS OR [COMMA,SEMICOLON,RPARENT])
02000				 UNTIL SY # COMMA;
02100				 IF SY = COLON
02200				 THEN
02300				   BEGIN
02400				    INSYMBOL;
02500				     IF SY = IDENT
02600				     THEN
02700				       BEGIN
02800					SEARCHID([TYPES],LCP);
02900					LSP := LCP^.IDTYPE;
03000					 IF LSP # NIL
03100					 THEN
03200					   IF  NOT (LSP^.FORM IN [SCALAR,SUBRANGE,POINTER])
03300					   THEN
03400					     BEGIN
03500					      ERROR(551); LSP := NIL
03600					     END;
03700					LCP3 := LCP2;
03800					WHILE LCP2 # NIL DO
03900					 BEGIN
04000					  LCP2^.IDTYPE := LSP; LCP := LCP2;
04100					  LCP2 := LCP2^.NEXT
04200					 END;
04300					LCP^.NEXT := LCP1; LCP1 := LCP3;
04400					INSYMBOL
04500				       END
04600				     ELSE ERROR(209);
04700				    IFERRSKIP(256,FSYS OR [SEMICOLON,RPARENT])
04800				   END
04900				 ELSE ERROR(151)
05000			       END
05100			     ELSE
05200			       BEGIN
05300				 IF SY = VARSY
05400				 THEN
05500				   BEGIN
05600				    LKIND := FORMAL; INSYMBOL
05700				   END
05800				 ELSE LKIND := ACTUAL;
05900				LCP2 := NIL12800	 is in CALLNONSTANDARD where by use a special routine in place of LOAD,
12900	 to do the actually funny passing.}
13000	 				    if (lsp = stringptr) or (lsp = pointerptr)
13100					      then if (lsp = pointerptr) and
13200						      (vkind = formal)
13300	{If it is POINTER called by ref, use a special tag, POINTERREF }
13400					             then begin 
13500					              idtype := pointerref;
13600					              vkind := actual
13700					              end
13800	{In any case, consider it actual so the size = 2 works }
13900						     else vkind := actual;
14000					     IF VKIND = FORMAL
14100					     THEN LC := LC + 1
14200					     ELSE
14300					       IF IDTYPE # NIL
14400					       THEN LC := LC + IDTYPE^.SIZE;
14500	(* 62 - clean up stack offset *)
14600					    IF IDTYPE = NIL
14700					      THEN REGC := REGC+1
14800					      ELSE IF (VKIND = ACTUAL) AND (IDTYPE^.SIZE = 2)
14900						THEN REGC := REGC+2
15000						ELSE REGC := REGC+1
15100					   END;
15200					  LCP := LCP3;
15300					  LCP3 := LCP3^.NEXT;
15400	(* 151 - CONS the new thing on individually instead of APPENDing the whole
15500	   string, in order to avoid getting I and J reversed in I,J:INTEGER *)
15600	{Note that we are here reversing the order again.  This is because the
15700	 whole thing gets reversed below.}
15800					  LCP^.NEXT := LCP1;
15900					  LCP1 := LCP;
16000					 END;
16100					INSYMBOL
16200				       END
16300				     ELSE ERROR(209);
16400				    IFERRSKIP(256,FSYS OR [SEMICOLON,RPARENT])
16500				   END
16600				 ELSE ERROR(151);
16700			       END;
16800			   IF SY = SEMICOLON
16900			   THEN
17000			     BEGIN
17100			      INSYMBOL;
17200			      SKIPIFERR(FSYS OR [IDENT,VARSY,PROCEDURESY,FUNCTIONSY],256,[RPARENT])
17300			     END
17400			 END %WHILE\ ;
17500			 IF SY = RPARENT
17600			 THEN
17700			   BEGIN
17800			    INSYMBOL;
17900			    IFERRSKIP(166,FSY OR FSYS)
18000			   END
18100			 ELSE ERROR(152);
18200			LCP3 := NIL;
18300			%REVERSE POINTERS\
18400			WHILE LCP1 # NIL DO
18500			WITH LCP1^ DO
18600			 BEGIN
18700			  LCP2 := NEXT; NEXT := LCP3;
18800			  LCP3 := LCP1; LCP1 := LCP2
18900			 END;
19000			FPAR := LCP3
19100		       END
19200		     ELSE FPAR := NIL;
19300	(* 62 - clean up stack offset *)
19400		   IF (REGC - 1) > PARREGCMAX
19500		     THEN TOPPOFFSET := LC - 1
19600		     ELSE TOPPOFFSET := 0;
19700		   END %PARAMETERLIST\ ;
19800	
19900		 BEGIN
20000		  %PROCEDUREDECLARATION\
20100		  LLC := LC;
20200		   IF FSY = PROCEDURESY
20300		   THEN LC := 1
20400		   ELSE LC := 2;
20500		   IF SY = IDENT
20600		   THEN
20700		     BEGIN
20800	(* 5 - CREF *)
20900		      IF CREF
21000		        THEN WRITE(CHR(15B),CHR(10),ID);
21100		      SEARCHSECTION(DISPLAY[TOP].FNAME,LCP);   %DECIDE WHETHER FORW.\
21200		       IF LCP # NIL
21300		       THEN
21400			WITH LCP^ DO
21500			 BEGIN
21600			   IF KLASS = PROC
21700			   THEN
21800			    FORW := FORWDECL AND (FSY = PROCEDURESY) AND (PFKIND = ACTUAL)
21900			   ELSE
22000			     IF KLASS = FUNC
22100			     THEN
22200			      FORW := FORWDECL AND (FSY = FUNCTIONSY) AND (PFKIND = ACTUAL)
22300			     ELSE FORW := FALSE;
22400			   IF  NOT FORW
22500			   THEN ERROR(406)
22600			 END
22700		       ELSE FORW := FALSE;
22800		       IF  NOT FORW
22900		       THEN
23000			 BEGIN
23100			   IF FSY = PROCEDURESY
23200			   THEN NEWZ(LCP,PROC,DECLARED,ACTUAL)
23300			   ELSE NEWZ(LCP,FUNC,DECLARED,ACTUAL);
23400			  WITH LCP^ DO
23500			   BEGIN
23600	(* 116 - be sure NEXT is NIL when unused, for COPYCTP *)
23700			    NAME := ID; IDTYPE := NIL; TESTFWDPTR := NIL; NEXT := NIL;
23800			    FORWDECL := FALSE; EXTERNDECL := FALSE; LANGUAGE := PASCALSY;
23900			    PFLEV := LEVEL; PFADDR := 0; FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0
24000			   END;
24100			  ENTERID(LCP)
24200			 END
24300		       ELSE
24400			 BEGIN
24500			  LCP1 := LCP^.NEXT;
24600			  WHILE LCP1 # NIL DO
24700			   BEGIN
24800			    WITH LCP1^ DO
24900			     IF KLASS = VARS
25000			     THEN
25100			       IF IDTYPE # NIL
25200			       THEN
25300				 BEGIN
25400				  LCM := VADDR + IDTYPE^.SIZE;
25500				   IF LCM > LC
25600				   THEN LC := LCM
25700				 END;
25800			    LCP1 := LCP1^.NEXT
25900			   END
26000			 END;
26100		      INSYMBOL
26200		     END
26300		   ELSE
26400		     BEGIN
26500		      ERROR(209);
26600		       IF FSY = PROCEDURESY
26700		       THEN LCP := UPRCPTR
26800		       ELSE LCP := UFCTPTR
26900		     END;
27000		  OLDLEV := LEVEL; OLDTOP := TOP;
27100		   IF LEVEL < MAXLEVEL
27200		   THEN LEVEL := LEVEL + 1
27300		   ELSE ERROR(453);
27400		   IF TOP < DISPLIMIT
27500		   THEN
27600		     BEGIN
27700		      TOP := TOP + 1;
27800		      WITH DISPLAY[TOP] DO
27900		       BEGIN
28000	(* 5 - save block name for CREF *)
28100			FNAME := NIL; OCCUR := BLCK; BLKNAME := LCP^.NAME;
28200			 IF DEBUG THEN BEGIN
28300	(* 214 - use ULBLPTR because UPRCPTR will not have NEXT treated
28400		properly *)
28500	{This is a dummy entry in the symbol table strictly for the debugger.
28600	 The debugger looks at its NEXT field to find the procedure name}
28700					NEWZ(LCP1); LCP1^ := ULBLPTR^;
28800					LCP1^.NEXT := LCP;
28900					ENTERID(LCP1);
29000					IF FORW AND (LCP^.NEXT # NIL)
29100					THEN BEGIN
29200	(* 150 - removed lcp1^.llink := lcp^.next.  LCP^.NEXT is a tree containing
29300	         the parameters.  It needs to be put into the symbol table.  Since
29400	         all legal symbols > blanks, just put it in Rlink.  Previously got
29500	         all symbols twice in debugger! *)
29600					  LCP1^.RLINK := LCP^.NEXT
29700					  END
29800				       END
29900				  ELSE IF FORW THEN FNAME := LCP^.NEXT
30000			END %WITH DISPLAY[TOP]\
30100		     END
30200		   ELSE ERROR(404);
30300		   IF FSY = PROCEDURESY
30400		   THEN
30500		     BEGIN
30600	(* 62 - clean up stack offset *)
30700		      PARAMETERLIST([SEMICOLON],LCP1,TOPPOFFSET);
30800		       IF  NOT FORW
30900			THEN WITH LCP^ DO
31000			  BEGIN NEXT := LCP1; POFFSET := TOPPOFFSET END
31100		     END
31200		   ELSE
31300		     BEGIN
31400	(* 62 - clean up stack offset *)
31500		      PARAMETERLIST([SEMICOLON,COLON],LCP1,TOPPOFFSET);
31600		       IF  NOT FORW
31700			THEN WITH LCP^ DO
31800			  BEGIN NEXT := LCP1; POFFSET := TOPPOFFSET END;
31900		       IF SY = COLON
32000		       THEN
32100			 BEGIN
32200			  INSYMBOL;
32300			   IF SY = IDENT
32400			   THEN
32500			     BEGIN
32600			       IF FORW
32700			       THEN ERROR(552);
32800			      SEARCHID([TYPES],LCP1);
32900			      LSP := LCP1^.IDTYPE;
33000			      LCP^.IDTYPE := LSP;
33100			       IF LSP # NIL
33200			       THEN
33300				 IF  NOT (LSP^.FORM IN [SCALAR,SUBRANGE,POINTER])
33400				 THEN
33500				   BEGIN
33600				    ERROR(551); LCP^.IDTYPE := NIL
33700				   END;
33800			      INSYMBOL
33900			     END
34000			   ELSE ERRANDSKIP(209,FSYS OR [SEMICOLON])
34100			 END
34200		       ELSE
34300			 IF  NOT FORW
34400			 THEN ERROR(455)
34500		     END;
34600		   IF SY = SEMICOLON
34700		   THEN INSYMBOL
34800		   ELSE ERROR(156);
34900		   IF SY = FORWARDSY
35000		   THEN
35100		     BEGIN
35200		       IF FORW
35300		       THEN ERROR(257)
35400		       ELSE
35500			WITH LCP^ DO
35600			 BEGIN
35700			  TESTFWDPTR := FORWPTR; FORWPTR := LCP; FORWDECL := TRUE
35800			 END;
35900		      INSYMBOL;
36000		       IF SY = SEMICOLON
36100		       THEN INSYMBOL
36200		       ELSE ERROR(156);
36300		      IFERRSKIP(166,FSYS)
36400		     END % SY = FORWARDSY \
36500		   ELSE
36600		    WITH LCP^ DO
36700		     BEGIN
36800		       IF SY = EXTERNSY
36900		       THEN
37000			 BEGIN
37100			   IF FORW
37200			   THEN ERROR(257)
37300			   ELSE EXTERNDECL := TRUE;
37400			  INSYMBOL;
37500			   IF LEVEL # 2
37600			   THEN ERROR(464);
37700			   IF SY IN LANGUAGESYS
37800			   THEN
37900			     BEGIN
38000			      LANGUAGE := SY;
38100			      INSYMBOL
38200			     END;
38300			   IF (LIBIX = 0) OR (NOT LIBRARY[LANGUAGE].INORDER)
38400			   THEN
38500			     BEGIN
38600			      LIBIX:= LIBIX+1;
38700			      LIBORDER[LIBIX]:= LANGUAGE;
38800			      LIBRARY[LANGUAGE].INORDER:= TRUE
38900			     END;
39000			  PFLEV := 1; PFCHAIN := EXTERNPFPTR; EXTERNPFPTR := LCP;
39100			   IF SY = SEMICOLON
39200	(* 56 - ACCEPT SYNTAX OF REQUIRE FILE *)
39300			     THEN BEGIN
39400			     INSYMBOL;
39500			     IFERRSKIP(166,FSYS)
39600			     END
39700			    ELSE IF NOT((SY=PERIOD) AND REQFILE)
39800			     THEN ERROR(166)
39900			 END % SY = EXTERNSY \
40000		       ELSE
40100			 BEGIN
40200	(* 55 - ONLY EXTERN DECL'S ALLOWED IN REQUIRE FILE *)
40300			  IF REQFILE
40400			    THEN ERROR(169);
40500			  PFCHAIN := LOCALPFPTR; LOCALPFPTR := LCP; FORWDECL := FALSE;
40600			  BLOCK(LCP,FSYS,[BEGINSY,FUNCTIONSY,PROCEDURESY,PERIOD,SEMICOLON]);
40700			   IF SY = SEMICOLON
40800			   THEN
40900			     BEGIN
41000			      INSYMBOL;
41100			      SKIPIFERR([BEGINSY,PROCEDURESY,FUNCTIONSY],166,FSYS)
41200			     END
41300			   ELSE
41400			     IF MAIN OR (LEVEL > 2) OR (SY # PERIOD)
41500			     THEN ERROR(156)
41600			 END % SY # EXTERNSY \
41700		     END % SY # FORWARDSY \ ;
41800		  LEVEL := OLDLEV; TOP := OLDTOP; LC := LLC;
41900	(* 5 - CREF *)
42000		  IF CREF
42100		    THEN WRITE(CHR(16B),CHR(10),LCP^.NAME)
42200		 END %PROCEDUREDECLARATION\ ;
42300	
42400		PROCEDURE BODY(FSYS: SETOFSYS);
42500		CONST
42600	(* 173 - rework for internal files *)
42700		  FILEOF = 1B; FILEOL = 2B; FILSTA = 11B;  FILTST=40B;
42800		  FILBFH =26B; FILLNR = 31B;
42900	(* 43 - new stuff for blocked files *)
43000	(* 50 - new labels for reinit *)
43100		  FILCMP =43B; filbll=36b; 
43200	(* 61 - tops20 *)
43300		  filjfn =4b;
43400		VAR
43500		  LASTFILE: CTP;
43600		  IDTREE: ADDRRANGE; %POINTER(IN THE USER'S CODE) TO THE IDENTIFIER-TREE\
43700	
43800		  PROCEDURE FULLWORD(FRELBYTE: RELBYTE; FLEFTH: ADDRRANGE; FRIGHTH: ADDRRANGE);
43900		   BEGIN
44000		    %FULLWORD\
44100		    CIX := CIX + 1;
44200		     IF CIX > CIXMAX
44300		     THEN
44400		       BEGIN
44500			IF FPROCP = NIL THEN ERRORWITHTEXT(356,'MAIN      ')
44600					ELSE ERRORWITHTEXT(356, FPROCP^.NAME);
44700			CIX := 0
44800		       END;
44900		    WITH CODE, HALFWORD[CIX] DO
45000		     BEGIN
45100		      LEFTHALF := FLEFTH;
45200		      RIGHTHALF := FRIGHTH;
45300		      INFORMATION[CIX] := 'W'; RELOCATION[CIX] := FRELBYTE
45400		     END;
45500		    IC := IC + 1
45600		   END %FULLWORD\ ;
45700	
45800	(* 164 - routine to allow Polish fixup in case ADDR can't be done by compiler *)
45900	
46000		procedure insertpolish(place,original:addrrange;adjust:integer);
46100		    var pol:polpt;
46200	{This routine requests the loader to fix up the right half of PLACE, by
46300	 putting in ORIGINAL (assumed relocatable) + ADJUST (assumed absolute).
46400	 A POLREC is created, and the actual request is put in the file by
46500	 WRITEMC(WRITEPOLISH).}
46600		  begin
46700		  if abs(adjust) > 377777B
46800		    then error(266)
46900		    else begin
47000		    new(pol);
47100		    with pol^ do
47200		      begin
47300		      where := place;
47400		      base := original;
47500		      offset := adjust;
47600		      nextpol := firstpol  {Link into chain of requests - FIRSTPOL}
47700		      end;
47800		    firstpol := pol
47900		    end;
48000		  end;
48100	
48200		  PROCEDURE INSERTADDR(FRELBYTE: RELBYTE; FCIX:CODERANGE;FIC:ADDRRANGE);
48300		   BEGIN
48400		     IF NOT ERRORFLAG
48500		     THEN
48600		      WITH CODE DO
48700		       BEGIN
48800			INSTRUCTION[FCIX].ADDRESS := FIC;
48900			RELOCATION[FCIX] := FRELBYTE
49000		       END
49100		   END;
49200	
49300		  PROCEDURE INCREMENTREGC;
49400		   BEGIN
49500		    REGC := REGC + 1 ;
49600		     IF REGC > REGCMAX
49700		     THEN
49800		       BEGIN
49900			ERROR(310) ; REGC := REGIN
50000		       END
50100		   END ;
50200	
50300		  PROCEDURE DEPCST(KONSTTYP:CSTCLASS; FATTR:ATTR);
50400		  VAR
50500		    II:INTEGER; LKSP,LLKSP: KSP; LCSP: CSP;
50600		    NEUEKONSTANTE,GLEICH:BOOLEAN; LCIX: CODERANGE;
50700		   BEGIN
50800		    I:=1;
50900		    NEUEKONSTANTE:=TRUE; LKSP := FIRSTKONST;
51000		    WHILE (LKSP#NIL) AND NEUEKONSTANTE DO
51100		    WITH LKSP^,CONSTPTR^ DO
51200		     BEGIN
51300		       IF CCLASS = KONSTTYP
51400		       THEN
51500			 CASE KONSTTYP OF
51600			  REEL:
51700				IF RVAL = FATTR.CVAL.VALP^.RVAL
51800				THEN
51900				 NEUEKONSTANTE := FALSE;
52000			  INT:
52100			       IF INTVAL = FATTR.CVAL.IVAL
52200			       THEN
52300				NEUEKONSTANTE := FALSE;
52400			  PSET:
52500				IF PVAL = FATTR.CVAL.VALP^.PVAL
52600				THEN
52700				 NEUEKONSTANTE := FALSE;
52800			  STRD,
52900			  STRG:
53000				IF FATTR.CVAL.VALP^.SLGTH = SLGTH
53100				THEN
53200				  BEGIN
53300				   GLEICH := TRUE;
53400				   II := 1;
53500				    REPEAT
53600				      IF FATTR.CVAL.VALP^.SVAL[II] # SVAL[II]
53700				      THEN
53800				       GLEICH := FALSE;
53900				     II:=II+1
54000				    UNTIL (II>SLGTH) OR NOT GLEICH;
54100				    IF GLEICH
54200				    THEN NEUEKONSTANTE := FALSE
54300				  END
54400			 END %CASE\;
54500		      LLKSP := LKSP; LKSP := NEXTKONST
54600		     END %WHILE\;
54700		     IF NOT NEUEKONSTANTE
54800		     THEN
54900		      WITH LLKSP^ DO
55000		       BEGIN
55100			INSERTADDR(RIGHT,CIX,ADDR); CODE.INFORMATION[CIX]:= 'C';
55200			 IF KONSTTYP IN [PSET,STRD]
55300			 THEN
55400			   BEGIN
55500			    INSERTADDR(RIGHT,CIX-1,ADDR1); CODE.INFORMATION[CIX-1]:= 'C'; ADDR1 := IC-2;
55600			   END;
55700			ADDR:= IC-1
55800		       END
55900		     ELSE
56000		       BEGIN
56100			 IF KONSTTYP = INT
56200			 THEN
56300			   BEGIN
56400			    NEWZ(LCSP,INT); LCSP^.INTVAL := FATTR.CVAL.IVAL
56500			   END
56600			 ELSE
56700			  LCSP := FATTR.CVAL.VALP;
56800			CODE.INFORMATION[CIX] := 'C';
56900			 IF KONSTTYP IN [PSET,STRD]
57000			 THEN CODE.INFORMATION[CIX-1] := 'C';
57100			NEWZ(LKSP);
57200			WITH LKSP^ DO
57300			 BEGIN
57400			  ADDR := IC-1;
57500	(* 72 - two fixup chains for 2 word consts *)
57600			  if konsttyp in [strd,pset]
57700			    then addr1 := ic-2;
57800			  CONSTPTR := LCSP; NEXTKONST := NIL
57900			 END;
58000			 IF FIRSTKONST = NIL
58100			 THEN FIRSTKONST := LKSP
58200			 ELSE LLKSP^.NEXTKONST := LKSP
58300		       END
58400		   END %DEPCST\;
58500	
58600		  PROCEDURE MACRO(FRELBYTE : RELBYTE;
58700				  FINSTR   : INSTRANGE;
58800				  FAC	   : ACRANGE;
58900				  FINDBIT  : IBRANGE;
59000				  FINXREG  : ACRANGE;
59100				  FADDRESS : INTEGER);
59200		   BEGIN
59300		     IF NOT INITGLOBALS
59400		     THEN
59500		       BEGIN
59600			CIX := CIX + 1;
59700			 IF CIX > CIXMAX
59800			 THEN
59900			   BEGIN
60000			     IF FPROCP = NIL
60100			     THEN ERRORWITHTEXT(356,'MAIN      ')
60200			     ELSE ERRORWITHTEXT(356, FPROCP^.NAME);
60300			    CIX := 0
60400			   END;
60500			WITH CODE, INSTRUCTION[CIX] DO
60600			 BEGIN
60700			  INSTR    :=FINSTR;
60800			  AC	   :=FAC;
60900			  INDBIT   :=FINDBIT;
61000			  INXREG   :=FINXREG;
61100			  ADDRESS  :=FADDRESS;
61200			  INFORMATION[CIX]:= ' '; RELOCATION[CIX] := FRELBYTE
     
00100			 END;
00200			IC := IC + 1
00300		       END
00400		     ELSE ERROR(507)
00500		   END %MACRO\;
00600	
00700		  PROCEDURE MACRO5(FRELBYTE: RELBYTE; FINSTR : INSTRANGE; FAC,FINXREG : ACRANGE; FADDRESS : INTEGER);
00800		   BEGIN
00900		    MACRO(FRELBYTE,FINSTR,FAC,0,FINXREG,FADDRESS)
01000		   END;
01100	
01200		  PROCEDURE MACRO4(FINSTR: INSTRANGE;FAC, FINXREG: ACRANGE;FADDRESS: INTEGER);
01300		   BEGIN
01400		    MACRO(NO,FINSTR,FAC,0,FINXREG,FADDRESS)
01500		   END;
01600	
01700		  PROCEDURE MACRO3(FINSTR : INSTRANGE; FAC:ACRANGE; FADDRESS: INTEGER);
01800		   BEGIN
01900		    MACRO(NO,FINSTR,FAC,0,0,FADDRESS)
02000		   END;
02100	
02200		  PROCEDURE MACRO4R(FINSTR : INSTRANGE; FAC,FINXREG : ACRANGE; FADDRESS : INTEGER);
02300		   BEGIN
02400		    MACRO(RIGHT,FINSTR,FAC,0,FINXREG,FADDRESS)
02500		   END;
02600	
02700		  PROCEDURE MACRO3R(FINSTR : INSTRANGE; FAC:ACRANGE; FADDRESS: INTEGER);
02800		   BEGIN
02900		    MACRO(RIGHT,FINSTR,FAC,0,0,FADDRESS)
03000		   END;
03100	
03200		  PROCEDURE PUTPAGER;
03300		   BEGIN
03400		    WITH PAGER DO
03500		     BEGIN
03600		      LASTPAGER := IC;
03700		      WITH WORD1 DO MACRO4R(304B%CAIA\,AC,INXREG,ADDRESS);
03800		      FULLWORD(RIGHT,LHALF,RHALF);
03900		      LASTPAGE := PAGECNT
04000		     END
04100		   END;
04200	
04300		  PROCEDURE PUTLINER;
04400		   BEGIN
04500		     IF PAGECNT # LASTPAGE
04600		     THEN PUTPAGER;
04700		     IF LINECNT # LASTLINE
04800		     THEN %BREAKPOINT\
04900		       BEGIN
05000			 IF LINENR # '-----'
05100			 THEN
05200			   BEGIN
05300			    LINECNT := 0;
05400			    FOR I := 1 TO 5 DO	LINECNT := 10*LINECNT + ORD(LINENR[I]) - ORD('0')
05500			   END;
05600			LINEDIFF := LINECNT - LASTLINE;
05700			 IF LINEDIFF > 255
05800			 THEN
05900			   BEGIN
06000			    MACRO3R(334B%SKIPA\,0,LASTSTOP);
06100			    LASTSTOP := IC-1;
06200			    MACRO3(320B%JUMP\,0,LASTLINE)
06300			   END
06400			 ELSE
06500			   BEGIN
06600			    MACRO4R(320B%JUMP\,LINEDIFF MOD 16,LINEDIFF DIV 16, LASTSTOP); %NOOP\
06700			    LASTSTOP := IC - 1
06800			   END;
06900			LASTLINE := LINECNT
07000		       END
07100		   END;
07200	
07300		  PROCEDURE SUPPORT(FSUPPORT: SUPPORTS);
07400		   BEGIN
07500		     CASE FSUPPORT OF
07600	(* 23 - check for bad pointer *)
07700		      BADPOINT,
07800		      ERRORINASSIGNMENT,
07900		      INDEXERROR    : MACRO3R(265B%JSA\,HAC,RNTS.LINK[FSUPPORT]);
08000	(* 12 - NOW STACKOVERFLOW IS NOT AN ERROR - GETS MORE MEMORY *)
08100	(* 74 - add initmem for 10 version under emulator *)
08200	(* 104 - debstack for tops-10 debugging stack check *)
08300	(* 120 - new calling method for INITFILES, for T20/Tenex *)
08400		      INITFILES,INITMEM,STACKOVERFLOW,DEBSTACK: MACRO3R(265B%JSP\,TAC,RNTS.LINK[FSUPPORT]);
08500	(* 64 - non-local gotos *)
08600		      EXITPROGRAM   : MACRO3R(254B%JRST\,0,RNTS.LINK[FSUPPORT]);
08700		      OTHERS	    : MACRO3R(260B%PUSHJ\,TOPP,RNTS.LINK[FSUPPORT])
08800		     END;
08900		    CODE.INFORMATION[CIX]:= 'E';
09000		    RNTS.LINK[FSUPPORT]:= IC-1
09100		   END;
09200	
09300		  PROCEDURE ENTERBODY;
09400		  VAR
09500		    I: INTEGER; LCP : CTP;
09600	(* 66 - NON-LOC GOTO *)
09700		    LBTP: BTP; NONLOC,INLEVEL: BOOLEAN;
09800		   BEGIN
09900		    LBTP := LASTBTP;
10000	(* 13 - ADD DATA FOR DDT SYMBOLS *)
10100		    PFPOINT := IC;
10200		    WHILE LBTP # NIL DO
10300		     BEGIN
10400		      WITH LBTP^ DO
10500		       CASE BKIND OF
10600			RECORDD: FIELDCP^.FLDADDR := IC;
10700			ARRAYY : ARRAYSP^.ARRAYBPADDR := IC
10800		       END;
10900		      LBTP := LBTP^.LAST;
11000		      IC := IC + 1
11100		     END;
11200	(* 66 - NON-LOC GOTO *)
11300		     LCP:=LASTLABEL;
11400		     INLEVEL:=TRUE; NONLOC:=FALSE;
11500		     WHILE(LCP#NIL) AND INLEVEL DO
11600			WITH LCP^ DO
11700			  IF SCOPE=LEVEL
11800			    THEN BEGIN
11900			    NONLOC := NONLOC OR NONLOCGOTO;
12000			    LCP := NEXT
12100			    END
12200			   ELSE INLEVEL := FALSE;
12300		     IF FPROCP # NIL
12400		     THEN
12500		       BEGIN
12600			FULLWORD(NO,0,377777B); IDTREE := CIX; %IF DEBUG, INSERT TREEPOINTER HERE\
12700	(* 13 - SAVE START ADDRESS FOR DDT SYMBOL *)
12800			PFDISP := IC;
12900			WITH FPROCP^ DO
13000			 IF PFLEV > 1
13100			 THEN
13200			  FOR I := MAXLEVEL DOWNTO PFLEV+1 DO
13300			  MACRO4(540B%HRR\,BASIS,BASIS,-1);
13400			PFSTART := IC;
13500	(* 62 - clean up stack offset *)
13600		        if fprocp^.poffset # 0
13700			  then macro4(262B%pop\,topp,topp,-fprocp^.poffset-1);
13800	(* 37 - fix static link for level one procedures *)
13900			if fprocp^.pflev = 1
14000			  then macro4(512b%hllzm\,basis,topp,-fprocp^.poffset-1)
14100			  ELSE MACRO4(202B%MOVEM\,BASIS,TOPP,-FPROCP^.POFFSET-1);
14200			if fprocp^.poffset # 0
14300			  then begin
14400			  macro4(201B%movei\,basis,topp,-fprocp^.poffset);
14500	(* 104 - several changes below to allow detection stack overflow *)
14600			  macro3(504B%hrl\,basis,basis);
14700			  end
14800			 ELSE MACRO3(507B%HRLS\,BASIS,TOPP);
14900	(* 115 - tenex *)
15000			IF KLCPU AND NOT TOPS10
15100			  THEN MACRO3(105B%ADJSP\,TOPP,0)
15200			  ELSE MACRO4(541B%HRRI\,TOPP,TOPP,0);
15300			INSERTSIZE := CIX;
15400	(* 66 - NONLOC GOTO *)
15500			IF NONLOC
15600			  THEN MACRO4(506B%HRLM\,TOPP,BASIS,0);
15700	(* If anyone has done a non-local goto into this block, save the
15800	   stack pointer here where the goto can recover it. *)
15900	(* 53 - figure out later how many loc's above stack we need *)
16000	(* 57 - LIMIT CORE ALLOCATION TO TOPS-10 VERSION *)
16100			IF TOPS10 THEN BEGIN
16200			IF RUNTMCHECK
16300			  THEN BEGIN
16400			  MACRO4(201B%MOVEI\,HAC,TOPP,0); CORALLOC := CIX;
16500			   %Will be fixed up - get highest core needed \
16600			  MACRO4(301B%CAIL\,HAC,BASIS,0); %check wraparound > 777777\
16700			  MACRO4(303B%CAILE\,HAC,NEWREG,0); %see if need more\
16800			  SUPPORT(DEBSTACK)
16900			  END
17000			 ELSE BEGIN %NOT DEBUG\
17100			  MACRO4(307B%CAIG\,NEWREG,TOPP,0); CORALLOC := CIX;
17200			    %will be fixed up - fails if wrap around 777777\
17300			  SUPPORT(STACKOVERFLOW);
17400			  END
17500			END;
17600	(* 24 - NOW ZERO ONLY IF RUNTIME CHECKING ON *)
17700	(* 25 - SEPARATE SWITCH /ZERO FOR THIS NOW *)
17800			IF ZERO
17900			THEN BEGIN
18000			IF LCPAR < LC  %ANY VARIABLES?\
18100			  THEN MACRO4(402B%SETZM\,0,BASIS,LCPAR);
18200			IF LCPAR < (LC-1) %MORE THAN ONE?\
18300			  THEN BEGIN
18400			  MACRO4(505B%HRLI\,TAC,BASIS,LCPAR);
18500			  MACRO4(541B%HRRI\,TAC,BASIS,LCPAR+1);
18600			  MACRO4(251B%BLT\,TAC,BASIS,LC-1)
18700			  END
18800			END;
18900			REGC := REGIN+1;
19000			LCP := FPROCP^.NEXT;
19100			WHILE LCP # NIL DO
19200			WITH LCP^ DO
19300			 BEGIN
19400	(* 33 - proc param.'s*)
19500			   IF KLASS # VARS
19600			   THEN
19700			     BEGIN
19800			     IF REGC <= PARREGCMAX
19900				THEN BEGIN
20000				MACRO4(202B%MOVEM\,REGC,BASIS,PFADDR);
20100				REGC := REGC+1
20200				END
20300			     END
20400			   ELSE
20500			     IF IDTYPE # NIL
20600			     THEN
20700			       IF (VKIND=FORMAL) OR (IDTYPE^.SIZE=1)
20800			       THEN   %COPY PARAMETERS FROM REGISTERS INTO LOCAL CELLS\
20900				 BEGIN
21000				   IF REGC <= PARREGCMAX
21100				   THEN
21200				     BEGIN
21300				      MACRO4(202B%MOVEM\,REGC,BASIS,VADDR); REGC := REGC + 1
21400				     END
21500				 END
21600			       ELSE
21700				 IF IDTYPE^.SIZE=2
21800				 THEN
21900				   BEGIN
22000				     IF REGC < PARREGCMAX
22100				     THEN
22200				       BEGIN
22300					MACRO4(202B%MOVEM\,REGC,BASIS,VADDR);
22400					MACRO4(202B%MOVEM\,REGC+1,BASIS,VADDR+1);
22500					REGC:=REGC+2
22600				       END
22700	(* 2 - bug fix for parameter passing *)
22800				     ELSE REGC:=PARREGCMAX+1
22900				   END
23000	(* 201 - zero size things *)
23100				 ELSE IF IDTYPE^.SIZE > 0
23200				   THEN BEGIN
23300				     IF REGC <= PARREGCMAX
23400				     THEN  %COPY MULTIPLE VALUES INTO LOCAL CELLS\
23500				       BEGIN
23600					MACRO3(504B%HRL\,TAC,REGC); REGC := REGC + 1
23700				       END
23800				     ELSE
23900				      MACRO4(504B%HRL\,TAC,BASIS,VADDR);
24000				    MACRO4(541B%HRRI\,TAC,BASIS,VADDR);
24100				    MACRO4(251B%BLT\,TAC,BASIS,VADDR+IDTYPE^.SIZE-1)
24200				   END
24300	(* 201 - zero size things *)
24400				 ELSE {zero size}
24500				  REGC := REGC + 1;
24600			  LCP := LCP^.NEXT;
24700			 END
24800		       END
24900		     ELSE  MAINSTART := IC
25000		   END %ENTERBODY\;
25100	
25200		  PROCEDURE LEAVEBODY;
25300		  VAR
25400		    J,K : ADDRRANGE ;
25500		    LFILEPTR: FTP; LKSP: KSP ;
25600	(* 33 - PROGRAM *)
25700		    LCP : CTP; OLDID : ALFA;
25800		   PROCEDURE ALFACONSTANT(FSTRING:ALFA);
25900		   VAR LCSP:CSP;
26000		     BEGIN
26100		     NEW(LCSP,STRG);
26200		     WITH LCSP^ DO
26300		       BEGIN
26400		       SLGTH := 10; FOR I := 1 TO 10 DO SVAL[I] := FSTRING[I]
26500		       END;
26600		     WITH GATTR DO
26700		       BEGIN
26800		       TYPTR := ALFAPTR;
26900		       KIND := CST; CVAL.VALP := LCSP
27000		       END
27100		     END;
27200		   BEGIN
27300		     IF DEBUG
27400		     THEN PUTLINER;
27500		     IF  FPROCP # NIL
27600		     THEN
27700	(* 173 - internal files - close them *)
27800		      if fileinblock[level]
27900		       then begin
28000	{We have to close any files in this block before we can change TOPP,
28100	 or we might be playing with locals above the stack!  So this is
28200	 coded like a non-local goto - new basis in regc, new topp in regc+1}
28300			regc := regin+1;
28400	(* 213 - forgot to subtract 1 from TOPP to simulate POPJ *)
28500			  {simulate HRLS TOPP,BASIS.  But have to subtract 1
28600			   since there would have been a POPJ TOPP, later.
28700			   Because of this, things that would be -1(TOPP) are
28800			   now (TOPP)}
28900			macro4(505B%hrli\,regc+1,basis,-1);
29000			macro3(544B%hlr\,regc+1,regc+1);
29100			  {simulate HLRS BASIS,-1(TOPP), but note that -1 has
29200			   already been done}
29300			macro4(544B%hlr\,regc,regc+1,0);
29400			macro3(504B%hrl\,regc,regc);
29500			  {now get return address from where POPJ TOPP, would
29600			   get it, i.e. (TOPP).  However note that -1 has been
29700			   done}
29800			macro4(550B%hrrz\,regc+2,regc+1,1);
29900			support(exitgoto)
30000			end
30100		      else
30200		       BEGIN
30300	(* 104 - keep LH=RH in topp for tops20 adjsp *)
30400			MACRO3(507B%HRLS\,TOPP,BASIS);
30500			MACRO4(547B%HLRS\,BASIS,TOPP,-1);
30600			MACRO3(263B%POPJ\,TOPP,0);
30700		       END
30800		     ELSE
30900		       BEGIN
31000			 IF MAIN
31100			 THEN
31200			   BEGIN
31300			    SUPPORT(EXITPROGRAM);
31400			    STARTADDR := IC;
31500	(* 2 - get some core by default if none there *)
31600	(* 12 - REDO INITIALIZATION FOR DYNAMIC EXPANDING CORE *)
31700	(* 16 - change entry code in case execute-only or entry at +1 *)
31800	(* 24 - CHANGE AGAIN TO ALLOW ST. ADDR OF HEAP AND STACK SPECIFIED *)
31900			MACRO3R(254B%JRST\,1,IC+2); %PORTAL - IN CASE EXEC-ONLY\
32000			MACRO3R(254B%JRST\,1,IC+2); %IN CASE OFFSET =1\
32100			MACRO3(634B%TDZA\,1,1); %NORMAL ENTRY - ZERO AND SKIP\
32200			MACRO3(201B%MOVEI\,1,1); %CCL ENTRY - SET TO ONE\
32300			MACRO3R(202B%MOVEM\,1,CCLSW); %STORE CCL VALUE\
32400			MACRO3R(200B%MOVE\,1,CCLSW+4); %SEE IF INIT DONE\
32500			MACRO3R(326B%JUMPN\,1,IC+5); %YES - DON'T RESAVE AC'S\
32600			MACRO3R(202B%MOVEM\,0,CCLSW+1); %RUNNAME\
32700			MACRO3R(202B%MOVEM\,7B,CCLSW+2); %RUNPPN\
32800			MACRO3R(202B%MOVEM\,11B,CCLSW+3); %RUNDEV\
32900			MACRO3R(476B%SETOM\,0,CCLSW+4); %SAY WE HAVE DONE IT\
33000	(* 132 - separate KA10 into NOVM and KACPU *)
33100			IF (HEAP = 0) AND (NOT NOVM)
33200			  THEN HEAP := 377777B;
33300			MACRO3(201B%MOVEI\,BASIS,HEAP); %LSTNEW_377777\
33400			MACRO3R(202B%MOVEM\,BASIS,LSTNEW); %WILL GET GLOBAL FIXUP\
33500			LSTNEW := IC-1;
33600			MACRO3(201B%MOVEI\,BASIS,HEAP+1); %NEWBND_400000\
33700			MACRO3R(202B%MOVEM\,BASIS,NEWBND); %GLOBAL FIXUP\
33800			NEWBND := IC-1;
33900			IF STACK#0
34000			  THEN MACRO3(201B%MOVEI\,BASIS,STACK)
34100			  ELSE MACRO3(550B%HRRZ\,BASIS,115B); %BASIS_.JBHRL\
34200			MACRO3(306B%CAIN\,BASIS,0); %IF NO HISEG\
34300			MACRO3(201B%MOVEI\,BASIS,377777B); %START STACK 400000\
34400			MACRO3(200B%MOVE\,NEWREG,BASIS); %NEWREG=HIGHEST ALLOC\
34500			MACRO3(271B%ADDI\,BASIS,1); %BASIS=NEXT TO USE\
34600			    MACRO4(505B%HRLI\,BASIS,BASIS,0);
34700			    MACRO4(541B%HRRI\,TOPP,BASIS,0); %GETS FIXED UP\
34800			    INSERTSIZE:= CIX;
34900	(* 104 - KEEP LH=RH FOR TOPS20 ADJSP *)
35000			    MACRO3(504B%HRL\,TOPP,TOPP);
35100	(* 66 - nonloc goto's *)
35200			    macro3r(202B%movem\,basis,globbasis);
35300			    macro3r(202B%movem\,topp,globtopp);
35400	(* 17 - LEAVE .JBFF ALONE, SINCE BUFFER HEADERS POINT INTO FREE AREA *)
35500	(* 57 - LIMIT UUO'S AND CORE ALLOC TO TOPS-10 VERSION *)
35600			IF TOPS10 THEN BEGIN
35700	(* 122 - seem not to need to save .jbff any more *)
35800		  {	    MACRO3(550B%HRRZ\,1,121B); %.JBFF\
35900			    MACRO3(506B%HRLM\,1,120B); %TO LH(.JBSA)\
36000		  }	    MACRO3(047B,0,0%RESET-UUO\); %.JBFF=.JBSA\
36100	(* 74 - new init stuff for tops10 under emulator *)
36200			    support(initmem);
36300	(* 53 - figure out later how many loc's above stack we need *)
36400	(* 130 - leave in dummy CAI in KA version so there is some place for the CORALLOC fixup to go *)
36500			  MACRO4(300B%CAI\,NEWREG,TOPP,0); CORALLOC := CIX;  %Will be fixed up later\
36600	(* 122 - already get core in initmem for KA *)
36700	(* 132 - separate KA10 into novm and kacpu *)
36800			  if not novm 
36900			    THEN SUPPORT(STACKOVERFLOW);	% GET CORE FOR STACK\
37000	(* 34 - TRAP ARITH EXCEPTIONS WHEN CHECKING *)
37100			IF ARITHCHECK
37200			  THEN BEGIN
37300			  MACRO3(201B%MOVEI\,1,110B); %TRAP ALL ARITH. EXCEPTIONS\
37400			  MACRO3(047B%CALLI\,1,16B); %APRENB - TURN ON APR SYS\
37500			  END;
37600	(* 57 - INIT ALL IN RUNTIMES FOR NON-TOPS10 *)
37700			END
37800			 ELSE MACRO3(201B%MOVEI\,2,ORD(ARITHCHECK));
37900	(* 50 - reinit file ctl. blocks *)
38000			support(initfiles);
38100			doinitTTY := false;
38200			    LFILEPTR := SFILEPTR ;
38300			    REGC := REGIN + 1 ;
38400	(* 33 - PROGRAM *)
38500	(* 50 - changed logic to only open INPUT and OUTPUT if in pgm state *)
38600			    LPROGFILE := FPROGFILE;
38700			    WHILE LPROGFILE # NIL DO
38800			      BEGIN
38900			      PRTERR := FALSE; OLDID := ID; ID := LPROGFILE^.FILID;
39000			      SEARCHID([VARS],LCP);
39100			      PRTERR := TRUE; ID := OLDID;
39200			      IF LCP = NIL
39300				THEN ERRORWITHTEXT(508,LPROGFILE^.FILID)
39400				ELSE
39500				  WITH LCP^ DO
39600				  BEGIN
39700				  IF IDTYPE#NIL THEN IF IDTYPE^.FORM#FILES
39800				    THEN ERRORWITHTEXT(509,LPROGFILE^.FILID);
39900				  MACRO3R(201B%MOVEI\,REGC,VADDR);
40000				  IF (VLEV = 0) AND (NOT MAIN)
40100				    THEN BEGIN
40200				    VADDR := IC -1;
40300				    CODE.INFORMATION[CIX] := 'E'
40400				    END;
40500			          ALFACONSTANT(LPROGFILE^.FILID);
40600				  MACRO3(551B%HRRZI\,REGC+1,0);DEPCST(STRG,GATTR);
40700	(* 61 - set up flags for gtjfn *)
40800				  i := 60023b; %mandatory flags for gtjfn\
40900				  if lprogfile^.wild
41000				    then i := i + 100B;
41100				  if lprogfile^.newgen
41200				    then i := i + 400000B;
41300				  if lprogfile^.oldfile
41400				    then i := i + 100000B;
41500				  macro3(505B%hrli\,regc+1,i);
41600	(* 172 - end of line proc *)
41700				  if lcp = ttyfile
41800				    then ttyseeeol := lprogfile^.seeeol;
41900				  if not ((lcp = ttyfile) or (lcp = ttyoutfile))
42000				    then SUPPORT(READFILENAME)
42100				  END;
42200	(* 171 - handle input and output as special - many changes to lcp = in/outfile *)
42300			      if (lcp = infile)
42400				and not lprogfile^.interact
42500				  then doinitTTY := true;
42600			      if (lcp = infile) or (lcp = outfile)
42700				then begin
42800				macro3(201B%movei\,regc-1,0);  {AC1=0 for text file}
42900				macro3(403B%setzb\,regc+1,regc+2);
43000				macro3(403B%setzb\,regc+3,regc+4);
43100	(* 64 - input:/ *)
43200	(* 157 - always open INPUT interactive - do GET below *)
43300				if lcp = infile
43400				  then macro3(201B%movei\,regc+3,1);
43500				macro3(403B%setzb\,regc+5,regc+6);
43600	(* 172 - new eoln handling *)
43700				if (lcp = infile) and lprogfile^.seeeol
43800				  then if tops10
43900					 then macro3(201B%movei\,regc+5,40000B)
44000					 else macro3(201B%movei\,regc+6,20B);
44100				if lcp = infile
44200				  then support(resetfile)
44300				  else support(rewritefile)
44400				end;
44500			      LPROGFILE := LPROGFILE^.NEXT
44600			      END;
44700	(* 15 - ZERO ALL ARGS TO OPEN *)
44800			    TTYINUSE := TTYINUSE OR DEBUG;
44900			    WHILE LFILEPTR # NIL DO
45000			    WITH LFILEPTR^ , FILEIDENT^ DO
45100	(* 50 - only open TTY here, as INPUT and OUTPUT done above *)
45200			    begin
45300			    if (fileident = ttyfile) or (fileident = ttyoutfile)
45400				then
45500			     BEGIN
45600			      MACRO3R(201B%MOVEI\,REGC,VADDR) ;
45700			      macro3(201B%movei\,regc-1,0);  {0=text file}
45800	(* 202 - fix illegal option *)
45900			      macro3(403B%setzb\,regc+1,regc+2);
46000			      macro3(403B%setzb\,regc+3,regc+4);
46100	(* 172 - new EOL *)
46200			      macro3(403B%setzb\,regc+5,regc+6);
46300			      if (fileident = ttyfile) and ttyseeeol
46400				  then if tops10
46500					 then macro3(201B%movei\,regc+5,40000B)
46600					 else macro3(201B%movei\,regc+6,20B);
46700	(* 36 - allow debugging non-main modules *)
46800			       IF fileident = ttyfile
46900			       THEN
47000				SUPPORT(RESETFILE)
47100			       ELSE
47200				  SUPPORT(REWRITEFILE) ;
47300			     end;
47400	(* 3 - Removed OPENTTY because of RUNTIM changes *)
47500			      LFILEPTR := NEXTFTP ;
47600			    END ;
47700			    if doinitTTY
47800			      then support(opentty);
47900			    macro3(200b%move\,tac,74b);  %get .jbddt\
48000			    macro3(602b%trne\,tac,777777b);  %if zero RH\
48100			    macro3(603b%tlne\,tac,777777b);  %or non-0 LH\
48200			    macro3r(254b%jrst\,0,mainstart); %isn't PASDDT\
48300			    macro4(260b%pushj\,topp,tac,-2); %init pt. is start-2\
48400			    MACRO3R(254B%JRST\,0,MAINSTART);
48500			   END;
48600		       END;
48700		    CODEEND := IC;
48800		    LKSP:= FIRSTKONST;
48900		    WHILE LKSP # NIL DO
49000		    WITH LKSP^,CONSTPTR^ DO
49100		     BEGIN
49200		      KADDR:= IC;
49300		       CASE  CCLASS OF
49400			INT,
49500			REEL: IC := IC + 1 ;
49600			PSET: IC := IC + 2 ;
49700			STRD,
49800			STRG: IC := IC + (SLGTH+4) DIV 5
49900		       END ;
50000		      %CASE\
50100		      LKSP := NEXTKONST
50200		     END  %WITH , WHILE\;
50300		     IF DEBUGSWITCH
50400		     THEN
50500		       BEGIN
50600			 IF (LEVEL > 1) AND ( DISPLAY[TOP].FNAME # NIL )
50700			 THEN INSERTADDR(RIGHT,IDTREE,IC)
50800		       END
50900		     ELSE
51000		       IF LEVEL = 1
51100		       THEN HIGHESTCODE := IC
51200		   END%LEAVEBODY\;
51300	
51400		  PROCEDURE FETCHBASIS(VAR FATTR: ATTR);
51500		  VAR
51600		    P,Q: INTEGER;
51700		   BEGIN
51800		    WITH FATTR DO
51900		     IF VLEVEL>1
52000		     THEN
52100		       BEGIN
52200			P := LEVEL - VLEVEL;
52300			 IF P=0
52400			 THEN
52500			   IF INDEXR=0
52600			   THEN INDEXR := BASIS
52700			   ELSE MACRO3(270B%ADD\,INDEXR,BASIS)
52800			 ELSE
52900			   BEGIN
53000			    MACRO4(540B%HRR\,TAC,BASIS,-1);
53100			    FOR Q := P DOWNTO 2 DO
53200			    MACRO4(540B%HRR\,TAC,TAC,-1);
53300			     IF INDEXR=0
53400			     THEN INDEXR := TAC
53500			     ELSE MACRO3(270B%ADD\,INDEXR,TAC)
53600			   END;
53700			VLEVEL:=1	%DA IN WITHSTATEMENT DIE MOEGLICHKEIT BESTEHT,
53800					 DASS ES 2-MAL DURCH FETCHBASIS LAEUFT\
53900		       END
54000		   END;
54100		  %FETCHBASIS\
54200	
54300		  PROCEDURE GETPARADDR;
54400		   BEGIN
54500		    FETCHBASIS(GATTR);
54600		    WITH GATTR DO
54700		     BEGIN
54800		      INCREMENTREGC;
54900		      MACRO5(VRELBYTE,200B%MOVE\,REGC,INDEXR,DPLMT);
55000		      INDEXR := REGC; VRELBYTE:= NO;
55100		      INDBIT := 0; VLEVEL := 1; DPLMT := 0;
55200		     END
55300		   END;
55400	
55500	{Warning to future modifiers: At the end of EXPRESSION, there is code that
55600	 second-guesses the register allocation in this procedure.  If you change
55700	 the register allocation here, please look at that code.}
55800		  PROCEDURE MAKECODE(FINSTR: INSTRANGE; FAC: ACRANGE; VAR FATTR: ATTR);
55900		  VAR
56000		    LINSTR: INSTRANGE; LREGC: ACRANGE;
56100		   BEGIN
56200		    WITH FATTR DO
56300		     IF TYPTR#NIL
56400		     THEN
56500		       BEGIN
56600			 CASE KIND OF
56700			  CST:
56800			       IF TYPTR=REALPTR
56900			       THEN
57000				 BEGIN
57100				  MACRO3(FINSTR,FAC,0); DEPCST(REEL,FATTR)
57200				 END
57300			       ELSE
57400				 IF TYPTR^.FORM=SCALAR
57500				 THEN
57600				  WITH CVAL DO
57700				   IF ((IVAL >= 0) AND (IVAL <= MAXADDR))
57800				    OR
57900	(* 50 - correct code for 400000,,0 *)
58000				    ((ABS(IVAL) <= HWCSTMAX+1) AND (IVAL # 400000000000B)
58100				     AND
58200				     ((FINSTR = 200B%MOVE\) OR (IVAL >= 0)))
58300				   THEN
58400				     BEGIN
58500				       IF FINSTR=200B%MOVE\
58600				       THEN
58700					 IF IVAL < 0
58800					 THEN FINSTR := 571B%HRREI\
58900					 ELSE FINSTR := 551B%HRRZI\
59000				       ELSE
59100					 IF (FINSTR>=311B) AND (FINSTR <= 317B)
59200					 THEN FINSTR := FINSTR - 10B %E.G. CAML --> CAIL\
59300					 ELSE FINSTR := FINSTR+1;
59400				      MACRO3(FINSTR,FAC,IVAL);
59500				     END
59600				   ELSE
59700				     BEGIN
59800				      MACRO3(FINSTR,FAC,0); DEPCST(INT,FATTR)
59900				     END
60000				 ELSE
60100				   IF TYPTR=NILPTR
60200				   THEN
60300				     BEGIN
60400				       IF FINSTR=200B%MOVE\
60500				       THEN FINSTR := 571B%HRREI\
60600				       ELSE
60700					 IF (FINSTR>=311B) AND (FINSTR<=317B)
60800					 THEN FINSTR := FINSTR-10B
60900					 ELSE FINSTR := FINSTR+1;
61000				      MACRO3(FINSTR,FAC,377777B);
61100				     END
61200				   ELSE
61300				     IF TYPTR^.FORM=POWER
61400				     THEN
61500				       BEGIN
61600					MACRO3(FINSTR,FAC,0); MACRO3(FINSTR,FAC-1,0); DEPCST(PSET,FATTR);
61700				       END
61800				     ELSE
61900				       IF TYPTR^.FORM=ARRAYS
62000				       THEN
62100					 IF TYPTR^.SIZE = 1
62200					 THEN
62300					   BEGIN
62400					    MACRO3(FINSTR,FAC,0); DEPCST(STRG,FATTR)
62500					   END
62600					 ELSE
62700					   IF TYPTR^.SIZE = 2
62800					   THEN
62900					     BEGIN
63000					      FATTR.CVAL.VALP^.CCLASS := STRD;
63100					      MACRO3(FINSTR,FAC,0); MACRO3(FINSTR,FAC-1,0); DEPCST(STRD,FATTR);
63200					     END;
63300			  VARBL:
63400				 BEGIN
63500				  FETCHBASIS(FATTR); LREGC := FAC;
63600				   IF (INDEXR>REGIN)  INCREMENTREGC ;
70700			  MAKECODE(200B%MOVE\,REGC,FATTR);REGC := REG
70800			 END;
70900		   END;
71000		  %LOAD\
71100	
71200	(* 104 - common procedure for improved range check on subranges *)
71300		  procedure loadsubrange(var gattr:attr;lsp:stp);
71400		    var slattr:attr; srmin,srmax:integer;
71500		    begin
71600	            GETBOUNDS(LSP,SRMIN,SRMAX);
71700		    IF (GATTR.KIND=CST)
71800		    THEN
71900		      IF (GATTR.CVAL.IVAL >= SRMIN) AND (GATTR.CVAL.IVAL <=SRMAX)
72000		      THEN LOAD (GATTR)
72100		      ELSE ERROR (367)
72200		    ELSE
72300		      BEGIN
72400		        IF RUNTMCHECK AND (( GATTR.KIND#VARBL) OR (GATTR.SUBKIND # LSP))
72500		        THEN
72600		          BEGIN
72700		           LOAD (GATTR);
72800		           WITH SLATTR DO
72900				BEGIN
73000				 TYPTR:=INTPTR;
73100				 KIND :=CST;
73200				 CVAL.IVAL:=SRMAX
73300				END;
73400		           MAKECODE(317B%CAMG\,REGC,SLATTR);
73500		           SLATTR.KIND:=CST;
73600		           SLATTR.CVAL.IVAL:=SRMIN;
73700		           MAKECODE(315B%CAMGE\,REGC,SLATTR);
73800		           SUPPORT(ERRORINASSIGNMENT)
73900		          END
74000		        ELSE LOAD (GATTR);
74100		      END
74200		    end;
74300	
74400		  PROCEDURE STORE(FAC: ACRANGE; VAR FATTR: ATTR);
74500		  VAR
74600		    LATTR: ATTR;
74700		   BEGIN
74800		    LATTR := FATTR;
74900		    WITH LATTR DO
75000		     IF TYPTR # NIL
75100		     THEN
75200		       BEGIN
75300			FETCHBASIS(LATTR);
75400			 CASE PACKFG OF
75500			  NOTPACK:
75600				   BEGIN
75700				     IF TYPTR^.SIZE = 2
75800				     THEN
75900				       BEGIN
76000					MACRO5(VRELBYTE,202B%MOVEM\,FAC,INDEXR,DPLMT+1); FAC := FAC-1
76100				       END;
76200				    MACRO(VRELBYTE,202B%MOVEM\,FAC,INDBIT,INDEXR,DPLMT)
76300				   END;
76400			  PACKK:
76500				 BEGIN
76600				  MACRO5(VRELBYTE,201B%MOVEI\,TAC,INDEXR,DPLMT);
76700				  MACRO3R(137B%DPB\,FAC,BPADDR);
76800				 END;
76900			  HWORDL:  MACRO5(VRELBYTE,506B%HRLM\,FAC,INDEXR,DPLMT);
77000			  HWORDR:  MACRO5(VRELBYTE,542B%HRRM\,FAC,INDEXR,DPLMT)
77100			 END  %CASE\ ;
77200		       END %WITH\ ;
77300		   END %STORE\ ;
77400	
77500	{Warning to future modifiers: At the end of EXPRESSION, there is code that
77600	 second-guesses the register allocation in this procedure.  If you change
77700	 the register allocation here, please look at that code.}
77800		  PROCEDURE LOADADDRESS;
77900		   BEGIN
78000		    INCREMENTREGC ;
78100		     BEGIN
78200		      WITH GATTR DO
78300		       IF TYPTR # NIL
78400		       THEN
78500			 BEGIN
78600			   CASE KIND OF
78700			    CST:
78800				 IF STRING(TYPTR)
     
00100				 THEN
00200				   BEGIN
00300				    MACRO3(201B%MOVEI\,REGC,0);
00400				    DEPCST(STRG,GATTR)
00500				   END
00600				 ELSE ERROR(171);
00700			    VARBL:
00800				   BEGIN
00900				     IF (INDEXR>REGIN)	AND  (INDEXR <= REGCMAX)
01000				     THEN REGC := INDEXR;
01100				    FETCHBASIS(GATTR);
01200				     CASE PACKFG OF
01300				      NOTPACK: MACRO(VRELBYTE,201B%MOVEI\,REGC,INDBIT,INDEXR,DPLMT);
01400				      PACKK,HWORDL,HWORDR: ERROR(357)
01500				     END;
01600				   END;
01700			    EXPR:  ERROR(171)
01800			   END;
01900			  KIND := VARBL;  DPLMT := 0; INDEXR:=REGC; INDBIT:=0; VRELBYTE := NO
02000			 END
02100		     END
02200		   END %LOADADDRESS\ ;
02300	
02400		  PROCEDURE WRITEMC(WRITEFLAG:WRITEFORM);
02500		  CONST
02600	(* 155 *)
02700		    MAXSIZE %OF CONSTANT-, STRUCTURE-, AND ID.-RECORD\ = 44 %WORDS\ ;
02800		  TYPE
02900		    WANDELFORM=(KONSTANTE,PDP10CODE,REALCST,STRCST,SIXBITCST,HALFWD,PDP10BP,RADIX) ;
03000		    RECORDFORM=(NONE,CONSTNTREC,STRUCTUREREC,IDENTIFREC,DEBUGREC);
03100		    BIGALFA = PACKED ARRAY[1..15] OF CHAR ;
03200		  VAR
03300		    I,J,L  : INTEGER; LLISTCODE: BOOLEAN; CHECKER: CTP;
03400		    LIC  : ADDRRANGE; LFIRSTKONST: KSP; LRELBYTE: RELBYTE;
03500		    STRING: ARRAY[1..6] OF CHAR; LFILEPTR: FTP; SWITCHFLAG: FLAGRANGE;
03600		    FILBLOCKADR : ADDRRANGE ; CODEARRAY: BOOLEAN; LICMOD4: ADDRRANGE;
03700		    LSIZE: 1..MAXSIZE; RUN1: BOOLEAN; SAVELISTCODE: BOOLEAN;
03800		    CSP0: CSP; %INSTEAD OF NIL\
03900		    RELARRAY, RELEMPTY: ARRAY[1..MAXSIZE] OF RELBYTE;
04000		    WANDLUNG : PACKED RECORD
04100					CASE WANDELFORM  OF
04200					     KONSTANTE:(WKONST :INTEGER);
04300					     PDP10CODE:(WINSTR :PDP10INSTR);
04400					     REALCST  :(WREAL: REAL);
04500					     STRCST   :(WSTRING:CHARWORD);
04600					     SIXBITCST:(WSIXBIT:PACKED ARRAY[1..6] OF 0..77B);
04700					     HALFWD   :(WLEFTHALF:ADDRRANGE ; WRIGHTHALF : ADDRRANGE);
04800					     PDP10BP  :(WBYTE: BPOINTER);
04900					     RADIX    :(FLAG: FLAGRANGE; SYMBOL: RADIXRANGE)
05000	
05100				      END;
05200		    ICWANDEL: PACKED RECORD
05300				       CASE VARIANTE:INTEGER OF
05400					    1:(ICVAL: ADDRRANGE);
05500					    2:(ICCSP: CSP);
05600					    3:(ICCTP: CTP);
05700					    4:(ICSTP: STP)
05800				     END;
05900		    RECORDWANDEL: PACKED RECORD
06000					   CASE RECORDFORM OF
06100						NONE:  (WORD:ARRAY[1..MAXSIZE] OF INTEGER);
06200						CONSTNTREC:(CONSTREC: CONSTNT);
06300						STRUCTUREREC:(STRUCTREC: STRUCTURE);
06400						IDENTIFREC:(IDENTREC: IDENTIFIER);
06500						DEBUGREC:(DEBUGREC: DEBENTRY)
06600					 END;
06700	
06800		    PROCEDURE NEUEZEILE;
06900		     BEGIN
07000	(* 6 - if CREFing, less stuff fits on a line *)
07100		      IF CREF
07200			THEN LICMOD4 := LIC MOD 3
07300			ELSE LICMOD4 := LIC MOD 4;
07400		       IF (LICMOD4 = 0) AND LISTCODE AND (LIC > 0)
07500		       THEN
07600			 BEGIN
07700	(* 136 - LISTING FORMAT *)
07800			  newline ;
07900			   IF RELBLOCK.ITEM = 1
08000			   THEN
08100			     BEGIN
08200			      WRITE(LIC:6:O);
08300			       IF LIC >= PROGRST
08400			       THEN WRITE('''')
08500			       ELSE WRITE(' ')
08600			     END
08700			   ELSE WRITE(' ':7)
08800			 END
08900		     END %NEUEZEILE\ ;
09000	
09100		    PROCEDURE PUTRELCODE;
09200		    VAR
09300		      I: INTEGER;
09400	
09500		     BEGIN
09600		      WITH RELBLOCK DO
09700	(* 146 - Move count := 0 outside the test, since we must zero count in
09800	   the case where COUNT = 1 and ITEM = 1. *)
09900		       BEGIN
10000		       IF ((COUNT > 1) OR (ITEM # 1)) AND (COUNT > 0)
10100		       THEN
10200			 BEGIN
10300			  FOR I:= COUNT+1 TO 18 DO RELOCATOR[I-1] := NO;
10400			  FOR I:= 1 TO COUNT+2 DO
10500			   BEGIN
10600			    OUTPUTREL^:= COMPONENT[I];
10700			    PUT(OUTPUTREL)
10800			   END;
10900			 END;
11000	(* 146 *)
11100		       COUNT := 0;
11200		       END;
11300		     END;
11400	
11500		    PROCEDURE SHOWRELOCATION(FSIDE: RELBYTE; FRELBYTE: RELBYTE);
11600		     BEGIN
11700		       IF (FRELBYTE = FSIDE) OR (FRELBYTE = BOTH)
11800		       THEN WRITE('''')
11900		       ELSE WRITE(' ')
12000		     END;
12100	
12200		    PROCEDURE WRITEBLOCKST( FITEM: ADDRRANGE);
12300		    VAR
12400		      WANDLUNG: PACKED RECORD
12500					 CASE BOOLEAN OF
12600					      TRUE: (WKONST: INTEGER);
12700					      FALSE: (WLEFTHALF: ADDRRANGE;WRIGHTHALF: ADDRRANGE)
12800				       END;
12900		     BEGIN
13000		      WITH RELBLOCK , WANDLUNG DO
13100		       BEGIN
13200			 IF COUNT # 0
13300			 THEN PUTRELCODE;
13400			ITEM:= FITEM;
13500			 IF ITEM = 1
13600			 THEN
13700			   BEGIN
13800			    WLEFTHALF:= 0;
13900			    WRIGHTHALF:= LIC;
14000			    CODE[0]:= WKONST;
14100			     IF WRIGHTHALF < PROGRST
14200			     THEN RELOCATOR[0] := NO
14300			     ELSE RELOCATOR[0] := RIGHT;
14400			    COUNT:= 1
14500			   END
14600		       END
14700		     END;
14800	
14900		    PROCEDURE WRITEWORD(FRELBYTE: RELBYTE; FWORD: INTEGER);
15000		    VAR
15100		      WANDLUNG: PACKED RECORD
15200					 CASE BOOLEAN OF
15300					      TRUE: (WKONST: INTEGER);
15400					      FALSE: (WLEFTHALF: ADDRRANGE; WRIGHTHALF: ADDRRANGE)
15500				       END;
15600		     BEGIN
15700		      WITH WANDLUNG DO
15800		       BEGIN
15900			WKONST := FWORD;
16000			WITH RELBLOCK DO
16100			 BEGIN
16200			   IF COUNT = 0
16300			   THEN WRITEBLOCKST(ITEM);
16400			  CODE[COUNT]:= FWORD;
16500			   IF FRELBYTE IN [LEFT,BOTH]
16600			   THEN
16700			     IF (WLEFTHALF < PROGRST) OR (WLEFTHALF = 377777B)
16800			     THEN FRELBYTE := FRELBYTE - LEFT;
16900			   IF FRELBYTE IN [RIGHT,BOTH]
17000			   THEN
17100			     IF (WRIGHTHALF < PROGRST) OR (WRIGHTHALF = 377777B)
17200			     THEN FRELBYTE := FRELBYTE - RIGHT;
17300			  RELOCATOR[COUNT]:= FRELBYTE; LRELBYTE := FRELBYTE;
17400			  COUNT := COUNT+1;
17500			   IF COUNT = 18
17600			   THEN PUTRELCODE
17700			 END;
17800			 IF LLISTCODE
17900			 THEN
18000			   BEGIN
18100			    NEUEZEILE;
18200			     IF LIC > 0
18300			     THEN WRITE(' ':13);
18400	(* 173 - remove writefileblocks *)
18500			     IF WRITEFLAG > WRITELIBRARY
18600			     THEN WRITE(' ':7)
18700			     ELSE
18800			       BEGIN
18900				WRITE(WLEFTHALF:6:O); SHOWRELOCATION(LEFT,FRELBYTE)
19000			       END;
19100			    WRITE(WRIGHTHALF:6:O); SHOWRELOCATION(RIGHT,FRELBYTE); WRITE(' ':3)
19200			   END;
19300			 IF NOT CODEARRAY
19400			 THEN LIC := LIC + 1
19500		       END
19600		     END;
19700	
19800		    FUNCTION RADIX50( FNAME: ALFA): RADIXRANGE;
19900		    VAR
20000		      I: INTEGER; OCTALCODE, RADIXVALUE: RADIXRANGE;
20100	
20200		     BEGIN
20300		      RADIXVALUE:= 0;
20400		      I:=1;
20500		      WHILE (FNAME[I] # ' ') AND (I <= 6) DO
20600		       BEGIN
20700			 IF FNAME[I] IN DIGITS
20800			 THEN OCTALCODE:= ORD(FNAME[I])-ORD('0')+1
20900			 ELSE
21000			   IF FNAME[I] IN LETTERS
21100			   THEN OCTALCODE:= ORD(FNAME[I])-ORD('A')+11
21200			   ELSE
21300			     CASE FNAME[I] OF
21400			      '.': OCTALCODE:= 37;
21500			      '$': OCTALCODE:= 38;
21600			      '%': OCTALCODE:= 39
21700			     END;
21800			RADIXVALUE:= RADIXVALUE*50B; RADIXVALUE:= RADIXVALUE+OCTALCODE; I:=I+1
21900		       END;
22000		      RADIX50:= RADIXVALUE
22100		     END;
22200	
22300		    PROCEDURE WRITEPAIR( FRELBYTE: RELBYTE; FADDR1, FADDR2: ADDRRANGE);
22400		     BEGIN
22500		      WITH WANDLUNG DO
22600		       BEGIN
22700			WLEFTHALF:= FADDR1;
22800			WRIGHTHALF:= FADDR2;
22900			WRITEWORD(FRELBYTE,WKONST)
23000		       END
23100		     END;
23200	
23300		    PROCEDURE WRITEIDENTIFIER( FFLAG: FLAGRANGE; FSYMBOL: ALFA);
23400		     BEGIN
23500		      LLISTCODE := FALSE;
23600		      WITH WANDLUNG DO
23700		       BEGIN
23800			 IF LISTCODE AND (WRITEFLAG > WRITEHISEG)
23900			 THEN
24000			   BEGIN
24100	(* 40 - if CREFing, less stuff fits on a line *)
24200			     IF ((NOT CREF) AND (LIC MOD 4 = 0) OR
24300				 CREF AND (LIC MOD 3 = 0)) AND (LIC > 0)
24400			     THEN
24500			       BEGIN
24600	(* 136 - LISTING FORMAT *)
24700				NEWLINE;
24800				WRITE(' ':7)
24900			       END;
25000			     IF LIC > 0
25100			     THEN WRITE(' ':13); WRITE(FSYMBOL:6,' ':11)
25200			   END;
25300	(* 40 - print format *)
25400			 if listcode and cref then lic := lic+1;
25500			 IF FFLAG # 6B
25600			 THEN
25700			   BEGIN
25800			    FLAG:= FFLAG; SYMBOL:= RADIX50(FSYMBOL)
25900			   END;
26000			WRITEWORD(NO,WKONST); LLISTCODE := LISTCODE
26100		       END
26200		     END;
26300	
26400		    PROCEDURE WRITEFIRSTLINE ;
26500		     BEGIN
26600		       IF LISTCODE
26700		       THEN
26800			 BEGIN
26900	(* 136 - LISTING FORMAT *)
27000			  NEWLINE;
27100	(* 6 - if CREFing, less stuff fits on a line *)
27200			  IF CREF
27300			    THEN LICMOD4 := LIC MOD 3
27400			    ELSE LICMOD4 := LIC MOD 4;
27500			   IF LICMOD4 > 0
27600			   THEN
27700			     BEGIN
27800			      WRITE(LIC-LICMOD4:6:O);
27900			       IF LIC >= PROGRST
28000			       THEN WRITE('''')
28100			       ELSE WRITE(' ');
28200			      WRITE(' ':LICMOD4*30);
28300			       IF (WRITEFLAG = WRITECODE) AND CODEARRAY
28400			       THEN WRITE(' ':2)
28500			     END
28600			 END
28700		     END ;
28800	
28900		    PROCEDURE WRITEHEADER(FTEXT: BIGALFA);
29000		     BEGIN
29100		      LIC := 0;
29200		       IF LISTCODE
29300		       THEN
29400			 BEGIN
29500	(* 136 - LISTING FORMAT *)
29600			  NEWLINE;
29700			  WRITE(FTEXT:15,':',' ':4)
29800			 END
29900		     END;
30000	
30100	(*173 - remove writefileblocks *)
30200	
30300		    PROCEDURE MCGLOBALS;
30400		     BEGIN
30500		      %MCGLOBALS\
30600		       IF LISTCODE AND (FGLOBPTR # NIL)
30700		       THEN WRITEBUFFER;
30800		      WHILE FGLOBPTR # NIL DO
30900		      WITH FGLOBPTR^ DO
31000		       BEGIN
31100			LIC := FIRSTGLOB ; WRITEFIRSTLINE ;
31200			J := FCIX ;
31300			WRITEBLOCKST(1);
31400			FOR I := FIRSTGLOB TO LASTGLOB DO
31500			 BEGIN
31600			  WANDLUNG.WINSTR := CODE.INSTRUCTION[J] ; J := J + 1 ;
31700			  WRITEWORD(NO,WANDLUNG.WKONST) ;
31800			 END ;
31900			FGLOBPTR := NEXTGLOBPTR
32000		       END;
32100		     END %MCGLOBALS\;
32200	
32300		    PROCEDURE MCCODE;
32400	
32500		      PROCEDURE WRITERECORD;
32600		       BEGIN
32700			FOR I := 1 TO LSIZE DO WRITEWORD(RELARRAY[I], RECORDWANDEL.WORD[I] )
32800		       END;
32900	
33000	(* 211 - MAKE CONSTANTS WORK IN THE DEBUGGER *)
33100		      FUNCTION CONSTRECSIZE(FCSP: CSP): INTEGER;
33200		       BEGIN
33300			WITH FCSP^ DO
33400			 CASE CCLASS OF
33500			  INT,PSET: CONSTRECSIZE := 5;
33600			  REEL	  : CONSTRECSIZE := 4;
33700			  STRD,STRG:CONSTRECSIZE := 4 + (SLGTH+4) DIV 5
33800			 END
33900		       END;
34000	
34100		      PROCEDURE COPYCSP(FCSP:CSP);
34200		       BEGIN
34300			 IF FCSP # NIL
34400			 THEN  WITH FCSP^ DO
34500			   IF RUN1
34600			   THEN
34700			     BEGIN
34800			       IF SELFCSP = CSP0%NIL\
34900			       THEN WITH ICWANDEL DO
35000				 BEGIN
35100				  ICVAL := IC; SELFCSP := ICCSP;
35200				  NOCODE := TRUE;
35300				  IC := IC + CONSTRECSIZE(FCSP)
35400				 END
35500			     END
35600			   ELSE
35700			     IF NOCODE
35800			     THEN
35900			       BEGIN
36000				RECORDWANDEL.CONSTREC := FCSP^;
36100				LSIZE := CONSTRECSIZE(FCSP);
36200				RELARRAY := RELEMPTY;
36300				WRITERECORD; NOCODE := FALSE
36400			       END
36500		       END %COPYCSP\;
36600	
36700		      PROCEDURE COPYSTP(FSP:STP); FORWARD;
36800	
36900		      PROCEDURE COPYCTP(FCP:CTP);
37000		       BEGIN
37100			 IF FCP # NIL
37200			 THEN WITH FCP^ DO
37300			   IF RUN1 AND (SELFCTP=NIL) OR NOT RUN1 AND NOCODE
37400			   THEN
37500			     BEGIN
37600			       IF RUN1
37700			       THEN
37800				WITH ICWANDEL DO
37900				 BEGIN
38000				  ICVAL := IC;
38100				  SELFCTP := ICCTP; NOCODE := TRUE;
38200				  IC := IC + IDRECSIZE[KLASS]
38300				 END %WITH\
38400			       ELSE %NOW RUN 2\
38500				WITH RECORDWANDEL DO
38600				 BEGIN
38700				  RELARRAY := RELEMPTY;
38800				  IDENTREC := FCP^;
38900				  WITH IDENTREC DO
39000				   BEGIN
39100				     IF LLINK#NIL
39200				     THEN
39300				       BEGIN
39400					LLINK:=LLINK^.SELFCTP; RELARRAY[3] := 1
39500				       END;
39600				     IF RLINK#NIL
39700				     THEN
39800				       BEGIN
39900					RLINK:=RLINK^.SELFCTP; RELARRAY[3] := RELARRAY[3] + 2
40000				       END;
40100				     IF NEXT #NIL
40200				     THEN
40300				       BEGIN
40400					NEXT := NEXT^.SELFCTP; RELARRAY[4] := 1B
40500				       END;
40600				     IF IDTYPE # NIL
40700				     THEN
40800				       BEGIN
40900					 IF KLASS = KONST
41000					 THEN
41100					   IF IDTYPE^.FORM > POINTER
41200					   THEN
41300	(* 211 - FIX CONSTANT PRINTING *)
41400					     BEGIN
41500					     VALUES.VALP := VALUES.VALP^.SELFCSP;
41600					     RELARRAY[6] := 1B
41700					     END
41800					   ELSE
41900					     IF IDTYPE = REALPTR
42000					     THEN
42100					       BEGIN
42200						WANDLUNG.WREAL := VALUES.VALP^.RVAL;
42300						VALUES.IVAL := WANDLUNG.WKONST
42400					       END;
42500					 IF KLASS=VARS
42600					 THEN
42700					   IF VLEV<2
42800					   THEN RELARRAY[6] := 2;
42900					 IF KLASS = FIELD
43000					 THEN
43100					   IF PACKF = PACKK
43200					   THEN RELARRAY[6] := 2;
43300					IDTYPE:=IDTYPE^.SELFSTP; RELARRAY[4] := RELARRAY[4] + 2
43400				       END
43500				   END;
43600				  LSIZE := IDRECSIZE[KLASS]; WRITERECORD;
43700				  NOCODE := FALSE
43800				 END %WITH RECORDWANDEL\;
43900			      COPYCTP(LLINK);
44000			      COPYCTP(RLINK);
44100			      COPYSTP(IDTYPE);
44200	(* 214 - fix debugger problem with foward declared proc's *)
44300	{The following is somewhat of a kludge. We don't want to do COPYCTP
44400	 on the NEXT field of a procedure.  If we did, the following could
44500	 happen:
44600		procedure foo(x:integer); forward;
44700		...
44800		  foo(1);
44900		...
45000		procedure foo;
45100		  var i,j;
45200	 When the final declaration of FOO is supplied, the symbol table is
45300	 initialized from symboltable(FOO)^.NEXT, which contains the parameters,
45400	 as supplied in the forward decl.  Then I and J are added to the symbol
45500	 table.  The result is that X points to I and J in the symbol table
45600	 tree.  This is all fine.  The problem comes when the identifier
45700	 record for FOO is put into the .REL file before the final declaration.
45800	 If COPYCTP traces the NEXT field, then the identifier records for all
45900	 the parameters are also put out.  Since a given identifier is put out
46000	 only once, this means that X is put into the .REL file before pointers
46100	 to I and J are added to it.  The effect is that the debugger can't
46200	 see I and J.
46300	    It turns out that the  debugger never uses the NEXT field of a
46400	 procedure entry.  Thus it is not crucial to have a correctly mapped
46500	 value when the identifier record for the procedure is put out.
46600	 If we don't call COPYCTP on NEXT, then the NEXT field put into the
46700	 .REL file will be junk, but at least records for the parameters won't
46800	 be put out prematurely.  They will get put out eventually even without
46900	 tracing NEXT, since they will show up in the symbol table for the
47000	 procedure when it is finally declared.  That should suffice.}
47100	
47200			      IF NOT (KLASS IN [PROC,FUNC])
47300			        THEN COPYCTP(NEXT);
47400			       IF (KLASS = KONST)  AND (IDTYPE # NIL)
47500			       THEN
47600				 IF IDTYPE^.FORM > POINTER
47700				 THEN COPYCSP(VALUES.VALP)
47800			     END %WITH FCP^\
47900		       END %COPYCTP\;
48000	
48100		      PROCEDURE COPYSTP;
48200		       BEGIN
48300			 IF FSP # NIL
48400			 THEN WITH FSP^ DO
48500			   IF RUN1 AND (SELFSTP = NIL)	OR  NOT RUN1 AND NOCODE
48600			   THEN
48700			     BEGIN
48800			       IF RUN1
48900			       THEN
49000				WITH ICWANDEL DO
49100				 BEGIN
49200				  NOCODE:=TRUE;
49300				  ICVAL := IC; SELFSTP := ICSTP;
49400				  IC := IC + STRECSIZE[FORM]
49500				 END
49600			       ELSE %NOW RUN 2\
49700				 IF NOCODE
49800				 THEN WITH RECORDWANDEL DO
49900				   BEGIN
50000				    RELARRAY := RELEMPTY; RELARRAY[2] := 1;
50100				    STRUCTREC := FSP^;
50200				    WITH STRUCTREC DO
50300				     CASE FORM OF
50400				      SCALAR:
50500					      IF SCALKIND = DECLARED
50600					      THEN
50700						IF FCONST#NIL
50800						THEN FCONST:=FCONST^.SELFCTP;
50900				      SUBRANGE:
51000						BEGIN
     
00100						 RANGETYPE:=RANGETYPE^.SELFSTP; RELARRAY[2]:=1
00200						END;
00300				      POINTER:
00400					       IF ELTYPE # NIL
00500					       THEN ELTYPE := ELTYPE^.SELFSTP;
00600				      POWER:	ELSET := ELSET^.SELFSTP;
00700				      ARRAYS:
00800					      BEGIN
00900	(* 122 - DON'T FOLLOW NILS ON FUDGED TYPES *)
01000					      IF AELTYPE#NIL
01100					        THEN AELTYPE := AELTYPE^.SELFSTP;
01200					      IF INXTYPE#NIL
01300						THEN INXTYPE := INXTYPE^.SELFSTP; 
01400					      RELARRAY[3] := 3
01500					      END;
01600				      RECORDS:
01700					       BEGIN
01800						 IF FSTFLD # NIL
01900						 THEN FSTFLD := FSTFLD^.SELFCTP;
02000						 IF RECVAR # NIL
02100						 THEN
02200						   BEGIN
02300						    RECVAR := RECVAR^.SELFSTP; RELARRAY[3] := 2
02400						   END
02500					       END;
02600				      FILES:	IF FILTYPE # NIL 
02700						  THEN FILTYPE := FILTYPE^.SELFSTP;
02800				      TAGFWITHID,
02900				      TAGFWITHOUTID:
03000						     BEGIN
03100						      FSTVAR := FSTVAR^.SELFSTP;
03200						       IF FORM = TAGFWITHID
03300						       THEN TAGFIELDP := TAGFIELDP^.SELFCTP
03400						       ELSE TAGFIELDTYPE := TAGFIELDTYPE^.SELFSTP;
03500						      RELARRAY[3] := 2
03600						     END;
03700				      VARIANT:
03800					       BEGIN
03900						 IF SUBVAR # NIL
04000						 THEN SUBVAR := SUBVAR^.SELFSTP;
04100						 IF FIRSTFIELD # NIL
04200						 THEN
04300						   BEGIN
04400						    FIRSTFIELD := FIRSTFIELD^.SELFCTP; RELARRAY[3]:=1
04500						   END;
04600						 IF NXTVAR # NIL
04700						 THEN
04800						   BEGIN
04900						    NXTVAR := NXTVAR^.SELFSTP; RELARRAY[3] :=RELARRAY[3] + 2
05000						   END;
05100					       END
05200				     END %CASE\;
05300				    LSIZE := STRECSIZE[FORM]; WRITERECORD;
05400				    NOCODE := FALSE
05500				   END %RUN 2\;
05600			       CASE FORM OF
05700				SCALAR:
05800					IF SCALKIND = DECLARED
05900					THEN COPYCTP(FCONST);
06000				SUBRANGE:COPYSTP(RANGETYPE);
06100				POINTER: COPYSTP(ELTYPE);
06200				POWER:	 COPYSTP(ELSET);
06300				ARRAYS:
06400					BEGIN
06500					 COPYSTP(AELTYPE);
06600					 COPYSTP(INXTYPE)
06700					END;
06800				RECORDS:
06900					 BEGIN
07000					  COPYCTP(FSTFLD);
07100					  COPYSTP(RECVAR)
07200					 END;
07300				FILES:	 COPYSTP(FILTYPE);
07400				TAGFWITHID,
07500				TAGFWITHOUTID:
07600					       BEGIN
07700						COPYSTP(FSTVAR);
07800						 IF FORM = TAGFWITHID
07900						 THEN COPYCTP(TAGFIELDP)
08000						 ELSE COPYSTP(TAGFIELDTYPE)
08100					       END;
08200				VARIANT:
08300					 BEGIN
08400					  COPYSTP(NXTVAR);
08500					  COPYSTP(SUBVAR);
08600					  COPYCTP(FIRSTFIELD)
08700					 END
08800			       END %CASE\
08900			     END %WITH\
09000		       END %COPYSTP\;
09100	
09200		     BEGIN
09300		      %MCCODE\
09400		      CODEARRAY := FALSE; LLISTCODE:= FALSE;
09500		       IF LISTCODE
09600		       THEN WRITEBUFFER;
09700		       IF LASTBTP # NIL
09800		       THEN
09900			WITH LASTBTP^ DO
10000			 CASE BKIND OF
10100			  RECORDD:  LIC := FIELDCP^.FLDADDR ;
10200			  ARRAYY :  LIC := ARRAYSP^.ARRAYBPADDR
10300			 END ;
10400		      WRITEFIRSTLINE ; WRITEBLOCKST(1);
10500		      WHILE LASTBTP # NIL DO
10600		       BEGIN
10700			WITH  LASTBTP^,BYTE  DO
10800			 BEGIN
10900			   IF LISTCODE
11000			   THEN
11100			     BEGIN
11200			      NEUEZEILE;
11300			       IF LICMOD4 = 0
11400			       THEN WRITE(' ':7)
11500			       ELSE WRITE(' ':5);
11600			      WRITE(' POINT  ',SBITS:2,',') ;
11700			       IF IBIT = 0
11800			       THEN WRITE('  ')
11900			       ELSE WRITE(' @') ;
12000			      WRITE(RELADDR:5:O,'(',IREG:2:O,'),',35-PBITS:2) ;
12100			     END;
12200			  WITH WANDLUNG DO
12300			   BEGIN
12400			    WBYTE := BYTE;
12500			    WRITEWORD(NO,WKONST)
12600			   END;
12700			  LASTBTP := LAST
12800			 END
12900		       END % WHILE\ ;
13000		      LIC := CODEEND - CIX - 1 ; CODEARRAY := TRUE;
13100		      WRITEBLOCKST(1); WRITEFIRSTLINE;
13200		      FOR  I := 0 TO  CIX  DO
13300		      WITH CODE, INSTRUCTION[I], HALFWORD[I] DO
13400		       BEGIN
13500			LRELBYTE := RELOCATION[I]; WRITEWORD(LRELBYTE,WORD[I]);
13600			 IF LISTCODE
13700			 THEN
13800			   BEGIN
13900			    NEUEZEILE;
14000			     IF LICMOD4 = 0
14100			     THEN WRITE(' ':7)
14200			     ELSE WRITE(' ':5);
14300			     CASE INFORMATION[I] OF
14400			      'W':
14500				   BEGIN
14600				    WRITE(' ':6,LEFTHALF :6:O); SHOWRELOCATION(LEFT,LRELBYTE);
14700				    WRITE(RIGHTHALF:6:O); SHOWRELOCATION(RIGHT,LRELBYTE);
14800				    WRITE(' ':5)
14900				   END;
15000				  %'B': WITH WANDLUNG.WBYTE DO
15100				   BEGIN
15200				   WANDLUNG.WKONST := WORD[I];
15300				   WRITE(' POINT  ',SBITS:2,',');
15400				   IF IBIT = 0 THEN WRITE('  ') ELSE WRITE(' @');
15500				   WRITE(RELADDR:5:O,'(',IREG:2:O,'),',35-PBITS:2)
15600				   END;\
15700			      OTHERS:
15800				      BEGIN
15900	(* 6 - UNPACK CAN'T DO THIS NOW *)
16000				       %UNPACK(MNEMONICS[(INSTR+9) DIV 10],((INSTR+9) MOD 10)*6+1,STRING,6);\
16100				       FOR J := 1 TO 6 DO
16200					STRING[J] := MNEMONICS[(INSTR+9) DIV 10, ((INSTR+9) MOD 10)*6 + J];
16300				       WRITE(' ',STRING:6, ' ',AC:2:O,', ');
16400					IF INDBIT = 0
16500					THEN WRITE(' ')
16600					ELSE WRITE('@');
16700				       WRITE(ADDRESS:6:O); SHOWRELOCATION(RIGHT,LRELBYTE);
16800					IF INXREG > 0
16900					THEN WRITE('(',INXREG:2:O,')',INFORMATION[I]:1)
17000					ELSE WRITE(' ':4,INFORMATION[I]:1)
17100				      END
17200			     END
17300			   END;
17400			LIC := LIC + 1
17500		       END  %FOR \ ;
17600		      CODEARRAY := FALSE; LLISTCODE := LISTCODE;
17700		       IF FIRSTKONST # NIL
17800		       THEN
17900			 BEGIN
18000			  LFIRSTKONST := FIRSTKONST; WRITEFIRSTLINE; WRITEBLOCKST(1);
18100			  WHILE LFIRSTKONST # NIL DO
18200			   BEGIN
18300			    WITH LFIRSTKONST^.CONSTPTR^ DO
18400			     CASE  CCLASS  OF
18500			      INT,
18600			      REEL: WRITEWORD(NO,INTVAL) ;
18700			      PSET:
18800				    BEGIN
18900				     % THE SET IS PICKED UP
19000				      AND WRITTEN OUT AS TWO OCTAL NUMBERS \
19100				     WRITEWORD(NO,INTVAL) ;
19200				     WRITEWORD(NO,INTVAL1) ;
19300				    END ;
19400			      STRD,
19500			      STRG: WITH WANDLUNG DO
19600				    BEGIN
19700				     J :=0; WKONST := 0;
19800				     FOR I := 1 TO SLGTH DO
19900				      BEGIN
20000				       J := J+1;
20100				       WSTRING[J] := SVAL[I];
20200					IF J=5
20300					THEN
20400					  BEGIN
20500					   J := 0;
20600					   WRITEWORD(NO,WKONST);
20700					   WKONST := 0
20800					  END
20900				      END;
21000				      IF J#0
21100				      THEN
21200				       WRITEWORD(NO,WKONST)
21300				    END
21400			     END;
21500			    LFIRSTKONST := LFIRSTKONST^.NEXTKONST
21600			   END	%WHILE\
21700			 END;
21800		       IF DEBUG
21900		       THEN
22000			 BEGIN
22100			   IF DEBUGSWITCH
22200			   THEN
22300			     BEGIN
22400	(* 103 - globalidtree moved below *)
22500			      WRITEFIRSTLINE;
22600			      FOR RUN1 := TRUE DOWNTO FALSE DO COPYCTP(DISPLAY[TOP].FNAME);
22700			       IF LEVEL = 1
22800			       THEN
22900				 BEGIN
23000	(* 103 - new way to set globalidtree and standardidtree *)
23100				  FOR RUN1 := TRUE DOWNTO FALSE DO COPYCTP(DISPLAY[0].FNAME);
23200				  if display[top].fname = nil
23300				    then debugentry.globalidtree := nil
23400				    else debugentry.globalidtree := display[top].fname^.selfctp;
23500				  debugentry.standardidtree := display[0].fname^.selfctp;
23600				 END;
23700			     END %DEBUGSWITCH\;
23800			   IF LEVEL = 1
23900			   THEN
24000			     BEGIN
24100			      WITH DEBUGENTRY DO
24200			       BEGIN
24300				NEWPAGER; LASTPAGEELEM := PAGER;
24400				INTPOINT  := INTPTR^. SELFSTP;
24500				REALPOINT := REALPTR^.SELFSTP;
24600				CHARPOINT := CHARPTR^.SELFSTP;
24700	(* 36 - ALLOW MULTIPLE MODULES *)
24800				NEXTDEB := 0; %LINK WILL MAKE THIS PTR TO SIMILAR ENTRY IN NEXT MODULE\
24900				MODNAME := FILENAME;
25000			       CURNAME(INPUT,SOURCE);
25100			       END;
25200			      PAGEHEADADR := IC;
25300			      LSIZE := 44; %LENGTH OF DEBUGENTRY-RECORD\
25400			      RELARRAY[1] := 0;
25500			      FOR I:=2 TO 8 DO RELARRAY[I] := 1;
25600			      FOR I:= 9 TO LSIZE DO RELARRAY[I] := 0;
25700			      RECORDWANDEL.DEBUGREC := DEBUGENTRY;
25800			      IC := IC + LSIZE;
25900			      WRITERECORD;
26000			      HIGHESTCODE := IC;
26100	(* 40 - fix printing format *)
26200	(* 136 - LISTING FORMAT *)
26300			      if listcode then NEWLINE;
26400			      WRITEHEADER('LINK IN CHAIN 1');
26500			      LLISTCODE := FALSE;
26600			      WRITEBLOCKST(12B); %LINK BLOCK\
26700			      WRITEPAIR(NO,0,1); %LINK NUMBER 1\
26800			      LLISTCODE := LISTCODE;
26900			      WRITEPAIR(RIGHT,0,PAGEHEADADR); %NEXTDEB FIELD\
27000	(* NB: LOCATION 141/2 ARE NOW HANDLED BY DEBSUP. 143 GETS .LNKEND FOR THE
27100	      LINK SET UP ABOVE *)
27200			     END;
27300	(* 5 - CREF *)
27400			 END;
27500	(* 136 - LISTING FORMAT *)
27600		     IF LISTCODE THEN NEWLINE;
27700		     END %MCCODE\;
27800	
27900		    PROCEDURE MCVARIOUS;
28000		    VAR
28100	(* 17 - MAKE SYMBOLS ACCEPTABLE TO DEC DDT *)
28200		      INLEVEL: BOOLEAN; PNAME:ALFA;
28300		     BEGIN
28400		      %MCVARIOUS\
28500		       CASE WRITEFLAG OF
28600	
28700	(* 13 - ADD WRITEBLOCK FOR DDT SYMBOLS *)
28800	(* 16 - MAKE ACCEPTABLE TO DEC DDT *)
28900			WRITEBLK:
29000					BEGIN
29100					PNAME := DISPLAY[TOP].BLKNAME;
29200	(* 40 - fix print format *)
29300				        WRITEHEADER('LOCAL SYMBOLS  ');
29400					WRITEBLOCKST(2);
29500					WRITEIDENTIFIER(2B,PNAME);
29600					WRITEPAIR(RIGHT,0,PFSTART);
29700					I:=5;
29800					WHILE PNAME[I]=' ' DO I:=I-1;
29900					IF PFDISP#PFSTART
30000					 THEN BEGIN
30100					 PNAME[I+1]:='.';
30200					 WRITEIDENTIFIER(2B,PNAME);
30300					 WRITEPAIR(RIGHT,0,PFDISP)
30400					 END;
30500					IF PFPOINT#PFDISP
30600					 THEN BEGIN
30700					 PNAME[I+1]:='%';
30800					 WRITEIDENTIFIER(2B,PNAME);
30900					 WRITEPAIR(RIGHT,0,PFPOINT)
31000					 END
31100					END;
31200	(* 164 - add Polish fixups *)
31300			WRITEPOLISH:
31400					BEGIN
31500					WRITEHEADER('POLISH FIXUPS  ');
31600					WHILE FIRSTPOL <> NIL DO
31700					  WITH FIRSTPOL^ DO
31800					    BEGIN
31900	{A Polish fixup block looks like this:
32000	   type 11
32100	   operator,,0		0 means next half word is operand
32200	   operand1,,0
32300	   operand2,,-1		-1 means put in RH of result addr
32400	   place to put result,,0
32500	}
32600					    WRITEBLOCKST(11B);
32700					    IF OFFSET < 0
32800					      THEN WRITEPAIR(NO,4,0)  {4 - SUB}
32900					      ELSE WRITEPAIR(NO,3,0); {3 - ADD}
33000					    WRITEPAIR(LEFT,BASE,0);
33100					    WRITEPAIR(NO,ABS(OFFSET),777777B);
33200					    WRITEPAIR(LEFT,WHERE,0);
33300					    PUTRELCODE;
33400					    FIRSTPOL := NEXTPOL;  {CDR down list}
33500					    END;
33600					if cref and listcode then NEWLINE;
33700					END;
33800					    
33900			WRITEINTERNALS:
34000					BEGIN
34100					 WRITEHEADER('LOCAL REQUESTS '); INLEVEL := TRUE;
34200					 WRITEBLOCKST(8); CHECKER := LOCALPFPTR;
34300					 WHILE (CHECKER # NIL) AND INLEVEL DO
34400					 WITH CHECKER^ DO
34500					  IF PFLEV = LEVEL
34600					  THEN
34700					    BEGIN
34800					      IF PFADDR # 0
34900					      THEN
35000					       FOR I := 0 TO MAXLEVEL DO
35100						IF LINKCHAIN[I] # 0
35200						THEN WRITEPAIR(BOTH,LINKCHAIN[I],PFADDR-I);
35300					     CHECKER:= PFCHAIN
35400					    END
35500					  ELSE INLEVEL := FALSE;
35600					  IF LEVEL > 1
35700					  THEN LOCALPFPTR := CHECKER;
35800					 WHILE FIRSTKONST # NIL DO
35900					 WITH FIRSTKONST^, CONSTPTR^ DO
36000					  BEGIN
36100					   WRITEPAIR(BOTH,ADDR,KADDR);
36200	(* 72 - two fixup chains for 2 word consts *)
36300					    IF (CCLASS IN [PSET,STRD]) AND (ADDR1 <> 0)
36400					    THEN WRITEPAIR(BOTH,ADDR1,KADDR+1);
36500					   FIRSTKONST:= NEXTKONST
36600					  END;
36700	(* 64 - non-local gotos *)
36800					inlevel := true;
36900					while (lastlabel # nil) and inlevel do
37000					  with lastlabel^ do
37100					    if scope = level
37200					      then begin
37300					      if gotochain # 0
37400						then if labeladdress = 0
37500						  then errorwithtext(215,name)
37600						  else writepair(both,gotochain,labeladdress);
37700					      lastlabel := next
37800					      end
37900					     else inlevel := false;
38000	(* 40 - print format *)
38100	(* 136 - LISTING FORMAT *)
38200					if cref and listcode then NEWLINE;
38300					END;
38400			WRITEEND:
38500				  BEGIN
38600				   WRITEHEADER('HIGHSEG-BREAK  ');
38700				   WRITEBLOCKST(5);
38800				   WRITEPAIR(RIGHT,0,HIGHESTCODE);
38900				   WRITEHEADER('LOWSEG-BREAK   ');
39000				   WRITEPAIR(RIGHT,0,LCMAIN); PUTRELCODE
39100				  END;
39200	
39300			WRITESTART:
39400				    IF MAIN
39500				    THEN
39600				      BEGIN
39700	(* 33 - VERSION NO. *)
39800					WRITEHEADER('VERSION NUMBER ');
39900					LIC := 137B;
40000	(* 40 - fix print format *)
40100					WRITEBLOCKST(1);
40200				  	if listcode then with version do
40300					  write('    ',who:1:o,'  ',major:3:o,'  ',minor:2:o,'  ',edit:6:o);
40400					llistcode := false;
40500					WRITEWORD(NO,VERSION.WORD);
40600					llistcode := listcode;
40700				       WRITEHEADER('STARTADDRESS   ');
40800				       WRITEBLOCKST(7);
40900				       WRITEPAIR(RIGHT,0,STARTADDR)
41000				      END;
41100	
41200			WRITEENTRY:
41300				    BEGIN
41400				     WRITEBLOCKST(4);
41500	(* 34 - USE LIST OF ENTRIES IN PROGRAM IF APPROPRIATE *)
41600				     IF MAIN OR (FPROGFILE = NIL)
41700				       THEN WRITEIDENTIFIER(0,FILENAME)
41800				       ELSE
41900					 BEGIN
42000					 NPROGFILE := FPROGFILE;
42100					 WHILE NPROGFILE # NIL DO
42200					   BEGIN
42300					   WRITEIDENTIFIER(0,NPROGFILE^.FILID);
42400					   NPROGFILE := NPROGFILE^.NEXT
42500					   END
42600					 END
42700				    END;
42800	
42900			WRITENAME:
43000				   BEGIN
43100				    WRITEBLOCKST(6);
43200				    WRITEIDENTIFIER(0,FILENAME)
43300				   END;
43400	
43500			WRITEHISEG:
43600				    BEGIN
43700				     LLISTCODE := FALSE;
43800				     WRITEBLOCKST(3);
43900				     WRITEPAIR(NO,400000B,400000B);
44000				    END
44100		       END %CASE\
44200		     END %MCVARIOUS\ ;
44300	
44400		    PROCEDURE MCSYMBOLS;
44500		    VAR
44600		      ENTRYFOUND: BOOLEAN; POLHEADERDONE:Boolean; chan:integer;
44700		     BEGIN
44800		      %MCSYMBOLS\
44900		      WRITEHEADER('ENTRYPOINT(S)  ');
45000		      WRITEBLOCKST(2);
45100		      SAVELISTCODE := LISTCODE;
45200		      LISTCODE := FALSE;
45300		      FOR SWITCHFLAG := 1B TO 2B DO
45400		       BEGIN
45500			 IF MAIN
45600			 THEN
45700			   BEGIN
45800			    WRITEIDENTIFIER(SWITCHFLAG,FILENAME);
45900			    WRITEPAIR(RIGHT,0,STARTADDR)
46000			   END
46100			 ELSE
46200			   BEGIN
46300	(* 34 - LOOK FOR FTN=FILENAME ONLY IF NOT SPEC. IN PROGRAM STATE. *)
46400			    CHECKER := LOCALPFPTR;
46500			    IF FPROGFILE=NIL
46600			      THEN ENTRYFOUND := FALSE
46700			      ELSE ENTRYFOUND := TRUE;
46800			    WHILE CHECKER # NIL DO
46900			    WITH CHECKER^ DO
47000			     BEGIN
47100			       IF PFADDR # 0
47200			       THEN
47300				 BEGIN
47400				   IF NOT ENTRYFOUND
47500	(* 34 - USING FILENAME FOR ENTRY NOW *)
47600				   THEN ENTRYFOUND := FILENAME = NAME;
47700				  WRITEIDENTIFIER(SWITCHFLAG,NAME);
47800				  WRITEPAIR(RIGHT,0,PFADDR);
47900				   IF PFCHAIN = NIL
48000				   THEN
48100				     IF NOT ENTRYFOUND
48200				     THEN
48300				       BEGIN
48400	(* 34 - USING FILENAME FOR ENTRY NOW *)
48500					WRITEIDENTIFIER(SWITCHFLAG,FILENAME);
48600					WRITEPAIR(RIGHT,0,PFADDR)
48700				       END
48800				 END;
48900			      CHECKER:= PFCHAIN
49000			     END
49100			   END;
49200			LISTCODE := SAVELISTCODE; LIC := 0
49300		       END;
49400		       IF MAIN
49500		       THEN
49600			 BEGIN
49700			  SWITCHFLAG:= 1B; WRITEHEADER('GLOBAL SYMBOLS ');
49800	(* 16 - ADD CCL SWITCH *)
49900			  WRITEIDENTIFIER(SWITCHFLAG,'%CCLSW    ');
50000			  WRITEPAIR(RIGHT,0,CCLSW);
50100			  WRITEIDENTIFIER(SWITCHFLAG,'%RNNAM    ');
50200			  WRITEPAIR(RIGHT,0,CCLSW+1);
50300			  WRITEIDENTIFIER(SWITCHFLAG,'%RNPPN    ');
50400			  WRITEPAIR(RIGHT,0,CCLSW+2);
50500			  WRITEIDENTIFIER(SWITCHFLAG,'%RNDEV    ');
50600			  WRITEPAIR(RIGHT,0,CCLSW+3);
50700			 END
50800		       ELSE
50900			 BEGIN
51000			  SWITCHFLAG:= 14B; WRITEHEADER('GLOBAL REQUESTS')
51100			 END;
51200		      FILEPTR := SFILEPTR;
51300		      WHILE FILEPTR # NIL DO
51400		      WITH FILEPTR^, FILEIDENT^ DO
51500		       BEGIN
51600			 IF VADDR # 0
51700			 THEN
51800			   BEGIN
51900			    WRITEIDENTIFIER(SWITCHFLAG,NAME);
52000			    WRITEPAIR(RIGHT,0,VADDR)
52100			   END;
52200			FILEPTR:= NEXTFTP
52300		       END;
52400		       IF MAIN
52500		       THEN WRITEHEADER('GLOBAL REQUESTS');
52600		      CHECKER:= EXTERNPFPTR;
52700		      WHILE CHECKER # NIL DO
52800		      WITH CHECKER^ DO
52900		       BEGIN
53000			 IF LINKCHAIN[0] # 0
53100			 THEN
53200			   BEGIN
53300			     IF PFLEV = 0
53400			     THEN WRITEIDENTIFIER(14B,EXTERNALNAME)
53500			     ELSE WRITEIDENTIFIER(14B,NAME);
53600			    WRITEPAIR(RIGHT,0,LINKCHAIN[0])
53700			   END;
53800			CHECKER:= PFCHAIN
53900		       END;
54000	(* 12 - ADD EXTERNAL REF TO RUNTIMES FOR DYNAMIC CORE ALLOC *)
54100		      IF LSTNEW # 0
54200		       THEN BEGIN
54300		       WRITEIDENTIFIER(14B,'LSTNEW    ');
54400		       WRITEPAIR(RIGHT,0,LSTNEW); % GLOBAL FIXUP TO INIT. CODE\
54500		       END;
54600		      IF NEWBND # 0
54700		       THEN BEGIN
54800		       WRITEIDENTIFIER(14B,'NEWBND    ');
54900		       WRITEPAIR(RIGHT,0,NEWBND); % DITTO \
55000		       END;
55100	(* 105 - improve lower case mapping in sets *)
55200		      if setmapchain # 0
55300			then begin
55400			writeidentifier (14B,'.STCHM    ');
55500			writepair (right,0,setmapchain)
55600			end;
55700		      FOR SUPPORTIX:= SUCC(FIRSTSUPPORT) TO PRED(LASTSUPPORT) DO
55800		       IF RNTS.LINK[SUPPORTIX] # 0
55900		       THEN
56000			 BEGIN
56100			  WRITEIDENTIFIER(14B,RNTS.NAME[SUPPORTIX]);
56200			  WRITEPAIR(RIGHT,0,RNTS.LINK[SUPPORTIX])
56300			 END;
56400	(* 36 - 141 is now set up elsewhere *)
56500	{In non-main modules, if there are references to TTY^, etc., a
56600	 Polish fixup may be needed to resolve them.}
56700		      polheaderdone := false;
56800		      FILEPTR := SFILEPTR;
56900		      IF NOT MAIN THEN WHILE FILEPTR # NIL DO
57000		      WITH FILEPTR^, FILEIDENT^ DO
57100		       begin
57200		       if chantab[channel] <> 0
57300			then begin
57400			if not polheaderdone
57500			  then begin
57600			  writeheader('SYMBOLIC POLISH');
57700			  polheaderdone := true;
57800			  end;
57900	{A Polish fixup block looks like this:
58000	   type 11
58100	   operator,,2		2 means next word is global req - that is operand
58200	   operand1
58300	   0,,operand2		0 means next half word is operand
58400	   -1,,place to put	-1 means put in RH of result addr
58500	}
58600			writeblockst(11B);
58700			writepair(no,3,2);  {add}
58800			writeidentifier(0,name);
58900			writepair(no,0,filcmp);
59000			writepair(right,777777B,chantab[channel]);
59100			putrelcode;
59200			end;
59300			FILEPTR:= NEXTFTP
59400		       END;
59500		     if polheaderdone and cref and listcode then NEWLINE;
59600		     END %MCSYMBOLS\ ;
59700	
59800		    PROCEDURE MCLIBRARY;
59900		     BEGIN
60000		      %MCLIBRARY\
60100		      WRITEHEADER('LINK LIBRARIES ');
60200		      WRITEBLOCKST(15);
60300		      FOR L := 1 TO 2 DO
60400		       BEGIN
60500			FOR I := 1 TO LIBIX DO
60600			WITH LIBRARY[LIBORDER[I]] DO
60700			 IF CALLED
60800			 THEN WITH WANDLUNG DO
60900			   BEGIN
61000			    FOR J := 1 TO 6 DO WSIXBIT[J] := ORD(NAME[J]) - 40B;
61100			    WRITEIDENTIFIER(6B,NAME);
61200			    WRITEPAIR(NO,PROJNR,PROGNR);
61300			    FOR J := 1 TO 6 DO WSIXBIT[J] := ORD(DEVICE[J]) - 40B;
61400			    WRITEIDENTIFIER(6B,DEVICE); LIC := LIC + 1
61500			   END;
61600			I := 1;
61700	(* 40 - load PASLIB first *)
61800			for languageix := pascalsy to fortransy do
61900			WITH LIBRARY[LANGUAGEIX] DO
62000			 BEGIN
62100			  CALLED := (NOT INORDER AND CALLED) OR (LANGUAGEIX = PASCALSY);
62200			  LIBORDER[I] := LANGUAGEIX; I := I + 1
62300			 END;
62400			LIBIX := 2
62500		       END;
62600		     END %MCLIBRARY\;
62700	
62800		   BEGIN
62900		    %WRITEMC\
63000	(* 121 - missing initialization - fix bollixed INITPROC's *)
63100		     CODEARRAY := FALSE;
63200		     IF NOT ERRORFLAG
63300		     THEN
63400		       BEGIN
63500	(* 5 - CREF *)
63600			IF CREF AND LISTCODE
63700			  THEN WRITE(CHR(177B),'F');
63800			FOR I:=1 TO MAXSIZE DO RELEMPTY[I] := 0;
63900			WITH ICWANDEL DO
64000			 BEGIN
64100			  ICVAL := 0;
64200			  CSP0 := ICCSP
64300			 END;
64400			LLISTCODE := LISTCODE;
64500			 CASE WRITEFLAG OF
64600			  WRITEGLOBALS	 : MCGLOBALS;	 %LINK-ITEM 01B\
64700			  WRITECODE	 : MCCODE;	 %LINK-ITEM 01B\
64800			  WRITESYMBOLS	 : MCSYMBOLS;	 %LINK-ITEM 02B\
64900			  WRITEBLK,			 %LINK-ITEM 02B\
65000			  WRITEINTERNALS,		 %LINK-ITEM 10B\
65100	(* 164 - Polish fixups *)
65200			  WRITEPOLISH,			 %LINK-ITEM 11B\
65300			  WRITEENTRY,			 %LINK-ITEM 04B\
65400			  WRITEEND,			 %LINK-ITEM 05B\
65500			  WRITESTART,			 %LINK-ITEM 07B\
65600			  WRITEHISEG,			 %LINK-ITEM 03B\
65700			  WRITENAME	 : MCVARIOUS;	 %LINK-ITEM 06B\
65800			  WRITELIBRARY	 : MCLIBRARY	 %LINK-ITEM 17B\
65900			 END %CASE\;
66000			 IF LISTCODE AND (WRITEFLAG > WRITEHISEG)
66100	(* 5 - CREF *)
66200	(* 136 - LISTING FORMAT *)
66300			 THEN NEWLINE;
66400		       IF CREF AND LISTCODE
66500		         THEN WRITE(CHR(177B),'B')
66600		       END %IF ERRORFLAG\
66700		     ELSE
66800		       IF WRITEFLAG = WRITECODE
66900		       THEN LASTBTP := NIL
67000		   END %WRITEMC\;
67100	
67200		  PROCEDURE STATEMENT(FSYS,STATENDS: SETOFSYS);
67300		  TYPE
67400		    VALUEKIND = (ONREGC,ONFIXEDREGC,TRUEJMP,FALSEJMP);
67500		  VAR
67600		    LCP: CTP;	  IX,J: INTEGER;
67700	
67800		    PROCEDURE EXPRESSION(FSYS: SETOFSYS; FVALUE:VALUEKIND); FORWARD;
67900	
68000		    PROCEDURE MAKEREAL(VAR FATTR: ATTR);
68100		     BEGIN
68200		       IF FATTR.TYPTR=INTPTR
68300		       THEN
68400			 BEGIN
68500			  LOAD(FATTR);
     
00100	(* 2 - hard code FLOAT using KI-10 op code *)
00200	(* 101 - fix code generation for fltr *)
00300	(* 122 - add back KA-10 code *)
00400	(* 132 - separate KA10 into NOVM and KACPU *)
00500			  if kacpu
00600			    then begin
00700			    macro3(201B%movei\,tac,fattr.reg);
00800			    support(convertintegertoreal);
00900			    end
01000			   ELSE WITH CODE.INSTRUCTION[CIX] DO
01100			    IF (INSTR = 200B%MOVE\) AND (AC = FATTR.REG)
01200			      THEN INSTR := 127B%FLTR\
01300			      ELSE MACRO3(127B%FLTR\,FATTR.REG,FATTR.REG);
01400			  FATTR.TYPTR := REALPTR
01500			 END;
01600		       IF GATTR.TYPTR=INTPTR
01700		       THEN MAKEREAL(GATTR)
01800		     END;
01900	
02000		    PROCEDURE SELECTOR(FSYS: SETOFSYS; FCP: CTP);
02100		    VAR
02200		      LATTR: ATTR; LCP: CTP; LSP: STP;
02300		      LMIN,LMAX,INDEXVALUE,INDEXOFFSET: INTEGER;
02400		      OLDIC: ACRANGE;
02500	
02600		      PROCEDURE SUBLOWBOUND;
02700		       BEGIN
02800			 IF LMIN > 0
02900			 THEN MACRO3(275B%SUBI\,REGC,LMIN)
03000			 ELSE
03100			   IF LMIN < 0
03200			   THEN MACRO3(271B%ADDI\,REGC,-LMIN);
03300			 IF RUNTMCHECK
03400			 THEN
03500			   BEGIN
03600			    MACRO3(301B%CAIL\,REGC,0);
03700			    MACRO3(303B%CAILE\,REGC,LMAX-LMIN);
03800			    SUPPORT(INDEXERROR)
03900			   END
04000		       END;
04100	
04200		     BEGIN
04300		      WITH FCP^, GATTR DO
04400		       BEGIN
04500			TYPTR := IDTYPE; KIND := VARBL; PACKFG := NOTPACK;
04600			 CASE KLASS OF
04700			  VARS:
04800				BEGIN
04900				 VLEVEL := VLEV;  DPLMT := VADDR; INDEXR := 0;
05000				  IF VLEV > 1
05100				  THEN VRELBYTE:= NO
05200				  ELSE VRELBYTE:= RIGHT;
05300				  IF IDTYPE^.FORM = FILES
05400				  THEN LASTFILE:= FCP
05500				  ELSE LASTFILE:= NIL;
05600				  IF VKIND=ACTUAL
05700				  THEN INDBIT:=0
05800				  ELSE INDBIT:=1
05900				END;
06000			  FIELD:
06100				WITH DISPLAY[DISX] DO
06200				 IF OCCUR = CREC
06300				 THEN
06400				   BEGIN
06500				    VLEVEL := CLEV; PACKFG := PACKF; VRELBYTE:= CRELBYTE;
06600				     IF PACKFG = PACKK
06700				     THEN
06800				       BEGIN
06900					BPADDR := FLDADDR;
07000					DPLMT := CDSPL
07100				       END
07200				     ELSE DPLMT := CDSPL+FLDADDR;
07300				    INDEXR := CINDR; INDBIT:=CINDB
07400				   END
07500				 ELSE
07600				  ERROR(171);
07700			  FUNC:
07800				IF PFDECKIND = STANDARD
07900				THEN ERROR(502)
08000				ELSE
08100				  IF PFLEV = 0
08200				  THEN ERROR(502)   %EXTERNAL FCT\
08300				  ELSE
08400				    IF PFKIND = FORMAL
08500				    THEN ERROR(456)
08600	(* 31 - BE SURE WE'RE IN THE BODY OF THE FTN *)
08700				    ELSE IF (LEVEL <= PFLEV) OR (DISPLAY[PFLEV+1].BLKNAME # NAME)
08800					THEN ERROR(412)
08900				    ELSE
09000				      BEGIN
09100	(* 166 - use pflev+1 for vlevel, to allow assignment from inner function *)
09200				       VLEVEL := PFLEV + 1; VRELBYTE := NO;
09300				       DPLMT := 1;   %IMPL. RELAT. ADDR. OF FCT. RESULT\
09400				       INDEXR :=0; INDBIT :=0
09500				      END
09600			 END;
09700			%CASE\
09800		       END %WITH\;
09900		      IFERRSKIP(166,SELECTSYS OR FSYS);
10000		      WHILE SY IN SELECTSYS DO
10100		       BEGIN
10200	(* 156 - error for selector on ftn name *)
10300		       IF FCP^.KLASS = FUNC
10400			 THEN ERROR(368);
10500			%[\
10600			 IF SY = LBRACK
10700			 THEN
10800			   BEGIN
10900			     IF GATTR.INDBIT = 1
11000			     THEN GETPARADDR;
11100			    OLDIC := GATTR.INDEXR;
11200			    INDEXOFFSET := 0 ;
11300			     LOOP
11400			      LATTR := GATTR; INDEXVALUE := 0 ;
11500			      WITH LATTR DO
11600			       IF TYPTR # NIL
11700			       THEN
11800				 BEGIN
11900				   IF TYPTR^.FORM # ARRAYS
12000				   THEN
12100				     BEGIN
12200				      ERROR(307); TYPTR := NIL
12300				     END;
12400				  LSP := TYPTR
12500				 END;
12600			      INSYMBOL;
12700			      EXPRESSION(FSYS OR [COMMA,RBRACK],ONREGC);
12800			       IF  GATTR.KIND#CST
12900			       THEN  LOAD(GATTR)
13000			       ELSE  INDEXVALUE := GATTR.CVAL.IVAL ;
13100			       IF GATTR.TYPTR # NIL
13200			       THEN
13300				 IF GATTR.TYPTR^.FORM # SCALAR
13400				 THEN ERROR(403);
13500			       IF LATTR.TYPTR # NIL
13600			       THEN
13700				WITH LATTR,TYPTR^ DO
13800				 BEGIN
13900				   IF COMPTYPES(INXTYPE,GATTR.TYPTR)
14000				   THEN
14100				     BEGIN
14200				       IF INXTYPE # NIL
14300				       THEN
14400					 BEGIN
14500					  GETBOUNDS(INXTYPE,LMIN,LMAX);
14600					   IF GATTR.KIND = CST
14700					   THEN
14800					     IF (INDEXVALUE < LMIN) OR (INDEXVALUE > LMAX)
14900					     THEN ERROR(263)
15000					 END
15100				     END
15200				   ELSE ERROR(457);
15300				  TYPTR := AELTYPE ;
15400				 END ;
15500			     EXIT IF SY # COMMA;
15600			      WITH LATTR DO
15700			       IF TYPTR#NIL
15800			       THEN
15900				 IF  GATTR.KIND = CST
16000				 THEN DPLMT := DPLMT +( INDEXVALUE - LMIN ) * TYPTR^.SIZE
16100				 ELSE
16200				   BEGIN
16300				    SUBLOWBOUND;
16400				     IF TYPTR^.SIZE > 1
16500				     THEN MACRO3(221B%IMULI\,REGC,TYPTR^.SIZE);
16600				     IF OLDIC = 0
16700				     THEN OLDIC := REGC
16800				     ELSE
16900				       IF OLDIC > REGCMAX
17000				       THEN
17100					 BEGIN
17200					  MACRO3(270B%ADD\,REGC,OLDIC);
17300					  OLDIC := REGC
17400					 END
17500				       ELSE
17600					 BEGIN
17700					  MACRO3(270B%ADD\,OLDIC,REGC) ;
17800					  REGC := REGC - 1
17900					 END;
18000				    INDEXR := OLDIC
18100				   END ;
18200			      GATTR := LATTR ;
18300			     END;
18400			    %LOOP\
18500			    WITH LATTR DO
18600			     IF  TYPTR # NIL
18700			     THEN
18800			       BEGIN
18900				 IF GATTR.KIND = CST
19000				 THEN INDEXOFFSET :=  ( INDEXVALUE - LMIN ) * TYPTR^.SIZE
19100				 ELSE
19200				   BEGIN
19300				     IF (TYPTR^.SIZE > 1) OR RUNTMCHECK
19400				     THEN SUBLOWBOUND
19500				     ELSE INDEXOFFSET := -LMIN;
19600				     IF TYPTR^.SIZE > 1
19700				     THEN MACRO3(221B%IMULI\,REGC,TYPTR^.SIZE);
19800				    INDEXR := REGC ;
19900				   END ;
20000				 IF LSP^.ARRAYPF
20100				 THEN
20200				   BEGIN
20300	(* 102 - kl array code *)
20400				     if not klcpu
20500				       THEN INCREMENTREGC;
20600				     IF INDEXR=OLDIC
20700				     THEN
20800				       BEGIN
20900					INCREMENTREGC; INDEXR := 0
21000				       END;
21100	(* 102 - kl adjbp code *)
21200				    if not klcpu then begin
21300				    MACRO4(571B%HRREI\,REGC,INDEXR,INDEXOFFSET);
21400				    INCREMENTREGC;   %TEST FOR IDIVI-INSTRUCTION\
21500				    REGC := REGC-1; INDEXOFFSET := 0;
21600				    MACRO3R(200B%MOVE\,REGC-1,LSP^.ARRAYBPADDR);
21700				    MACRO3(231B%IDIVI\,REGC,BITMAX DIV LSP^.AELTYPE^.BITSIZE);
21800				    MACRO3(133B%IBP\,0,REGC-1);
21900				    MACRO3R(365B%SOJGE\,REGC+1,IC-1);
22000				    BPADDR := REGC-1;  PACKFG := PACKK; INDEXR := REGC;
22100	(* 102 - kl adjbp code *)
22200				    end
22300				     else begin (* kl code*)
22400				     macro4(571B%hrrei\,regc,indexr,indexoffset+1);
22500				     macro3r(133B%adjbp\,regc,lsp^.arraybpaddr);
22600				     bpaddr := regc; packfg := packk; indexr := 0;
22700				     indexoffset := 0;
22800				     end;
22900				   END;
23000				DPLMT := DPLMT + INDEXOFFSET ;
23100				KIND := VARBL ;
23200				 IF ( OLDIC # INDEXR )	AND  ( OLDIC # 0 )
23300				 THEN
23400				   BEGIN
23500	(* 102 - new packed array code *)
23600				   if indexr = 0
23700				     then indexr := oldic
23800				     ELSE IF OLDIC > REGCMAX
23900				     THEN  MACRO3(270B%ADD\,INDEXR,OLDIC)
24000				     ELSE
24100				       BEGIN
24200					MACRO3(270B%ADD\,OLDIC,INDEXR);
24300					REGC := REGC - 1;
24400					INDEXR := OLDIC
24500				       END
24600				   END
24700			       END %WITH.. IF TYPTR # NIL\ ;
24800			    GATTR := LATTR ;
24900			     IF SY = RBRACK
25000			     THEN INSYMBOL
25100			     ELSE ERROR(155)
25200			   END %IF SY = LBRACK\
25300			 ELSE
25400			  %.\
25500			   IF SY = PERIOD
25600			   THEN
25700			     BEGIN
25800			      WITH GATTR DO
25900			       BEGIN
26000				 IF TYPTR # NIL
26100				 THEN
26200				   IF TYPTR^.FORM # RECORDS
26300				   THEN
26400				     BEGIN
26500				      ERROR(308); TYPTR := NIL
26600				     END;
26700				 IF INDBIT=1
26800				 THEN GETPARADDR;
26900				INSYMBOL;
27000				 IF SY = IDENT
27100				 THEN
27200				   BEGIN
27300				     IF TYPTR # NIL
27400				     THEN
27500				       BEGIN
27600					SEARCHSECTION(TYPTR^.FSTFLD,LCP);
27700	(* 5 - CREF *)
27800					IF CREF
27900				          THEN WRITE(CHR(1B),CHR(21),ID,' .FIELDID. ');
28000					 IF LCP = NIL
28100					 THEN
28200					   BEGIN
28300					    ERROR(309); TYPTR := NIL
28400					   END
28500					 ELSE
28600					  WITH LCP^ DO
28700					   BEGIN
28800					    TYPTR := IDTYPE;PACKFG := PACKF;
28900					     IF PACKFG = PACKK
29000					     THEN
29100					      BPADDR := FLDADDR
29200					     ELSE
29300					      DPLMT := DPLMT + FLDADDR;
29400					   END
29500				       END;
29600				    INSYMBOL
29700				   END %SY = IDENT\
29800				 ELSE ERROR(209)
29900			       END %WITH GATTR\
30000			     END %IF SY = PERIOD\
30100			   ELSE
30200			    %^\
30300			     BEGIN
30400			       IF GATTR.TYPTR # NIL
30500			       THEN
30600				WITH GATTR,TYPTR^ DO
30700	(* 173 - changes for internal files, since we can't assume FILPTR is set up *)
30800				 IF FORM = FILES
30900				   THEN BEGIN
31000				    TYPTR := FILTYPE;
31100	{What we are trying to do here is to generate code like
31200		MOVEI 2,INPUT+FILCMP
31300	 In the usual case, we just do a loadaddress on the file, after add
31400	 filcmp to the displacement.  There are two cases where this won't
31500	 work:
31600	   - when the address is an external reference, since it then
31700		becomes an address in a fixup chain, and can't have FILCMP
31800		added to it at compile time.  Thus we have a separate
31900		fixup chain stored in CHANTAB which the loader will add
32000		FILCMP to after fixing up.
32100	   - when the thing is indirect, since we have to add the displacemtn
32200		after doing the indirection.  The only solution there is 
32300		an ADDI, as far as I can see.
32400	 Hamburg used to just do a LOAD, which works because at INPUT there
32500	 is a pointer to INPUT+FILCMP.  I can't do that because if the
32600	 FCB isn't initialized that will be garbage, and I need the real
32700	 address to do the validity check}
32800				    WITH FCP^ DO
32900				     IF (VLEV = 0) AND (NOT MAIN)
33000				      THEN BEGIN
33100				      INCREMENTREGC;
33200				      MACRO3R(201B%MOVEI\,REGC,CHANTAB[CHANNEL]);
33300				      CHANTAB[CHANNEL] := IC-1;
33400				      CODE.INFORMATION[CIX] := 'E';
33500			  	      WITH GATTR DO
33600					BEGIN
33700					KIND := VARBL;  DPLMT := 0; INDEXR:=REGC;
33800					INDBIT:=0; VRELBYTE := NO
33900					END
34000				      END
34100	(* 200 - fix addressing *)
34200				     ELSE IF INDBIT = 0
34300				      THEN BEGIN
34400				      DPLMT := DPLMT + FILCMP;
34500				      LOADADDRESS;
34600				      END
34700				     ELSE BEGIN
34800				     LOADADDRESS;
34900				     MACRO3(271B%ADDI\,REGC,FILCMP)
35000				     END;
35100				    IF RUNTMCHECK
35200				      THEN BEGIN
35300	{See if the file is open.  A magic value of 314157 is left in FILTST if so }
35400				      MACRO4(200B%MOVE\,HAC,REGC,FILTST-FILCMP);
35500				      MACRO3(302B%CAIE\,HAC,314157B);
35600				      SUPPORT(FILEUNINITIALIZED)
35700				      END
35800				   END
35900				 ELSE IF FORM = POINTER
36000				  THEN
36100				   BEGIN
36200				    TYPTR := ELTYPE;
36300				     IF TYPTR # NIL
36400				     THEN WITH GATTR DO
36500				       BEGIN
36600					LOADNOPTR := FALSE;
36700					LOAD(GATTR); LOADNOPTR := TRUE;
36800	(* 23 - check for bad pointer *)
36900	(* 26 - but not for file *)
37000					IF RUNTMCHECK
37100					  THEN BEGIN
37200					  MACRO3(302B%CAIE\,REG,0);
37300					  MACRO3(306B%CAIN\,REG,377777B);
37400					  SUPPORT(BADPOINT)
37500					  END;
37600					INDEXR := REG; DPLMT := 0; INDBIT:=0; 
37700					PACKFG := NOTPACK; KIND := VARBL; 
37800					VRELBYTE:= NO
37900				       END
38000				   END
38100				 ELSE ERROR(407);
38200			      INSYMBOL
38300			     END;
38400			IFERRSKIP(166,FSYS OR SELECTSYS)
38500		       END;
38600		      %WHILE\
38700		      WITH GATTR DO
38800		       IF TYPTR#NIL
38900		       THEN
39000			 IF TYPTR^.SIZE = 2
39100			 THEN
39200			   BEGIN
39300			     IF INDBIT = 1
39400			     THEN GETPARADDR;
39500			     IF (INDEXR>REGIN) AND (INDEXR<=REGCMAX)
39600			     THEN INCREMENTREGC
39700			   END
39800		     END %SELECTOR\ ;
39900	
40000		    PROCEDURE CALL(FSYS: SETOFSYS; FCP: CTP);
40100		    VAR
40200	(* 10 - ALLOW MORE RUNTIMES *)
40300		      LKEY: 1..44;
40400		      LFOLLOWERROR, NORIGHTPARENT : BOOLEAN;
40500	
40600	(* 33 - allow use with non-TEXT files *)
40700	(* 171 - allow read/write of records *)
40800	(* 173 - completely new getfilename *)
40900	(* 204 - don't check validty of file to be closed *)
41000		      PROCEDURE GETFILENAME(DEFAULTFILE:CTP;TEXTPROC:BOOLEAN;
41100				VAR FILETYPE:STP;VAR GOTARG:BOOLEAN;CHECK:BOOLEAN);
41200		      VAR
41300	(* 177 - fix AC *)
41400			GOTFILE : BOOLEAN;  FILEREGC: ACRANGE;
41500	{When we are finished we will have loaded a file into REGC, and parsed
41600	 the next parameter if there is one, using EXPRESSION with REGC incremented}
41700		       BEGIN
41800			INCREMENTREGC;  {by default we will load into 3}
41900			FILEREGC := REGC;  {but file goes into 2, which this still is}
42000	    {REGC = 2}
42100			GOTARG := FALSE; NORIGHTPARENT := TRUE; GOTFILE := FALSE;
42200			IF SY = LPARENT
42300			 THEN BEGIN
42400			 NORIGHTPARENT := FALSE;
42500			 INSYMBOL;
42600			 EXPRESSION(FSYS OR [COMMA,RPARENT,COLON],ONFIXEDREGC);
42700	   {REGC = 3 if expression (file can't be), 2 otherwise}
42800			 GOTFILE := FALSE;
42900	{We have an expression, see if it is a legal file.  If so, load it into
43000	 REGC (note: no incrementregc first) and do a few tests.  We have to do
43100	 our own loading mostly to avoid the INCREMENTREGC done by LOADADDRESS}
43200			 WITH GATTR DO
43300			  IF TYPTR <> NIL
43400			   THEN WITH TYPTR^ DO
43500			    IF FORM = FILES
43600			     THEN BEGIN
43700			     IF TEXTPROC
43800			      THEN IF NOT (COMPTYPES(FILTYPE,CHARPTR))
43900			      	     THEN ERROR(366);
44000	{Yes, it is a legal file.  Now load it}
44100	{If TTY that is supposed to be mapped to TTYOUTPUT, handle that}
44200			     IF (LASTFILE = TTYFILE) AND (DEFAULTFILE = OUTFILE)
44300			       THEN BEGIN
44400			       LASTFILE := TTYOUTFILE;
44500			       MACRO3R(201B%MOVEI\,REGC,TTYOUTFILE^.VADDR);
44600			       END
44700			      ELSE BEGIN
44800			       FETCHBASIS(GATTR);
44900			       MACRO(VRELBYTE,201B%MOVEI\,REGC,INDBIT,INDEXR,DPLMT);
45000			       END;
45100			     KIND := VARBL;  DPLMT := 0; INDEXR:=REGC; 
45200			     INDBIT:=0; VRELBYTE := NO;
45300			     WITH LASTFILE^ DO
45400			      IF (VLEV=0) AND (NOT MAIN)
45500			       THEN BEGIN VADDR:=IC-1; CODE.INFORMATION[CIX]:='E' END;
45600			     GOTFILE := TRUE;
45700			     FILETYPE := TYPTR;
45800	{Runtime checks if appropriate}
45900	(* 204 - don't check for CLOSE *)
46000			     if runtmcheck and check
46100			      then begin
46200			      macro4(200B%MOVE\,hac,regc,filtst);  {File test word}
46300			      macro3(302B%CAIE\,hac,314157B);  {True if file is open}
46400			      support(fileuninitialized);   {Not open}
46500			      end;
46600	{Now see if there is an arg}
46700			     IF SY <> RPARENT
46800			      THEN BEGIN
46900			      IF SY = COMMA
47000			       THEN INSYMBOL
47100			       ELSE ERROR(158);
47200	    {Note that this is guaranteed not to change REGC unless it sees an
47300	     expression, in which case it advances to 3.  We can't have two
47400	     advances (i.e. due to the EXPRESSION above and this one), since
47500	     this is done only if the one above saw a file, which can't have
47600	     advanced REGC}
47700			      EXPRESSION(FSYS OR [COMMA,RPARENT,COLON],ONFIXEDREGC);
47800			      GOTARG := TRUE
47900			      END
48000			     END;
48100	{Now we are done processing a file arg}
48200			 IF NOT GOTFILE  {If expression wasn't a file, use it as arg}
48300			  THEN GOTARG := TRUE
48400			 END;
48500	{End of IF RPARENT}
48600	   {At this point REGC = 2 unless what we saw was an expr (which a file
48700		can't be), in which case REGC = 3 and it is loaded}
48800			IF NOT GOTFILE
48900			 THEN WITH DEFAULTFILE^ DO
49000	{If we didn't get a file above, here is the code to do it}
49100			  BEGIN
49200	(* 177 - fix AC *)
49300			  MACRO3R(201B%MOVEI\,FILEREGC,VADDR);
49400			  IF NOT GOTARG
49500			   THEN WITH GATTR DO
49600			    BEGIN
49700			    KIND := VARBL;  DPLMT := 0; INDEXR:=REGC; 
49800			    INDBIT:=0; VRELBYTE := NO;
49900			    END;
50000			  IF (VLEV=0) AND (NOT MAIN)
50100			   THEN BEGIN VADDR:=IC-1; CODE.INFORMATION[CIX]:='E' END;
50200			  FILETYPE := IDTYPE;
50300	(* 204 - don't check for CLOSE *)
50400			  if runtmcheck and check
50500			   then begin
50600	(* 207 - more bad AC's *)
50700			    macro4(200B%MOVE\,hac,fileregc,filtst);  {File test word}
50800			    macro3(302B%CAIE\,hac,314157B);  {True if file is open}
50900			    support(fileuninitialized);   {Not open}
51000			    end;
51100			  END;		 
51200	  {If we saw an arg, REGC is exactly like it would have been with a
51300	   simple   INCREMENTREGC;  EXPRESSION;  which is the whole point.
51400	   That is,it is 2 unless an expression was seen, in which case the
51500	   expression is loaded into 3.  If we didn't see an expression, then
51600	   REGC is guaranteed to be 2.  Very shady...}
51700		       END %GETFILENAME\ ;
51800	
51900		      PROCEDURE VARIABLE(FSYS: SETOFSYS);
52000		      VAR
52100			LCP: CTP;
52200		       BEGIN
52300			 IF SY = IDENT
52400			 THEN
52500			   BEGIN
52600			    SEARCHID([VARS,FIELD],LCP); INSYMBOL
52700			   END
52800			 ELSE
52900			   BEGIN
53000			    ERROR(209); LCP := UVARPTR
53100			   END;
53200			SELECTOR(FSYS,LCP)
53300		       END %VARIABLE\ ;
53400	(* 22 - add GETFN - common non-defaulting file name scanner *)
53500	(* 73 - add ,COLON since used in NEW *)
53600	(* 175 - internal files *)
53700		      PROCEDURE GETFN(TEST:BOOLEAN);
53800		        BEGIN
53900			VARIABLE(FSYS OR [RPARENT,COLON,COMMA]);
54000			LOADADDRESS;
54100			IF GATTR.TYPTR#NIL
54200			  THEN IF GATTR.TYPTR^.FORM#FILES
54300			    THEN ERROR(212)
54400			    ELSE WITH LASTFILE^ DO
54500			      IF (VLEV=0) AND (NOT MAIN)
54600				THEN BEGIN VADDR:=IC-1; CODE.INFORMATION[CIX]:='E' END;
54700	(* 175 - internal files *)
54800			if test and runtmcheck
54900			  then begin
55000			  macro4(200B%MOVE\,hac,regc,filtst);  {File test word}
55100			  macro3(302B%CAIE\,hac,314157B);  {Magic value if it is open}
55200			  support(fileuninitialized);   {Not open}
55300			  end;
55400			END;
55500	
55600	(* 14 - SEVERAL CHANGES IN THIS PROC TO ADD NEW RUNTIMES AND ADD OPTIONAL XBLOCK ARG *)
55700		      PROCEDURE GETPUTRESETREWRITE;
55800		      VAR
55900	(* 172 - new options string *)
56000			LMAX,LMIN: INTEGER;
56100	(* 173 - internal files *)
56200			LATTR: ATTR;
56300			ADR : SUPPORTS ; 
56400			DEFAULT : ARRAY [1..6] OF BOOLEAN;
56500			I,J : INTEGER;
56600	
56700			PROCEDURE GETSTRINGADDRESS ;
56800	
56900			 VAR LMAX,LMIN: INTEGER;
57000	(* 61 - allow flags for gtjfn in tops20 *)
57100			    flagbits: packed record case Boolean of
57200				true: (dum:0..777777B;usetty:Boolean;wildok:Boolean);
57300				false: (dum2:0..777777B; rh:0..777777B)
57400				end;
57500			 BEGIN
57600			   IF SY=COMMA
57700			   THEN
57800			     BEGIN
57900			      INSYMBOL;
58000			      EXPRESSION(FSYS OR [COMMA,RPARENT,COLON],ONFIXEDREGC);
58100			      WITH GATTR DO
58200			       IF TYPTR#NIL
58300			       THEN
58400				WITH TYPTR^ DO
58500				 IF(FORM=ARRAYS) AND ARRAYPF
58600				 THEN
58700				   IF COMPTYPES(AELTYPE,CHARPTR)
58800				   THEN
58900				     BEGIN
59000	(* 15 - CHANGE DUE TO SLIGHTLY DIFFERENT LOGIC IN MAIN PROC *)
59100				      DEFAULT[I] := FALSE;
59200				      I:=I+1;DEFAULT[I]:=FALSE;
59300				      LOADADDRESS;
59400					GETBOUNDS(INXTYPE,LMIN,LMAX);
59500					LMAX := LMAX-LMIN+1;
59600					INCREMENTREGC;
59700					MACRO3(201B%MOVEI\,REGC,LMAX);
59800				     END
59900				   ELSE ERROR(212)
60000				 ELSE ERROR(212);
60100	(* 61 - implement extra syntax for tops20 *)
60200	(* 144 - allow it for tops10, too *)
60300			     if (sy=colon)
60400			      then begin
60500			      insymbol;
60600			      flagbits.rh := 0;
60700			      while sy in [relop,addop,mulop] do
60800				begin
60900				if op = leop (* @ *)
61000				  then flagbits.usetty := true
61100				else if (op = mul) and (not tops10)
61200				  then flagbits.wildok := true
61300				else error(158);
61400				insymbol
61500				end;
61600			      macro3(505b%hrli\,regc-1,flagbits.rh);
61700			      end;
61800			     END;
61900			 END ;
62000	
62100		       BEGIN
62200			VARIABLE( FSYS OR [RPARENT,COMMA] ) ;
62300			LOADADDRESS ;
62400	(* 173 - internal files *)
62500			LATTR := GATTR;
62600			 IF GATTR.TYPTR # NIL
62700			 THEN
62800			   IF GATTR.TYPTR^.FORM # FILES
62900			   THEN ERRANDSKIP(458,FSYS OR [RPARENT])
63000			   ELSE
63100			     BEGIN
63200			      WITH LASTFILE^ DO
63300			       IF (VLEV = 0) AND (NOT MAIN)
63400			       THEN
63500				 BEGIN
63600				  VADDR:= IC-1; CODE.INFORMATION[CIX] := 'E'
63700				 END;
63800			       IF (LKEY>=5) AND (LKEY#28)
63900			       THEN
64000				 BEGIN
64100				  FOR I := 1 TO 6 DO DEFAULT[I] := TRUE;
64200				  I := 1;
64300				  GETSTRINGADDRESS % OF FILENAME \ ;
64400	(* 15 - ADD NEW PARAMETERS AND ALLOW OMITTING BLOCK *)
64500				  WHILE NOT DEFAULT[I] AND (SY=COMMA) DO
64600				   BEGIN
64700				    I := I+1;
64800				    INSYMBOL;
64900	(* 172 - ADD OPTION STRING AS 3RD ARG *)
65000				    IF I = 3
65100				      THEN BEGIN
65200				      EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
65300			      	      WITH GATTR DO
65400			       	       IF TYPTR#NIL
65500					THEN WITH TYPTR^ DO
65600				 	IF(FORM=ARRAYS) AND ARRAYPF
65700				 	 THEN IF COMPTYPES(AELTYPE,CHARPTR)
65800				   	  THEN BEGIN
65900				          DEFAULT[I] := FALSE;
66000				          LOADADDRESS;
66100					  GETBOUNDS(INXTYPE,LMIN,LMAX);
66200					  LMAX := LMAX-LMIN+1;
66300					  MACRO3(505B%HRLI\,REGC,LMAX);
66400					  END
66500					  ELSE ERROR(212)  {not CHAR array}
66600					 ELSE BEGIN  {not packed array}
66700					 LOAD(GATTR); DEFAULT[I] := FALSE
66800					 END
66900				      END {I=3}
67000	(* 57 - ONLY TOPS10 HAS XBLOCK ARG *)
67100				    ELSE IF (NOT TOPS10) OR (I # 4) OR ((SY=INTCONST)AND(VAL.IVAL=0))
67200				      THEN BEGIN
67300				      EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
67400				       IF GATTR.TYPTR#NIL
67500				       THEN
67600				       BEGIN
67700					LOAD(GATTR); DEFAULT[I] := FALSE;
67800	(* 77 - allow sets, since they are elegant for specifying bits *)
67900					if gattr.typtr^.form = power
68000					  then regc := regc-1;
68100				       END
68200				      END
68300				     ELSE BEGIN
68400				     VARIABLE(FSYS OR[COMMA,RPARENT]);
68500				     IF GATTR.TYPTR # NIL
68600	(* 26 - allow record as lookup block *)
68700					THEN IF NOT (GATTR.TYPTR^.FORM IN [ARRAYS,RECORDS])
68800					  THEN ERROR(264)
68900					  ELSE IF GATTR.TYPTR^.SIZE<5
69000					    THEN ERROR(265)
69100					    ELSE BEGIN LOADADDRESS; DEFAULT[I]:=FALSE END
69200					ELSE ERROR(458)
69300				     END;
69400				   END;
69500				  FOR I := 1 TO 6 DO
69600				   IF DEFAULT[I]
69700				   THEN
69800				     BEGIN
69900				      INCREMENTREGC;
70000				      IF I=6
70100					THEN MACRO3(474B%SETO\,REGC,0)
70200				        ELSE MACRO3(201B%MOVEI\,REGC,0)
70300				     END;
70400				 END;
70500	(* 173 - internal files *)
70600			       if lkey in [5,6,29,36]  {openning}
70700				 then begin
70800				 if lattr.typtr <> nil
70900				   then if lattr.typtr^.form = files
71000				     then if comptypes(lattr.typtr^.filtype,charptr)
71100	{In AC1, put size of component, or 0 if text file}
71200				       then macro3(201B%movei\,tac,0)
71300				       else macro3(201B%movei\,tac,
71400	{Normally we would have to type filtype^ for nil, but if it is nil, the
71500	 comptypes above will succeed, and this code will never happen.}
71600						   lattr.typtr^.filtype^.size)
71700				 end
71800	(* 204 - don't validty check for DISMISS *)
71900	(* 205 - fix AC for RENAME *)
72000				else if runtmcheck and (lkey <> 28)
72100				 then begin
72200			         macro4(200B%MOVE\,hac,regin+1,filtst);{File test word}
72300			         macro3(302B%CAIE\,hac,314157B); {Magic value if open}
72400			         support(fileuninitialized);   {Not open}
72500			         end;
72600			       CASE LKEY OF
72700				2: ADR:= GETLINE ;
72800				4: ADR:= PUTLINE ;
72900				5: ADR:= RESETFILE ;
73000				6: ADR:= REWRITEFILE;
73100				27:ADR:=NAMEFILE;
73200				28:ADR:=DISFILE;
73300				29:ADR:=UPFILE;
73400				36:ADR:=APFILE
73500			       END ;
73600			      SUPPORT(ADR) ;
73700			     END ;
73800		       END;
73900	
74000	(* 10 - ADD SETSTRING, TO ALLOW I/O TO STRINGS *)
74100	(* 13 - CODE MODIFIED TO ALLOW 4TH ARG, LIMIT *)
74200	(* 51 - allow any file type, any packed array *)
74300		      PROCEDURE SETSTRING;
74400		      VAR
74500			LREGC:ACRANGE;
74600			LMIN,LMAX:ADDRRANGE;
74700			ARRAY1,OFFSET,FILEP,LIMIT:ATTR;
74800			NOOFF,NOLIM: BOOLEAN;
74900	
75000			BEGIN
75100			LREGC := REGC;  NOOFF := FALSE;  NOLIM:=FALSE;
75200	(* 175 - if not inited, do it *)
75300		        GETFN(FALSE);
75400	{If the file block is not legal yet, call routine to make it so}
75500			macro4(200B%MOVE\,hac,regc,filtst);  {File test word}
75600			macro3(302B%CAIE\,hac,314157B);  {Magic value if it is open}
75700			support(initfileblock);
75800			FILEP := GATTR;
75900			IF SY = COMMA
76000			  THEN INSYMBOL
76100			  ELSE ERROR(158);
76200			VARIABLE(FSYS OR [RPARENT,COMMA]);
76300			LOADADDRESS;
76400			WITH GATTR DO
76500			  BEGIN
76600			  KIND := EXPR; REG := INDEXR;
76700			  IF TYPTR # NIL
76800			    THEN WITH TYPTR^ DO
76900			      IF FORM # ARRAYS
77000				THEN ERROR(458)
77100				ELSE IF FILEP.TYPTR#NIL
77200				  THEN IF NOT ARRAYPF
77300				    THEN ERROR(458)
77400			  END;
77500			ARRAY1 := GATTR;
77600			IF SY = RPARENT
77700			  THEN NOOFF := TRUE
77800			ELSE IF SY = COMMA
77900			  THEN BEGIN
78000			  INSYMBOL;
78100			  EXPRESSION(FSYS OR [RPARENT,COMMA],ONREGC);
78200			  IF GATTR.TYPTR # NIL
78300			    THEN IF GATTR.TYPTR^.FORM # SCALAR
78400			      THEN ERROR(458)
78500			      ELSE IF NOT COMPTYPES(ARRAY1.TYPTR^.INXTYPE,GATTR.TYPTR)
78600				THEN ERROR(458);
78700			  OFFSET := GATTR;
78800			  IF OFFSET.KIND = EXPR
78900			    THEN INCREMENTREGC
79000			  END
79100			ELSE ERROR(158);
79200			IF SY = RPARENT
79300			  THEN NOLIM := TRUE
79400			ELSE IF SY = COMMA
79500			  THEN BEGIN
79600			  INSYMBOL;
79700			  EXPRESSION(FSYS OR [RPARENT],ONREGC);
79800			  IF GATTR.TYPTR # NIL
79900			    THEN IF GATTR.TYPTR^.FORM # SCALAR
80000			      THEN ERROR(458)
80100			      ELSE IF NOT COMPTYPES(ARRAY1.TYPTR^.INXTYPE,GATTR.TYPTR)
80200				THEN ERROR(458);
80300			  LIMIT := GATTR;
80400			  IF LIMIT.KIND = EXPR
80500			    THEN INCREMENTREGC
80600			  END
80700			ELSE ERROR(158);
80800			IF NOT ERRORFLAG
80900			  THEN BEGIN
81000			  GETBOUNDS(ARRAY1.TYPTR^.INXTYPE,LMIN,LMAX);
81100			  LMAX := LMAX - LMIN;
81200			  IF NOT NOLIM
81300			    THEN BEGIN
81400			    IF LIMIT.KIND # EXPR
81500			      THEN BEGIN LOAD(LIMIT); INCREMENTREGC END;
81600			    WITH LIMIT DO
81700			      BEGIN
81800			      IF LMIN > 0
81900				THEN MACRO3(275B%SUBI\,REG,LMIN)
82000			      ELSE IF LMIN < 0
82100				THEN MACRO3(271B%ADDI\,REG,-LMIN);
82200			      IF RUNTMCHECK
82300				THEN BEGIN
82400				MACRO3(307B%CAIG\,REG,LMAX);
82500				MACRO3(305B%CAIGE\,REG,0);
82600				SUPPORT(INDEXERROR)
82700				END;
82800			      END;
82900			    END;
83000			  IF NOT NOOFF
83100			    THEN BEGIN
83200			    IF OFFSET.KIND # EXPR
83300			      THEN BEGIN LOAD(OFFSET); INCREMENTREGC END;
83400			    WITH OFFSET DO
83500			      BEGIN
83600			      IF LMIN > 0
83700				THEN MACRO3(275B%SUBI\,REG,LMIN)
83800			      ELSE IF LMIN < 0
83900				THEN MACRO3(271B%ADDI\,REG,-LMIN);
84000			      IF RUNTMCHECK
84100				THEN BEGIN
84200				MACRO3(301B%CAIL\,REG,0);
84300				MACRO3(303B%CAILE\,REG,LMAX+1);
84400				SUPPORT(INDEXERROR)
84500				END;
84600			      END;
84700			    INCREMENTREGC;
84800			    IF NOLIM
84900			      THEN MACRO4(211B%MOVNI\,REGC,OFFSET.REG,-LMAX-1)
85000			      ELSE BEGIN
85100			      MACRO4(201B%MOVEI\,REGC,LIMIT.REG,1);
85200			      MACRO4(275B%SUBI\,REGC,OFFSET.REG,0);
85300			      IF RUNTMCHECK
85400				THEN BEGIN
85500				MACRO3(305B%CAIGE\,REGC,0);
85600				SUPPORT(INDEXERROR)
85700				END
85800			      END;
85900			    MACRO4(552B%HRRZM\,REGC,FILEP.INDEXR,FILBFH+2);
86000			    MACRO3R(200B%MOVE\,REGC,ARRAY1.TYPTR^.ARRAYBPADDR);
86100			    MACRO3(621B%TLZ\,REGC,17B);
86200			    MACRO3(231B%IDIVI\,OFFSET.REG,BITMAX DIV ARRAY1.TYPTR^.AELTYPE^.BITSIZE);
86300			    MACRO3(270B%ADD\,ARRAY1.REG,OFFSET.REG);
86400			    MACRO3(540B%HRR\,REGC,ARRAY1.REG);
86500			    MACRO3(303B%CAILE\,OFFSET.REG+1,0);
86600			    MACRO3(133B%IBP\,0,REGC);
86700			    MACRO3R(367B%SOJG\,OFFSET.REG+1,IC-1);
86800			    MACRO4(202B%MOVEM\,REGC,FILEP.INDEXR,FILBFH+1)
86900			    END
87000			   ELSE BEGIN
87100			    INCREMENTREGC;
87200			    IF NOLIM
87300			      THEN MACRO3(201B%MOVEI\,REGC,LMAX+1)
87400			      ELSE MACRO4(201B%MOVEI\,REGC,LIMIT.REG,1);
87500			    MACRO4(202B%MOVEM\,REGC,FILEP.INDEXR,FILBFH+2);
87600			    MACRO3R(200B%MOVE\,REGC,ARRAY1.TYPTR^.ARRAYBPADDR);
87700			    MACRO3(621B%TLZ\,REGC,17B);
87800			    MACRO3(540B%HRR\,REGC,ARRAY1.REG);
87900			    MACRO4(202B%MOVEM\,REGC,FILEP.INDEXR,FILBFH+1)
88000			    END;
88100			  IF NOLIM
88200			    THEN MACRO3(505B%HRLI\,REGC,LMIN+LMAX+400001B)
88300			    ELSE MACRO4(505B%HRLI\,REGC,LIMIT.REG,LMIN+400001B);
88400	(* 60 - DON'T PUT IN LH(0) FOR TOPS-20.  "FILBFH" IS FREE *)
88500	(* 143 - Tops10 now like Tops20 *)
88600			  IF TOPS10
88700			    THEN MACRO4(556B%HLRZM\,REGC,FILEP.INDEXR,FILBLL)
88800			    ELSE MACRO4(556B%HLRZM\,REGC,FILEP.INDEXR,FILBFH);
88900	(* 43 - setzm to avoid blocked or dump mode I/O *)
89000	(* 60 - kludge needed only for tops10 *)
89100	(* 143 - tops10 now like tops20 *)
89200			  CASE LKEY OF
89300	(* 60 - TOPS20 USES RUNTIME TO INIT *)
89400	(* 143 - so does Tops10 *)
89500			    22: SUPPORT(RESETSTRING);
89600			    23: SUPPORT(REWRITESTRING)
89700			    END;
89800			  END;
89900			REGC := LREGC
90000			END;
90100	
90200	(* 57 - ADD SET20STRING FOR 20 STRSET,STRWRITE *)
90300	(* 60 - on further thought, use normal one *)
90400	
90500		      PROCEDURE GETINDEX;
90600			  VAR LREGC:ACRANGE;
90700			      FILEP:ATTR;
90800			BEGIN
90900			LREGC := REGC;
91000	(* 175 *)
91100			GETFN(TRUE);
91200			FILEP := GATTR;
91300			IF SY = COMMA
91400			  THEN INSYMBOL
91500			  ELSE ERROR(158);
91600			VARIABLE(FSYS OR [RPARENT]);
91700			LOADADDRESS;
91800			WITH GATTR DO
91900			  BEGIN
92000			  IF TYPTR # NIL
92100			    THEN WITH TYPTR^ DO
92200			      IF (FORM # SCALAR) AND (FORM # SUBRANGE)
92300				THEN ERROR(458)
92400			  END;
92500			IF NOT ERRORFLAG
92600			  THEN BEGIN
92700			  INCREMENTREGC;
92800			  WITH FILEP DO
92900			    BEGIN
93000	(* 60 - TOPS20 HAS MAGIC NO. IN DIFFERENT PLACE *)
93100	(* 143 - tops10 now the same *)
93200			    IF TOPS10
93300			      THEN MACRO4(200B%MOVE\,REGC,INDEXR,FILBLL)
93400			      ELSE MACRO4(200B%MOVE\,REGC,INDEXR,FILBFH);
93500			    MACRO3(620B%TRZ\,REGC,400000B);
93600			    MACRO4(274B%SUB\,REGC,INDEXR,FILBFH+2);
93700			    MACRO4(202B%MOVEM\,REGC,GATTR.INDEXR,0);
93800			    END
93900			  END;
94000			REGC := LREGC
94100			END;
     
00100	
00200		      PROCEDURE READREADLN;
00300		      VAR
00400	(* 14 ADD READING OF STRING *)
00500	(* 171 read into packed objects, ALLOW READ OF RECORDS *)
00600			LADDR : SUPPORTS;  LMIN,LMAX:INTEGER; LATTR:ATTR;
00700			READREC: BOOLEAN; LREGC: ACRANGE;
00800	{This procedure is complicated by a number of special cases.  The first is
00900	 the question of whether the file is text or binary.  The code for a binary
01000	 file is more or less completely different.  (Note also that only READLN
01100	 is not legal for a binary file.)  The second question is whether the
01200	 address is passed to the runtimes or whether they return a value.  For
01300	 binary files we must pass the address of the variable to be filled, since
01400	 it can be arbitrarily big.  Similarly for strings.  For simple values,
01500	 the runtimes return the value in AC 3, and we must do a store.  This is
01600	 to allow for storing into packed objects (what kind of address could be
01700	 pass for that?)  We do LOADADDRESS for binary files and strings, and
01800	 for simple objects we do STORE afterwards.}
01900		       BEGIN
02000	(* 33 - ALLOW GETFILENAME WITH NON-TEXT FILES *)
02100	(* 171 - PREDECL FILES ARE GLOBAL, ALSO ALLOW READ OF RECORD *)
02200			IF LKEY = 7  {read?}
02300			  THEN GETFILENAME(INFILE,FALSE,THISFILE,GOTARG,TRUE)  {might be binary}
02400			  ELSE GETFILENAME(INFILE,TRUE,THISFILE,GOTARG,TRUE);  {must be text}
02500			IF (LKEY = 7) AND NOT GOTARG
02600			  THEN ERROR(554);   {READ must have args}
02700			READREC := FALSE;   {now see if a binary file}
02800		        IF LKEY = 7
02900			  THEN IF NOT COMPTYPES(CHARPTR,THISFILE^.FILTYPE)
03000			    THEN READREC := TRUE;
03100		        LREGC := REGC;
03200			 IF GOTARG
03300			 THEN
03400			   LOOP
03500	(* 14 ADD READING OF STRING *)
03600	(* 171 read into packed objects *)
03700			    LATTR := GATTR;
03800	(* 31 - INITIALIZE LADDR IN CASE OF ERROR - PREVENT ILL MEM REF *)
03900			    IF READREC
04000			      THEN BEGIN {separate code for binary files}
04100			      LADDR := READRECORD;
04200			      IF GATTR.TYPTR#NIL
04300			        THEN IF NOT COMPTYPES(THISFILE^.FILTYPE,GATTR.TYPTR)
04400				  THEN ERROR(260);
04500			      LOADADDRESS
04600			      END
04700			    ELSE BEGIN  {Here is the code for TEXT files}
04800			    LADDR := READCHARACTER;
04900			     IF GATTR.TYPTR#NIL
05000			     THEN
05100			       IF GATTR.TYPTR^.FORM<=SUBRANGE
05200			       THEN
05300				 IF COMPTYPES(INTPTR,GATTR.TYPTR)
05400				 THEN
05500				  LADDR := READINTEGER
05600				 ELSE
05700				   IF COMPTYPES(REALPTR,GATTR.TYPTR)
05800				   THEN
05900				    LADDR := READREAL
06000				   ELSE
06100				     IF COMPTYPES(CHARPTR,GATTR.TYPTR)
06200				     THEN
06300				      LADDR := READCHARACTER
06400				     ELSE ERROR(169)
06500			       ELSE WITH GATTR.TYPTR^ DO
06600				  IF FORM = ARRAYS
06700				    THEN IF COMPTYPES(CHARPTR,AELTYPE)
06800				      THEN
06900					BEGIN
07000	(* 171 - read into packed objects *)
07100					LOADADDRESS;  {of array}
07200					GETBOUNDS(INXTYPE,LMIN,LMAX);
07300					INCREMENTREGC;
07400					MACRO3(201B%MOVEI\,REGC,LMAX-LMIN+1);
07500					IF ARRAYPF
07600					  THEN LADDR := READPACKEDSTRING
07700					  ELSE LADDR := READSTRING;
07800					IF SY = COLON
07900					 THEN BEGIN
08000					  INSYMBOL;
08100	(* 76 - allow set of break characters *)
08200					  VARIABLE(FSYS OR [COMMA,RPARENT,COLON]);
08300					  LOADADDRESS;
08400					  IF NOT COMPTYPES(INTPTR,GATTR.TYPTR)
08500					    THEN ERROR(458);
08600					  END
08700					 else begin
08800					  incrementregc;
08900					  MACRO3(201B%MOVEI\,REGC,0);
09000					  end;
09100					if sy = colon
09200					  then begin
09300					  insymbol;
09400					  expression(fsys or [comma,rparent],onfixedregc);
09500					  if gattr.typtr#nil
09600					    then if (gattr.typtr^.form = power)
09700					     then if comptypes(gattr.typtr^.elset, charptr)
09800					      then begin
09900					      load(gattr);
10000					      regc := regc-2;
10100					      end
10200					     else error(458)
10300					    else error(458)
10400					   end
10500					  else macro3(403B%SETZB\,regc+1,regc+2);
10600					END
10700				      ELSE ERROR(458)
10800				    ELSE ERROR(458);
10900			    END; {of TEXT file case}
11000	(* 171 - read into packed objects *)
11100			    REGC := LREGC;
11200			    if not (readrec or (laddr in [readstring,readpackedstring]))
11300			      then begin
11400	  {This is for reading single words, which may go into packed structures.
11500	   Note that we have to redo the ac allocation because the read routine
11600	   will return a value in AC 3, which quite likely is used as INDEXR or
11700	   BPADDR.  Since we are pushing the active AC's anyway, we might as well
11800	   pop them back into a different place.}
11900			      incrementregc;  {place that read will return the value}
12000			      if (lattr.indexr > regin) and (lattr.indexr <= 10B)
12100			        then begin
12200				macro3(261B%PUSH\,topp,lattr.indexr);
12300				incrementregc;
12400				lattr.indexr := regc;  {Place to put this value afterwards}
12500				end;
12600			      if (lattr.packfg = packk) and (lattr.bpaddr > regin)
12700						        and (lattr.bpaddr <= 10B)
12800				then begin
12900			        macro3(261B%PUSH\,topp,lattr.bpaddr);
13000				incrementregc;
13100				lattr.bpaddr := regc;
13200				end;
13300			      regc := lregc;  {restore regc}
13400			      support(laddr);
13500			      if (lattr.packfg = packk) and (lattr.bpaddr > regin) 
13600					          	and (lattr.bpaddr <= 10B)
13700			        then macro3(262B%POP\,topp,lattr.bpaddr);
13800			      if (lattr.indexr > regin) and (lattr.indexr <= 10B)
13900			        then macro3(262B%POP\,topp,lattr.indexr);
14000			      fetchbasis(lattr);   {Now do the store}
14100			      store(regc+1,lattr)
14200			      end
14300			     else SUPPORT(LADDR);
14400			   EXIT IF SY # COMMA;
14500			    INSYMBOL;
14600			   VARIABLE(FSYS OR [COMMA,COLON,RPARENT]); 
14700			   END;
14800			 IF LKEY = 8
14900			 THEN SUPPORT(GETLINE)
15000		       END %READREADLN\ ;
15100	
15200	(* 42 - move breakin to close *)
15300	(* 43 - add putx *)
15400		      procedure putx;
15500			begin
15600	(* 175 *)
15700			getfn(true);
15800	(* 61 - add delete *)
15900			case lkey of
16000			  37: support(putxfile);
16100			  41: support(delfile)
16200			  end;
16300			end;
16400	
16500		      PROCEDURE BREAK;
16600		       BEGIN
16700	(* 26 - allow non-text files *)
16800	(* 171 - PREDECL FILES ARE SPECIAL *)
16900			GETFILENAME(OUTFILE,FALSE,THISFILE,GOTARG,TRUE);
17000			IF GOTARG THEN ERROR(554);
17100			SUPPORT(BREAKOUTPUT) ;
17200		       END ;
17300	
17400	(* 10 - ADD CLOSE *)
17500	(* 15 - AND ALLOW OPT. PARAM FOR CLOSE BITS *)
17600	(* 42 - move breakin here, to allow param to suppress get *)
17700		      PROCEDURE CLOSE;
17800		       BEGIN
17900	(* 26 - allow non-text files *)
18000	(* 61 - rclose for tops20 *)
18100			if (lkey = 25) or (lkey = 42)
18200	(* 171 - PREDECL FILES ARE SPECIAL *)
18300	(* 204 - don't validity check CLOSE and RCLOSE *)
18400			  THEN GETFILENAME(OUTFILE,FALSE,THISFILE,GOTARG,FALSE)
18500			  else getfilename(INFILE,false,THISFILE,GOTARG,FALSE);
18600			IF GOTARG
18700			 THEN LOAD(GATTR)
18800			 ELSE BEGIN
18900			  INCREMENTREGC;
19000			  MACRO3(201B%MOVEI\,REGC,0)
19100			  END;
19200	(* 45 - add NEXTBLOCK *)
19300	(* 61 - add RCLOSE *)
19400			case lkey of
19500			  25: support(closefile);
19600			  34: support(breakinput);
19700			  39: support(nextblockf);
19800			  42: support(relfile)
19900			  end;
20000		       END;
20100	
20200	(* 14 - ADD DUMP MODE STUFF *)
20300	(* 42 - allow variable size *)
20400		     PROCEDURE DUMP;
20500			VAR FILEP:ATTR; s:integer;
20600		      BEGIN
20700	(* 175 *)
20800		      GETFN(TRUE);
20900		      FILEP:=GATTR;
21000		      IF SY=COMMA
21100		        THEN INSYMBOL
21200			ELSE ERROR(158);
21300		      EXPRESSION(FSYS OR[COMMA,RPARENT],ONFIXEDREGC);
21400		      LOADADDRESS;
21500		      if gattr.typtr#nil
21600		       then s:=gattr.typtr^.size;
21700		      if sy=comma
21800		       then
21900			begin
22000			insymbol;
22100			expression(fsys or [rparent],onfixedregc);
22200			if comptypes(intptr,gattr.typtr)
22300			 then load(gattr)
22400			 else error(458);
22500			if runtmcheck
22600			 then begin
22700			 macro3(303b%caile\,regc,s);
22800			 support(indexerror)
22900			 end
23000			end
23100	               else
23200			begin
23300		        INCREMENTREGC;
23400			MACRO3(201B%MOVEI\,REGC,GATTR.TYPTR^.SIZE)
23500		        end;
23600		      IF LKEY=30
23700			THEN SUPPORT(READDUMP)
23800			ELSE SUPPORT(WRITEDUMP)
23900		      END;
24000	
24100		    PROCEDURE USET;
24200			VAR FILEP:ATTR;
24300		      BEGIN
24400	(* 175 *)
24500		      GETFN(TRUE);
24600		      FILEP:=GATTR;
24700		      IF SY = COMMA
24800			THEN INSYMBOL
24900			ELSE ERROR(158);
25000	(* 43 - new optional arg for useti *)
25100		      EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
25200		      LOAD(GATTR);
25300		      IF GATTR.TYPTR=NIL
25400			THEN ERROR(458)
25500			ELSE IF GATTR.TYPTR#INTPTR
25600			  THEN ERROR(458);
25700	(* 44 - add SETPOS and SKIP *)
25800		      IF LKEY # 33
25900	(* 43 - new optional arg for useti *)
26000			then begin
26100			  if sy=comma
26200			    then begin
26300			    insymbol;
26400			    expression(fsys or [rparent],onfixedregc);
26500			    load(gattr);
26600			    end
26700			  else begin
26800			    incrementregc;
26900			    macro3(201b%movei\,regc,0)
27000			    end;
27100			  case lkey of
27200				32:support(setin);
27300				38:support(setposf)
27400				end
27500			  end
27600			ELSE SUPPORT(SETOUT)
27700		      END;
27800	
27900		      PROCEDURE WRITEWRITELN;
28000		      VAR
28100			LSP: STP; DEFAULT,REALFORMAT,WRITEOCT: BOOLEAN; LSIZE,LMIN,LMAX: INTEGER; LADDR: SUPPORTS;
28200	(* 171 - write records *)
28300			writerec: Boolean;
28400		       BEGIN
28500	(* 171 - PREDECL FILES ARE GLOBAL, ALSO ALLOW READ OF RECORD *)
28600	{First scan file name and see if binary file}
28700			IF LKEY = 10   {WRITE?}
28800			  THEN GETFILENAME(OUTFILE,FALSE,THISFILE,GOTARG,TRUE)  {Yes, might be binary}
28900			  ELSE GETFILENAME(OUTFILE,TRUE,THISFILE,GOTARG,TRUE);  {No, WRITELN not legal for binary files}
29000			IF (LKEY = 10) AND NOT GOTARG
29100			  THEN ERROR(554);
29200			WRITEREC := FALSE;
29300		        IF LKEY = 10   {Now see if it was a binary file}
29400			  THEN IF NOT COMPTYPES(CHARPTR,THISFILE^.FILTYPE)
29500			    THEN WRITEREC := TRUE;
29600			 IF GOTARG
29700			 THEN
29800			   LOOP
29900	(* 22 - INITIALIZE LADDR IN CASE OF ERRORS.  PREVENTS ILL MEM REF *)
30000	(* 206 - moved initialization below *)
30100			    LSP := GATTR.TYPTR; LSIZE := LGTH; WRITEOCT := FALSE;
30200			     IF LSP # NIL
30300			     THEN
30400	(* 206 - make non-text files work for constants *)
30500	{Note that the values of LADDR set here are used only for binary files.
30600	 LADDR is reset below for text files.  Only in case of error will these
30700	 values remain for a text file, and in that case having them prevents
30800	 an ill mem ref}
30900			       IF LSP^.FORM <= POWER
31000			       THEN BEGIN LOAD(GATTR); LADDR := WRITESCALAR END
31100			       ELSE
31200				 BEGIN
31300				   IF (GATTR.KIND = VARBL)
31400				    AND
31500				    (GATTR.INDEXR = TOPP)
31600				   THEN ERROR(458);
31700				  LOADADDRESS;
31800				  LADDR := WRITERECORD;
31900				 END;
32000	(* 206 - make non-text files work for constants *)
32100			     IF WRITEREC
32200			       THEN BEGIN {For binary files, make sure of type match}
32300			       IF GATTR.TYPTR#NIL
32400			         THEN IF NOT COMPTYPES(THISFILE^.FILTYPE,GATTR.TYPTR)
32500				   THEN ERROR(260);
32600			       END  {end binary}
32700			     ELSE BEGIN
32800			     IF SY = COLON
32900			     THEN
33000			       BEGIN
33100				INSYMBOL; EXPRESSION(FSYS OR [COMMA,COLON,RPARENT],ONFIXEDREGC);
33200				 IF GATTR.TYPTR # NIL
33300				 THEN
33400				   IF GATTR.TYPTR # INTPTR
33500				   THEN ERROR(458);
33600				LOAD(GATTR); DEFAULT := FALSE;
33700			       END
33800			     ELSE
33900			       BEGIN
34000				DEFAULT := TRUE; INCREMENTREGC %RESERVE REGISTER FOR DEFAULT VALUE\
34100			       END ;
34200			     IF LSP = INTPTR
34300			     THEN
34400			       BEGIN
34500				LADDR := WRITEINTEGER ; LSIZE := 12
34600			       END;
34700			     IF SY = COLON
34800			     THEN
34900			       BEGIN
35000				INSYMBOL;
35100				 IF (SY = IDENT) AND ((ID='O         ') OR (ID='H         '))
35200				 THEN
35300				   BEGIN
35400				     IF NOT COMPTYPES(LSP,INTPTR)
35500				     THEN ERROR(262);
35600				     IF ID = 'O         '
35700				     THEN LADDR := WRITEOCTAL
35800				     ELSE
35900				       BEGIN
36000					LADDR := WRITEHEXADECIMAL; LSIZE := 11
36100				       END;
36200				    INSYMBOL
36300				   END
36400				 ELSE
36500				   BEGIN
36600				    EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
36700				     IF GATTR.TYPTR # NIL
36800				     THEN
36900				       IF GATTR.TYPTR # INTPTR
37000				       THEN ERROR(458);
37100				     IF LSP # REALPTR
37200				     THEN ERROR(258);
37300				    LOAD(GATTR); REALFORMAT := FALSE
37400				   END
37500			       END
37600			     ELSE REALFORMAT := TRUE;
37700			     IF LSP = INTPTR
37800			     THEN GOTO 1;
37900			     IF LSP = CHARPTR
38000			     THEN
38100			       BEGIN
38200				LSIZE := 1; LADDR := WRITECHARACTER
38300			       END
38400			     ELSE
38500			       IF LSP = REALPTR
38600			       THEN
38700				 BEGIN
38800				  LSIZE := 16; LADDR := WRITEREAL;
38900				   IF REALFORMAT
39000				   THEN MACRO3(201B%MOVEI\,REGIN+4,123456B);
39100				 END
39200			       ELSE
39300				 IF LSP = BOOLPTR
39400				 THEN
39500				   BEGIN
39600				    LSIZE := 6; LADDR := WRITEBOOLEAN
39700				   END
39800				 ELSE
39900				   IF LSP # NIL
40000				   THEN
40100				     BEGIN
40200				       IF LSP^.FORM = SCALAR
40300				       THEN ERROR(169)
40400				       ELSE
40500					 IF STRING(LSP)
40600					 THEN
40700					   BEGIN
40800					     IF LSP^.INXTYPE#NIL
40900					     THEN
41000					       BEGIN
41100						GETBOUNDS(LSP^.INXTYPE,LMIN,LMAX);
41200						LSIZE := LMAX-LMIN+1;
41300					       END;
41400					    MACRO3(201B%MOVEI\,REGIN+4,LSIZE);
41500					     IF LSP^.ARRAYPF
41600					     THEN LADDR := WRITEPACKEDSTRING
41700					     ELSE LADDR := WRITESTRING ;
41800					   END
41900					 ELSE ERROR(458)
42000				     END;
42100	1:
42200			     IF DEFAULT
42300			     THEN MACRO3(201B%MOVEI\,REGIN+3,LSIZE);
42400			    END;  {of IF WRITEREC}
42500			    SUPPORT(LADDR);
42600			    REGC :=REGIN + 1;
42700			   EXIT IF SY # COMMA;
42800			    INSYMBOL;
42900	(* 206 - allow constants for records *)
43000			    EXPRESSION(FSYS OR [COMMA,COLON,RPARENT],ONFIXEDREGC);
43100			   END;
43200			 IF LKEY = 11
43300			 THEN SUPPORT(PUTLINE) ;
43400		       END %WRITE\ ;
43500	
43600	(* 6 - PACK and UNPACK have been rewritten to be as described in Jensen and Wirth *)
43700		      PROCEDURE PACK;
43800	
43900			% PACK(A,I,Z) MEANS:
44000			 FOR L := LMIN(Z) TO LMAX(Z) DO Z[L] := A[L-LMIN(Z)+I] \
44100	
44200		      VAR
44300			ARRAY1,OFFSET1,ARRAY2,OFFSET2: ATTR;
44400			LADDR,START,STOP,LMIN1,LMAX1,LMIN2,LMAX2: ADDRRANGE;
44500			LREGC: ACRANGE;
44600	
44700		       BEGIN
44800			LREGC := REGC; START := 0;
44900			VARIABLE(FSYS OR [COMMA,RPARENT]);
45000			LOADADDRESS;
45100			WITH GATTR DO
45200			 BEGIN
45300			  KIND := EXPR; REG := INDEXR;
45400	(* 135 prevent ill mem ref if not a variable *)
45500			   IF TYPTR = NIL
45600			   THEN TYPTR := UARRTYP
45700			   ELSE WITH TYPTR^ DO
45800			     IF FORM # ARRAYS
45900			     THEN ERROR(458)
46000			     ELSE
46100			       IF ARRAYPF
46200			       THEN ERROR(458)
46300			 END;
46400			ARRAY1 := GATTR;
46500			 IF SY = COMMA
46600			 THEN INSYMBOL
46700			 ELSE ERROR(158);
46800			EXPRESSION(FSYS OR [COMMA,RPARENT],ONREGC);
46900			 IF GATTR.TYPTR # NIL
47000			 THEN
47100			   IF GATTR.TYPTR^.FORM # SCALAR
47200			   THEN ERROR(458)
47300			   ELSE
47400			     IF NOT COMPTYPES(ARRAY1.TYPTR^.INXTYPE,GATTR.TYPTR)
47500			     THEN ERROR(458);
47600			OFFSET1 := GATTR;
47700			 IF SY = COMMA
47800			 THEN INSYMBOL
47900			 ELSE ERROR(158);
48000			VARIABLE(FSYS OR [RPARENT]);
48100			LOADADDRESS;
48200			WITH GATTR DO
48300			 BEGIN
48400			  KIND := EXPR; REG := INDEXR;
48500			   IF TYPTR # NIL
48600			   THEN WITH TYPTR^ DO
48700			     IF FORM # ARRAYS
48800			     THEN ERROR(458)
48900			     ELSE
49000			       IF NOT ARRAYPF
49100				OR
49200				NOT (COMPTYPES(AELTYPE,ARRAY1.TYPTR^.AELTYPE)
49300				     AND
49400				     COMPTYPES(INXTYPE,ARRAY1.TYPTR^.INXTYPE))
49500			       THEN ERROR(458)
49600			 END;
49700			ARRAY2 := GATTR;
49800	
49900			 IF NOT ERRORFLAG
50000			 THEN
50100			   BEGIN
50200			    GETBOUNDS(ARRAY1.TYPTR^.INXTYPE,LMIN1,LMAX1); LMAX1 := LMAX1 - LMIN1;
50300			    GETBOUNDS(ARRAY2.TYPTR^.INXTYPE,LMIN2,LMAX2); LMAX2 := LMAX2 - LMIN2;
50400			    WITH OFFSET2 DO  %MAKE OFFSET2 A CONST = LMAX2+1 \
50500				BEGIN
50600				TYPTR := INTPTR;
50700				KIND := CST;
50800				CVAL.IVAL := LMAX2 + 1
50900				END;
51000			     IF (OFFSET1.KIND = CST)
51100			     THEN
51200			       BEGIN
51300				STOP := OFFSET2.CVAL.IVAL;
51400				START := OFFSET1.CVAL.IVAL - LMIN1;
51500				 IF (START < 0) OR (START > (LMAX1+1-STOP))
51600				 THEN ERROR(263);
51700				MACRO3(505B%HRLI\,ARRAY1.REG,-STOP);
51800			       END
51900			     ELSE
52000			       BEGIN
52100				LOAD(OFFSET2);
52200				WITH OFFSET2 DO
52300				  MACRO3(210B%MOVN\,REG,REG);
52400				LOAD(OFFSET1);
52500				WITH OFFSET1 DO
52600				 BEGIN
52700				   IF LMIN1 > 0
52800				   THEN MACRO3(275B%SUBI\,REG,LMIN1)
52900				   ELSE
53000				     IF LMIN1 < 0
53100				     THEN MACRO3(271B%ADDI\,REG,-LMIN1);
53200				   IF RUNTMCHECK
53300				   THEN
53400				     BEGIN
53500				      MACRO3(301B%CAIL\,REG,0);
53600				      MACRO4(303B%CAILE\,REG,OFFSET2.REG,LMAX1+1);
53700				      SUPPORT(INDEXERROR)
53800				     END;
53900				  MACRO3(270B%ADD\,ARRAY1.REG,REG);
54000				  MACRO4(505B%HRLI\,ARRAY1.REG,OFFSET2.REG,0)
54100				 END
54200			       END;
54300			    INCREMENTREGC;
54400			    MACRO3(540B%HRR\,TAC,ARRAY2.REG);
54500			    MACRO3R(200B%MOVE\,REGC,ARRAY2.TYPTR^.ARRAYBPADDR);
54600			    LADDR := IC;
54700			    MACRO4(200B%MOVE\,HAC,ARRAY1.REG,START);
54800			    MACRO3(136B%IDPB\,HAC,REGC);
54900			    MACRO3R(253B%AOBJN\,ARRAY1.REG,LADDR)
55000			   END;
55100			REGC := LREGC
55200		       END;
55300	
55400		      PROCEDURE UNPACK;
55500	
55600			% UNPACK(Z,A,I) MEANS:
55700			 FOR L := LMIN(Z) TO LMAX(Z) DO A[L-LMIN(Z)+I] := Z[L] \
55800	
55900		      VAR
56000			ARRAY1,OFFSET1,ARRAY2,OFFSET2: ATTR;
56100			LADDR,START,STOP,LMIN1,LMAX1,LMIN2,LMAX2: ADDRRANGE;
56200			LREGC: ACRANGE;
56300	
56400		       BEGIN
56500			LREGC := REGC; START := 0;
56600			VARIABLE(FSYS OR [COMMA,RPARENT]);
56700			LOADADDRESS;
56800			WITH GATTR DO
56900			 BEGIN
57000			  KIND := EXPR; REG := INDEXR;
57100	(* 135 - prevent ill mem ref if not a variable *)
57200			   IF TYPTR = NIL
57300			   THEN TYPTR := UARRTYP
57400			   ELSE WITH TYPTR^ DO
57500			     IF FORM # ARRAYS
57600			     THEN ERROR(458)
57700			     ELSE
57800			       IF NOT ARRAYPF
57900			       THEN ERROR(458)
58000			 END;
58100			ARRAY1 := GATTR;
58200			 IF SY = COMMA
58300			 THEN INSYMBOL
58400			 ELSE ERROR(158);
58500			VARIABLE(FSYS OR [COMMA,RPARENT]);
58600			LOADADDRESS;
58700			WITH GATTR DO
58800			 BEGIN
58900			  KIND := EXPR; REG := INDEXR;
59000	(* 135 - prevent ill mem ref if not a variable *)
59100			   IF TYPTR = NIL
59200			   THEN TYPTR := UARRTYP
59300			   ELSE WITH TYPTR^ DO
59400			     IF FORM # ARRAYS
59500			     THEN ERROR(458)
59600			     ELSE
59700			       IF ARRAYPF
59800				OR
59900				NOT (COMPTYPES(AELTYPE,ARRAY1.TYPTR^.AELTYPE)
60000				     AND
60100				     COMPTYPES(INXTYPE,ARRAY1.TYPTR^.INXTYPE))
60200			       THEN ERROR(458)
60300			 END;
60400			ARRAY2 := GATTR;
60500			 IF SY = COMMA
60600			 THEN INSYMBOL
60700			 ELSE ERROR(158);
60800			EXPRESSION(FSYS OR [RPARENT],ONREGC);
60900			 IF GATTR.TYPTR # NIL
61000			 THEN
61100			   IF GATTR.TYPTR^.FORM # SCALAR
61200			   THEN ERROR(458)
61300			   ELSE
61400			     IF NOT COMPTYPES(ARRAY2.TYPTR^.INXTYPE,GATTR.TYPTR)
61500			     THEN ERROR(458);
61600			OFFSET2 := GATTR;
61700	
61800			 IF NOT ERRORFLAG
61900			 THEN
62000			   BEGIN
62100			    GETBOUNDS(ARRAY1.TYPTR^.INXTYPE,LMIN1,LMAX1); LMAX1 := LMAX1 - LMIN1;
62200			    GETBOUNDS(ARRAY2.TYPTR^.INXTYPE,LMIN2,LMAX2); LMAX2 := LMAX2 - LMIN2;
62300			    WITH OFFSET1 DO  %MAKE OFFSET1 A CONST = LMAX1+1 \
62400				BEGIN
62500				TYPTR := INTPTR;
62600				KIND := CST;
62700				CVAL.IVAL := LMAX1 + 1
62800				END;
62900			     IF (OFFSET2.KIND = CST)
63000			     THEN
63100			       BEGIN
63200				STOP := OFFSET1.CVAL.IVAL;
63300				START := OFFSET2.CVAL.IVAL - LMIN2;
63400				 IF (START < 0) OR (START > (LMAX2+1-STOP))
63500				 THEN ERROR(263);
63600				MACRO3(505B%HRLI\,ARRAY2.REG,-STOP);
63700			       END
63800			     ELSE
63900			       BEGIN
64000				LOAD(OFFSET1);
64100				WITH OFFSET1 DO
64200				  MACRO3(210B%MOVN\,REG,REG);
64300				LOAD(OFFSET2);
64400				WITH OFFSET2 DO
64500				 BEGIN
64600				   IF LMIN2 > 0
64700				   THEN MACRO3(275B%SUBI\,REG,LMIN2)
64800				   ELSE
64900				     IF LMIN2 < 0
65000				     THEN MACRO3(271B%ADDI\,REG,-LMIN2);
65100				   IF RUNTMCHECK
65200				   THEN
65300				     BEGIN
65400				      MACRO3(301B%CAIL\,REG,0);
65500				      MACRO4(303B%CAILE\,REG,OFFSET1.REG,LMAX2+1);
65600				      SUPPORT(INDEXERROR)
65700				     END;
65800				  MACRO3(270B%ADD\,ARRAY2.REG,REG);
65900				  MACRO4(505B%HRLI\,ARRAY2.REG,OFFSET1.REG,0)
66000				 END
66100			       END;
66200			    INCREMENTREGC;
66300			    MACRO3(540B%HRR\,TAC,ARRAY1.REG);
66400			    MACRO3R(200B%MOVE\,REGC,ARRAY1.TYPTR^.ARRAYBPADDR);
66500			    LADDR := IC;
66600			    MACRO3(134B%ILDB\,HAC,REGC);
66700			    MACRO4(202B%MOVEM\,HAC,ARRAY2.REG,START);
66800			    MACRO3R(253B%AOBJN\,ARRAY2.REG,LADDR)
66900			   END;
67000			REGC := LREGC
67100		       END;
67200	
67300	
67400		      PROCEDURE NEW;
67500		      CONST
67600			TAGFMAX=5;
67700		      VAR
67800	(* 42 - move GET and PUT here *)
67900	(* 47 - add GETX and RECSIZE - no other comments in body *)
68000			adr:supports; sizereg:acrange;
68100			LSP,LSP1: STP; VARTS,LMIN,LMAX: INTEGER;
68200			FIRSTLOAD:BOOLEAN;
68300			LSIZE,LSZ: ADDRRANGE; LVAL: VALU;
68400			LATTR: ATTR; I,TAGFC: INTEGER;
68500			TAGFSAV: ARRAY[0..TAGFMAX] OF RECORD
68600							TAGFVAL: INTEGER;
68700							TAGFADDR: ADDRRANGE;
68800							LPACKKIND:PACKKIND;
68900	(* 21 - KEEP FROM STORING TAG VALUE IF NO PLACE TO PUT IT *)
69000							TAGWITHID:BOOLEAN
69100						      END;
69200		       BEGIN
69300			FOR I:=0 TO TAGFMAX DO TAGFSAV[I].TAGWITHID := FALSE;
69400	(* 42 - move GET and PUT in here *)
69500	(* 73 - restructure to use GETFN for file names, to allow extern files *)
69600	(* 152 - DISPOSE *)
69700	(* 153 - repair AC usage in DISPOSE *)
69800			if lkey = 44 {dispose}
69900			  then begin
70000			       incrementregc; incrementregc;
70100			       sizereg := regc;
70200			       variable(fsys or [comma,colon,rparent]);
70300			       lattr := gattr;  {We have to use a local copy so that
70400						 if AC1 is loaded here, that fact is
70500						 not saved for the store later.}
70600			       fetchbasis(lattr);
70700			       with lattr do  {modelled after loadaddress}
70800				 macro(vrelbyte,200B%MOVE\,sizereg-1,indbit,indexr,dplmt);
70900			       end
71000	(* 162 - fix RECSIZE *)
71100			else if lkey in [14,35]
71200			  then begin   (* all except file names *)
71300			       incrementregc; sizereg := regc ;
71400			       VARIABLE(FSYS OR [COMMA,COLON,RPARENT]);
71500			       end
71600	(* 175 - validate files for get and put stuff, but not for RECSIZE,
71700		which seems OK even if the file isn't open yet *)
71800			else begin getfn(lkey in [1,3,40]); sizereg := regin+2 end;
71900			LSP := NIL; VARTS := 0; LSIZE := 0; TAGFC := -1;
72000			LATTR := GATTR;
72100			 IF GATTR.TYPTR # NIL
72200			 THEN
72300			  WITH GATTR.TYPTR^ DO
72400	(* 42 - move GET and PUT in here *)
72500	(* 152 - dispose *)
72600	(* 162 - fix RECSIZE *)
72700			   if (lkey in [14,35,44]) and (form=pointer) or
72800			      (lkey in [1,3,15,40]) and (form=files)
72900			   THEN
73000			     BEGIN  %WARNING: This code depends upon fact that ELTYPE and FILTYPE are in the same place\
73100			       IF ELTYPE # NIL
73200			       THEN
73300				 BEGIN
73400				  LSIZE := ELTYPE^.SIZE;
73500				   IF ELTYPE^.FORM = RECORDS
73600				   THEN
73700				     BEGIN
73800				      LSP := ELTYPE^.RECVAR;
73900				     END
74000				   ELSE
74100				     IF ELTYPE^.FORM = ARRAYS
74200				     THEN LSP := ELTYPE
74300				 END
74400			     END
74500			   ELSE ERROR(458);
74600			WHILE SY = COMMA DO
74700			 BEGIN
74800			  INSYMBOL; CONSTANT(FSYS OR [COMMA,COLON,RPARENT],LSP1,LVAL);
74900			  VARTS := VARTS + 1;
75000			  %CHECK TO INSERTADDR HERE: IS CONSTANT IN TAGFIELDTYPE RANGE\
75100			   IF LSP = NIL
75200			   THEN ERROR(408)
75300			   ELSE
75400			     IF STRING(LSP1) OR (LSP1=REALPTR)
75500			     THEN ERROR(460)
75600			     ELSE
75700			       BEGIN
75800				TAGFC := TAGFC + 1;
75900				 IF TAGFC > TAGFMAX
76000				 THEN
76100				   BEGIN
76200				    ERROR(409);TAGFC := TAGFMAX; GOTO 1
76300				   END;
76400				 IF LSP^.FORM = TAGFWITHID
76500				 THEN
76600				   BEGIN
76700				     IF LSP^.TAGFIELDP # NIL
76800				     THEN
76900				       IF COMPTYPES(LSP^.TAGFIELDP^.IDTYPE,LSP1)
77000				       THEN
77100					WITH TAGFSAV[TAGFC],LSP^.TAGFIELDP^ DO
77200					 BEGIN
77300					  TAGFVAL := LVAL.IVAL;
77400					  TAGFADDR:= FLDADDR;
77500					  LPACKKIND:= PACKF;
77600	(* 21 - KEEP FROM STORING TAG VALUE INTO NON-EXISTENT FIELD *)
77700					  TAGWITHID:=TRUE
77800					 END
77900				       ELSE
78000					 BEGIN
78100					  ERROR(458);GOTO 1
78200					 END
78300				   END
78400				 ELSE
78500				   IF LSP^.FORM=TAGFWITHOUTID
     
00100				   THEN
00200				     BEGIN
00300				       IF NOT COMPTYPES(LSP^.TAGFIELDTYPE,LSP1)
00400				       THEN
00500					 BEGIN
00600					  ERROR(458); GOTO 1
00700					 END
00800				     END
00900				   ELSE
01000				     BEGIN
01100				      ERROR(358);GOTO 1
01200				     END;
01300				LSP1 := LSP^.FSTVAR;
01400				WHILE LSP1 # NIL DO
01500				WITH LSP1^ DO
01600				 IF VARVAL.IVAL = LVAL.IVAL
01700				 THEN
01800				   BEGIN
01900				    LSIZE :=SIZE; LSP := SUBVAR; GOTO 1
02000				   END
02100				 ELSE LSP1:=NXTVAR;
02200				LSIZE := LSP^.SIZE; LSP := NIL
02300			       END;
02400	1:
02500			 END %WHILE\ ;
02600			 IF SY = COLON
02700			 THEN
02800			   BEGIN
02900			    INSYMBOL;
03000			    EXPRESSION(FSYS OR [RPARENT],ONREGC);
03100			     IF LSP = NIL
03200			     THEN ERROR(408)
03300			     ELSE
03400			       IF LSP^.FORM # ARRAYS
03500			       THEN ERROR(259)
03600			       ELSE
03700				 BEGIN
03800				   IF  NOT COMPTYPES(GATTR.TYPTR,LSP^.INXTYPE)
03900				   THEN
04000				    ERROR(458);
04100				  LSZ := 1; LMIN := 1;
04200				   IF LSP^.INXTYPE # NIL
04300				   THEN
04400				    GETBOUNDS(LSP^.INXTYPE,LMIN,LMAX);
04500				   IF LSP^.AELTYPE # NIL
04600				   THEN LSZ := LSP^.AELTYPE^.SIZE;
04700				  LOAD(GATTR);
04800	(* 47 - add bounds checking *)
04900				  if runtmcheck
05000				    then begin
05100				    macro3(301B%cail\,regc,lmin);
05200				    macro3(303B%caile\,regc,lmax);
05300				    support(indexerror)
05400				    end;
05500				   IF LSZ # 1
05600				   THEN
05700				    MACRO3(221B%IMULI\,REGC,LSZ);
05800				   IF LSP^.ARRAYPF
05900				   THEN
06000				     BEGIN
06100	(* 30 - added BITMAX DIV, per Nagel's instructions *)
06200	(* 47 - repair calculation, and adjust for LMIN *)
06300				      lsz := bitmax div lsp^.aeltype^.bitsize-1-(lmin-1);
06400				      if lsz > 0
06500					then macro3(271B%addi\,regc,lsz)
06600				      else if lsz < 0
06700					then macro3(275B%subi\,regc,-lsz);
06800				      INCREMENTREGC; REGC := REGC - 1;
06900				      %FOR TESTING BECAUSE IDIV WORKS ON AC+1 TOO\
07000				      MACRO3(231B%IDIVI\,REGC,BITMAX DIV LSP^.AELTYPE^.BITSIZE);
07100				      LSZ := LSIZE - LSP^.SIZE;
07200				     END
07300				   ELSE
07400				    LSZ := LSIZE - LSP^.SIZE - LSZ*(LMIN - 1);
07500	(* 42 - change for GET and PUT *)
07600				    MACRO4(201B%MOVEI\,SIZEREG,REGC,LSZ);
07700				 END
07800			   END
07900			 ELSE MACRO3(201B%MOVEI\,SIZEREG,LSIZE);
08000	(* 24 - DON'T ZERO CORE UNLESS CHECKING *)
08100	(* 25 - USE /ZERO NOW INSTEAD *)
08200	(* 27 - add NEWZ *)
08300	(* 42 - move get and put in here *)
08400			if lattr.typtr # nil
08500			  then begin
08600			  case lkey of
08700			    1:if comptypes(lattr.typtr^.filtype,charptr)
08800			        then adr := getcharacter
08900				else adr := getfile;
09000			    3:adr := putfile;
09100			    14:if zero
09200				then adr := clearalloc
09300				else adr := allocate;
09400			    15:with gattr do
09500				begin typtr:=intptr; reg:=sizereg;kind:=expr;regc:=sizereg end;
09600			    35:adr := clearallocate;
09700			    40:if comptypes(lattr.typtr^.filtype,charptr)
09800				then error(458)
09900				else adr:=getxf;
10000	(* 173 - internal files *)
10100			    44:if lattr.typtr^.eltype <> nil
10200				 then if lattr.typtr^.eltype^.hasfile
10300				        then adr := withfiledeallocate
10400				        else adr := deallocate
10500				 else adr := deallocate
10600			    end;
10700	{Perhaps this is premature optimization, but NEW and DISPOSE do not save any
10800	 ac's.  Hence any that are active here have to be saved by the caller.  Since
10900	 only ac's 1 to 6 are used by the NEW and DISPOSE, we save only things <= 6:
11000	   any WITH ac's <= 6  (a fairly rare case)
11100	   lattr.indexr, if it is <= 6.  This is used in cases such as
11200		new(a^.b^.c)
11300	     to save information needed to get to C again after the call.
11400	   ac 1 sometimes contains the display pointer for a higher-level block.
11500	     However by gerrymandering LATTR, we force this to be recomputed after
11600	     the call by FETCHBASIS, so it is not saved.
11700	}
11800	(* 154 - don't clobber With AC's *)
11900			  if (lkey in [14,35,44]) and (regcmax < 6)
12000			    then for i := 0 to withix do
12100			      with display[top-i] do
12200			        if (cindr#0) and (cindr <= 6)
12300				  then macro4(202B%MOVEM\,cindr,basis,clc);
12400	(* 153 - save AC's *)
12500	(* 154 - don't need to save WITH acs *)
12600	(* 171 - more AC saving *)
12700			  if (lkey in [14,35,44])
12800			   then begin
12900			   if (lattr.indexr > regin) and (lattr.indexr <= 6)
13000			     then macro3(261B%PUSH\,topp,lattr.indexr);
13100			   if (lattr.packfg = packk) and (lattr.bpaddr > regin)
13200						     and (lattr.bpaddr <= 6)
13300			     then macro3(261B%PUSH\,topp,lattr.bpaddr);
13400			   support(adr);
13500			   if (lattr.packfg = packk) and (lattr.bpaddr > regin)
13600						     and (lattr.bpaddr <= 6)
13700			     then macro3(262B%POP\,topp,lattr.bpaddr);
13800			   if (lattr.indexr > regin) and (lattr.indexr <= 6)
13900			     then macro3(262B%POP\,topp,lattr.indexr);
14000			   end
14100			  else if lkey#15
14200			   then support(adr);
14300	(* 154 - restore WITH ac's *)
14400			  if (lkey in [14,35,44]) and (regcmax < 6)
14500			    then for i := 0 to withix do
14600			      with display[top-i] do
14700			        if (cindr#0) and (cindr <= 6)
14800				  then macro4(200B%MOVE\,cindr,basis,clc);
14900			  end;
15000			if (lkey=14)or(lkey=35)
15100			then begin
15200			REGC := REGIN+1;
15300			FIRSTLOAD := TRUE;
15400			FOR I := 0 TO TAGFC DO
15500			WITH TAGFSAV[I] DO
15600	(* 21 - KEEP FROM STORING TAG VALUE INTO NON-EXISTENT FIELD *)
15700			IF TAGWITHID THEN
15800			 BEGIN
15900			  MACRO3(201B%MOVEI\,HAC,TAGFVAL);
16000			   CASE LPACKKIND OF
16100			    NOTPACK:  MACRO4(202B%MOVEM\,HAC,REGC,TAGFADDR);
16200			    HWORDR:MACRO4(542B%HRRM\,HAC,REGC,TAGFADDR);
16300			    HWORDL:MACRO4(506B%HRLM\,HAC,REGC,TAGFADDR);
16400			    PACKK :
16500				    BEGIN
16600				      IF FIRSTLOAD
16700				      THEN
16800					BEGIN
16900					 MACRO3(200B%MOVE\,TAC,REGC);
17000					 FIRSTLOAD := FALSE
17100					END;
17200				     MACRO3R(137B%DPB\,HAC,TAGFADDR)
17300				    END
17400			   END%CASE\
17500			 END;
17600			STORE(REGC,LATTR)
17700	(* 42 - move GET and PUT in here *)
17800			end
17900	(* 152 - DISPOSE *)
18000	(* 153 - make reg usage safer *)
18100		       else if lkey=44
18200			then begin
18300		        incrementregc;
18400		        macro3(201B%MOVEI\,regc,377777B%nil\);
18500			store(regc,lattr)
18600		        end
18700		       END %NEW\ ;
18800	
18900	(* 46 - major reorganization to handle all arg formats *)
19000		      PROCEDURE CALLI;
19100			type argform=(bareac,xwd,twowords,oneword);
19200			VAR LSP:STP; LVAL,acval:VALU;
19300			    LH,RH,BOOL,RESUL:ATTR;
19400			    arg:argform;
19500			BEGIN
19600			arg := xwd;  %default format\
19700			CONSTANT(FSYS OR [RPARENT,COMMA],LSP,LVAL);
19800			IF NOT(COMPTYPES(INTPTR,LSP))
19900			  THEN ERROR(458);
20000			IF SY = COMMA
20100			  THEN INSYMBOL
20200			  ELSE ERROR(158);
20300			if sy=comma %,,word\
20400			  then begin
20500			  insymbol;
20600			  arg := oneword;
20700			  expression(fsys or [rparent,comma],onregc);
20800			  load(gattr);
20900			  lh := gattr
21000			  end
21100			else if sy=colon  %:ac\
21200			  then begin
21300			  arg := bareac;
21400			  insymbol;
21500			  constant(fsys or [rparent,comma],lsp,acval);
21600			  if not(comptypes(intptr,lsp))
21700			    then error(458)
21800			  end
21900			else begin  %lh,rh   or w1:w2\
22000			EXPRESSION(FSYS OR [RPARENT,COMMA,COLON],ONREGC);
22100			LOAD(GATTR);
22200			LH := GATTR;
22300			IF SY = COMMA
22400			  THEN INSYMBOL
22500			else if sy=colon
22600			  then begin arg:=twowords; insymbol end
22700			else error(158);
22800			  EXPRESSION(FSYS OR [RPARENT,COMMA],ONREGC);
22900			  IF GATTR.TYPTR # NIL
23000			    THEN IF (GATTR.TYPTR^.FORM <= POWER) or (arg=twowords)
23100			      THEN LOAD(GATTR)
23200			      ELSE BEGIN
23300			      LOADADDRESS;
23400			      GATTR.KIND:=EXPR;
23500			      GATTR.REG:=GATTR.INDEXR
23600			      END;
23700			  RH := GATTR;
23800			  end  %of lh,rh and w1:w2\;
23900			IF SY = COMMA
24000			  THEN INSYMBOL
24100			  ELSE ERROR(158);
24200			VARIABLE(FSYS OR [RPARENT,COMMA]);
24300			IF GATTR.TYPTR = NIL
24400			  THEN ERROR(458)
24500			  ELSE IF NOT(GATTR.TYPTR^.FORM IN [SUBRANGE,SCALAR])
24600			    THEN ERROR(458)
24700			    ELSE LOADADDRESS;
24800			RESUL:=GATTR;
24900			IF SY = COMMA
25000			  THEN INSYMBOL
25100			  ELSE ERROR(158);
25200			VARIABLE(FSYS OR [RPARENT]);
25300			IF NOT COMPTYPES(BOOLPTR,GATTR.TYPTR)
25400			  THEN ERROR(158)
25500			  ELSE LOADADDRESS;
25600			BOOL := GATTR;
25700			IF NOT ERRORFLAG
25800			  THEN BEGIN
25900			  case arg of
26000			    bareac: regc := acval.ival;
26100			    xwd: begin regc := rh.reg; macro3(504B%hrl\,rh.reg,lh.reg) end;
26200			    oneword: regc := lh.reg;
26300			    twowords: begin
26400				      regc := lh.reg;
26500				      if (regc+1) # rh.reg
26600				        then macro3(200B%move\,regc+1,rh.reg)
26700				      end
26800			  end %case\;
26900			  macro3(201B%movei\,tac,1);
27000			  macro4(202B%movem\,tac,bool.indexr,0);
27100			  MACRO3(047B%CALLI\,REGC,LVAL.IVAL);
27200			  MACRO4(402B%SETZM\,0,BOOL.INDEXR,0);
27300			  MACRO4(202B%MOVEM\,REGC,RESUL.INDEXR,0)
27400			  END
27500			END;
27600	
27700	(* 61 - tops20 system version *)
27800		      procedure jsys;
27900			var
28000			lval:valu; lsp:stp; jsysnum,numrets,i:integer;
28100			retsave:attr; saveret,ercal,done1: Boolean;
28200			realregc:acrange;
28300	(* 133 - add variable to allow saving stuff in display *)
28400			savelc:addrrange;
28500		       procedure loadarg;
28600			(* Handles input args for jsys:
28700			    simple vars - use their values
28800			    sets - use LH word only
28900			    files - use jfn word
29000			    packed arrays - make byte ptr to it
29100			    other - make pointer to it
29200			*)
29300			 begin
29400			 expression (fsys or [rparent,comma,semicolon,colon],onfixedregc);
29500			 if gattr.typtr # nil
29600			  then if (gattr.typtr^.form < power)
29700				then load(gattr)
29800			       else if (gattr.typtr^.form = power)
29900				then begin
30000	(* 77 - can't treat as integer. have to load both words and throw away 2nd *)
30100				load(gattr);
30200				regc := regc-1;
30300				end
30400			       else if (gattr.typtr^.form = files)
30500				then begin
30600				loadaddress;
30700				with lastfile^ do
30800				 if (vlev = 0) and (not main)
30900				  then begin vaddr := ic-1; code.information[cix] := 'E' end;
31000				macro4(200b%move\,regc,regc,filjfn)
31100				end
31200			       else if (gattr.typtr^.form = arrays) and gattr.typtr^.arraypf
31300				then begin
31400				loadaddress;
31500				macro3r(500b%hll\,regc,gattr.typtr^.arraybpaddr);
31600				macro3(621b%tlz\,regc,17b)
31700				end
31800			       else loadaddress
31900			 end;
32000		       procedure storearg;
32100			(* stores results of jsys.  As above, but error for
32200			   anything bigger than a word *)
32300			 begin
32400			 variable(fsys or [rparent,comma]);
32500			 if gattr.typtr # nil
32600			  then if (gattr.typtr^.form < power)
32700				then store(realregc,gattr)
32800			       else if (gattr.typtr^.form = power)
32900				then begin
33000				gattr.typtr := intptr;
33100				store(realregc,gattr)
33200				end
33300			       else if (gattr.typtr^.form = files)
33400				then begin
33500				loadaddress;  {addr of file now in REGC}
33600				with lastfile^ do
33700				 if (vlev = 0) and (not main)
33800				  then begin vaddr:=ic-1; code.information[cix] := 'E' end;
33900	(* 173 - internal files *)
34000	{We have to compile code to see if the file is initialized.  If not,
34100	 call INITB. to do so.  INITB. needs the file in AC 2.  Note that
34200	 the AC use here is such that REGC is always above 2, so the only
34300	 reason for 2 not to be free is that realregc is using it.  This is
34400	 certainly not the best possible code, but at this point I am going
34500	 for the last code in the compiler to implement it.}
34600				macro3(250b%exch\,2,regc);
34700				macro4(200b%move\,0,2,filtst);
34800				macro3(302b%caie\,0,314157B);
34900				support(initfileblock);
35000				if realregc = 2
35100				  then macro4(202b%movem\,regc,2,filjfn)
35200				  else macro4(202b%movem\,realregc,2,filjfn)
35300				end
35400			       else error(458)
35500			 end;
35600			begin (* jsys *)
35700			ercal := false; saveret := false; numrets := 0; done1 := false;
35800			constant(fsys or [rparent,comma,semicolon],lsp,lval);
35900			jsysnum := lval.ival;
36000			if not comptypes (intptr, lsp)
36100			  then error(458);
36200			if sy = comma
36300			  then begin (* return spec *)
36400			  insymbol;
36500			  constant(fsys or [rparent,comma,semicolon],lsp,lval);
36600			  if lval.ival < 0
36700			    then ercal := true;
36800			  numrets := abs(lval.ival);
36900			  if not comptypes (intptr, lsp)
37000			    then error(458);
37100			  if sy = comma
37200			    then begin (* return var *)
37300			    insymbol;
37400			    variable(fsys or [rparent,semicolon]);
37500			    if comptypes (intptr,gattr.typtr)
37600			      then begin saveret := true; retsave := gattr end
37700			      else error (459)
37800			    end
37900			  end; (* return spec *)
38000			if sy = semicolon
38100			  then begin (* prolog *)
38200			  insymbol;
38300			  regc := 1;
38400			  if sy # semicolon
38500			    then loop (* non-empty prolog *)
38600			    loadarg;
38700			    if sy = colon
38800			      then begin
38900			      insymbol;
39000			      realregc := regc;
39100			      loadarg;
39200			      macro3(504b%hrl\,realregc,realregc);
39300			      macro3(540b%hrr\,realregc,regc);
39400			      regc := realregc
39500			      end;
39600			    if not done1
39700			      then begin
39800	(* 133 - save in display instead of PUSH P, *)
39900			      {Here we prepared a place on the display to store the value}
40000			      savelc := lc;
40100			      lc := lc+1;
40200			      if lc > lcmax
40300				then lcmax := lc;
40400			      macro4(202B%movem\,2,basis,savelc);
40500			      done1 := true;
40600			      regc := 1
40700			      end;
40800			    exit if sy # comma;
40900			    insymbol
41000			    end (* non-empty prolog *)
41100			  end; (* prolog *)
41200			(* main call *)
41300			if done1
41400	(* 133 - save in display instead of POP P, *)
41500			  then begin
41600			  macro4(200B%move\,1,basis,savelc);
41700			  lc := savelc
41800			  end;
41900			if saveret
42000			  then macro3(201b%movei\,0,numrets+1);
42100			macro3(104b%jsys\,0,jsysnum);
42200			if ercal
42300			  then begin
42400			  macro3r(320b%jump\,16b,ic+numrets);
42500			  numrets := numrets -1
42600			  end;
42700			for i := 1 to numrets do
42800			  if saveret then
42900			    macro3(275b%subi\,0,1)
43000			    else macro3(255b%jfcl\,0,0);
43100			if sy = semicolon (* if epilog, save reg a over store *)
43200			  then begin
43300	(* 133 - use display instead of stack to save *)
43400			  {find a place in the display to save ac 2}
43500			  savelc := lc;
43600			  lc := lc + 1;
43700			  if lc > lcmax
43800			    then lcmax := lc;
43900			  macro4(202B%movem\,2,basis,savelc);
44000			  macro3(200b%move\,2,1);
44100			  done1 := true
44200			  end
44300			 else done1 := false;
44400			if saveret
44500			  then store(0,retsave);
44600			if sy = semicolon
44700			  then begin (* epilog *)
44800			  realregc := 1;
44900			  repeat
45000			    insymbol;
45100			    regc := 4; (* so temp ac's start at 5 *)
45200			    realregc := realregc + 1;
45300			    if realregc > 4
45400			      then error(458);
45500			    storearg;
45600			    if done1
45700			      then begin
45800	(* 133 - use display instead of stack to store ac 2 *)
45900			      macro4(200B%move\,2,basis,savelc);
46000			      lc := savelc;
46100			      realregc := 1;
46200			      done1 := false
46300			      end
46400			   until sy # comma
46500			  end (* epilog *)
46600			end; (* jsys *)
46700	
46800		      PROCEDURE MARK;
46900		       BEGIN
47000			VARIABLE(FSYS OR [RPARENT]);
47100			 IF COMPTYPES(INTPTR,GATTR.TYPTR)
47200			 THEN
47300	(* 12 - REWRITE FOR NEW DYNAMIC MEMORY *)
47400	(* 122 - retrofit KA code *)
47500	(* 132 - separate KA10 into NOVM and KACPU *)
47600			 if novm
47700			   then begin
47800			   loadaddress;
47900			   macro4(202B%movem\,newreg,gattr.indexr,0)
48000			   end
48100			  else
48200			   BEGIN
48300			   LOADADDRESS;
48400			   INCREMENTREGC;
48500		 	   MACRO3R(200B%MOVE\,REGC,LSTNEW);
48600			   LSTNEW:=IC-1;  %GLOBAL FIXUP\
48700			   MACRO4(202B%MOVEM\,REGC,GATTR.INDEXR,0)
48800			   END
48900			 ELSE ERROR(459)
49000		       END %MARK\ ;
49100	
49200		      PROCEDURE RELEASE;
49300		       BEGIN
49400			EXPRESSION(FSYS OR [RPARENT],ONREGC);
49500			 IF GATTR.TYPTR = INTPTR
49600			 THEN
49700			   BEGIN
49800	(* 12 - RECODE FOR NEW DYNAMIC MEMORY *)
49900			   LOAD(GATTR);
50000	(* 122 - retrofit for KA *)
50100	(* 132 - separate KA10 into NOVM and KACPU *)
50200			   if novm
50300			     then macro3(200B%move\,newreg,regc)
50400			     ELSE BEGIN
50500			     MACRO3R(202B%MOVEM\,REGC,LSTNEW);
50600			     LSTNEW := IC-1;  % GLOBAL FIXUP \
50700			     end
50800			   END
50900			 ELSE ERROR(458)
51000		       END %RELEASE\ ;
51100	
51200		      PROCEDURE GETLINENR;
51300		       BEGIN
51400	(* 33 - ALLOW GETFILENAME WITH NON-TEXT *)
51500	(* 171 - PREDECL FILES ARE SPECIAL *)
51600			GETFILENAME(INFILE,TRUE,THISFILE,GOTARG,TRUE);
51700			IF NOT GOTARG
51800			  THEN ERROR(554);
51900			IF GATTR.KIND <> VARBL
52000			 THEN ERROR(458)
52100			 ELSE IF  GATTR.TYPTR # NIL
52200			 THEN
52300			   IF COMPTYPES(CHARPTR,GATTR.TYPTR^.AELTYPE) AND (GATTR.TYPTR^.FORM = ARRAYS)
52400			   THEN
52500			     BEGIN
52600			      MACRO4(200B%MOVE\,REGC,REGC,FILLNR); STORE(REGC,GATTR)
52700			     END
52800			   ELSE ERROR(458);
52900		       END;
53000	
53100		      PROCEDURE GETINTEGERFILENAME(DEFAULTNAME : ALFA);
53200		      VAR
53300			LCP : CTP; LID : ALFA;
53400		       BEGIN
53500			LID := ID;
53600			ID := DEFAULTNAME; SEARCHID([VARS],LCP);
53700			SELECTOR(FSYS OR FACBEGSYS OR [COMMA], LCP); LOADADDRESS;
53800			WITH LCP^, IDTYPE^ DO
53900			 IF (FORM = FILES) AND (VLEV = 0) AND (NOT MAIN)
54000			 THEN
54100			   BEGIN
54200			    VADDR:= IC-1; CODE.INFORMATION[CIX] := 'E'
54300			   END;
54400			ID := LID
54500		       END;
54600	
54700		      PROCEDURE PUT8BITSTOTTY;
54800		       BEGIN
54900			EXPRESSION(FSYS OR [RPARENT],ONREGC) ;
55000			LOAD(GATTR);
55100			MACRO3(051B%TTCALL\,15B%IONEOU\,GATTR.REG)
55200		       END %PUT8BITSTOTTY\ ;
55300	
55400		      PROCEDURE PAGE;
55500		       BEGIN
55600	(* 33 - ALLOW GETFILENAME WITH NON-TEXT *)
55700	(* 171 - PREDECL FILES ARE SPECIAL *)
55800			GETFILENAME(OUTFILE,TRUE,THISFILE,GOTARG,TRUE);
55900			IF GOTARG
56000			  THEN ERROR(554);
56100			SUPPORT(PUTPAGE)
56200		       END;
56300	(* 63 - support for tops-20 time and runtime *)
56400		      procedure jsysf(jsysnum,hireg:integer);
56500			var i:integer;
56600			begin
56700			if hireg > regc
56800			  then hireg := regc;
56900			for i := 2 to hireg do
57000			  macro3(261B%push\,topp,i);
57100			if jsysnum = 15B
57200			  then macro3(211B%movni\,1,5);
57300			macro3(104B%jsys\,0,jsysnum);
57400			with gattr do
57500			  begin
57600			  incrementregc; typtr := intptr; reg := regc; kind := expr;
57700			  macro3(200B%move\,regc,1)
57800			  end;
57900			for i := hireg downto 2 do
58000			  macro3(262B%pop\,topp,i)
58100			end;
58200	
58300	
58400		      PROCEDURE RUNTIME;
58500		       BEGIN
58600	(* 63 - TOPS20 *)
58700		       IF TOPS10
58800			THEN WITH GATTR DO
58900			 BEGIN
59000			  INCREMENTREGC; TYPTR := INTPTR; REG := REGC; KIND := EXPR;
59100			  MACRO3(047B,REGC,30B%PJOB-UUO\);
59200			  MACRO3(047B,REGC,27B%RUNTIM-UUO\)
59300			 END
59400		        ELSE JSYSF(15B%RUNTM\,3)
59500		       END;
59600	
59700		      PROCEDURE ABS;
59800		       BEGIN
59900			WITH GATTR DO
60000			 IF (TYPTR = INTPTR) OR (TYPTR = REALPTR)
60100			 THEN
60200			  WITH CODE.INSTRUCTION[CIX] DO
60300			   IF INSTR = 200B%MOVE\
60400			   THEN INSTR := 214B%MOVM\
60500			   ELSE MACRO3(214B%MOVM\,REG,REG)
60600			 ELSE
60700			   BEGIN
60800			    ERROR(459); TYPTR:= INTPTR
60900			   END
61000		       END %ABS\ ;
61100	
61200		      PROCEDURE TIME;
61300		       BEGIN
61400	(* 63 - TOPS20 *)
61500			WITH GATTR DO
61600			 BEGIN
61700			  INCREMENTREGC; TYPTR := INTPTR; REG := REGC; KIND := EXPR;
61800			  if tops10
61900			    then MACRO3(047B,REGC,23B%MSTIME-UUO\)
62000			   else begin
62100			   support(getdaytime);
62200			   macro3(262B%POP\,17B,regc)
62300			   end
62400			 END
62500		       END;
62600	
62700		      PROCEDURE SQR;
62800		       BEGIN
62900			WITH GATTR DO
63000			 IF TYPTR = INTPTR
63100			 THEN MACRO3(220B%IMUL\,REG,REG)
63200			 ELSE
63300			   IF TYPTR = REALPTR
63400			   THEN MACRO3(164B%FMPR\,REG,REG)
63500			   ELSE
63600			     BEGIN
63700			      ERROR(459); TYPTR := INTPTR
63800			     END
63900		       END %SQR\ ;
64000	
64100		      PROCEDURE TRUNC;
64200			VAR INSTRUC:1..777;
64300		       BEGIN
64400			IF LKEY = 5
64500			  THEN INSTRUC := 122B%FIX\
64600			  ELSE INSTRUC := 126B%FIXR\;
64700			 IF GATTR.TYPTR # REALPTR
64800			 THEN ERROR(459)
64900			 ELSE
65000	(* 2 - hard code TRUNC using KI-10 op code *)
65100	(* 10 - ADD ROUND *)
65200	(* 101 - fix bad code generation for fix and fixr *)
65300	(* 122 - put back KA code *)	 
65400	(* 132 - separate KA10 into NOVM and KACPU *)
65500			 if kacpu
65600			   then begin
65700			   if lkey=5
65800			     then macro3(551B%hrrzi\,tac,gattr.reg)
65900			     else macro3(561B%hrroi\,tac,gattr.reg);
66000			   support(convertrealtointeger);
66100			   end
66200			  ELSE WITH CODE.INSTRUCTION[CIX] DO
66300			    IF (INSTR = 200B%MOVE\) AND (AC = GATTR.REG)
66400			      THEN INSTR := INSTRUC
66500			      ELSE MACRO3(INSTRUC,GATTR.REG,GATTR.REG);
66600			GATTR.TYPTR := INTPTR
66700		       END %TRUNC\ ;
66800	
66900		      PROCEDURE ODD;
67000		       BEGIN
67100			WITH GATTR DO
67200			 BEGIN
67300			   IF TYPTR # INTPTR
67400			   THEN ERROR(459);
67500			  MACRO3(405B%ANDI\,REG,1);
67600			  TYPTR := BOOLPTR
67700			 END
67800		       END %ODD\ ;
67900	
68000		      PROCEDURE ORD;
68100		       BEGIN
68200			 IF GATTR.TYPTR # NIL
68300			 THEN
68400			   IF GATTR.TYPTR^.FORM >= POWER
68500			   THEN ERROR(459);
68600			GATTR.TYPTR := INTPTR
68700		       END %ORD\ ;
68800	
68900		      PROCEDURE CHR;
69000		       BEGIN
69100			 IF GATTR.TYPTR # INTPTR
69200			 THEN ERROR(459);
69300			GATTR.TYPTR := CHARPTR
69400		       END %CHR\ ;
69500	
69600		      PROCEDURE PREDSUCC;
69700		      VAR
69800			LSTRPTR:STP; LATTR: ATTR;
69900		       BEGIN
70000			 IF GATTR.TYPTR # NIL
70100			 THEN
70200			   IF (GATTR.TYPTR^.FORM>SUBRANGE) OR (GATTR.TYPTR=REALPTR)
70300			   THEN ERROR(459)
70400			   ELSE
70500			     IF RUNTMCHECK
70600			     THEN
70700			       BEGIN
70800				LSTRPTR:=GATTR.TYPTR;
70900				 IF (LSTRPTR^.FORM=SUBRANGE) AND (LSTRPTR^.RANGETYPE #NIL)
71000				 THEN LSTRPTR:=LSTRPTR^.RANGETYPE;
71100				 IF LKEY=9
71200				 THEN
71300				   BEGIN
71400				     IF LSTRPTR=INTPTR
71500				     THEN
71600				       BEGIN
71700					MACRO3R(255B%JFCL\,10B,IC+1);
71800					MACRO3(275B%SUBI\,REGC,1  );
71900					MACRO3R(255B%JFCL\,10B,IC+2);
72000					MACRO3(334B%SKIPA\,0,0	  );
72100					SUPPORT(ERRORINASSIGNMENT)
72200				       END
72300				     ELSE%  CHAR OR DECLARED \
72400				       BEGIN
72500					MACRO3R(365B%SOJGE\,REGC,IC+2);
72600					SUPPORT(ERRORINASSIGNMENT)
72700				       END
72800				   END % LKEY = 9 \
72900				 ELSE % LKEY = 10 \
73000				   BEGIN
73100				     IF LSTRPTR=INTPTR
73200				     THEN
73300				       BEGIN
73400					MACRO3R(255B%JFCL \,10B,IC+1);
73500					MACRO3(271B%ADDI \,REGC,1  );
73600					MACRO3R(255B%JFCL \,10B,IC+2);
73700					MACRO3(334B%SKIPA\,0,0	   );
73800					SUPPORT(ERRORINASSIGNMENT)
73900				       END
74000				     ELSE %CHAR OR DECLARED\
74100				       BEGIN
74200					WITH LATTR DO
74300					 BEGIN
74400					  TYPTR := LSTRPTR; KIND := CST; CVAL.IVAL := 0;
74500					   IF LSTRPTR=CHARPTR
74600					   THEN CVAL.IVAL := 177B
74700					   ELSE
74800					     IF LSTRPTR^.FCONST # NIL
74900					     THEN CVAL.IVAL:=LSTRPTR^.FCONST^.VALUES.IVAL;
75000					  MAKECODE(311B%CAML\,REGC,LATTR);
75100					  SUPPORT(ERRORINASSIGNMENT);
75200					  MACRO3(271B%ADDI \,REGC,1 );
75300					 END
75400				       END
75500				   END % LKEY = 10 \;
75600			       END % RUNTMCHECK \
75700			     ELSE
75800			       IF LKEY = 9
75900			       THEN MACRO3(275B%SUBI\,REGC,1)
76000			       ELSE MACRO3(271B%ADDI\,REGC,1)
76100		       END %PREDSUCC\ ;
76200	
76300		      PROCEDURE EOFEOLN;
76400		       BEGIN
76500	(* 33 - USE GETFILENAME, SO DEFAULTS TO INPUT *)
76600	(* 171 - PREDECL FILES ARE SPECIAL *)
76700		       GETFILENAME(INFILE,FALSE,THISFILE,GOTARG,TRUE);
76800		       IF GOTARG
76900			 THEN ERROR(554);
77000			WITH GATTR DO
77100			 BEGIN
77200			  KIND := EXPR; REG := INDEXR;
77300			   IF LKEY=11
77400			   THEN
77500			     BEGIN
77600			      MACRO4(332B%SKIPE\,REG,REG,FILEOF) ;
77700			      MACRO3(201B%MOVEI\,REG,1) ;
77800			     END
77900			   ELSE MACRO4(200B%MOVE\,REG,REG,FILEOL);
78000			  TYPTR := BOOLPTR
78100			 END
78200		       END %EOF\ ;
78300	
78400		      PROCEDURE PROTECTION;
78500			(* FOR DETAILS SEE  DEC-SYSTEM-10 MONITOR CALLS MANUAL, 3.2.4 *)
78600		       BEGIN
78700			EXPRESSION ( FSYS OR [RPARENT], ONREGC );
78800			 IF GATTR.TYPTR = BOOLPTR
78900	(* 63 - TOPS20 *)
79000			 THEN IF TOPS10
79100			  THEN
79200			   BEGIN
79300			    LOAD(GATTR);
79400			    MACRO3(047B%CALLI\,REGC,36B%SETUWP\);
79500			    MACRO3(254B%HALT\,4,0)
79600			   END
79700			  ELSE
79800			 ELSE ERROR(458)
79900		       END;
80000	
80100		      PROCEDURE CALLNONSTANDARD;
80200		      VAR
80300			NXT,LNXT,LCP: CTP;
80400			LSP: STP;
80500	(* 33 - PROC PARAM.S*)
80600			PKIND,LKIND: IDKIND;	LB: BOOLEAN;
80700			SAVECOUNT,P,I,NOFPAR: INTEGER;
80800			TOPPOFFSET,OFFSET,PARLIST,ACTUALPAR,FIRSTPAR,LLC: ADDRRANGE;
80900			LREGC: ACRANGE;
81000	
81100	(* 111 - STRING, POINTER *)
81200			procedure paramfudge;
81300			  var lmin,lmax:integer;
81400			(* This is used to handle special parameter types with
81500			   reduced type checking, such as STRING, POINTER.  They
81600			   are always one of STRINGPTR, POINTERPTR, or POINTERREF.
81700			   STRINGPTR is for STRING, the other two for POINTER.
81800			   POINTERREF is for call by ref *)
81900			begin
82000			with gattr.typtr^ do
82100			  if lsp=stringptr
82200			    then if (form=arrays) and arraypf
82300			      then if comptypes(aeltype,charptr)
82400				then begin  (* STRING *)
82500				getbounds (gattr.typtr^.inxtype, lmin, lmax);
82600				loadaddress;
82700				incrementregc;
82800				macro3(201B%movei\,regc,lmax-lmin+1);
82900				end
83000			       else error(503)
83100			      else error(503)
83200			    else if form=pointer  {pointerptr or pointerref}
83300			      then if eltype <> nil
83400				then begin (* POINTER *)
83500	(* 202 - fix up pointer by ref *)
83600				if lsp = pointerptr
83700				  then load(gattr)
83800				  else loadaddress;
83900				incrementregc;
84000				macro3(201B%movei\,regc,eltype^.size)
84100				end
84200			       else  (* bad type decl - already have error *)
84300			      else error(503);
84400			gattr.typtr := lsp  (* so comptypes later succeeds *)
84500			end;
84600	
84700		       BEGIN
84800			NOFPAR:= 0; TOPPOFFSET := 0; PARLIST := 0; ACTUALPAR := 0;
84900			WITH FCP^ DO
85000			 BEGIN
85100			  NXT := NEXT; LKIND := PFKIND;
85200			   IF KLASS = FUNC
85300			   THEN FIRSTPAR := 2
85400			   ELSE FIRSTPAR := 1;
85500	(* 33 - PROC PARAM.S *)
85600			   IF LKIND = ACTUAL
85700			   THEN IF EXTERNDECL
85800			   THEN LIBRARY[LANGUAGE].CALLED:= TRUE;
85900			  SAVECOUNT := REGC - REGIN;
86000			   IF  SAVECOUNT > 0
86100			   THEN
86200			     BEGIN
86300			      LLC := LC ;
86400			      LC := LC + SAVECOUNT ;
86500			       IF LC > LCMAX
86600			       THEN  LCMAX := LC ;
86700			       IF SAVECOUNT > 3
86800			       THEN
86900				 BEGIN
87000				  MACRO3(505B%HRLI\,TAC,2);
87100				  MACRO4(541B%HRRI\,TAC,BASIS,LLC);
87200				  MACRO4(251B%BLT\,TAC,BASIS,LLC+SAVECOUNT-1)
87300				 END
87400			       ELSE FOR  I := 1 TO SAVECOUNT DO  MACRO4(202B%MOVEM\,REGIN+I,BASIS,LLC+I-1)
87500			     END;
87600			  LREGC:= REGC;
87700			  IF LKIND = FORMAL
87800			    THEN REGC := REGIN
87900			  ELSE IF LANGUAGE # PASCALSY
88000			    THEN REGC:= PARREGCMAX
88100			  ELSE REGC:= REGIN
88200			 END;
88300			 IF SY = LPARENT
88400			 THEN
88500			   BEGIN
88600			     REPEAT
88700			      LB := FALSE;  %DECIDE WHETHER PROC/FUNC MUST BE PASSED\
88800			       IF LKIND = ACTUAL
88900			       THEN
89000				 BEGIN
89100				   IF NXT = NIL
89200				   THEN ERROR(554)
89300				   ELSE LB := NXT^.KLASS IN [PROC,FUNC]
89400				 END
89500	(* 33 - PROC PARAM.S *)
89600			       ELSE LB := FALSE;
89700				%FOR FORMAL PROC/FUNC LB IS FALSE AND EXPRESSION
89800				 WILL BE CALLED, WHICH WILL ALLWAYS INTERPRET A PROC/FUNC ID
89900				 AT ITS BEGINNING AS A CALL RATHER THAN A PARAMETER PASSING.
90000				 IN THIS IMPLEMENTATION, PARAMETER PROCEDURES/FUNCTIONS
90100				 ARE THEREFORE NOT ALLOWED TO HAVE PROCEDURE/FUNCTION
90200				 PARAMETERS\
90300			      INSYMBOL;
90400			       IF LB
90500			       THEN   %PASS FUNCTION OR PROCEDURE\
90600				 BEGIN
90700				   IF SY # IDENT
90800				   THEN
90900				    ERRANDSKIP(209,FSYS OR [COMMA,RPARENT])
91000				   ELSE
91100				     BEGIN
91200				       IF NXT^.KLASS = PROC
91300				       THEN SEARCHID([PROC],LCP)
91400				       ELSE
91500					 BEGIN
91600					  SEARCHID([FUNC],LCP);
91700					   IF  NOT COMPTYPES(LCP^.IDTYPE,NXT^.IDTYPE)
91800					   THEN
91900					    ERROR(555)
92000					 END;
92100				      INSYMBOL;
92200				      IFERRSKIP(166,FSYS OR [COMMA,RPARENT])
92300				     END;
92400	(* 33 - PROC PARAM.S *)
92500				 WITH LCP^ DO
92600				  IF (PFDECKIND = STANDARD) OR (PFKIND = ACTUAL) AND (LANGUAGE # PASCALSY)
92700				    THEN ERROR (466)
92800				    ELSE BEGIN
92900				    INCREMENTREGC;
93000	(* 67 - fix proc param's *)
93100				   if pflev > 1
93200				     then p := level - pflev
93300				     else p := 0;
93400				    IF PFKIND = ACTUAL
93500				      THEN BEGIN
93600				      IF P = 0
93700					THEN MACRO3(514B%HRLZ\,REGC,BASIS)
93800				      ELSE IF P=1
93900					THEN MACRO4(514B%HRLZ\,REGC,BASIS,-1)
94000				      ELSE %P>1\
94100					BEGIN
94200					MACRO4(550B%HRRZ\,REGC,BASIS,-1);
94300					FOR I := 3 TO P DO MACRO4(550B%HRRZ\,REGC,REGC,-1);
94400					MACRO4(514B%HRLZ\,REGC,REGC,-1)
94500					END;
94600				    IF PFADDR = 0
94700				      THEN BEGIN
94800	(* 67 - fix typo: R in macro3r omitted *)
94900				      MACRO3R(541B%HRRI\,REGC,LINKCHAIN[P]);
95000				      LINKCHAIN[P] := IC - 1;
95100				      IF EXTERNDECL
95200					THEN CODE.INFORMATION[CIX] := 'E'
95300					ELSE CODE.INFORMATION[CIX] := 'F'
95400				      END
95500				     ELSE MACRO3R(541B%HRRI\,REGC,PFADDR);
95600				    END %OF PFKIND = ACTUAL \
95700				    ELSE %PFKIND = FORMAL \
95800				      IF P = 0
95900					THEN MACRO4(200B%MOVE\,REGC,BASIS,PFADDR)
96000					ELSE
96100					  BEGIN
96200					  MACRO4(200B%MOVE\,REGC,BASIS,-1);
96300					  FOR I := 2 TO P DO MACRO4(200B%MOVE\,REGC,REGC,-1);
96400					  MACRO4(200B%MOVE\,REGC,REGC,PFADDR)
96500					  END
96600				    END;
96700				 END %IF LB\
96800			       ELSE
96900				 BEGIN
97000				  EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
97100				   IF GATTR.TYPTR # NIL
97200				   THEN
97300	(* 33 - PROC PARAM.S *)
97400				       BEGIN
97500	%NOTE : WE TREAT ALL PARAM'S OF A FORMAL PROC AS ACTUAL\
97600					 IF (NXT # NIL) OR (LKIND = FORMAL)
97700					 THEN
97800					   BEGIN
97900	(*33 - PROC PARAM.S *)
98000					    IF LKIND = FORMAL
98100					      THEN BEGIN LSP := GATTR.TYPTR; PKIND := ACTUAL END
98200					      ELSE BEGIN LSP := NXT^.IDTYPE; PKIND := NXT^.VKIND END;
98300					     IF LSP # NIL
98400					     THEN
98500					       BEGIN
98600	(* 33 - PROC PARAM.S *)
98700	(* 161 - fix STRING,POINTER *)
98800						IF  (PKIND = ACTUAL)
98900						 THEN
99000						   IF LSP^.SIZE <= 2
99100						   THEN
99200						     BEGIN
99300	(* 104 - more range checking for subrange things *)
99400	(* 202 - pointer by ref *)
99500						       if (lsp = stringptr) or
99600							  (lsp = pointerptr) or
99700							  (lsp = pointerref)
99800							     then paramfudge
99900						       else if lsp^.form = subrange
     
00100							then loadsubrange(gattr,lsp)
00200						       else load(gattr);
00300						       IF COMPTYPES(REALPTR,LSP)
00400							AND (GATTR.TYPTR = INTPTR)
00500						       THEN MAKEREAL(GATTR)
00600						     END
00700						   ELSE
00800						     BEGIN
00900						      LOADADDRESS;
01000	(* 33 - PROC PARAM.S *)
01100						       IF (LKIND = ACTUAL) AND (FCP^.LANGUAGE # PASCALSY)
01200						       THEN CODE.INSTRUCTION[CIX].INSTR := 505B%HRLI\
01300						     END
01400						 ELSE
01500						   IF GATTR.KIND = VARBL
01600						   THEN LOADADDRESS
01700						   ELSE ERROR(463) ;
01800	(* 22 - ALLOW EXTERNAL FILE REFERENCES *)
01900						 IF GATTR.TYPTR#NIL
02000						  THEN IF GATTR.TYPTR^.FORM=FILES
02100						    THEN WITH LASTFILE^ DO
02200						     IF (VLEV=0) AND (NOT MAIN)
02300						      THEN BEGIN VADDR:=IC-1;CODE.INFORMATION[CIX]:='E' END;
02400	(* 64 - fix proc param's that don't fit in ac's *)
02500						 IF  NOT COMPTYPES(LSP,GATTR.TYPTR)
02600						 THEN ERROR(503)
02700					       END
02800					   END
02900				       END
03000	(* 33 - PROC PARAM.S *)
03100				 END;
03200				 IF REGC>PARREGCMAX
03300				 THEN
03400	(* 33 - PROC PARAM.S *)
03500	(* NOTE: CURRENTLY WE PUNT IF ARG'S DON'T FIT IN AC'S IN FORMAL PROC*)
03600				  IF LKIND=FORMAL
03700				   THEN ERROR(413)
03800				   ELSE BEGIN
03900				     IF TOPPOFFSET = 0
04000				     THEN
04100				       BEGIN
04200					LNXT := FCP^.NEXT ;
04300					 IF FCP^.LANGUAGE = PASCALSY
04400	(* 62 - clean up offset *)
04500					 then toppoffset := fcp^.poffset + 1
04600					 ELSE
04700					   BEGIN
04800					    TOPPOFFSET := 1 + FIRSTPAR;
04900					     REPEAT
05000					      WITH LNXT^ DO
05100					       BEGIN
05200						NOFPAR := NOFPAR +1;
05300						TOPPOFFSET := TOPPOFFSET + 1;
05400						 IF VKIND = ACTUAL
05500						 THEN TOPPOFFSET := TOPPOFFSET + IDTYPE^.SIZE;
05600						 IF LKIND = ACTUAL
05700						 THEN LNXT := NEXT
     
00100					       END;
00200					     UNTIL LNXT = NIL;
00300					    PARLIST := 1 + FIRSTPAR;
00400					    ACTUALPAR := PARLIST + NOFPAR
00500					   END;
00600	(* 104 - TOPS20 DETECTION OF STACK OVERFLOW *)
00700	(* 115 - TENEX *)
00800					IF KLCPU AND NOT TOPS10
00900					  THEN MACRO3(105B%ADJSP\,TOPP,TOPPOFFSET)
01000					  ELSE MACRO3(271B%ADDI\,TOPP,TOPPOFFSET);
01100	(* 54 - keep track of how many loc's above stack are used *)
01200					stkoff := stkoff + toppoffset;
01300					if stkoff > stkoffmax
01400					  then stkoffmax := stkoff
01500				       END ;
01600				    WITH NXT^ DO
01700				     BEGIN
01800				       IF FCP^.LANGUAGE = PASCALSY
01900				       THEN
02000	(* 64 - fix parameter proc's that don't fit in ac's *)
02100				       if klass # vars
02200					 then macro4(202b%movem\,regc,topp,pfaddr+1-toppoffset)
02300					 ELSE BEGIN
02400	(* 52 - if VAR, size is always 1 *)
02500					   IF (VKIND=ACTUAL) AND (IDTYPE^.SIZE=2)
02600					   THEN
02700					     BEGIN
02800					      MACRO4(202B%MOVEM\,REGC,TOPP,VADDR+2-TOPPOFFSET);
02900					      REGC := REGC - 1
03000					     END;
03100	(* 201 - zero size things *)
03200					  IF (IDTYPE^.SIZE > 0) OR (VKIND <> ACTUAL)
03300					    THEN MACRO4(202B%MOVEM\,REGC,TOPP,VADDR+1-TOPPOFFSET)
03400					 END
03500				       ELSE
03600	(* 64 - proc param's that don't fit in ac's *)
03700					if klass # vars
03800					 then error(466)
03900					 ELSE BEGIN
04000					   IF VKIND = ACTUAL
04100					   THEN
04200					     BEGIN
04300					       IF IDTYPE^.SIZE <= 2
04400					       THEN
04500						 BEGIN
04600						   IF IDTYPE^.SIZE = 2
04700						   THEN
04800						     BEGIN
04900						      MACRO4(202B%MOVEM\,REGC,TOPP,ACTUALPAR+1-TOPPOFFSET);
05000						      REGC := REGC - 1
05100						     END;
05200	(* 201 - zero size objects *)
05300						  IF IDTYPE^.SIZE > 0
05400						    THEN MACRO4(202B%MOVEM\,REGC,TOPP,ACTUALPAR-TOPPOFFSET);
05500						  MACRO4(541B%HRRI\,REGC,TOPP,ACTUALPAR-TOPPOFFSET)
05600						 END
05700					       ELSE
05800						 BEGIN
05900						  MACRO4(541B%HRRI\,REGC,TOPP,ACTUALPAR-TOPPOFFSET);
06000						  MACRO4(251B%BLT\,REGC,TOPP,ACTUALPAR+IDTYPE^.SIZE-1-TOPPOFFSET);
06100	(* 52 - BLT may change REGC, so reset it since used below *)
06200						  MACRO4(541B%HRRI\,REGC,TOPP,ACTUALPAR-TOPPOFFSET)
06300						 END;
06400					      ACTUALPAR := ACTUALPAR + IDTYPE^.SIZE
06500					     END;
06600					  MACRO4(552B%HRRZM\,REGC,TOPP,PARLIST-TOPPOFFSET);
06700					  PARLIST := PARLIST + 1
06800					 END;
06900				      REGC := PARREGCMAX
07000				     END
07100				   END;
07200			       IF (LKIND = ACTUAL) AND (NXT # NIL)
07300			       THEN NXT := NXT^.NEXT
07400			     UNTIL SY # COMMA;
07500			     IF SY = RPARENT
07600			     THEN INSYMBOL
07700			     ELSE ERROR(152)
07800			   END %IF LPARENT\;
07900			FOR I := 0 TO WITHIX DO
08000			WITH DISPLAY[TOP-I] DO
08100			 IF (CINDR#0)  AND  (CINDR#BASIS)
08200			 THEN
08300			  MACRO4(202B%MOVEM\,CINDR,BASIS,CLC);
08400			WITH FCP^ DO
08500			 BEGIN
08600	(* 33 - PROC. PARAM.S *)
08700			   IF LKIND = FORMAL
08800			     THEN BEGIN END %TOPOFFSET=0 ALWAYS AT THE MOMENT\
08900			   ELSE IF  (LANGUAGE = PASCALSY) AND (TOPPOFFSET # 0)
09000	(* 54 - keep track of offsets above top of stack *)
09100	(* 62 - clean up offset *)
09200			     THEN STKOFF := STKOFF - TOPPOFFSET
09300			   ELSE IF (LANGUAGE # PASCALSY) AND (TOPPOFFSET = 0)
09400			     THEN
09500			     BEGIN
09600			      TOPPOFFSET:= FIRSTPAR+2;
09700	(* 104 - TOPS20 ADJSP *)
09800	(* 115 - TENEX *)
09900			      IF KLCPU AND NOT TOPS10
10000				THEN MACRO3(105B%ADJSP\,TOPP,TOPPOFFSET)
10100			        ELSE MACRO3(271B%ADDI\,TOPP,TOPPOFFSET);
10200	(* 54 - keep track of how many loc's above stack are used *)
10300			      STKOFF := STKOFF + TOPPOFFSET;
10400			      IF STKOFF > STKOFFMAX
10500			        THEN STKOFFMAX := STKOFF
10600			     END;
10700			   IF PFLEV > 1
10800			   THEN P := LEVEL - PFLEV
10900			   ELSE P:= 0;
11000			   IF LKIND = ACTUAL
11100			   THEN
11200			     BEGIN
11300			       IF NXT # NIL
11400			       THEN ERROR(554);
11500			       IF LANGUAGE # PASCALSY
11600			       THEN
11700				 BEGIN
11800				  MACRO3(515B%HRLZI\,HAC,-NOFPAR);
11900				  MACRO4(202B%MOVEM\,HAC,TOPP,FIRSTPAR-TOPPOFFSET);
12000				  MACRO4(202B%MOVEM\,BASIS,TOPP,-TOPPOFFSET);
12100				  MACRO4(201B%MOVEI\,BASIS,TOPP,FIRSTPAR-TOPPOFFSET+1);
12200				   IF NOFPAR = 0
12300				   THEN MACRO4(402B%SETZM\,0,TOPP,FIRSTPAR-TOPPOFFSET+1)
12400				 END;
12500			       IF PFADDR = 0
12600			       THEN
12700				 BEGIN
12800				  MACRO3R(260B%PUSHJ\,TOPP,LINKCHAIN[P]); LINKCHAIN[P]:= IC-1;
12900				   IF EXTERNDECL
13000				   THEN CODE.INFORMATION[CIX] := 'E'
13100				   ELSE CODE.INFORMATION[CIX] := 'F'
13200				 END
13300			       ELSE MACRO3R(260B%PUSHJ\,TOPP,PFADDR-P);
13400	(* 33 - PROC PARAM.S *)
13500			   IF LANGUAGE # PASCALSY
13600			   THEN
13700			     BEGIN
13800	(* 104 - TOPS20 ADJSP *)
13900			      IF KLCPU AND NOT TOPS10
14000				THEN MACRO3(105B%ADJSP\,TOPP,-TOPPOFFSET)
14100			        ELSE MACRO3(275B%SUBI\,TOPP,TOPPOFFSET);
14200	(* 54 - keep track of how many loc's above stack are used *)
14300			      STKOFF := STKOFF - TOPPOFFSET;
14400			       IF KLASS = FUNC
14500			       THEN
14600				 BEGIN
14700				  MACRO4(202B%MOVEM\,HAC,TOPP,2);
14800				   IF IDTYPE^.SIZE = 2
14900				   THEN MACRO4(202B%MOVEM\,TAC,TOPP,3)
15000				 END;
15100			      MACRO4(200B%MOVE\,BASIS,TOPP,0)
15200			     END
15300	(* 33 - PROC PARAM.S *)
15400			     END  (* OF LKIND = ACTUAL *)
15500			   ELSE
15600			     BEGIN
15700			     IF P = 0
15800			      THEN BEGIN
15900			       MACRO4(550B%HRRZ\,TAC,BASIS,PFADDR);
16000			       MACRO4(544B%HLR\,BASIS,BASIS,PFADDR)
16100			       END
16200			      ELSE BEGIN
16300			       MACRO4(550B%HRRZ\,TAC,BASIS,-1);
16400			       FOR I := 2 TO P DO MACRO4(550B%HRRZ\,TAC,TAC,-1);
16500			       MACRO4(544B%HLR\,BASIS,TAC,PFADDR);
16600			       MACRO4(550B%HRRZ\,TAC,TAC,PFADDR)
16700			       END;
16800			     MACRO4(260B%PUSHJ\,TOPP,TAC,0)
16900			     END
17000			 END;
17100			FOR I := 0 TO WITHIX DO
17200			WITH DISPLAY[TOP-I] DO
17300			 IF (CINDR#0)  AND  (CINDR#BASIS)
17400			 THEN MACRO4(200B%MOVE\,CINDR,BASIS,CLC) ;
17500			 IF  SAVECOUNT > 0
17600			 THEN
17700			   BEGIN
17800			     IF SAVECOUNT > 3
17900			     THEN
18000			       BEGIN
18100				MACRO4(505B%HRLI\,TAC,BASIS,LLC);
18200				MACRO3(541B%HRRI\,TAC,2);
18300				MACRO3(251B%BLT\,TAC,SAVECOUNT+1)
18400			       END
18500			     ELSE FOR  I := 1 TO SAVECOUNT  DO	MACRO4(200B%MOVE\,REGIN+I,BASIS,LLC+I-1) ;
18600			    LC := LLC
18700			   END ;
18800			GATTR.TYPTR := FCP^.IDTYPE; REGC := LREGC
18900		       END %CALLNONSTANDARD\ ;
19000	
19100		     BEGIN
19200		      %CALL\
19300		       IF FCP^.PFDECKIND = STANDARD
19400		       THEN
19500			 BEGIN
19600			  LKEY := FCP^.KEY;
19700			   IF FCP^.KLASS = PROC
19800			   THEN
19900			     BEGIN
20000	(* 26 - allow non-text files *)
20100	(* 61 - rclose *)
20200			       IF NOT (LKEY IN [7,8,9,10,11,17,19,25,34,39,42] )
20300			       THEN
20400				 IF SY = LPARENT
20500				 THEN INSYMBOL
20600				 ELSE ERROR(153);
20700	(* 45 - APPEND, UPDATE, RENAME, use REG5 and REG6 *)
20800			       IF (LKEY IN [5,6,7,8,10,11,27,29,36]) AND (REGCMAX <= 8)
20900			       THEN ERROR(317);
21000				%REGISTER USED BY RUNTIME SUPPORT FREE OR NOT  \
21100			       CASE LKEY OF
21200	(* 42 - move GET and PUT to NEW *)
21300				2,4,
21400	(* 14 - NEW DUMP MODE I/O *)
21500				5,6,27,28,29,36:  GETPUTRESETREWRITE;
21600				7,
21700				8:
21800				   BEGIN
21900				    READREADLN;
22000				     IF NORIGHTPARENT
22100				     THEN GOTO 9
22200				   END;
22300				9:
22400				   BEGIN
22500				    BREAK;
22600				     IF NORIGHTPARENT
22700				     THEN GOTO 9
22800				   END;
22900				10,
23000				11:
23100				    BEGIN
23200				     WRITEWRITELN;
23300				      IF NORIGHTPARENT
23400				      THEN GOTO 9
23500				    END;
23600				12:    PACK;
23700				13:    UNPACK;
23800	(* 27 - add NEWZ *)
23900	(* 42 - move GET and PUT to NEW *)
24000	(* 152 - add DISPOSE *)
24100				1,3,14,35,40,44:    NEW;
24200				15:    MARK;
24300				16:    RELEASE;
24400				17:    GETLINENR;
24500				18:    PUT8BITSTOTTY;
24600				19:
24700				    BEGIN
24800				     PAGE;
24900				      IF NORIGHTPARENT
25000				      THEN GOTO 9
25100				    END;
25200				21:    PROTECTION;
25300	(* 10 - ADD SETSTRING *)
25400				22,23:  SETSTRING;
25500				24:	GETINDEX;
25600	(* 26 - allow non-text files *)
25700	(* 42 - move breakin to close *)
25800	(* 61 - rclose *)
25900				25,34,39,42:	BEGIN CLOSE;IF NORIGHTPARENT THEN GOTO 9 END;
26000				26:CALLI;
26100	(* 14 - NEW DUMP MODE I/O *)
26200				30,31:DUMP;
26300				32,33,38:USET;
26400	(* 61 - delete *)
26500				37,41:PUTX;
26600	(* 61 - tops20 system version *)
26700			        43:JSYS
26800			       END
26900			     END
27000			   ELSE
27100			     BEGIN
27200			       IF NOT (LKEY IN [1,2,11,12])
27300			       THEN
27400				 BEGIN
27500				   IF SY = LPARENT
27600				   THEN INSYMBOL
27700				   ELSE ERROR(153);
27800				  if lkey#15
27900				    then EXPRESSION(FSYS OR [RPARENT],ONREGC);
28000				   IF NOT (LKEY IN [7,8,11,12,15])
28100				   THEN LOAD(GATTR)
28200				 END;
28300			       CASE LKEY OF
28400				1:    RUNTIME;
28500				2:    TIME;
28600				3:    ABS;
28700				4:    SQR;
28800				5,14:    TRUNC;
28900				6:    ODD;
29000				7:    ORD;
29100				8:    CHR;
29200				9,10:  PREDSUCC;
29300				11,12: BEGIN EOFEOLN; IF NORIGHTPARENT THEN GOTO 9 END;
29400				15: NEW
29500			       END;
29600			       IF LKEY < 3
29700			       THEN GOTO 9
29800			     END;
29900			   IF SY = RPARENT
30000			   THEN INSYMBOL
30100			   ELSE ERROR(152);
30200	9:
30300			 END %STANDARD PROCEDURES AND FUNCTIONS\
30400		       ELSE CALLNONSTANDARD
30500		     END %CALL\ ;
30600	
30700		    PROCEDURE EXPRESSION;
30800		    VAR
30900		      LATTR: ATTR; LOP: OPERATOR; LSIZE: ADDRRANGE; LOFFSET: INTEGER; DEFAULT,NEEDSHIFT: BOOLEAN;
31000		      BOOLREGC,TESTREGC:ACRANGE; LINSTR,LINSTR1: INSTRANGE; LREGC1,LREGC2: ACRANGE;
31100		      SETINCLUSION : BOOLEAN; JMPADRIFALLEQUAL : INTEGER;
31200	
31300		      PROCEDURE CHANGEBOOL(VAR FINSTR: INSTRANGE);
31400		       BEGIN
31500			 IF (FINSTR>=311B) AND (FINSTR<=313B)
31600			 THEN FINSTR := FINSTR+4  %CAML,CAME,CAMLE --> CAMGE,CAMN,CAMG\
31700			 ELSE
31800			   IF (FINSTR>=315B) AND (FINSTR<=317B)
31900			   THEN FINSTR := FINSTR-4  %SAME IN THE OTHER WAY\;
32000		       END;
32100	
32200		      PROCEDURE SEARCHCODE(FINSTR:INSTRANGE; FATTR: ATTR);
32300			PROCEDURE CHANGEOPERANDS(VAR FINSTR:INSTRANGE);
32400			 BEGIN
32500			   IF FINSTR=311B%CAML\
32600			   THEN FINSTR := 317B%CAMG\
32700			   ELSE
32800			     IF FINSTR = 313B%CAMLE\
32900			     THEN FINSTR := 315B%CAMGE\
33000			     ELSE
33100			       IF FINSTR=315B%CAMGE\
33200			       THEN FINSTR := 313B%CAMLE\
33300			       ELSE
33400				 IF FINSTR = 317B%CAMG\
33500				 THEN FINSTR := 311B%CAML\
33600				 ELSE
33700				   IF FINSTR = 420B%ANDCM\
33800				   THEN FINSTR := 410B%ANDCA\
33900				   ELSE
34000				     IF FINSTR = 410B%ANDCA\
34100				     THEN FINSTR := 420B%ANDCM\;
34200			 END;
34300	
34400		       BEGIN
34500			WITH GATTR DO
34600			 IF FATTR.KIND = EXPR
34700			 THEN
34800			   BEGIN
34900			    MAKECODE(FINSTR,FATTR.REG,GATTR); REG := FATTR.REG
35000			   END
35100			 ELSE
35200			   IF KIND = EXPR
35300			   THEN
35400			     BEGIN
35500			      CHANGEOPERANDS(FINSTR); MAKECODE(FINSTR,REG,FATTR)
35600			     END
35700			   ELSE
35800			     IF (KIND=VARBL) AND ((PACKFG#NOTPACK)
35900						  OR (INDEXR>REGIN) AND (INDEXR<=REGCMAX) AND
36000						  ((FATTR.INDEXR<=REGIN) OR (FATTR.INDEXR>REGCMAX)))
36100			     THEN
36200			       BEGIN
36300				LOAD(GATTR); CHANGEOPERANDS(FINSTR); MAKECODE(FINSTR,REG,FATTR)
36400			       END
36500			     ELSE
36600			       BEGIN
36700				LOAD(FATTR); MAKECODE(FINSTR,FATTR.REG,GATTR); REG := FATTR.REG
36800			       END;
36900		       END;
37000	
37100		      PROCEDURE SIMPLEEXPRESSION(FSYS: SETOFSYS);
37200		      VAR
37300			LATTR: ATTR; LOP: OPERATOR; SIGNED : BOOLEAN;
37400	(* 52 - new var needed to prevent clobbering CONST decl. *)
37500			NEWREALCSP: CSP;
37600	
37700			PROCEDURE TERM(FSYS: SETOFSYS);
37800			VAR
37900			  LATTR: ATTR; LOP: OPERATOR;
38000	
38100			  PROCEDURE FACTOR(FSYS: SETOFSYS);
38200			  VAR
38300			    LCP: CTP; LVP: CSP; VARPART: BOOLEAN;
38400			    CSTPART: SET OF 0..71; LSP: STP;
38500			    RANGEPART: BOOLEAN;LRMIN: INTEGER;
38600			   BEGIN
38700			     IF NOT (SY IN FACBEGSYS)
38800			     THEN
38900			       BEGIN
39000				ERRANDSKIP(173,FSYS OR FACBEGSYS);
39100				GATTR.TYPTR := NIL
39200			       END;
39300			     IF SY IN FACBEGSYS
39400			     THEN
39500			       BEGIN
39600				 CASE SY OF
39700				  %ID\	  IDENT:
39800						 BEGIN
39900						  SEARCHID([KONST,VARS,FIELD,FUNC],LCP);
40000						  INSYMBOL;
40100						   IF LCP^.KLASS = FUNC
40200						   THEN
40300						     BEGIN
40400						      CALL(FSYS,LCP);
40500						       IF LCP^.PFDECKIND=DECLARED
40600						       THEN
40700							 BEGIN
40800							  WITH LCP^,GATTR DO
40900							   BEGIN
41000							    TYPTR :=IDTYPE; KIND :=VARBL; PACKFG :=NOTPACK;
41100							    VRELBYTE := NO;
41200							    VLEVEL :=1; DPLMT :=2;
41300							    INDEXR := TOPP; INDBIT :=0;
41400							     IF TYPTR # NIL
41500							     THEN
41600							       IF TYPTR^.SIZE = 1
41700							       THEN LOAD(GATTR)
41800							   END
41900							 END
42000						     END
42100						   ELSE
42200						     IF LCP^.KLASS = KONST
42300						     THEN
42400						      WITH GATTR, LCP^ DO
42500						       BEGIN
42600							TYPTR := IDTYPE; KIND := CST;
42700							CVAL := VALUES
42800						       END
42900						     ELSE
43000						      SELECTOR(FSYS,LCP);
43100						   IF GATTR.TYPTR # NIL
43200						   THEN       %ELIM. SUBR. TYPES TO\
43300						    WITH GATTR, TYPTR^ DO	  %SIMPLIFY LATER TESTS\
43400						     IF FORM = SUBRANGE
43500						     THEN  TYPTR := RANGETYPE
43600						 END;
43700				  %CST\   INTCONST:
43800						    BEGIN
43900						     WITH GATTR DO
44000						      BEGIN
44100						       TYPTR := INTPTR; KIND := CST;
44200						       CVAL := VAL;
44300						      END;
44400						     INSYMBOL
44500						    END;
44600				  REALCONST:
44700					     BEGIN
44800					      WITH GATTR DO
44900					       BEGIN
45000						TYPTR := REALPTR; KIND := CST;
45100						CVAL := VAL
45200					       END;
45300					      INSYMBOL
45400					     END;
45500				  STRINGCONST:
45600					       BEGIN
45700						WITH GATTR DO
45800						 BEGIN
45900						  CONSTANT(FSYS,TYPTR,CVAL) ; KIND := CST ;
46000						 END;
46100					       END;
46200				  %(\	  LPARENT:
46300						   BEGIN
46400						    INSYMBOL; EXPRESSION(FSYS OR [RPARENT],ONREGC);
46500						     IF SY = RPARENT
46600						     THEN INSYMBOL
46700						     ELSE ERROR(152)
46800						   END;
46900				  % NOT \ NOTSY:
47000						 BEGIN
47100						  INSYMBOL; FACTOR(FSYS);
47200						   IF GATTR.TYPTR = BOOLPTR
47300						   THEN
47400						     BEGIN
47500						      LOAD(GATTR); MACRO3(411B%ANDCAI\,REGC,1)
47600						     END
47700						   ELSE
47800						     BEGIN
47900						      ERROR(359); GATTR.TYPTR := NIL
48000						     END;
48100						 END;
48200				  %[\	  LBRACK:
48300						  BEGIN
48400						   INSYMBOL; CSTPART := [ ]; VARPART := FALSE;
48500	(* 110 - MOVED RANGEPART INITIALIZATION INSIDE LOOP *)
48600						   NEWZ(LSP,POWER);
48700						   WITH LSP^ DO
48800						    BEGIN
48900						     ELSET:=NIL; SIZE:= 2
49000						    END;
49100						    IF SY = RBRACK
49200						    THEN
49300						      BEGIN
49400						       WITH GATTR DO
49500							BEGIN
49600							 TYPTR:=LSP; KIND:=CST;
49700							 NEWZ(LVP,PSET); LVP^.PVAL := CSTPART; CVAL.VALP := LVP
49800							END;
49900						       INSYMBOL
50000						      END
50100						    ELSE
50200						      BEGIN
50300	(* 110 - THIS ROUTINE LARGELY RECODED *)
50400	(* AC usage in the following is documented at the end.  In order to provide
50500	   any sanity at all, REGC has to be kept the same whatever the expression
50600	   types found.  Since an expression will advance REGC in most cases, we
50700	   have to be sure it gets advanced in others.  This means incrementregc
50800	   for constants and LOAD otherwise.  We don't LOAD constants because if
50900	   the other half of the range is also constant we will just remember it
51000	   as constant and not do a load at all. *)
51100							LOOP
51200			(* RANGEPART IS FLAG: 1ST EXPRESSION IS VARIABLE *)
51300							 RANGEPART := FALSE;
51400							 INCREMENTREGC; INCREMENTREGC;  (* FIRST EXPR *)
51500							 EXPRESSION(FSYS OR [COMMA,RBRACK,COLON],ONFIXEDREGC);
51600							  IF GATTR.TYPTR # NIL
51700							  THEN
51800							    IF GATTR.TYPTR^.FORM # SCALAR
51900							    THEN
52000							      BEGIN
52100							       ERROR(461); GATTR.TYPTR := NIL
52200							      END
52300							    ELSE
52400							      IF COMPTYPES(LSP^.ELSET,GATTR.TYPTR)
52500							      THEN
52600								BEGIN (* LOAD IF VAR, SAVE IN LRMIN IF CONST *)
52700								  IF GATTR.KIND = CST
52800								  THEN
52900								    BEGIN (* FIRST EXPR IS CONST *)
53000	(* 127 - fix reversed AC's *)
53100								    INCREMENTREGC;
53200	(* 137 - CHAR needs different test *)
53300								    IF (GATTR.CVAL.IVAL<0)
53400								      OR (GATTR.CVAL.IVAL>BASEMAX) AND (GATTR.TYPTR<>CHARPTR)
53500								      OR (GATTR.CVAL.IVAL>CHARMAX) AND (GATTR.TYPTR=CHARPTR)
53600								     THEN BEGIN ERROR(352) ; GATTR.CVAL.IVAL := 0 END;
53700								    IF GATTR.TYPTR=CHARPTR
53800								      THEN
53900	(* 7 - TREAT LOWER CASE AS UPPER IN SETS *)
54000	(* 105 - improve lower case mapping in sets *)
54100									GATTR.CVAL.IVAL := SETMAP[GATTR.CVAL.IVAL];
54200								    LRMIN := GATTR.CVAL.IVAL;
54300								    END
54400								  ELSE
54500								    BEGIN (* FIRST EXPR IS NOT A CONSTANT *)
54600								    RANGEPART := TRUE; (* SIGNAL VARIABLE *)
54700								    LOAD(GATTR);
54800	(* 112 - range check sets *)
54900								    if runtmcheck
55000								      then begin
55100	(* 137 - different range check for char *)
55200								      if gattr.typtr = charptr
55300									then macro3(307B%caig\,regc,charmax)
55400								        else macro3(307B%caig\,regc,basemax);
55500								      macro3(305B%caige\,regc,0);
55600								      support(errorinassignment)
55700								      end;
55800								    IF GATTR.TYPTR = CHARPTR
55900								       THEN BEGIN
56000	(* 105 - improve lower case mapping in sets *)
56100									    macro4r(200B%MOVE\,regc,regc,setmapchain);
56200									    code.information[cix] := 'E';
56300									    setmapchain := ic-1;
56400									    END;
56500								     END;
56600								  IF SY <> COLON
56700								   THEN (* ONLY ONE EXPR *)
56800								    IF NOT RANGEPART
56900								     THEN (* CONSTANT *)
57000								      BEGIN
57100								      CSTPART := CSTPART OR [LRMIN];
57200	(* 127 - fixed reversed AC's *)
57300								      REGC := REGC - 3;
57400								      END
57500								     ELSE (* ONE VARIABLE *)
57600								      BEGIN
57700								      IF GATTR.TYPTR = CHARPTR
57800									THEN CODE.INSTRUCTION[CIX].INSTR := 210B%MOVN\
57900								        ELSE MACRO3(210B%MOVN\,REGC,REGC);
58000								      REGC := REGC - 1;
58100								      MACRO3(515B%HRLZI\,REGC-1,400000B);
58200								      MACRO3(400B%SETZ\,REGC,0);
58300	(* 105 - more improvements for lower case mapping *)
58400								      MACRO4(246B%LSHC\,REGC-1,REGC+1,0);
58500								      IF VARPART
58600								      THEN
58700									BEGIN
58800									 MACRO3(434B%IOR\,REGC-3,REGC-1);
58900									 MACRO3(434B%IOR\,REGC-2,REGC);
59000									 REGC := REGC-2;
59100									END
59200								      ELSE VARPART := TRUE;
59300								      GATTR.KIND := EXPR; GATTR.REG := REGC
59400								      END
59500								   ELSE (* RANGE *)
59600								    BEGIN
59700								    INSYMBOL;
59800								    EXPRESSION(FSYS OR [COMMA,RBRACK],ONFIXEDREGC);
59900								    IF GATTR.TYPTR <> NIL (* 2ND EXPR *)
60000								     THEN
60100								      IF GATTR.TYPTR^.FORM <> SCALAR
60200								       THEN BEGIN
60300								       ERROR(461);
60400								       GATTR.TYPTR := NIL
60500								       END
60600								       ELSE
60700									IF COMPTYPES(LSP^.ELSET,GATTR.TYPTR)
60800									THEN
60900									 BEGIN
61000									 IF GATTR.KIND = CST
61100									   THEN BEGIN
61200	(* 137 - different test for CHAR, fix AC mess *)
61300									   INCREMENTREGC;
61400									   IF (GATTR.CVAL.IVAL < 0)
61500									      OR (GATTR.CVAL.IVAL > BASEMAX) AND (GATTR.TYPTR<>CHARPTR)
61600									      OR (GATTR.CVAL.IVAL > CHARMAX) AND (GATTR.TYPTR=CHARPTR)
61700									     THEN BEGIN ERROR(352); GATTR.CVAL.IVAL := 0 END;
61800									   IF GATTR.TYPTR = CHARPTR
61900									     THEN GATTR.CVAL.IVAL := SETMAP[GATTR.CVAL.IVAL]
62000									   END
62100	(* 137 - more AC confusion *)
62200									  ELSE LOAD(GATTR);
62300									 IF (GATTR.KIND = CST) AND (NOT RANGEPART)
62400									  THEN (* CONSTANT RANGE *)
62500									   BEGIN
62600									   WHILE(LRMIN <= GATTR.CVAL.IVAL) DO
62700									    BEGIN
62800									    CSTPART := CSTPART OR [LRMIN];
62900									    LRMIN := LRMIN+1
63000									    END;
63100	(* 127 - fix reversed AC's *)
63200	(* 137 - once again *)
63300									   REGC := REGC - 4
63400									   END
63500									  ELSE
63600									   BEGIN (* VARIABLE LIMITS ON RANGE *)
63700									   IF NOT RANGEPART (* FIRST PART IS CONSTANT *)
63800									    THEN
63900									     BEGIN (* SO NOT IN AC YET *)
64000	(* 127 - fix reversed AC's *)
64100	(* 137 - once again *)
64200									     MACRO3(201B%MOVEI\,REGC-1,LRMIN)
64300									     END;
64400									   if gattr.kind = cst  (* same for second *)
64500									     then macro3(201B%movei\,regc,gattr.cval.ival);
64600	(* 112 - range check sets *)
64700	(* 137 - different test needed for CHAR *)
64800									   if (gattr.kind <> cst) and runtmcheck
64900										then begin
65000										if gattr.typtr = charptr
65100										  then macro3(307B%caig\,regc,charmax)
65200										  else macro3(307B%caig\,regc,basemax);
65300										macro3(305B%caige\,regc,0);
65400										support(errorinassignment);
65500										end;
65600								           IF (GATTR.TYPTR=CHARPTR) AND (GATTR.KIND <> CST)
65700								            THEN BEGIN
65800	(* 105 - improve lower case mapping in sets *)
65900									    macro4r(200B%MOVE\,regc,regc,setmapchain);
66000									    code.information[cix] := 'E';
66100									    setmapchain := ic-1;
66200									    END;
66300			(* HERE IS WHAT IS IN THE AC'S:
66400				REGC    - RH LIMIT
66500				REGC-1	- LH LIMIT
66600				REGC-2  - DOUBLE WORD OF BITS
66700				REGC-3         "
66800			*)
66900									   MACRO3(477B%SETOB\,REGC-3,REGC-2);
67000									   MACRO4(246B%LSHC\,REGC-3,REGC-1,0);
67100									   MACRO3(275B%SUBI\,REGC,71);
67200									   MACRO3(210B%MOVN\,REGC,REGC);
67300									   MACRO3(270B%ADD\,REGC-1,REGC);
67400									   MACRO3(210B%MOVN\,REGC-1,REGC-1);
67500									   MACRO4(246B%LSHC\,REGC-3,REGC-1,0);
67600									   MACRO4(246B%LSHC\,REGC-3,REGC,0);
67700									   REGC := REGC -2;
67800								           IF VARPART
67900								            THEN
68000									     BEGIN
68100									     MACRO3(434B%IOR\,REGC-3,REGC-1);
68200									     MACRO3(434B%IOR\,REGC-2,REGC);
68300									     REGC := REGC-2;
68400									     END
68500								            ELSE VARPART := TRUE;
68600								           GATTR.KIND := EXPR; GATTR.REG := REGC
68700								           END
68800									 END
68900								    END;
     
00100								 LSP^.ELSET := GATTR.TYPTR;
00200								 GATTR.TYPTR :=LSP
00300								END
00400							      ELSE ERROR(360);
00500							EXIT IF NOT(SY IN [COMMA]);
00600							 INSYMBOL
00700							END;
00800							IF SY = RBRACK
00900							THEN INSYMBOL
01000							ELSE ERROR(155);
01100							IF VARPART
01200							THEN
01300							  BEGIN
01400							    IF CSTPART # [ ]
01500							    THEN
01600							      BEGIN
01700	(* 34 - BUG FIX FROM HAMBURG - NEEDED FOR PROGSTAT *)
01800								NEW(LVP,PSET);LVP^.PVAL := CSTPART;
01900								GATTR.KIND:=CST; GATTR.CVAL.VALP := LVP;
02000								MAKECODE(434B%IOR\,REGC,GATTR)
02100							      END
02200							  END
02300							ELSE
02400							  BEGIN
02500							   NEWZ(LVP,PSET); LVP^.PVAL := CSTPART; GATTR.CVAL.VALP := LVP
02600							  END
02700						      END;
02800						  END
02900				 END %CASE\ ;
03000				IFERRSKIP(166,FSYS)
03100			       END;
03200			      %IF SY IN FACBEGSYS\
03300			   END %FACTOR\ ;
03400	
03500			 BEGIN
03600			  %TERM\
03700			  FACTOR(FSYS OR [MULOP]);
03800			  WHILE SY = MULOP DO
03900			   BEGIN
04000			     IF OP IN [RDIV,IDIV,IMOD]
04100			     THEN LOAD(GATTR);	%BECAUSE OPERANDS ARE NOT
04200						 ALLOWED TO BE CHOSEN\
04300			    LATTR := GATTR; LOP := OP;
04400			    INSYMBOL; FACTOR(FSYS OR [MULOP]);
04500			     IF (LATTR.TYPTR # NIL) AND (GATTR.TYPTR # NIL)
04600			     THEN
04700			       CASE LOP OF
04800				%*\	  MUL:
04900					       IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
05000					       THEN SEARCHCODE(220B%IMUL\,LATTR)
05100	(* 21 - * with sets is and *)
05200					       ELSE IF (LATTR.TYPTR^.FORM=POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
05300						 THEN SEARCHCODE(404B%AND\,LATTR)
05400					       ELSE
05500						 BEGIN
05600						  MAKEREAL(LATTR);
05700						   IF (LATTR.TYPTR = REALPTR)
05800						    AND (GATTR.TYPTR = REALPTR)
05900						   THEN SEARCHCODE(164B%FMPR\,LATTR)
06000						   ELSE
06100						     BEGIN
06200						      ERROR(311); GATTR.TYPTR := NIL
06300						     END
06400						 END;
06500				%/\	  RDIV:
06600						BEGIN
06700						 MAKEREAL(LATTR);
06800						  IF (LATTR.TYPTR = REALPTR)
06900						   AND (GATTR.TYPTR = REALPTR)
07000						  THEN SEARCHCODE(174B%FDVR\,LATTR)
07100						  ELSE
07200						    BEGIN
07300						     ERROR(311); GATTR.TYPTR := NIL
07400						    END
07500						END;
07600				%DIV\	  IDIV:
07700						IF (LATTR.TYPTR = INTPTR)
07800						 AND (GATTR.TYPTR = INTPTR)
07900						THEN SEARCHCODE(230B%IDIV\,LATTR)
08000						ELSE
08100						  BEGIN
08200						   ERROR(311); GATTR.TYPTR := NIL
08300						  END;
08400				%MOD\	  IMOD:
08500						IF (LATTR.TYPTR = INTPTR)
08600						 AND (GATTR.TYPTR = INTPTR)
08700						THEN
08800						  BEGIN
08900						   SEARCHCODE(230B%IDIV\,LATTR);GATTR.REG := GATTR.REG+1
09000						  END
09100						ELSE
09200						  BEGIN
09300						   ERROR(311); GATTR.TYPTR := NIL
09400						  END;
09500				% AND \  ANDOP:
09600						IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
09700						 AND ( (LATTR.TYPTR^.FORM = POWER) OR (GATTR.TYPTR = BOOLPTR) )
09800						THEN SEARCHCODE(404B%AND\,LATTR)
09900						ELSE
10000						  BEGIN
10100						   ERROR(311); GATTR.TYPTR := NIL
10200						  END
10300			       END %CASE\
10400			     ELSE GATTR.TYPTR := NIL;
10500			    REGC:=GATTR.REG
10600			   END %WHILE\
10700			 END %TERM\ ;
10800	
10900		       BEGIN
11000			%SIMPLEEXPRESSION\
11100			SIGNED := FALSE;
11200			 IF (SY = ADDOP) AND (OP IN [PLUS,MINUS])
11300			 THEN
11400			   BEGIN
11500			    SIGNED := OP = MINUS; INSYMBOL
11600			   END;
11700			TERM(FSYS OR [ADDOP]);
11800			 IF SIGNED
11900			 THEN WITH GATTR DO
12000			   IF TYPTR # NIL
12100			   THEN
12200			     IF (TYPTR = INTPTR) OR (TYPTR = REALPTR)
12300			     THEN
12400			       IF KIND = CST
12500			       THEN
12600				 IF TYPTR = INTPTR
12700				 THEN CVAL.IVAL := - CVAL.IVAL
12800	(* 52 - have to put negated value in new place, since old one might be a CONST declaration used elsewhere *)
12900				 ELSE
13000				   BEGIN
13100				   NEW(NEWREALCSP);
13200				   NEWREALCSP^.CCLASS := REEL;
13300				   NEWREALCSP^.RVAL := -CVAL.VALP^.RVAL;
13400				   CVAL.VALP := NEWREALCSP
13500				   END
13600			       ELSE
13700				 BEGIN
13800				  LOAD(GATTR) ;
13900				  WITH CODE, INSTRUCTION[CIX] DO
14000				   IF INSTR=200B%MOVE\
14100				   THEN INSTR := 210B%MOVN\
14200				   ELSE MACRO3(210B%MOVN\,GATTR.REG,GATTR.REG)
14300				 END
14400			     ELSE
14500			       BEGIN
14600				ERROR(311) ; GATTR.TYPTR := NIL
14700			       END ;
14800			WHILE SY = ADDOP DO
14900			 BEGIN
15000			   IF OP=MINUS
15100			   THEN LOAD(GATTR); %BECAUSE OPD MAY NOT BE CHOSEN\
15200			  LATTR := GATTR; LOP := OP;
15300			  INSYMBOL; TERM(FSYS OR [ADDOP]);
15400			   IF (LATTR.TYPTR # NIL) AND (GATTR.TYPTR # NIL)
15500			   THEN
15600			     CASE LOP OF
15700			      %+\	PLUS:
15800					      IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
15900					      THEN
16000					       SEARCHCODE(270B%ADD\,LATTR)
16100	(* 21 - ALLOW + AS SET UNION *)
16200					      ELSE IF(LATTR.TYPTR^.FORM=POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
16300						THEN SEARCHCODE(434B%IOR\,LATTR)
16400					      ELSE
16500						BEGIN
16600						 MAKEREAL(LATTR);
16700						  IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR)
16800						  THEN SEARCHCODE(144B%FADR\,LATTR)
16900						  ELSE
17000						    BEGIN
17100						     ERROR(311); GATTR.TYPTR := NIL
17200						    END
17300						END;
17400			      %-\	MINUS:
17500					       IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
17600					       THEN
17700						SEARCHCODE(274B%SUB\,LATTR)
17800	(* 21 - ALLOW - AS SET DIFFERENCE *)
17900					       ELSE IF (LATTR.TYPTR^.FORM = POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
18000						 THEN SEARCHCODE(420B%ANDCM\,LATTR)
18100					       ELSE
18200						 BEGIN
18300						  MAKEREAL(LATTR);
18400						   IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR)
18500						   THEN SEARCHCODE(154B%FSBR\,LATTR)
18600						   ELSE
18700						     IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
18800						      AND (LATTR.TYPTR^.FORM = POWER)
18900						     THEN SEARCHCODE(420B%ANDCM\,LATTR)
19000						     ELSE
19100						       BEGIN
19200							ERROR(311); GATTR.TYPTR := NIL
19300						       END
19400						 END;
19500			      % OR \	OROP:
19600					      IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
19700					       AND ( (GATTR.TYPTR = BOOLPTR) OR (LATTR.TYPTR^.FORM = POWER) )
19800					      THEN SEARCHCODE(434B%IOR\,LATTR)
19900					      ELSE
20000						BEGIN
20100						 ERROR(311); GATTR.TYPTR := NIL
20200						END
20300			     END %CASE\
20400			   ELSE GATTR.TYPTR := NIL;
20500			  REGC:=GATTR.REG
20600			 END %WHILE\
20700		       END %SIMPLEEXPRESSION\ ;
20800	
20900		     BEGIN
21000		      %EXPRESSION\
21100		      TESTREGC := REGC+1;
21200		      SIMPLEEXPRESSION(FSYS OR [RELOP]);
21300		       IF SY = RELOP
21400		       THEN
21500			 BEGIN
21600			   IF FVALUE IN [ONREGC,ONFIXEDREGC]
21700			   THEN
21800			     BEGIN
21900			      INCREMENTREGC; MACRO3(201B%MOVEI\,REGC,1); BOOLREGC := REGC
22000			     END;
22100			   IF GATTR.TYPTR # NIL
22200			   THEN
22300	(* 24 - STRING IS ONLY STRUCTURE ALLOWED *)
22400			     IF STRING(GATTR.TYPTR)
22500			     THEN LOADADDRESS; LREGC1 := REGC;
22600			  LATTR := GATTR; LOP := OP;
22700			   IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC < BOOLREGC)
22800			   THEN REGC := BOOLREGC;
22900			  INSYMBOL; SIMPLEEXPRESSION(FSYS);
23000			   IF GATTR.TYPTR # NIL
23100			   THEN
23200	(* 24 - STRING IS ONLY STRUCTURE ALLOWED *)
23300			     IF STRING(GATTR.TYPTR)
23400			     THEN LOADADDRESS; LREGC2 := REGC;
23500			   IF (LATTR.TYPTR # NIL) AND (GATTR.TYPTR # NIL)
23600			   THEN
23700			     BEGIN
23800			       IF LOP = INOP
23900			       THEN
24000				 IF GATTR.TYPTR^.FORM = POWER
24100				 THEN
24200				   IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR^.ELSET)
24300				   THEN
24400				     BEGIN
24500				      LOAD(LATTR);
24600				       IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC < BOOLREGC)
24700				       THEN REGC := BOOLREGC;
24800				      LOAD(GATTR); REGC := GATTR.REG - 1;
24900				       IF LATTR.TYPTR=CHARPTR
25000				       THEN
25100	(* 7 - TREAT LOWER CASE AS UPPER IN SETS *)
25200					BEGIN
25300	(* 105 - improve lower case mapping in sets *)
25400					macro4r(200B%move\,lattr.reg,lattr.reg,setmapchain);
25500					code.information[cix] := 'E';
25600					setmapchain := ic-1;
25700					END;
25800				      MACRO4(246B%LSHC\,REGC,LATTR.REG,0);
25900				       IF FVALUE = TRUEJMP
26000				       THEN LINSTR := 305B%CAIGE\
26100				       ELSE LINSTR := 301B%CAIL\;
26200				      MACRO3(LINSTR,REGC,0);
26300				     END
26400				   ELSE
26500				     BEGIN
26600				      ERROR(260); GATTR.TYPTR := NIL
26700				     END
26800				 ELSE
26900				   BEGIN
27000				    ERROR(213); GATTR.TYPTR := NIL
27100				   END
27200			       ELSE
27300				 BEGIN
27400				   IF LATTR.TYPTR # GATTR.TYPTR
27500				   THEN
27600				    MAKEREAL(LATTR);
27700				   IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
27800				   THEN
27900				     BEGIN
28000				      LSIZE := LATTR.TYPTR^.SIZE;
28100				       CASE LATTR.TYPTR^.FORM OF
28200					POINTER:
28300						 IF LOP IN [LTOP,LEOP,GTOP,GEOP]
28400						 THEN ERROR (312);
28500					POWER:
28600					       IF LOP IN [LTOP,GTOP]
28700					       THEN ERROR(313);
28800					ARRAYS:
28900						IF  NOT STRING(LATTR.TYPTR)
29000	(* 24 - STRING IS ONLY STRUCT. ALLOWED *)
29100						THEN ERROR(312);
29200					RECORDS,
29300					FILES:
29400					      ERROR(314)
29500				       END;
29600				      WITH LATTR.TYPTR^ DO
29700				       BEGIN
29800					    DEFAULT := TRUE; LOFFSET := 3; SETINCLUSION := FALSE;
29900					     CASE LOP OF
30000					      LTOP:
30100						    BEGIN
30200						     LINSTR := 311B%CAML\; LINSTR1 := 313B
30300						    END;
30400					      LEOP:
30500						    IF FORM = POWER
30600						    THEN
30700						      BEGIN
30800						       SEARCHCODE(420B%ANDCM\,LATTR);
30900						       SETINCLUSION := TRUE
31000						      END
31100						    ELSE
31200						      BEGIN
31300						       LINSTR := 313B%CAMLE\; LINSTR1 := 313B
31400						      END;
31500					      GTOP:
31600						    BEGIN
31700						     LINSTR := 317B%CAMG\; LINSTR1 := 315B
31800						    END;
31900					      GEOP:
32000						    IF FORM = POWER
32100						    THEN
32200						      BEGIN
32300						       SEARCHCODE(410B%ANDCA\,LATTR);
32400						       SETINCLUSION := TRUE
32500						      END
32600						    ELSE
32700						      BEGIN
32800						       LINSTR := 315B%CAMGE\; LINSTR1 := 315B
32900						      END;
33000					      NEOP:
33100						    BEGIN
33200						     LINSTR := 316B%CAMN\;DEFAULT := FALSE
33300						    END;
33400					      EQOP:
33500						    BEGIN
33600						     LINSTR := 312B%CAME\; DEFAULT := FALSE; LOFFSET := 2
33700						    END
33800					     END;
33900					     IF FVALUE = TRUEJMP
34000					     THEN CHANGEBOOL(LINSTR);
34100	(* 24 - STRING IS ONLY STRUCTURE *)
34200					   IF FORM#ARRAYS THEN BEGIN
34300					     IF SIZE = 1
34400					     THEN SEARCHCODE(LINSTR,LATTR)
34500					     ELSE
34600					       IF SETINCLUSION
34700					       THEN
34800						 BEGIN
34900						  MACRO3(336B%SKIPN\,0,GATTR.REG);
35000						  MACRO3(332B%SKIPE\,0,GATTR.REG-1);
35100						   IF FVALUE = TRUEJMP
35200						   THEN
35300						    MACRO3R(254B%JRST\,0,IC+2)
35400						 END
35500					       ELSE
35600						 BEGIN
35700						  LOAD(LATTR);
35800						   IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC<BOOLREGC)
35900						   THEN
36000						    REGC := BOOLREGC;
36100						  LOAD(GATTR);
36200						   IF DEFAULT
36300						   THEN
36400						     BEGIN
36500						      MACRO3(LINSTR1,LATTR.REG-1,GATTR.REG-1);
36600						      MACRO3R(254B%JRST\,0,IC+4)	  %FALSE\
36700						     END;
36800						  MACRO3(312B%CAME\,LATTR.REG-1,GATTR.REG-1);
36900						  MACRO3R(254B%JRST\,0,IC+LOFFSET);
37000						  MACRO3(LINSTR,LATTR.REG,GATTR.REG)
37100						 END
37200					   END
37300					 ELSE
37400	(* 24 - THIS CODE IS NOW ONLY FOR STRINGS *)
37500					   BEGIN (*STRING*)
37600					   GETBOUNDS(INXTYPE,LOFFSET,LSIZE);
37700					   LSIZE:=LSIZE-LOFFSET+1;
37800	(* 40 - fix this code for unpacked strings, too *)
37900					 if arraypf
38000					  then begin
38100					   LOFFSET:=(LSIZE MOD 5)*700B;
38200					   LSIZE:=LSIZE DIV 5;
38300					   end
38400					  else loffset:=0;
38500					   IF (LSIZE=0) AND (LOFFSET=0)
38600					     THEN MACRO3(403B%SETZB\,TAC,HAC)
38700					   ELSE IF (LSIZE=0)
38800					     THEN BEGIN
38900					     MACRO3(505B%HRLI\,LREGC1,LOFFSET+440000B);
39000					     MACRO3(505B%HRLI\,LREGC2,LOFFSET+440000B);
39100					     MACRO3(134B%ILDB\,TAC,LREGC1);
39200					     MACRO3(134B%ILDB\,HAC,LREGC2)
39300					     END
39400					   ELSE
39500					     BEGIN
39600	(* 40 - fix for nonpacked arrays *)
39700					   if arraypf
39800					    then begin
39900					     MACRO3(505B%HRLI\,LREGC1,444300B);
40000					     MACRO3(505B%HRLI\,LREGC2,444300B);
40100					     end
40200					    else begin
40300					     macro3(505b%hrli\,lregc1,444400b);
40400					     macro3(505b%hrli\,lregc2,444400b)
40500					     end;
40600					     INCREMENTREGC;
40700					     IF LSIZE > 1
40800						THEN MACRO3(201B%MOVEI\,REGC,LSIZE);
40900					     MACRO3(134B%ILDB\,TAC,LREGC1);
41000					     MACRO3(134B%ILDB\,HAC,LREGC2);
41100					     IF (LOFFSET=0)
41200					       THEN BEGIN
41300					       IF LSIZE>1
41400						 THEN BEGIN
41500						 MACRO3(316B%CAMN\,TAC,HAC);
41600						 MACRO3R(367B%SOJG\,REGC,IC-3)
41700						 END
41800					       END
41900					      ELSE %OFFSET NOT 0\ BEGIN
42000					D=VARBL we may leave AC's set up with
48100	 info needed to access arrays (in the fieldS INDEXR and/or BPADDR).
48200	 So in that case this amounts to second-guessing LOAD and MAKECODE
48300	 to make sure that whichever place the result will be loaded
48400	 (usually INDEXR or BPADDR) is pointing to the fixed AC.}
48500	
48600			 IF FVALUE = ONFIXEDREGC
48700			 THEN
48800			   BEGIN
48900			     IF KIND=EXPR
49000			       THEN BEGIN
49100			       IF SIZE = 2
49200			         THEN TESTREGC := TESTREGC + 1;
49300			       IF TESTREGC # REGC
49400			         THEN BEGIN
49500			         IF SIZE = 2
49600				   THEN MACRO3(200B%MOVE\,TESTREGC-1,REGC-1);
49700			         MACRO3(200B%MOVE\,TESTREGC,REGC);
49800			         REG := TESTREGC; REGC := TESTREGC;
49900			         END
50000			       END
50100			     ELSE IF KIND=VARBL
50200			       THEN BEGIN
50300			       IF (PACKFG = PACKK) AND (BPADDR>REGIN) AND (BPADDR<=REGCMAX)
50400				 THEN IF (INDEXR <= REGIN) OR (BPADDR<INDEXR)
50500					THEN IF BPADDR<> TESTREGC
50600					       THEN BEGIN
50700					       MACRO3(200B%MOVE\,TESTREGC,BPADDR);
50800					       BPADDR := TESTREGC
50900					       END
51000					      ELSE
51100					ELSE IF INDEXR<>TESTREGC
51200					       THEN BEGIN
51300					       MACRO3(200B%MOVE\,TESTREGC,INDEXR);
51400					       INDEXR := TESTREGC
51500					       END
51600					      ELSE
51700			       ELSE IF (INDEXR>REGIN) AND (INDEXR<=REGCMAX) AND (INDEXR<>TESTREGC)
51800				 THEN BEGIN
51900				 MACRO3(200B%MOVE\,TESTREGC,INDEXR);
52000				 INDEXR := TESTREGC
52100				 END;
52200			       REGC := TESTREGC - 1;
52300			       END
52400			     ELSE REGC := TESTREGC-1
52500			   END
52600		     END %EXPRESSION\ ;
52700	
52800		    PROCEDURE ASSIGNMENT(FCP: CTP);
52900		    VAR
53000		      LATTR,SLATTR: ATTR;
53100		      SRMIN,SRMAX: INTEGER;
53200	
53300		      PROCEDURE STOREGLOBALS ;
53400		      TYPE
53500			WANDELFORM = (PTRW,INTW,REELW,PSETW,STRGW,INSTW) ;
53600		      VAR
53700			WANDEL : RECORD
53800				   CASE KW : WANDELFORM OF
53900					PTRW: (WPTR :GTP %TO ALLOW NIL\) ;
54000					INTW: (WINT : INTEGER ; WINT1 : INTEGER %TO PICK UP SECOND WORD OF SET\) ;
54100					REELW: (WREEL: REAL) ;
54200					PSETW: (WSET : SET OF 0..71) ;
54300					STRGW: (WSTRG: CHARWORD) ;
54400					INSTW: (WINST: PDP10INSTR)
54500				 END ;
54600			I,J : INTEGER ;
54700			PROCEDURE STOREWORD ;
54800			 BEGIN
54900			  CIX := CIX + 1 ;
55000			   IF CIX > CIXMAX
55100			   THEN
55200			     BEGIN
55300			      CIX := 0 ; ERRORWITHTEXT(356,'INITPROCD.')
55400			     END ;
55500			  WITH CGLOBPTR^ DO
55600			   BEGIN
55700			    CODE.INSTRUCTION[CIX] := WANDEL.WINST ;
55800			    LASTGLOB := LASTGLOB + 1 ;
55900			   END ;
56000			 END ;
56100			PROCEDURE GETNEWGLOBPTR ;
56200			VAR
56300			  LGLOBPTR : GTP ;
56400			 BEGIN
56500			  NEWZ(LGLOBPTR) ;
56600			  WITH LGLOBPTR^ DO
56700			   BEGIN
56800			    NEXTGLOBPTR := NIL ;
56900			    FIRSTGLOB	:= 0 ;
57000			   END ;
57100			   IF CGLOBPTR # NIL
57200			   THEN CGLOBPTR^.NEXTGLOBPTR := LGLOBPTR ;
57300			  CGLOBPTR := LGLOBPTR ;
57400			 END;
57500		       BEGIN
57600			%STOREGLOBALS\
57700			 IF FGLOBPTR = NIL
57800			 THEN
57900			   BEGIN
58000			    GETNEWGLOBPTR ;
58100			    FGLOBPTR := CGLOBPTR ;
58200	
58300			   END
58400			 ELSE
58500			   IF LATTR.DPLMT # CGLOBPTR^.LASTGLOB + 1
58600			   THEN GETNEWGLOBPTR ;
58700			WITH WANDEL,CGLOBPTR^,GATTR,CVAL DO
     
00100			 BEGIN
00200			   IF FIRSTGLOB = 0
00300			   THEN
00400			     BEGIN
00500			      FIRSTGLOB := LATTR.DPLMT ;
00600			      LASTGLOB := FIRSTGLOB - 1 ;
00700			      FCIX := CIX + 1 ;
00800			     END ;
00900			   CASE TYPTR^.FORM OF
01000			    SCALAR,
01100			    SUBRANGE:
01200			      BEGIN
01300	(* 174 30-Sep-80 Andy Hisgen, CMU,  Problems with xreal:=xinteger, 
01400	   				    and with subranges.
01500	The lines below used to read --
01600		        IF TYPTR = REALPTR
01700			THEN
01800			  IF LATTR.TYPTR=INTPTR
01900			  THEN WREEL := IVAL
02000			  ELSE WREEL := VALP^.RVAL
02100			ELSE WINT  := IVAL ;
02200	Unfortunately, that was testing to see if the RightHandSide (GATTR) was
02300	a real, and if so doing weird things.  For example, that let the
02400	assignment "x:=2", where x is a real, go thru, but without doing
02500	any conversion, thus x contained the bit pattern for the integer 2.
02600	The problem here seems to have been that the roles of LATTR and
02700	GATTR got reversed in the coder's mind.  Below, we have reversed
02800	them back.
02900	    A second unrelated problem was that subrange checking was not
03000	being done.  In the code below, we now handle this.
03100	*)
03200					IF lattr.typtr = realptr
03300					THEN
03400					  IF gattr.typtr = intptr
03500					  THEN WREEL := IVAL
03600					  ELSE WREEL := VALP^.RVAL
03700					ELSE BEGIN (*left isn't real*)
03800					      IF lattr.typtr^.form = subrange
03900					      THEN
04000						BEGIN (*left is subrange*)
04100						 getBounds(lattr.typtr,srmin,srmax);
04200						 IF NOT( (srmin <= ival) AND
04300						         (ival <= srmax) )
04400						 THEN error(367);
04500						END; (*left is subrange*)
04600					      WINT := IVAL;
04700					     END; (*left isn't real*)
04800	(*30-Sep-80 end of changes for xreal:=integer and for subranges*)
04900	
05000				       STOREWORD ;
05100				      END ;
05200			    POINTER:
05300				     BEGIN
05400				      WPTR := NIL ; STOREWORD
05500				     END ;
05600			    POWER   :
05700				      BEGIN
05800				       WSET := VALP^.PVAL ; STOREWORD ;
05900				       WINT := WINT1 %GET SECOND WORD OF SET\ ;
06000				       STOREWORD ;
06100				      END ;
06200			    ARRAYS   : WITH VALP^,WANDEL DO
06300				       BEGIN
06400					J := 0; WINT := 0;
06500					FOR I := 1 TO SLGTH DO
06600					 BEGIN
06700					  J := J + 1;
06800					  WSTRG[J] := SVAL[I];
06900					   IF J=5
07000					   THEN
07100					     BEGIN
07200					      J := 0;
07300					      STOREWORD; WINT := 0
07400					     END
07500					 END;
07600					 IF J#0
07700					 THEN STOREWORD
07800				       END;
07900	
08000			    RECORDS,
08100			    FILES    :	ERROR(411)
08200			   END %CASE\ ;
08300			 END % WITH \ ;
08400		       END % STOREGLOBALS \ ;
08500	
08600		     BEGIN
08700		      %ASSIGNMENT\
08800		      SELECTOR(FSYS OR [BECOMES],FCP);
08900		       IF SY = BECOMES
09000		       THEN
09100			 BEGIN
09200			  LATTR := GATTR;
09300			  INSYMBOL;
09400			  EXPRESSION(FSYS,ONREGC);
09500			   IF (LATTR.TYPTR # NIL) AND (GATTR.TYPTR # NIL)
09600			   THEN
09700			     IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) OR
09800			      (REALPTR=LATTR.TYPTR) AND (GATTR.TYPTR=INTPTR)
09900			     THEN
10000			       IF INITGLOBALS
10100			       THEN
10200				 IF GATTR.KIND = CST
10300				 THEN STOREGLOBALS
10400				 ELSE ERROR(504)
10500			       ELSE
10600				 IF (GATTR.KIND=CST) AND (GATTR.CVAL.IVAL=0)
10700				  AND (LATTR.PACKFG=NOTPACK)
10800				 THEN
10900				   BEGIN
11000				    FETCHBASIS(LATTR);
11100				    WITH LATTR DO
11200				     BEGIN
11300	(* 104 - check subranges *)
11400				      if lattr.typtr^.form = subrange
11500					then begin
11600					getbounds(lattr.typtr,srmin,srmax);
11700					if (0 < srmin) or (0 > srmax)
11800					  then error(367)
11900					end;
12000				      MACRO(VRELBYTE,402B%SETZM\,0,INDBIT,INDEXR,DPLMT)
12100				     END
12200				   END
12300				 ELSE
12400				   CASE LATTR.TYPTR^.FORM OF
12500				    SCALAR,
12600				    POINTER,
12700				    POWER:
12800					   BEGIN
12900					    LOAD(GATTR);
13000					     IF COMPTYPES(REALPTR,LATTR.TYPTR) AND (GATTR.TYPTR=INTPTR)
13100					     THEN
13200					      MAKEREAL(GATTR);
13300					    STORE(GATTR.REG,LATTR)
13400					   END;
13500				    SUBRANGE:
13600					      BEGIN
13700	(* 104 - moved code into procedure for use elsewhere *)
13800					       loadsubrange(gattr,lattr.typtr);
13900					       STORE(GATTR.REG,LATTR)
14000					      END;
14100	
14200				    ARRAYS,
14300				    RECORDS:
14400	(* 201 - zero size objects *)
14500					     IF GATTR.TYPTR^.SIZE = 0
14600					      THEN
14700					     ELSE IF GATTR.TYPTR^.SIZE = 1
14800					      THEN
14900					       BEGIN
15000						LOAD(GATTR) ; STORE(GATTR.REG,LATTR)
15100					       END
15200					     ELSE WITH LATTR DO
15300					       BEGIN
15400						LOADADDRESS ;
15500						CODE.INSTRUCTION[CIX].INSTR := 505B%HRLI\ ;
15600						FETCHBASIS(LATTR);
15700						MACRO(VRELBYTE,541B%HRRI\,REGC,INDBIT,INDEXR,DPLMT) ;
15800						 IF INDBIT=0
15900						 THEN MACRO5(VRELBYTE,251B%BLT \,REGC,INDEXR,DPLMT+TYPTR^.SIZE-1)
16000						 ELSE
16100						   BEGIN
16200						    INCREMENTREGC ;
16300						    MACRO3(200B%MOVE\,REGC,REGC-1);
16400						    MACRO4(251B%BLT \,REGC,REGC-1,TYPTR^.SIZE-1)
16500						   END;
16600					       END;
16700				    FILES: ERROR(361)
16800				   END
16900			     ELSE ERROR(260)
17000			 END %SY = BECOMES\
17100		       ELSE ERROR(159);
17200		     END %ASSIGNMENT\ ;
17300	
17400		    PROCEDURE GOTOSTATEMENT;
17500		    VAR
17600	(* 64 - non-local gotos *)
17700	(* 65 - remove exit labels *)
17800		      I,J,JJ:INTEGER; lcp:ctp;
17900		     BEGIN
18000			 IF SY = INTCONST
18100			 THEN
18200			   BEGIN
18300			    prterr := false;
18400			    searchid([labelt],lcp);
18500			    prterr := true;
18600			    if lcp # nil
18700			      then with lcp^ do
18800	(* See if the goto is out of the current block.  If so, handle
18900	 specially, since we have to restore the basis and topp.  Except
19000	 for the global level, we recover the basis by tracing the static
19100	 links.  Then we arranged for topp's RH to be stored in the LH
19200	 of word 0 of the display.  Global labels are odd because the
19300	 static link will be 0.  So the global topp and basis are stored
19400	 in special variables. *)
19500	(* 173 - As of this edit, we have to call GOTOC. in order to
19600	 close files in the blocks exited.  In order to prevent problems
19700	 if we are interrupted while this is happening, we can't really
19800	 change BASIS or TOPP until after the files are closed, else we
19900	 might be trying to close a file whose control block is above TOPP.
20000	 So we REGC is the new BASIS and REGC+1 is the new TOPP *)
20100			        if scope # level
20200				  then begin
20300				  incrementregc;
20400				  if scope = 1
20500				    then begin
20600				    macro3r(200B%move\,regc,globbasis);
20700				    macro3r(200B%move\,regc+1,globtopp)
20800				    end
20900				   else begin
21000				    macro4(504B%hrl\,regc,basis,-1);
21100				    macro3(544B%hlr\,regc,regc);
21200				    for i := scope to level - 2 do
21300				      macro4(507B%hrls\,regc,regc,-1);
21400				    macro4(544B%hlr\,regc+1,regc,0);
21500				    macro3(504B%hrl\,regc+1,regc+1);
21600				    end;
21700	(* 75 - following was macro3 due to typo *)
21800				  macro3r(201B%movei\,regc+2,gotochain);
21900				  gotochain := ic-1;
22000				  code.information[cix] := 'F';
22100				  nonlocgoto := true;
22200				  support(exitgoto);
22300				  goto 2
22400				  end;
22500			    FOR I:=1 TO LIX DO
22600			     BEGIN
22700			      WITH LABELS[I] DO
22800			       IF LABSVAL = VAL.IVAL
22900			       THEN
23000				 BEGIN
23100				  MACRO3R(254B%JRST\,0,LABSADDR);
23200				  GOTO 2
23300				 END
23400			     END;
23500			    MACRO3(254B%JRST\,0,0);
23600			    FOR I:=1 TO JIX DO
23700			     BEGIN
23800			      WITH GOTOS[I] DO
23900			       IF GOTOVAL = VAL.IVAL
24000			       THEN
24100				 BEGIN
24200				  J:= CODE.INSTRUCTION[GOTOADDR].ADDRESS;
24300				  JJ:= GOTOADDR;
24400				  WHILE J#0 DO
24500				   BEGIN
24600				    JJ:=J;
24700				    J:= CODE.INSTRUCTION[J].ADDRESS
24800				   END;
24900				  INSERTADDR(NO,JJ,CIX);
25000				  GOTO 2
25100				 END
25200			     END;
25300			    FOR I:=1 TO JIX DO
25400			     BEGIN
25500			      WITH GOTOS[I] DO
25600			       IF GOTOVAL = -1
25700			       THEN
25800				 BEGIN
25900				  GOTOVAL:=VAL.IVAL;
26000				  GOTOADDR:=CIX;
26100				  GOTO 2
26200				 END
26300			     END;
26400			    JIX :=JIX+1;
26500			     IF JIX > LABMAX
26600			     THEN
26700			       BEGIN
26800				ERROR(362);
26900				JIX := LABMAX
27000			       END;
27100			    WITH GOTOS[JIX] DO
27200			     BEGIN
27300			      GOTOVAL := VAL.IVAL;
27400			      GOTOADDR:=CIX
27500			     END;
27600	2:
27700			    INSYMBOL
27800			   END
27900			 ELSE ERROR(255)
28000		     END %GOTOSTATEMENT\ ;
28100	
28200		    PROCEDURE COMPOUNDSTATEMENT;
28300		     BEGIN
28400		       LOOP
28500			 REPEAT
28600			  STATEMENT(FSYS,STATENDS)
28700			 UNTIL	NOT (SY IN STATBEGSYS);
28800		       EXIT IF SY # SEMICOLON;
28900			INSYMBOL
29000		       END;
29100		       IF SY = ENDSY
29200		       THEN INSYMBOL
29300		       ELSE ERROR(163)
29400		     END %COMPOUNDSTATEMENET\ ;
29500	
29600		    PROCEDURE IFSTATEMENT;
29700		    VAR
29800		      LCIX1,LCIX2: CODERANGE;
29900		     BEGIN
30000		      EXPRESSION(FSYS OR [THENSY],FALSEJMP);
30100		      LCIX1 := CIX;
30200		       IF SY = THENSY
30300		       THEN INSYMBOL
30400		       ELSE ERROR(164);
30500		      STATEMENT(FSYS OR [ELSESY],STATENDS OR [ELSESY]);
30600		       IF SY = ELSESY
30700		       THEN
30800			 BEGIN
30900			  MACRO3(254B%JRST\,0,0); LCIX2 := CIX;
31000			  INSERTADDR(RIGHT,LCIX1,IC);
31100			  INSYMBOL; STATEMENT(FSYS,STATENDS);
31200			  INSERTADDR(RIGHT,LCIX2,IC)
31300			 END
31400		       ELSE INSERTADDR(RIGHT,LCIX1,IC)
31500		     END %IFSTATEMENT\ ;
31600	
31700		    PROCEDURE CASESTATEMENT;
31800		    TYPE
31900		      CIP = ^CASEINFO;
32000		      CASEINFO = PACKED
32100		      RECORD
32200			NEXT: CIP;
32300			CSSTART: ADDRRANGE;
32400			CSEND: CODERANGE;
32500			CSLAB: INTEGER
32600		      END;
32700		    VAR
32800		      LSP,LSP1: STP; FSTPTR,LPT1,LPT2,LPT3,OTHERSPTR: CIP; LVAL: VALU;
32900		      LIC,LADDR,JUMPADDR: ADDRRANGE; LCIX: CODERANGE; LMIN,LMAX: INTEGER;
33000	
33100		      PROCEDURE INSERTBOUND(FCIX:CODERANGE;FIC: ADDRRANGE;BOUND:INTEGER);
33200		      VAR
33300			LCIX1:CODERANGE; LIC1: ADDRRANGE;
33400			LATTR:ATTR;
33500		       BEGIN
33600			 IF BOUND>=0
33700			 THEN INSERTADDR(NO,FCIX,BOUND)
33800			 ELSE
33900			   BEGIN
34000			    LCIX1:=CIX; LIC1 := IC;
34100			    CIX:=FCIX; IC := FIC;
34200			    WITH LATTR DO
34300			     BEGIN
34400			      KIND:=CST;
34500			      CVAL.IVAL:=BOUND;
34600			      TYPTR:=NIL
34700			     END;
34800			    DEPCST(INT,LATTR);
34900			    CIX:=LCIX1; IC:= LIC1;
35000			    WITH CODE.INSTRUCTION[FCIX] DO
35100			    INSTR:=INSTR+10B  %CAILE-->CAMLE, CAIL-->CAML\
35200			   END
35300		       END;
35400	
35500		     BEGIN
35600		      OTHERSPTR:=NIL;
35700		      EXPRESSION(FSYS OR [OFSY,COMMA,COLON],ONREGC);
35800		      LOAD(GATTR);
35900		      MACRO3(301B%CAIL\,REGC,0);%<<<---------- LMIN IS INSERTED HERE\
36000		      MACRO3(303B%CAILE\,REGC,0);%<<<--------- LMAX IS INSERTED HERE\
36100		      MACRO3(254B%JRST\,0,0);%<<<------------- START OF "OTHERS" IS INSERTED HERE\
36200		      MACRO(NO,254B%JRST\,0,1,REGC,0);%<<<---- START OF JUMP TABLE IS INSERTED HERE\
36300		      LCIX := CIX; LIC := IC;
36400		      LSP := GATTR.TYPTR;
36500		       IF LSP # NIL
36600		       THEN
36700			 IF (LSP^.FORM # SCALAR) OR (LSP = REALPTR)
36800			 THEN
36900			   BEGIN
37000			    ERROR(315); LSP := NIL
37100			   END;
37200		       IF SY = OFSY
37300		       THEN INSYMBOL
37400		       ELSE ERROR(160);
37500	(* 65 - allow extra semicolon *)
37600		      while sy=semicolon do
37700			insymbol;
37800		      FSTPTR := NIL; LPT3 := NIL;
37900		       LOOP
38000			 LOOP
38100			  CONSTANT(FSYS OR [COMMA,COLON],LSP1,LVAL);
38200			   IF LSP # NIL
38300			   THEN
38400			     IF COMPTYPES(LSP,LSP1)
38500			     THEN
38600			       BEGIN
38700				LPT1 := FSTPTR; LPT2 := NIL;
38800				 IF ABS(LVAL.IVAL) > HWCSTMAX
38900				 THEN ERROR(316);
39000				WHILE LPT1 # NIL DO
39100				WITH LPT1^ DO
39200				 BEGIN
39300				   IF CSLAB <= LVAL.IVAL
39400				   THEN
39500				     BEGIN
39600				       IF CSLAB = LVAL.IVAL
39700				       THEN ERROR(261);
39800				      GOTO 1
39900				     END;
40000				  LPT2 := LPT1; LPT1 := NEXT
40100				 END;
40200	1:
40300				NEWZ(LPT3);
40400				WITH LPT3^ DO
40500				 BEGIN
40600				  NEXT := LPT1; CSLAB := LVAL.IVAL;
40700				  CSSTART := IC; CSEND := 0
40800				 END;
40900				 IF LPT2 = NIL
41000				 THEN FSTPTR := LPT3
41100				 ELSE LPT2^.NEXT := LPT3
41200			       END
41300			     ELSE ERROR(505);
41400			 EXIT IF SY # COMMA;
41500			  INSYMBOL
41600			 END;
41700			 IF SY = COLON
41800			 THEN INSYMBOL
41900			 ELSE ERROR(151);
42000			 REPEAT
42100			  STATEMENT(FSYS,STATENDS)
42200			 UNTIL	NOT (SY IN STATBEGSYS);
42300			 IF LPT3 # NIL
42400			 THEN
42500			   BEGIN
42600			    MACRO3(254B%JRST\,0,0); LPT3^.CSEND := CIX
42700			   END;
42800	(* 65 - allow extra semicolons *)
42900			while sy = semicolon
43000			  do insymbol;
43100		       exit if sy in (fsys or statends);
43200			 IF SY=OTHERSSY
43300			 THEN
43400			   BEGIN
43500			    INSYMBOL;
43600			     IF SY=COLON
43700			     THEN INSYMBOL
43800			     ELSE ERROR(151);
43900			    NEWZ(OTHERSPTR);
44000			    WITH OTHERSPTR^ DO
44100			     BEGIN
44200			      CSSTART:=IC;
44300			       REPEAT
44400				STATEMENT(FSYS,STATENDS)
44500			       UNTIL NOT(SY IN STATBEGSYS);
44600			      MACRO3(254B %JRST\,0,0);
44700			      CSEND:=CIX;
44800	(* 65 - allow extra semicolons *)
44900			      while sy=semicolon do
45000				insymbol;
45100			      GOTO 2
45200			     END
45300			   END
45400		       END;
45500	2:
45600		       IF FSTPTR # NIL
45700		       THEN
45800			 BEGIN
45900			  LMAX := FSTPTR^.CSLAB;
46000			  %REVERSE POINTERS\
46100			  LPT1 := FSTPTR; FSTPTR := NIL;
46200			   REPEAT
46300			    LPT2 := LPT1^.NEXT; LPT1^.NEXT := FSTPTR;
46400			    FSTPTR := LPT1; LPT1 := LPT2
46500			   UNTIL LPT1 = NIL;
46600			  LMIN := FSTPTR^.CSLAB;
46700			  INSERTBOUND(LCIX-2,LIC-2,LMAX);
46800			  INSERTBOUND(LCIX-3,LIC-3,LMIN);
46900	(* 164 - Polish fixups to avoid problem with LOADER *)
47000			  INSERTPOLISH(LIC-1,IC,-LMIN);  {put IC-LMIN at LIC-1}
47100			   IF LMAX - LMIN < CIXMAX-CIX
47200			   THEN
47300			     BEGIN
47400			      LADDR := IC + LMAX - LMIN + 1;
47500			       IF OTHERSPTR=NIL
47600			       THEN JUMPADDR:=LADDR
47700			       ELSE
47800				 BEGIN
47900				  INSERTADDR(RIGHT,OTHERSPTR^.CSEND,LADDR);
48000				  JUMPADDR:=OTHERSPTR^.CSSTART
48100				 END;
48200			      INSERTADDR(RIGHT,LCIX-1,JUMPADDR);
48300			       REPEAT
48400				WITH FSTPTR^ DO
48500				 BEGIN
48600				  WHILE CSLAB > LMIN DO
48700				   BEGIN
48800				    FULLWORD(RIGHT,0,JUMPADDR); LMIN := LMIN + 1
48900				   END;
49000				  FULLWORD(RIGHT,0,CSSTART);
49100				   IF CSEND # 0
49200				   THEN INSERTADDR(RIGHT,CSEND,LADDR);
49300				  FSTPTR := NEXT; LMIN := LMIN + 1
49400				 END
49500			       UNTIL FSTPTR = NIL
49600			     END
49700			   ELSE ERROR(363)
49800			 END;
49900		       IF SY = ENDSY
50000		       THEN INSYMBOL
50100		       ELSE ERROR(163)
50200		     END %CASESTATEMENT\ ;
50300	
50400		    PROCEDURE REPEATSTATEMENT;
50500		    VAR
50600		      LADDR: ADDRRANGE;
50700		     BEGIN
50800		      LADDR := IC;
50900		       LOOP
51000			 REPEAT
51100			  STATEMENT(FSYS OR [UNTILSY],STATENDS OR [UNTILSY])
51200			 UNTIL	NOT (SY IN STATBEGSYS);
51300		       EXIT IF SY # SEMICOLON;
51400			INSYMBOL
51500		       END;
51600		       IF SY = UNTILSY
51700		       THEN
51800			 BEGIN
51900			  INSYMBOL; EXPRESSION(FSYS,FALSEJMP); INSERTADDR(RIGHT,CIX,LADDR);
52000			 END
52100		       ELSE ERROR(202)
52200		     END %REPEATSTATEMENT\ ;
52300	
52400		    PROCEDURE WHILESTATEMENT;
52500		    VAR
52600		      LADDR: ADDRRANGE; LCIX: CODERANGE;
52700		     BEGIN
52800		      LADDR := IC;
52900		      EXPRESSION(FSYS OR [DOSY],FALSEJMP);
53000		      LCIX := CIX;
53100		       IF SY = DOSY
53200		       THEN INSYMBOL
53300		       ELSE ERROR(161);
53400		      STATEMENT(FSYS,STATENDS);
53500		      MACRO3R(254B%JRST\,0,LADDR);
53600		      INSERTADDR(RIGHT,LCIX,IC)
53700		     END %WHILESTATEMENT\ ;
53800	
53900		    PROCEDURE FORSTATEMENT;
54000		    VAR
54100	(* 104 - check subranges *)
54200		      LATTR,SATTR: ATTR; LSP: STP; LSY: SYMBOL;
54300		      LCIX: CODERANGE; LADDR,LDPLMT: ADDRRANGE; LINSTR: INSTRANGE;
54400		      LREGC,LINDREG: ACRANGE; LINDBIT: IBRANGE; LRELBYTE: RELBYTE;
54500		      ADDTOLC: INTEGER;
54600		     BEGIN
54700		       IF SY = IDENT
54800		       THEN
54900			 BEGIN
55000			  SEARCHID([VARS],LCP);
55100			  WITH LCP^, LATTR DO
     
00100			   BEGIN
00200			    TYPTR := IDTYPE; KIND := VARBL;
00300			     IF VKIND = ACTUAL
00400			     THEN
00500			       BEGIN
00600				VLEVEL := VLEV;
00700				 IF VLEV > 1
00800				 THEN VRELBYTE := NO
00900				 ELSE VRELBYTE := RIGHT;
01000				DPLMT := VADDR; INDEXR :=0; PACKFG := NOTPACK;
01100				INDBIT:=0
01200			       END
01300			     ELSE
01400			       BEGIN
01500				ERROR(364); TYPTR := NIL
01600			       END
01700			   END;
01800			   IF LATTR.TYPTR # NIL
01900			   THEN
02000			     IF COMPTYPES(REALPTR,LATTR.TYPTR) OR (LATTR.TYPTR^.FORM > SUBRANGE)
02100			     THEN
02200			       BEGIN
02300				ERROR(365); LATTR.TYPTR := NIL
02400			       END;
02500			  INSYMBOL
02600			 END
02700		       ELSE
02800			BEGIN
02900			 ERRANDSKIP(209,FSYS OR [BECOMES,TOSY,DOWNTOSY,DOSY]);
03000			 LATTR.TYPTR := NIL
03100			END;
03200		       IF SY = BECOMES
03300		       THEN
03400			 BEGIN
03500			  INSYMBOL; EXPRESSION(FSYS OR [TOSY,DOWNTOSY,DOSY],ONREGC);
03600			   IF GATTR.TYPTR # NIL
03700			   THEN
03800			     IF GATTR.TYPTR^.FORM # SCALAR
03900			     THEN ERROR(315)
04000			     ELSE
04100			       IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
04200	(* 104 - range check subranges *)
04300			       then begin
04400			       if lattr.typtr # nil
04500			       then if lattr.typtr^.form = subrange
04600				    then loadsubrange(gattr,lattr.typtr)
04700				    else load(gattr)
04800			       end
04900			       ELSE ERROR(556);
05000			  LREGC := GATTR.REG
05100			 END
05200		       ELSE ERRANDSKIP(159,FSYS OR [TOSY,DOWNTOSY,DOSY]);
05300		       IF SY IN [TOSY,DOWNTOSY]
05400		       THEN
05500			 BEGIN
05600			  LSY := SY; INSYMBOL; EXPRESSION(FSYS OR [DOSY],ONREGC);
05700			   IF GATTR.TYPTR # NIL
05800			   THEN
05900			     IF GATTR.TYPTR^.FORM # SCALAR
06000			     THEN ERROR(315)
06100			     ELSE
06200			       IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
06300			       THEN
06400				 BEGIN
06500				  ADDTOLC := 0 ;
06600				  WITH GATTR DO
06700	{This test checks for forms of upper bound that must be copied into a local
06800	 variable. Originally, they tried to use variables in place instead of
06900	 copying, to save the MOVE, MOVEM.  The problem is that if the user changes
07000	 the variable inside the loop, you have the wrong upper bound.  We
07100	 interpret the language spec as requiring the bound to be evaluated only
07200	 once, at the start.  The following test, commented out, was the original
07300	 test, to see whether the object could be used in place for a CAMGE, or
07400	 needed to be copied.  Now we copy all variables, as just discussed.}
07500	{IF ( (KIND = VARBL) AND ( (VLEVEL > 1) AND (VLEVEL < LEVEL) OR
07600	 (PACKFG # NOTPACK) OR (INDEXR > 0) AND (INDEXR <=   REGCMAX) ) ) OR
07700	 (KIND = EXPR) }
07800				  IF (KIND = VARBL) OR (KIND = EXPR)
07900				   THEN
08000				     BEGIN
08100	(* 104 - add range checking for subrange types *)
08200				      if lattr.typtr # nil
08300				      then if lattr.typtr^.form = subrange
08400					   then loadsubrange(gattr,lattr.typtr)
08500					   else load(gattr);
08600				      MACRO4(202B%MOVEM\,REGC,BASIS,LC); ADDTOLC := 1;
08700				      KIND := VARBL ; INDBIT := 0  ; INDEXR := BASIS ; VLEVEL := 1;
08800				      DPLMT := LC ; PACKFG := NOTPACK ; VRELBYTE := NO
08900				     END
09000				  else if lattr.typtr # nil
09100				       then if (lattr.typtr^.form = subrange) and runtmcheck
09200					    then begin
09300					     (* must copy, since otherwise at end of loop
09400					        makecode will think it is in an AC *)
09500					    sattr := gattr;
09600					    loadsubrange(sattr,lattr.typtr)
09700					    end;
09800				  FETCHBASIS(LATTR);
09900				  WITH LATTR DO
10000				   BEGIN
10100				     IF (INDEXR>0) AND (INDEXR<=REGCMAX)
10200				     THEN
10300				       BEGIN
10400					MACRO(NO,201B%MOVEI\,INDEXR,INDBIT,INDEXR,DPLMT);
10500					LINDBIT := 1; LDPLMT := LC+ADDTOLC; LINDREG := BASIS ;
10600					MACRO4(202B%MOVEM\,INDEXR,BASIS,LDPLMT);
10700					ADDTOLC := ADDTOLC + 1 ;
10800				       END
10900				     ELSE
11000				       BEGIN
11100					LINDBIT := INDBIT; LINDREG := INDEXR; LDPLMT := DPLMT
11200				       END;
11300				    LRELBYTE:= VRELBYTE
11400				   END;
11500				  MACRO(LRELBYTE,202B%MOVEM\,LREGC,LINDBIT,LINDREG,LDPLMT);
11600				   IF LSY = TOSY
11700				   THEN LINSTR := 313B%CAMLE\
11800				   ELSE LINSTR := 315B%CAMGE\;
11900				  LADDR := IC;
12000				  MAKECODE(LINSTR,LREGC,GATTR) ;
12100				 END
12200			       ELSE ERROR(556)
12300			 END
12400		       ELSE ERRANDSKIP(251,FSYS OR [DOSY]);
12500		      MACRO3(254B%JRST\,0,0); LCIX :=CIX;
12600		       IF SY = DOSY
12700		       THEN INSYMBOL
12800		       ELSE ERROR(161);
12900		      LC := LC + ADDTOLC;
13000		       IF LC > LCMAX
13100		       THEN LCMAX:=LC;
13200		      STATEMENT(FSYS,STATENDS);
13300		      LC := LC - ADDTOLC;
13400		       IF LSY = TOSY
13500		       THEN LINSTR  := 350B%AOS\
13600		       ELSE LINSTR := 370B%SOS\;
13700		      MACRO(LRELBYTE,LINSTR,LREGC,LINDBIT,LINDREG,LDPLMT);
13800		      MACRO3R(254B%JRST\,0,LADDR); INSERTADDR(RIGHT,LCIX,IC)
13900		     END %FORSTATEMENT\ ;
14000	
14100		    PROCEDURE LOOPSTATEMENT;
14200		    VAR
14300		      LADDR: ADDRRANGE; LCIX: CODERANGE;
14400		     BEGIN
14500		      LADDR := IC;
14600		       LOOP
14700			 REPEAT
14800			  STATEMENT(FSYS OR [EXITSY],STATENDS OR [EXITSY])
14900			 UNTIL	NOT (SY IN STATBEGSYS);
15000		       EXIT IF SY # SEMICOLON;
15100			INSYMBOL
15200		       END;
15300		       IF SY = EXITSY
15400		       THEN
15500			 BEGIN
15600			  INSYMBOL;
15700			   IF SY = IFSY
15800			   THEN
15900			     BEGIN
16000			      INSYMBOL; EXPRESSION(FSYS OR [SEMICOLON,ENDSY],TRUEJMP);
16100			     END
16200			   ELSE ERRANDSKIP(162,FSYS OR [SEMICOLON,ENDSY]);
16300			  LCIX := CIX;
16400			   LOOP
16500			     REPEAT
16600			      STATEMENT(FSYS,STATENDS)
16700			     UNTIL  NOT (SY IN STATBEGSYS);
16800			   EXIT IF SY # SEMICOLON;
16900			    INSYMBOL
17000			   END;
17100			  MACRO3R(254B%JRST\,0,LADDR); INSERTADDR(RIGHT,LCIX,IC)
17200			 END
17300		       ELSE ERROR(165);
17400		       IF SY = ENDSY
17500		       THEN INSYMBOL
17600		       ELSE ERROR(163)
17700		     END %LOOPSTATEMENT\ ;
17800	
17900		    PROCEDURE WITHSTATEMENT;
18000		    VAR
18100		      LCP: CTP; OLDLC: ADDRRANGE; LCNT1: DISPRANGE; OLDREGC: ACRANGE;
18200		     BEGIN
18300		      LCNT1 := 0; OLDREGC := REGCMAX; OLDLC := LC;
18400		       LOOP
18500			 IF SY = IDENT
18600			 THEN
18700			   BEGIN
18800			    SEARCHID([VARS,FIELD],LCP); INSYMBOL
18900			   END
19000			 ELSE
19100			   BEGIN
19200			    ERROR(209); LCP := UVARPTR
19300			   END;
19400			SELECTOR(FSYS OR [COMMA,DOSY],LCP);
19500			 IF GATTR.TYPTR # NIL
19600			 THEN
19700			   IF GATTR.TYPTR^.FORM = RECORDS
19800			   THEN
19900			     IF TOP < DISPLIMIT
20000			     THEN
20100			       BEGIN
20200				TOP := TOP + 1; LCNT1 := LCNT1 + 1; WITHIX := WITHIX + 1;
20300				DISPLAY[TOP].FNAME := GATTR.TYPTR^.FSTFLD;
20400				WITH DISPLAY[TOP],GATTR DO
20500				 BEGIN
20600				  OCCUR := CREC;
20700	(* 5 - create block name for CREF *)
20800				  BLKNAME := '.FIELDID. ';
20900				   IF INDBIT = 1
21000				   THEN GETPARADDR;
21100				  FETCHBASIS(GATTR);
21200				   IF (INDEXR#0) AND (INDEXR # BASIS)
21300				   THEN
21400				     BEGIN
21500				      MACRO3(200B%MOVE\,REGCMAX,INDEXR);
21600				      INDEXR := REGCMAX;
21700				      REGCMAX := REGCMAX-1;
21800				       IF REGCMAX<REGC
21900				       THEN
22000					 BEGIN
22100					  ERROR(317);
22200					  REGC := REGCMAX
22300					 END
22400				     END;
22500				  CLEV := VLEVEL; CRELBYTE := VRELBYTE;
22600				  CINDR := INDEXR; CINDB:=INDBIT;
22700				  CDSPL := DPLMT;
22800				  CLC := LC;
22900				   IF (CINDR#0)  AND  (CINDR#BASIS)
23000				   THEN
23100				     BEGIN
23200				      LC := LC + 1;
23300				       IF LC>LCMAX
23400				       THEN LCMAX := LC;
23500				     END
23600				 END
23700			       END
23800			     ELSE ERROR(404)
23900			   ELSE ERROR(308);
24000		       EXIT IF SY # COMMA;
24100			INSYMBOL
24200		       END;
24300		       IF SY = DOSY
24400		       THEN INSYMBOL
24500		       ELSE ERROR(161);
24600		      STATEMENT(FSYS,STATENDS);
24700		      REGCMAX:=OLDREGC;
24800		      TOP := TOP - LCNT1; LC := OLDLC; WITHIX := WITHIX - LCNT1;
24900		     END %WITHSTATEMENT\ ;
25000	
25100		   BEGIN
25200		    %STATEMENT\
25300		     IF SY = INTCONST
25400		     THEN %LABEL\
25500		       BEGIN
25600	(* 64 - non-loc gotos *)
25700			prterr := false;
25800			searchid([labelt],lcp);
25900			prterr := true;
26000			if lcp # nil
26100			  then with lcp^ do
26200			    if scope = level
26300			      then labeladdress := ic;
26400			FOR IX:=1 TO LIX DO
26500			 BEGIN
26600			  WITH LABELS[IX] DO
26700			   IF LABSVAL = VAL.IVAL
26800			   THEN
26900			     BEGIN
27000			      ERROR(211);
27100			      GOTO 1
27200			     END
27300			 END;
27400			LIX := LIX+1;
27500			 IF LIX > LABMAX
27600			 THEN
27700			   BEGIN
27800			    ERROR(362);
27900			    LIX:=LABMAX
28000			   END;
28100			WITH LABELS[LIX] DO
28200			 BEGIN
28300			  LABSVAL:=VAL.IVAL;
28400			  LABSADDR:=IC
28500			 END;
28600			FOR IX:=1 TO JIX DO
28700			 BEGIN
28800			  WITH GOTOS[IX] DO
28900			   IF GOTOVAL = VAL.IVAL
29000			   THEN
29100			     BEGIN
29200			      J:=CODE.INSTRUCTION[GOTOADDR].ADDRESS;
29300			      INSERTADDR(RIGHT,GOTOADDR,IC);
29400			      WHILE J#0 DO
29500			       BEGIN
29600				GOTOADDR:=J;
29700				J:=CODE.INSTRUCTION[GOTOADDR].ADDRESS;
29800				INSERTADDR(RIGHT,GOTOADDR,IC)
29900			       END;
30000			      GOTOVAL:=-1;
30100			      GOTO 1
30200			     END
30300			 END;
30400	1:
30500			INSYMBOL;
30600			 IF SY = COLON
30700			 THEN INSYMBOL
30800			 ELSE ERROR(151)
30900		       END;
31000		     IF DEBUG AND NOT INITGLOBALS
31100		     THEN PUTLINER;
31200		     IF  NOT (SY 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;
 ENTRY *)
23100		CCLSW := LC; LC := LC+5;
23200	(* 66 - nonloc gotos *)
23300		globtopp := lc; lc:=lc+1; globbasis := lc; lc:=lc+1;
23400	(* 61 - allow us to distinguish tops10 and tops20 specific ftns *)
23500		if tops10
23600		  then othermachine := t20name
23700		  else othermachine := t10name;
23800	
23900		% GET,GETLN,PUT,PUTLN,RESET,REWRITE,READ,READLN,
24000		 WRITE,WRITELN,PACK,UNPACK,NEW,MARK,RELEASE,GETLINR,
24100		 PUT8BITSTOTTY,PAGE\
24200	
24300		FOR I := 7 TO 25 DO
24400	(* 61 - restrict tops10 and tops20 specific *)
24500		 if machna[i] # othermachine then
24600		 BEGIN
24700		  NEWZ(CP,PROC,STANDARD);
24800		  WITH CP^ DO
24900		   BEGIN
25000		    NAME := NA[I]; IDTYPE := NIL;
25100		    NEXT := NIL; KEY := I - 6;
25200		   END;
25300	
25400		  ENTERID(CP)
25500		 END;
25600	(* 10 - ADD SETSTRING *)
25700	(* 14 - AND OTHERS *)
25800	
25900	(* 27 - add NEWZ *)
26000	(* 61 - restrict tops10 and tops20 defn's *)
26100	(* 152 - DISPOSE *)
26200		FOR I := 54 TO 76 DO
26300		 if machna[i] # othermachine then
26400		 BEGIN
26500		  NEWZ(CP,PROC,STANDARD);
26600		  WITH CP^ DO
26700		   BEGIN
26800		    NAME := NA[I]; IDTYPE := NIL;
26900		    NEXT := NIL; KEY := I - 32;
27000		   END;
27100	
27200		 ENTERID(CP)
27300		END;
27400	
27500	(* 44 - add curpos and its arg *)
27600	        (* arg for CURPOS *)
27700		newz(cp1,vars);
27800		with cp1^ do
27900		  begin
28000		  name:='          ';idtype:=anyfileptr;
28100		  vkind:=formal;next:=nil;vlev:=1;vaddr:=2
28200		  end;
28300	
28400		(* CURPOS *)
28500	(* 47 - more of this kind now *)
28600	(* 61 - tops10 and tops20 specific functions *)
28700		FOR I:=77 TO 79 DO
28800		if machna[i] # othermachine then
28900		begin
29000		newz(cp,func,declared,actual);
29100		with cp^ do
29200		  begin
29300		  name := na[i]; idtype:=intptr; next:=cp1; forwdecl:=false;
29400		  externdecl := true; pflev:=0; pfaddr:=0; pfchain:=externpfptr;
29500		  externpfptr:=cp; for j:=0 to maxlevel do linkchain[j]:=0; externalname:=na[i];
29600		  language:=pascalsy
29700		  end;
29800		enterid(cp);
29900		end;
30000	
30100		NEWZ(CP,FUNC,DECLARED,ACTUAL);
30200		WITH CP^ DO
30300		 BEGIN
30400		  NAME := NA[26]; IDTYPE := DATEPTR; NEXT := NIL; FORWDECL := FALSE;
30500		  EXTERNDECL := TRUE; PFLEV := 0; PFADDR := 0; PFCHAIN := EXTERNPFPTR;
30600		  EXTERNPFPTR := CP; FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0; EXTERNALNAME := NA[26];
30700		  LANGUAGE := FORTRANSY
30800		 END;
30900		ENTERID(CP);
31000	
31100		% RUNTIME,TIME,ABS,SQR,TRUNC,ODD,ORD,CHR,PRED,SUCC,EOF,EOLN \
31200	
31300		FOR I := 27 TO 38 DO
31400		 BEGIN
31500		  NEWZ(CP,FUNC,STANDARD);
31600		  WITH CP^ DO
31700		   BEGIN
31800		    NAME := NA[I]; IDTYPE := NIL;
31900		    NEXT := NIL; KEY := I - 26;
32000		   END;
32100		  ENTERID(CP)
32200		 END;
32300	
32400		FOR I := 80 TO 81 DO
32500		 BEGIN
32600		  NEWZ(CP,FUNC,STANDARD);
32700		  WITH CP^ DO
32800		   BEGIN
32900		    NAME := NA[I]; IDTYPE := NIL;
33000		    NEXT := NIL; KEY := I - 66;
33100		   END;
33200		  ENTERID(CP)
33300		 END;
33400		NEWZ(CP,VARS); %PARAMETER OF PREDECLARED FUNCTIONS\
33500		WITH CP^ DO
33600		 BEGIN
33700		  NAME := '          '; IDTYPE := REALPTR;
33800		  VKIND := ACTUAL; NEXT := NIL; VLEV := 1; VADDR := 2
33900		 END;
34000	
34100		% SIN,COS,EXP,SQRT,ALOG,ATAN,ALOG10,
34200		 SIND,COSD,SINH,COSH,TANH,ASIN,ACOS,RAN \
34300	
34400		FOR I := 39 TO 53 DO
34500		 BEGIN
34600		  NEWZ(CP1,FUNC,DECLARED,ACTUAL);
34700		  WITH CP1^ DO
34800		   BEGIN
34900		    NAME := NA[I]; IDTYPE := REALPTR; NEXT := CP;
35000		    FORWDECL := FALSE; EXTERNDECL := TRUE; PFLEV := 0; PFADDR := 0;
35100		    PFCHAIN:= EXTERNPFPTR; EXTERNPFPTR:= CP1; EXTERNALNAME := EXTNA[I];
35200		    FOR J := 0 TO MAXLEVEL DO LINKCHAIN[J] := 0; LANGUAGE := EXTLANGUAGE[I]
35300		   END;
35400		  ENTERID(CP1)
35500		 END;
35600		LCMAIN := LC;
35700	       END %ENTERSTDNAMES\ ;
35800	
35900	      PROCEDURE ENTERUNDECL;
36000	      VAR
36100		I: INTEGER;
36200	       BEGIN
36300		NEWZ(UTYPPTR,TYPES);
36400		WITH UTYPPTR^ DO
36500		 BEGIN
36600		  NAME := '          '; IDTYPE := NIL; NEXT := NIL;
36700		 END;
36800		NEWZ(UCSTPTR,KONST);
36900		WITH UCSTPTR^ DO
37000		 BEGIN
37100		  NAME := '          '; IDTYPE := NIL; NEXT := NIL;
37200		  VALUES.IVAL := 0
37300		 END;
37400		NEWZ(UVARPTR,VARS);
37500		WITH UVARPTR^ DO
37600		 BEGIN
37700		  NAME := '          '; IDTYPE := NIL; VKIND := ACTUAL;
37800		  NEXT := NIL; VLEV := 0; VADDR := 0
37900		 END;
38000	(* 135 - UARRPTR is needed as dummy to prevent ill mem ref in PACK/UNPACK *)
38100		NEWZ(UARRTYP,ARRAYS);
38200		WITH UARRTYP^ DO
38300		  BEGIN
38400		  ARRAYPF := FALSE; SELFSTP := NIL; AELTYPE := NIL;
38500		  INXTYPE := NIL; SIZE := 777777B; BITSIZE := 36
38600		  END;
38700		NEWZ(UFLDPTR,FIELD);
38800		WITH UFLDPTR^ DO
38900		 BEGIN
39000		  NAME := '          '; IDTYPE := NIL; NEXT := NIL; FLDADDR := 0;
39100		  PACKF := NOTPACK
39200		 END;
39300		NEWZ(UPRCPTR,PROC,DECLARED,ACTUAL);
39400		WITH UPRCPTR^ DO
39500		 BEGIN
39600		  NAME := '          '; IDTYPE := NIL; FORWDECL := FALSE;
39700		  FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0;
39800		  NEXT := NIL; EXTERNDECL := FALSE; PFLEV := 0; PFADDR := 0
39900		 END;
40000		NEWZ(UFCTPTR,FUNC,DECLARED,ACTUAL);
40100		WITH UFCTPTR^ DO
40200		 BEGIN
40300		  NAME := '          '; IDTYPE := NIL; NEXT := NIL;
40400		  FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0;
40500		  FORWDECL := FALSE; EXTERNDECL := FALSE; PFLEV := 0; PFADDR := 0
40600		 END;
40700	(* 64 - non-loc gotos *)
40800		newz(ulblptr,labelt);
40900		with ulblptr^ do
41000		  begin
41100		  name := '          '; idtype := nil; next := nil;
41200		  scope := 0; gotochain := 0; labeladdress := 0;
41300		  end;
41400	       END %ENTERUNDECL\ ;
41500	
41600	      PROCEDURE ENTERDEBNAMES;
41700	      VAR
41800		CP:CTP;
41900	       BEGIN
42000		NEWZ(CP,PROC,STANDARD);
42100		WITH CP^ DO
42200		 BEGIN
42300		  NAME := 'PROTECTION';
42400		  IDTYPE := NIL; NEXT := NIL; KEY:= 21
42500		 END;
42600		ENTERID(CP);
42700	       END;
42800	
42900	(* 4 - replace file name scanner with call to SCAN *)
43000	(* 11 - new definition of PASPRM *)
43100	     FUNCTION PASPRM(VAR I,O:TEXT;VAR R:INTFILE):RPGPT; EXTERN;
43200	
43300	(* 104 - improved error detection in tops10 *)
43400	(* 107 - moved declaration of analys earlier *)
43500	
43600	     BEGIN
43700	      %ENTER STANDARD NAMES AND STANDARD TYPES:\
43800	      %****************************************\
43900	
44000	(* 41 - make restartable *)
44100	      reinit;
44200	
44300	      RTIME := RUNTIME; DAY := DATE;
44400	      LEVEL := 0; TOP := 0;
44500	      WITH DISPLAY[0] DO
44600	       BEGIN
44700	(* 5 - create block name for CREF *)
44800		FNAME := NIL; OCCUR := BLCK; BLKNAME := '.PREDEFIN.';
44900	       END;
45000	      ENTERSTDTYPES; ENTERSTDNAMES; ENTERUNDECL; ENTERDEBNAMES;
45100	
45200	      TOP := 1; LEVEL := 1;
45300	      WITH DISPLAY[1] DO
45400	       BEGIN
45500	(* 5 - create block name for CREF *)
45600		FNAME := NIL; OCCUR := BLCK; BLKNAME := '.GLOBAL.  ';
45700	       END;
45800	
45900	      %OPEN COMPILER FILES\
46000	      %*******************\
46100	
46200	(* 4 - here we open the files that SCAN gave us *)
46300	      REWRITE(TTYOUTPUT);
46400	      SCANDATA := PASPRM(INPUT,OUTPUT,OUTPUTREL);
46500	      WITH SCANDATA ^ DO
46600	       BEGIN
46700	(* 33 - VERSION NO *)
46800	       VERSION.WORD := VERVAL;
46900	(* I haven't figured out what to do about lookup blocks.  Commented out for now *)
47000	(* 104 - fix error detection on tops10 *)
47100	       if tops10 
47200	         then reset(input,'',true,lookblock,40000B,4000B)  {tag for SOS}
47300	 	 else reset(input,'',0,0,0,20B);  {see EOL char's}
47400	       if eof		{tag for SOS}
47500		 then begin
47600		 analys(input);
47700		 pasxit(input,output,outputrel);
47800		 end;
47900	       get(input);		     {tag for SOS}
48000	       IF VERSION.WORD = 0 THEN VERSION.WORD := LOOKBLOCK[6];
48100	       LOOKBLOCK[6] := VERSION.WORD;
48200	       FOR I := 1 TO 5 DO LOOKBLOCK[I] := 0;
48300	       REWRITE(OUTPUT,'',0,LOOKBLOCK);  {tag for SOS}
48400	       FOR I := 1 TO 5 DO LOOKBLOCK[I] := 0;
48500	       REWRITE(OUTPUTREL,'',0,LOOKBLOCK);  {tag for SOS}
48600	       FILENAME := RELNAME;
48700	(* 34 - DON'T NEED ENTRY NOW *)
48800	       IF FILENAME = '          '
48900	         THEN FILENAME := '.NONAM    '; %A BLANK ENTRY NAME IS BAD NEWS\
49000	       LISTCODE := LSW;
49100	       TTYINUSE := TSW;
49200	       MAIN := MSW;
49300	       RUNTMCHECK := CSW;
49400	(* 160 - compiler switch /ARITHCHECK *)
49500	       ARITHCHECK := ASW;
49600	       DEBUGSWITCH := DSW;
49700	       CREF:=CRSW;
49800	       DEBUG := DSW;
49900	       RPGENTRY := RPGSW;
50000	(* 7 - ADD /HEAP SWITCH *)
50100	(* 12 - /heap no longer needed *)
50200	(* 24 - /HEAP AND /STACK NOW USED FOR START ADDR *)
50300		
50400	       HEAP := HEAPVAL;
50500	       STACK := STACKVAL;
50600	(* 25 - /ZERO *)
50700	       ZERO := ZSW
50800	       END;
50900	
51000	      %WRITE HEADER\
51100	      %************\
51200	
51300	(* 136 - listing format *)
51400	      pagehead;
51500	      %NEW LINE FOR ERROR MESSAGES OR PROCEDURENAMES\
51600	      GETNEXTLINE;     %GETS FIRST LINENUMBER IF ANY\
51700	      CH := ' '; INSYMBOL; RESETFLAG := FALSE;
51800	       IF NOT MAIN
51900	       THEN
52000		 BEGIN
52100		  LC := PROGRST; LCMAIN := LC;
52200		  WHILE SFILEPTR # NIL DO
52300		  WITH SFILEPTR^, FILEIDENT^ DO
52400		   BEGIN
52500		    VADDR:= 0; SFILEPTR:= NEXTFTP
52600		   END;
52700		  SFILEPTR := FILEPTR;
52800		 END;
52900	
53000		%COMPILE:\
53100		%********\
53200	
53300	(* 5 - CREF *)
53400	      IF CREF
53500	        THEN WRITE(CHR(15B),CHR(10),'.GLOBAL.  ');
53600	
53700	      FOR I := 1 TO CHCNTMAX DO ERRLINE[I] := ' '; RELBLOCK.COUNT:= 0;
53800	      FOR SUPPORTIX := FIRSTSUPPORT TO LASTSUPPORT DO RNTS.LINK[SUPPORTIX] := 0;
53900	
54000	(* 6 - allow PROGRAM statement *)
54100	      PROGSTAT;
54200	(* 13 - PRINT HEADER NOW THAT HAD PROG STATEMENT SCANNED *)
54300	      IF RPGENTRY
54400	       THEN WRITELN(TTY,'PASCAL:',CHR(11B),FILENAME:6);
54500	(* 41 - Don't print header *)
54600	(* 26 - break not needed for TTY *)
54700	      BLOCK(NIL,BLOCKBEGSYS OR STATBEGSYS-[CASESY],[PERIOD]);
54800	
54900	(* 104 - detect programs that don't fit in address space *)
55000	      if (highestcode > 777777B) or (lcmain > 377777B)
55100		then error(266);
55200	
55300	(* 5 - CREF *)
55400	      IF CREF
55500	        THEN WRITE(CHR(16B),CHR(10),'.GLOBAL.  ');
55600	
55700	(* 16 - EOF *)
55800	      ENDOFLINE(TRUE);
55900	(* 5 - CREF *)
56000	      if cref and not eof(input)
56100		then write(chr(177B),'A'); %balances <ro>B from ENDOFLINE\
56200	(* 136 - LISTING FORMAT *)
56300	      NEWLINE ; NEWLINE ;
56400	       IF NOT ERRORFLAG
56500	       THEN
56600		 BEGIN
56700	(* 4 - Make us look normal if called by COMPIL *)
56800		  WRITE('No ') ; IF NOT RPGENTRY THEN WRITE(TTY,'No ')
56900		 END
57000	       ELSE WRITE(TTY,'?');
57100	(* 136 - LISTING FORMAT *)
57200	      WRITE('error detected') ; NEWLINE;
57300	      IF (NOT RPGENTRY) OR ERRORFLAG 
57400	        THEN
57500	(* 26 - break not needed for TTY *)
57600	          WRITELN(TTY,'error detected');
57700	       IF ERRORFLAG
57800	(* 112 - clrbfi when error *)
57900		THEN BEGIN
58000		REWRITE(OUTPUTREL);
58100	        clribf;
58200	        end
58300	       ELSE IF NOT RPGENTRY THEN
     
00100		 BEGIN
00200	(* 136 - LISTING FORMAT *)
00300		  WRITELN(TTY); NEWLINE;
00400		  I := (HIGHESTCODE - 400000B + 1023) DIV 1024;
00500		  WRITELN(TTY,'Highseg: ',I:3,'K'); WRITELN('Highseg: ',I:3,'K');
00600		  I := (LCMAIN + 1023) DIV 1024;
00700		  WRITELN(TTY,'Lowseg : ',I:3,'K'); WRITELN('Lowseg : ',I:3,'K');
00800		 END;
00900	(* 4 - Make us look normal if called by COMPIL *)
01000	      IF  NOT RPGENTRY THEN BEGIN
01100	      RTIME := RUNTIME - RTIME;
01200	      WRITE(TTY,'Runtime: ',(RTIME DIV 60000):3,':');
01300	      RTIME := RTIME MOD 60000;
01400	      WRITE(TTY,(RTIME DIV 1000):2,'.');
01500	      RTIME := RTIME MOD 1000;
01600	      WRITELN(TTY,RTIME:3)
01700	(* 4 - get back to SCAN if appropriate *)
01800	      END;
01900	     PASXIT(INPUT,OUTPUT,OUTPUTREL)
02000	     END.