Google
 

Trailing-Edge - PDP-10 Archives - BB-4157E-BM - fortran-compiler/outmod.bli
There are 26 other files named outmod.bli in the archive. Click here to see a list.
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
!  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

!COPYRIGHT (C) 1973,1981 BY DIGITAL EQUIPMENT CORPORATION
!AUTHOR: F. INFANTE/MD/DCE/JNG/TFV/AHM

MODULE OUTMOD(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN

SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE REQREL.BLI;
SWITCHES LIST;

GLOBAL BIND OUTMOV = 6^24 + 0^18 + 85;		! Version Date:	28-Sep-81

%(

***** Begin Revision History *****

44	-----	-----	MODIFY "PROCEQUIV" TO TURN OFF THE "BOUNDS" FLAG
			WHEN ARRXPN IS CALLED FOR AN EQUIVALENCE STMNT
45	-----	-----	MOVE DECLARATIONS OF LOADER BLOCK TYPES TO A
			REQUIRE FILE.
46	-----	-----	REMOVE THE ROUTINES "ZOUTBLOCK" (WHICH
			HAS MOVED TO THE MODULE "RELBUF") AND "ZDMPBLK"
			(WHICH IS NO LONGER NEEDED)
			ALSO REMOVE THE ROUTINE "DATAOUT" AND CHANGE "OUTDATA"
			TO CALL "ZOUTBLOCK" RATHER THAN "DATAOUT". ALSO
			CHANGE OUTDATA TO CALL "DMPRLBLOCK" OF "MAINRLBF"
			WHEN THE BUFFER DOESNT HAVE ENOUGH ROOM RATHER
			THAN CALLING "ZDMPBLK".
47	-----	-----	REMOVE DEFINITIONS OF CBLK AND ZDATCNT AND ALL
			REFERENCES TO THEM.
			ALSO, REMOVE ALL REFERENCES TO "RELOCPTR" AND
			"RELBLOCK".
48	-----	-----	MODIFY "RELINIT" TO CALL "INITRLBUFFS" TO INITIALIZE
			THE REL FILE BUFFERS.
49	-----	-----	DELETE THE ROUTINE "DMPRELONLS"
50	-----	-----	DELETE THE ROUTINES:
				ZOUTMSG,ZOUTSYM,ZOUTOCT,RADIX50,ZOUDECIMAL,
				ZOUOFFSET
51	-----	-----	MISSPELLED "INIRLBUFFS" (IN "RELINIT")
			THESE HAVE BEEN MOVED TO THE MODULE "RELBUFF"
52	-----	-----	TAKE OUT THE DEF OF THE ROUTINE "CRLF" - IT IS
			NOW A MACRO DEFINED IN THE REQUIRE FILE
			"REQREL"
53	-----	-----	IN "OUTDATA", CALL "DMPMAINRLBF" TO CLEAR THE MAIN
			REL FILE BUFFER RATHER THAN CALLING "DMPRLBLOCK"
			DIRECTLY (SINCE DMPRLBLOCK DOES NOT REINIT THE BUFFER)
54	-----	-----	IN "DMPFORMAT", CALL "DMPMAINRLBF" RATHER THAN
			DMPRLBLOCK
55	-----	-----	TAKE OUT UNUSED ROUITNE ROUIMFUN
56	-----	-----	CHANGE THE CHECKS IN VARIABLE ALLOCATION TTO
			WORK PROPERLY

			PUT IN LISTING HEADING CHECKS
			PUT OUT A VALID ENTRY NAME BLOCK

57	-----	-----	IN "OUTDATA" PUT A CHECK FOR WHETHER A REL FILE
			IS BEING PRODUCED (SINCE WANT TO EXECUTE
			THE MAIN DATA STMNT PROCESSOR FOR ERROR
			DETECTION EVEN IF NO REL FILE IS PRODUCED)
58	----	----	GRPSCAN - MAKE IT PUT THE COMMON VARIABLE IN AN
			EQUIVALENCE GROUP FIRST IN THE LIST SO ITS
			DISPLACEMENT WILL BE CALCULATED FIRST IF IT WAS
			DELAYED.

			ALSO CHECK FOR TWO COMMON VARIABLES IN EQUVALENCE

			PROCEQUIV - CHECK TO BE SURE THAT AT LEAST IN THE
			SINGLE SUBSCRIPT CASE THE EQUIVALENCE IS AN INTEGER
			CONSTANT.   NO VARIABLES OR EXPRESSIONS

59	-----	----	CHECK POSITIVE AND NEGATIVE RANGE LIMITS
			OF EQUIVALENCE SUBSCRIPTS
60	-----	-----	IN "ALLFORM", PUT THE ADDRESS OF THE FORMAT
			INTO THE SNUMBER TABLE ENTRY FOR ITS LABEL
61	-----	-----	SET THE GLOBAL "ENDSCAA" TO THE ADDR AFTER END
			OF ALL ARRAYS AND SCALARS
62	-----	-----	LISTSYM - SUBPROGLIST - ALLSCA
			OUTPUT A WARNING PREFIX CHARACTER AFTER
			VARIABLES, ARRAYS WHICH WERE NEVER EXPLICITLY
			DEFINED OR WERE EXPLICITLY DEFINED BUT NEVER
			REFERENCED

			* - NOT EXPLICITLY DEFINED
			PERCENT SIGN - DEFINED BUT NOT REFERENCED

63	236	14654	EQUIVALENCE ARRAY1-ARRAY2 FAILS AFTER ARRAY1-SCALAR,
			(MD/DT)
64	241	-----	CORRECT HIGH SEG START ADDR FOR LINK
			IF LOW SEG SIZE IS GREATER THAN 128K, (MD)
65	337	17305	ROUND UP IMMEDIATE CONSTANTS CORRECTLY, (DCE)
66	364	18251	CORRECT EQUIVALENCE PROCESSING, (DCE)
67	436	19427	DON'T ALLOW 2 BLOCK COMMON VARIABLES TO
			BE EQUIVALENCED IF BLOCKS ARE DIFFERENT, (DCE)
68	470	20744	MAKE SURE HIGH SEG STARTS AT LEAST 1000 LOCS
			ABOVE END OF LOW SEG, (JNG)
69	472	20494	IF COMMON ITEM IS LAST IN GROUP,
			MOVE IT TO BEGINNING CORRECTLY, (DCE)
70	473	20478	SCALARS AND ARRAYS LISTING TOO WIDE, (DCE)
71	474	20479	SHOULD GIVE CRLF AFTER COMMON BLOCK NAMES, (DCE)

***** Begin Version 5A *****

72	604	23425	FIX LISTING OF COMMON BLOCK ELEMENTS, (DCE)

***** Begin Version 5B *****

73	636	23066	SET SNDEFINED WHEN DEFINING A LABEL, (JNG)
74	645	25249	SCALARS AND ARRAYS INCREMENTS LINE COUNT BY
			ONE TOO MANY, (DCE)
75	702	-----	LISTING OF SUBPROGRAMS CALLED CAN BE INCORRECT, (DCE)
76	703	-----	LISTING OF SCALARS AND ARRAYS CAN GIVE BLANK PAGE, (DCE)
77	735	28528	CLEAN UP LISTING OF VARIOUS HEADERS, (DCE)

***** Begin Version 6 *****

78	761	TFV	1-Mar-80	-----
	Clean up KISNGL to use CNSTCM.  Remove KA10FLG. 
	Output GFLOATING FORTRAN as compiler type in .REL file

79	1003	TFV	1-Jul-80	------
	Use binds for processor type and compiler id in REL blocks.

80	1006	TFV	1-July-80	------
	Move KISNGL to UTIL.BLI (It is also in CGEXPR.BLI.)

86	1120	AHM	9-Sep-81	Q10-06505
	Fix edit 735 by always clearing a flag so that the
	"EQUIVALENCED VARIABLES" header is produced again.

87	1133	TFV	28-Sep-81	------
	Setup CHDSTART to be the start of the hiseg for /STATISTICS.

***** End Revision History *****

)%

EXTERNAL ZOUTMSG,ZOUTSYM,ZOUTOCT,RADIX50,ZOUDECIMAL,ZOUOFFSET;
EXTERNAL ZOUTBLOCK;
EXTERNAL  STRNGOUT,CHAROUT;
EXTERNAL RDATWD,LSTOUT,FATLERR,RELDATA,RELBLOCK,HILOC,RELOCWD,RELOUT;
FORWARD ALLFORM,PROCCOM,PROCEQUIV;
EXTERNAL  HEADCHK;


GLOBAL ROUTINE LSTHDR( MINLINE, HDRLINES, HDRPTR) =

![735] THIS ROUTINE PUTS OUT VARIOUS HEADING LINES FOR THE LISTING FILE
![735] AND MAKES SURE THAT THERE IS ROOM FOR THEM ON THE CURRENT LISTING
![735] PAGE.  THE PARAMETERS ARE:
![735]		MINLINE - THERE MUST BE THIS MANY LINES LEFT ON THE CURRENT
![735]			PAGE OR THE NEXT PAGE WILL BE STARTED - THIS MAY INCLUDE
![735]			THE FIRST (OR MORE) LINE(S) AFTER THE HEADER.
![735]		HDRLINES - THIS IS THE ACTUAL NUMBER OF LINES WHICH ARE
![735]			CAUSED TO BE OUTPUT BY THE HEADER ALONE.
![735]		HDRPTR - THIS IS A POINTER TO THE ACTUAL MESSAGE TEXT, AN
![735]			ASCIZ STRING TO BE PUT INTO THE LISTING.

%[735]%	IF .FLGREG<LISTING> THEN
%[735]%	BEGIN
%[735]%		EXTERNAL HEADING, PAGELINE;
%[735]%		IF .PAGELINE LEQ .MINLINE
%[735]%		THEN %NO ROOM ON THIS PAGE% HEADING();
%[735]%		PAGELINE _ .PAGELINE-.HDRLINES;
%[735]%		STRNGOUT(.HDRPTR);
%[735]%	END;

GLOBAL ROUTINE OUTDATA(SYMADDR,SYMVALUE,SYMPT)=
BEGIN
%
ROUTINE INSTRUCTS LOADER ABOUT INITIALIZATION OF LOW SEG DATA AS SPECIFIED
IN DATA STATEMENTS.  SYMPT IS PTR TO SYMBOL BEING INITIALIZED.
SYMVALUE IS VALUE TO USE IN ITIALIZATION. SYMADDR IS THE ALLOCATED
ADDRESS OF THE SYMBOL
%
EXTERNAL DMPMAINRLBF;	!ROUTINE TO OUTPUT THE CONTENTS OF THE MAIN
			! REL FILE BUFFER AND REIINITIALIZE IT
EXTERNAL MAINRLBF;	!MAIN REL FILE BUFFER
MAP RELBUFF MAINRLBF;
MAP BASE R2:SYMPT;
BIND RDATBLK = #21;	!LOADER BLOCK TYPE FOR DATA FIXUP

	IF NOT .FLGREG<OBJECT> THEN RETURN;	!IF NO REL FILE IS TO BE PRODUCED
	IF .SYMPT[IDATTRIBUT(INCOM)]
	THEN BEGIN	!DO SPECIAL BLOCK 1 FIXUP
		IF .MAINRLBF[RDATCNT] GTR RBLKSIZ-5	!NO ROOM LEFT IN BUFFER FOR NEXT
						!  3 WDS
		THEN DMPMAINRLBF();
		R2 _ .SYMPT[IDCOMMON]; !PTR TO COMMON BLOCK NODE
		R2 _ .R2[COMNAME];
		RDATWD _ RGLOBREQ + RADIX50();
		ZOUTBLOCK(RDATBLK,RELN);
		RDATWD _ (1^18) + .SYMADDR<RIGHT>;
		ZOUTBLOCK(RDATBLK,RELN);
		RDATWD _ .SYMVALUE;
		ZOUTBLOCK(RDATBLK,RELN);
	     END
	ELSE BEGIN
		IF .MAINRLBF[RDATCNT] GTR RBLKSIZ-4
		 THEN DMPMAINRLBF(); !NO ROOM LEFT IN BUFFER FOR 2 WORDS
		RDATWD _ (1^18)+.SYMADDR<RIGHT>;
		ZOUTBLOCK(RDATBLK,RELRI);
		RDATWD _ .SYMVALUE;
		ZOUTBLOCK(RDATBLK,RELN);
	     END;
END;	!OF OUTDATA
ROUTINE LISTSYM(PTR)=
BEGIN
EXTERNAL LSTOUT,ZOUTSYM,ZOUTOCT,ZOUTMSG,PROGNAME;
EXTERNAL CHAROUT;
MAP BASE PTR;
LABEL BLNK;
     		R2 _ .PTR[IDSYMBOL];
		% NOTE INSTANCES OF  NO EXPLICIT DEFINITION %
		BLNK:BEGIN
			IF NOT .PTR[IDATTRIBUT(INTYPE)]
			THEN	IF  .PTR[OPRSP1]  NEQ  ARRAYNM1
				THEN
					IF .R2<30,6>  NEQ  SIXBIT"."	!FORGET COMPLER DEFINED VARS
					THEN	( CHAROUT( "*" ); LEAVE BLNK );
			CHAROUT( " " );
		END;	%BLNK%
		ZOUTSYM();
		CHR _ #11; LSTOUT(); !TAB
		R2<LEFT> _ .PTR[IDADDR]; ZOUTOCT();
		CHR_#11;LSTOUT();!TAB
END;
ROUTINE SUBPROGLIST=
BEGIN
!
!LISTS CALLED SUBPROGRAMS ON LIST DEVICE IN ALLOCATION SUMMARY
!
EXTERNAL LSTOUT,ZOUTSYM,ZOUTMSG,PROGNAME;
EXTERNAL HEADCHK;	!CHECKS FOR END OF LISTNG PAGE
%[735]% LOCAL BASE SYMPTR,COUNT,HDRFLG;
EXTERNAL HEADING,PAGELINE;

%[702]%	COUNT_0;
%[735]% HDRFLG _ 0; !NO HEADING LINE OUTPUT YET
DECR I FROM SSIZ-1 TO 0 DO
BEGIN
	IF (SYMPTR _ .SYMTBL[.I]) NEQ 0
	THEN DO BEGIN
			IF .SYMPTR[OPRSP1] EQL FNNAME1
			THEN IF NOT .SYMPTR[IDATTRIBUT(NOALLOC)]
				THEN BEGIN
%[702]%					IF .COUNT LEQ 0 THEN HEADCHK();
%[735]%					IF .HDRFLG EQL 0 THEN
%[735]%					BEGIN
%[735]%						HDRFLG _ 1;
%[735]%						LSTHDR(5,4,PLIT'?M?J?M?JSUBPROGRAMS CALLED?M?J?M?J?0');
%[735]%					END;
					R2 _ .SYMPTR[IDSYMBOL];  ZOUTSYM();
					IF (COUNT _ .COUNT+1) GTR 5
%[702]%					THEN (COUNT _ 0; CRLF)
					ELSE (C _ #11; LSTOUT());
				     END;
		END WHILE (SYMPTR _ .SYMPTR[CLINK]) NEQ 0;
END;
%[702]%	IF .COUNT NEQ 0 THEN CRLF;
END;	!OF ROUTINE SUBPROGLIST
ROUTINE ALLSCAA=	!ALLOCATES STORAGE TO LOCAL SCALARS AND 
				!ARRAYS (NOT IN COMMON AND NOT IN EQUIVALENCE LISTS)
				!SEARCHES SYMTBL
				!ASSUMES ALL FIXUPS AND ALLOCATION  FOR COMMON AND EQUIVALENCE
				!HAVE ALREADY BEEN DONE.
BEGIN
OWN PTR,SCNT;
EXTERNAL LSTOUT,LOWLOC,ZOUTSYM,ZOUTOCT,ZOUTMSG,PROGNAME;
%[735]% LOCAL HDRFLG;	!SCALARS AND ARRAYS LISTING HEADER FLAG
EXTERNAL ENDSCAA;
LOCAL BASE ARRAPT;
LABEL L1,L2;
MAP BASE PTR;
%[735]%	ROUTINE HDRSAA=
%[735]%	LSTHDR(4,3,PLIT '?M?JSCALARS AND ARRAYS [ "*" NO EXPLICIT DEFINITION - "%" NOT REFERENCED ]?M?J?M?J?0');
%[735]%	HDRFLG_0;
	SCNT_0;
	DECR I FROM SSIZ-1 TO 0 DO
	BEGIN
	  IF (PTR _ .SYMTBL[.I]) NEQ 0
	  THEN	BEGIN
		DO BEGIN
		L1: IF NOT  .PTR[IDATTRIBUT(INCOM)]
			AND NOT .PTR[IDATTRIBUT(NAMNAM)]
			AND NOT .PTR[OPERSP]  EQL  FNNAME
				%ALLOCATE SPACE FOR FORMAL FUNCTIONS%
			THEN
			IF NOT .PTR[IDATTRIBUT(NOALLOC)]
			THEN(  IF NOT .PTR[IDATTRIBUT(INEQV)]
					%EQUIVALENCED VARS ARE LISTED BUT NOT ALLOCATED HERE%
			     THEN
			     L2:BEGIN
			!
			!ALLOACATE AN ADDRESS ONLY IF ALL ABOVE TESTS PASSED
			!
				PTR[IDADDR] _ .LOWLOC;
				IF .PTR[OPRSP1] EQL ARRAYNM1 !IS IT AN ARRAY?
				 THEN(  ARRAPT _ .PTR[IDDIM]; !PTR TO DIMENSION NODE
					 IF NOT .PTR[IDATTRIBUT(DUMMY)]
					       THEN (
							LOWLOC _ .LOWLOC+ .ARRAPT[ARASIZ];
							LEAVE L2;
					            )
						ELSE IF NOT .ARRAPT[ADJDIMFLG]
							THEN (LOCAL BASE PTRVAR;
								PTRVAR _ .ARRAPT[ARADDRVAR];
								PTRVAR[IDADDR] _ .LOWLOC;
							     );
						LOWLOC _ .LOWLOC + 1;
						LEAVE L2
					);
				  IF .PTR[DBLFLG] !IS THE VARIABLE DOUBLE LENGTH?
					THEN LOWLOC _ .LOWLOC + 2
					ELSE LOWLOC _ .LOWLOC + 1
			     END;
			     IF .FLGREG<LISTING>
				THEN
				BEGIN
%[703]%				IF .SCNT LEQ 0 THEN HEADCHK();
%[735]%					IF .HDRFLG EQL 0 THEN (HDRFLG_1; HDRSAA());
%[703]%					LISTSYM(.PTR);
%[703]%					IF .SCNT LSS 4 THEN SCNT_.SCNT+1 ELSE (SCNT_0;CRLF);
				END;
			)
			ELSE
			BEGIN
			  IF .FLGREG<LISTING>
			  THEN
			  BEGIN
				%NOTE NAMES WHICH HAVE BEEN DECLARED
				 BUT NEVER REFERENCED  AND THUS NEVER
				  ALLOCATED%
				IF .PTR[OPRSP1]  EQL ARRAYNM1
				  OR  .PTR[IDATTRIBUT(INTYPE)]
				  OR  .PTR[IDATTRIBUT(DUMMY)]
				THEN
				BEGIN
%[703]%					IF .SCNT LEQ 0 THEN HEADCHK();
%[735]%					IF .HDRFLG EQL 0 THEN (HDRFLG_1; HDRSAA());
					R2_.PTR[IDSYMBOL];
					CHAROUT("%");
					ZOUTSYM();
					CHAROUT(#11);	!TAB
					CHAROUT(#11);	!TAB
					!LISTING FOR SCALARS AND ARRAYS IS A BIT TOO WIDE
%[703]%					IF .SCNT LSS 4 THEN SCNT _ .SCNT+1 ELSE (SCNT _ 0; CRLF);
				END
			  END
			END;

		    END WHILE (PTR _ .PTR[CLINK]) NEQ 0
	   END
	END;
%[703]%	IF .FLGREG<LISTING>  THEN IF .SCNT NEQ 0 THEN CRLF;

	ENDSCAA_.LOWLOC;	!LOC AFTER LAST ARRAY/SCALAR
END;
!THE ROUTINES IN THIS MODULE ARE FOR THE PURPOSE
!OF GENERATING THE FOLLOWING THINGS:
%	THE CORRECT ALLOCATION OF ADDRESSES TO THE VARIABLES,ARRAYS
	CONSTANTS,STRINGS ETC., IN THE SUBPROGRAM BEING COMPILED
	.THE STATISTICS LISTING OF THE SCALARS,ARRAYS ,COMMON,
	 CONSTANTS,TEMPORARIES ETC. THAT THE SUBPROGRAM DEFINES.
%
!
ROUTINE ALLCOM=
BEGIN
%ROUTINE ALLOCATES RELATIVE ADDRESSES TO ALL VARIABLES DECLARED IN COMMON.
THE ADDRESSES OF THE VARIABLES / ARRAYS IN A COMMON BLOCK ARE ARLATIVE TO THE 
BEGINNING OF THE BLOCK IN WHICH THEY ARE DECLARED. EACH BLOCK HAS AN ORIGIN
OF ZERO. AT LOAD TIME THE LOADER WILL ASSIGN ACTUAL LOCATIONS TO 
COMMON BLOCKS BASED ON THEIR SIZES AND ORDER OF
APPEARANCE TO LOADER. IN THE RLOACTABLE BINARY, REFERENCES TO
COMMON VARIABLES WILL USE ADDITIVE GLOBAL FIXUPS.

THE CALL TO THIS ROUTINE OCCURS AFTER ANY EQUIVALENCE RELATIONS 
HAVE BEEN PROCESSED BY ROUTINE PROCEQUIV
%
REGISTER ICNT;
EXTERNAL COMBLKPTR,EQVPTR;
REGISTER BASE CSYMPTR;
LOCAL BASE CCOMPTR;
MACRO COMBLOK=#20$;

ICNT _ 0;
%[735]%	 LSTHDR(5,3,PLIT'?M?JCOMMON BLOCKS?M?J?0');
CCOMPTR _ .FIRCOMBLK; !PTR TO FIRST COMMON BLOCK DECLARED
WHILE 1 DO  %1%
BEGIN
	!START BY OUTPUTTING NAME OF BLOCK
	IF .FLGREG<LISTING> THEN
	BEGIN
	  CRLF;
	  HEADCHK();
	  CHR_"/";LSTOUT();
	R2 _ .CCOMPTR[COMNAME]; ZOUTSYM();
	  CHR _ "/"; LSTOUT();
	  CHR _ "("; LSTOUT(); R1 _ .CCOMPTR[COMSIZE]; ZOUOFFSET(); CHR _ ")"; LSTOUT();
	END;
	!RELOCATABLE BINARY IF NECESSARY
	IF .FLGREG<OBJECT>
	THEN (R2 _ .CCOMPTR[COMNAME]; !FOR RADIX 50 CONVERSION
		RDATWD_RGLOBDEF+RADIX50(); ZOUTBLOCK(COMBLOK,RELN);
		RDATWD_ .CCOMPTR[COMSIZE]; ZOUTBLOCK(COMBLOK,RELN);
	     );
	!NOW LIST THE SYMBOLS IN THE BLOCK

		IF .FLGREG<LISTING> THEN
		BEGIN
			CSYMPTR _ .CCOMPTR[COMFIRST];
		CRLF;!CR/LF
		HEADCHK();
		WHILE 1 DO %2%
		BEGIN
		R2 _ .CSYMPTR[IDSYMBOL]; ZOUTSYM();
		CHR _ #11; LSTOUT();	!TAB
		R1 _ .CSYMPTR[IDADDR]; ZOUOFFSET();
		!BE SURE TO OUTPUT CRLF AFTER LAST COMMON BLOCK NAME
		IF (CSYMPTR _ .CSYMPTR[IDCOLINK]) EQL 0 THEN
			!RESET ICNT SO THAT WE DO NOT GET LINE WITH SINGLE
			! ELEMENT BY ACCIDENT!
			(ICNT_0; CRLF; HEADCHK();
				EXITLOOP);
		IF (ICNT _ .ICNT +1) EQL 5
		THEN (ICNT _ 0; CRLF; HEADCHK()) ELSE (CHR _ #11; LSTOUT() %TAB% );
		END; !OF %2%
	END;

	IF (CCOMPTR _ .CCOMPTR[NEXCOMBLK]) EQL 0 THEN RETURN;
END
END;	!OF ALLCOM ROUTINE
ROUTINE ALLOCAT=
BEGIN
%ALOCATES RELATIVE ADDRESSES TO ALL VARIABLES AND STORAGE
 IN THE LOW SEGMENT,EXCEPT TEMPORARIES WHICH ARE ALLOCATED AFTER
 CODE GENERATION.
THIS ROUTINE CONTROLS THE ALLOCATION BY CALLING THE ACTUAL ROUTINES
THAT DO THE ALLOCATION AND PROCESSING OF VARIABLES,COMMON BLOCKS,EQUIVALENCE
 GROUPS ,DATA FIXUPS ETC.
%

EXTERNAL LSTOUT,FATLERR,FORMPTR,COMBLKPTR,EQVPTR,
	LOWLOC,	!LOW SEG AVAILABLE ADDRESS
	COMSIZ;	!CURRENT TOTAL SIZE OF COMMON INCLUDING BLANK

COMSIZ _ 0;
IF .COMBLKPTR NEQ 0 THEN COMSIZ _ PROCCOM(); ! PROCESS COMMON BLOCKS
IF .EQVPTR NEQ 0 THEN PROCEQUIV();	!PROCESS EQUIVALENCE GROUPS
IF .COMBLKPTR NEQ 0 THEN ALLCOM(); !ALLOCATE COMMON NOW
!
!NOW ALLOCATE AND LIST ALL VARIABLES,ARRAYS ETC.
!
!LIST SUBPROGRAMS CALLED IF ANY
!
IF .FLGREG<LISTING> THEN SUBPROGLIST();
ALLSCAA();	!ALLOCATE SCALARS AND ARRAYS

IF .FORMPTR NEQ 0 THEN ALLFORM();	!ALLOCATE FORMAT STRINGS

END;
ROUTINE DMPFORMAT=
BEGIN
!
!DUMPS FORMAT STRING DEFINITIONS  TO REL FILE AFTER ALL LOWSEG
!ALLOCATION HAS BEEN DONE
!
LOCAL SAVHILOC;
REGISTER BASE ZFORPTR;
EXTERNAL LOWLOC,FORMPTR,HILOC,DMPMAINRLBF;
ZFORPTR _ .FORMPTR<LEFT>;	!PTR TO FIRST FORMAT STRING
SAVHILOC _ .HILOC; HILOC _ .ZFORPTR[FORADDR]; !TO PUT DATA BLOCK IN LOWSEG
DO
BEGIN
	INCR I FROM 0 TO .ZFORPTR[FORSIZ]-1 DO
	 (RDATWD _ .(.ZFORPTR[FORSTRING])[.I]<FULL>;
	  ZOUTBLOCK(RCODE,RELN);
	   HILOC _ .HILOC+1;	!INCREMENT FOR POSSIBLE USE IN ZOUTBLOCK
	 );
END WHILE (ZFORPTR _ .ZFORPTR[FMTLINK]) NEQ 0;
DMPMAINRLBF();	!DUMP OUT THE CODE BLOCK IMMEDIATELY
HILOC _ .SAVHILOC;
RETURN .VREG
END;
ROUTINE ALLFORM=
BEGIN
%ALLOCATES LOW SEG STORAGE ADDRESS TO FORMAT STRINGS
BUT DOES NOT TELL THE LOADER YET
%
REGISTER BASE ZFORPTR;
EXTERNAL LOWLOC,FORMPTR,HILOC;
ZFORPTR _ .FORMPTR<LEFT>;	!PTR TO FIRST FORMAT STRING
WHILE 1 DO
BEGIN
	REGISTER BASE SNUMENTRY;
	SNUMENTRY_.ZFORPTR[SRCLBL];
	ZFORPTR[FORADDR] _ .LOWLOC;
	SNUMENTRY[SNADDR]_.LOWLOC;	!SET ADDRESS OF THE LABEL
%[636]%	SNUMENTRY[SNDEFINED]_TRUE;	!REMEMBER THAT SNADDR IS VALID
	LOWLOC _ .LOWLOC+.ZFORPTR[FORSIZ];
	IF .ZFORPTR[FMTLINK] EQL 0
	THEN EXITLOOP
	ELSE ZFORPTR _ .ZFORPTR[FMTLINK]
END;
RETURN .VREG
END;
ROUTINE PROCCOM=
BEGIN
%ROUTINE MAKES A FAST PASS THRU THE LINKED LISTS OF COMMON BLOCKS
AND ASSOCIATED SYMBOL TABLE ENTRIES COMPUTING THE DECLARED SIZE OF EACH
BLOCK AND ASSIGNING A TEMPORARY ADDRESS TO THE VARIABLES IN EACH
BLOCK RELATIVE TO THE BEGINNING OF THE BLOCK
%
EXTERNAL COMBLKPTR;
MACRO CBLKSIZ = R1$,	!SIZE OF CURRENT BLOCK
	TCOMSIZ = R2$;
REGISTER BASE CSYMPTR;
LOCAL BASE CCOMPTR;
!
XTRAC;
!
TCOMSIZ _ 0;
CCOMPTR _ .FIRCOMBLK;	!PTR TO FIRST COMMON BLOCK

WHILE 1 DO	%1% !LOOP ON LINKED LIST
BEGIN
	CSYMPTR _ .CCOMPTR[COMFIRST];	!PTR TO FIRST SYMBOL ENTRY IN BLOCK
	CBLKSIZ _ 0;
	WHILE 1 DO %2% !LOOP ON LINKEDLIST OF SYMBOLS IN BLOCK
	BEGIN
	  CSYMPTR[IDADDR] _.CBLKSIZ;
	  IF .CSYMPTR[IDDIM] NEQ 0
	  THEN (LOCAL BASE DIMPTR;
		DIMPTR _ .CSYMPTR[IDDIM];
		CBLKSIZ _ .CBLKSIZ + .DIMPTR[ARASIZ];
		)
	  ELSE (IF .CSYMPTR[VALTYPE] GTR REAL
		THEN CBLKSIZ _ .CBLKSIZ + 2
		ELSE CBLKSIZ _ .CBLKSIZ + 1
		);
	  IF .CSYMPTR[IDCOLINK] EQL 0 THEN EXITLOOP
		ELSE CSYMPTR _ .CSYMPTR[IDCOLINK];
	END;! OF %2% LOOP
  !NOW UPDATE TOTAL SIZE OF COMMON
	CCOMPTR[COMSIZE] _ .CBLKSIZ;
	TCOMSIZ _ .TCOMSIZ + .CBLKSIZ;
	IF .CCOMPTR[NEXCOMBLK] EQL 0
	  THEN EXITLOOP
	  ELSE CCOMPTR _ .CCOMPTR[NEXCOMBLK];
END; !OF %1% LOOP
RETURN .TCOMSIZ
END; !OF ROUTINE
ROUTINE EQERRLIST(GROUP)=
BEGIN
!LIST THE GROUP OF EQUIVALENCE VARIABLES IN CONFLICT
!
EXTERNAL LSTOUT,ZOUTMSG,ISN,E49;
MAP BASE GROUP:R2;
LOCAL BASE SYMPTR;
	SYMPTR _ .GROUP[EQVFIRST];
	FATLERR(.ISN,E49<0,0>);	!SAME MSG AS BELOW
	IF NOT .FLGREG<LISTING> THEN RETURN;
	HEADCHK();
	STRNGOUT(PLIT '?M?J	CONFLICTING VARIABLES( ?0');
	WHILE 1 DO(	R2 _ .SYMPTR[EQLID];
			R2 _ .R2[IDSYMBOL]; ZOUTSYM();
			IF (SYMPTR _ .SYMPTR[EQLLINK]) EQL 0 THEN( STRNGOUT(PLIT')?M?J'); HEADCHK();  EXITLOOP)
				ELSE (C _ ","; LSTOUT());
		   );
END;	!OF EQERRLIST
ROUTINE GROUPTOCOMMON(COMSYM,NEWGRP,ELIM,GRPDISPL)=
BEGIN
!COMSYM POINTS TO SYMBOL ALREADY IN COMMON
!NEWGRP POINTS TO NEW EQV GROUP GOING TO COMMON
!ELIM IS THE EQVLIMIT OF GROUP TO WHICH COMSYM BELONGS
!GRPDISPL IS THE DISPLACEMENT OF THE MATCH ITEM IN NEWGRP
!
MAP BASE COMSYM :NEWGRP;
LOCAL BASE COMBLPTR :LASCOMSYM :DIMPTR :NEWSYM :NEWITEM;
LOCAL SYMSIZ;
NEWITEM _ .NEWGRP[EQVFIRST];	!FIRST ITEM IN NEW GROUP
WHILE 1 DO
BEGIN
   NEWSYM _ .NEWITEM[EQLID]; !PTR TO SYMBOL TABLE NODE
   IF .COMSYM NEQ .NEWSYM
   THEN IF NOT .NEWSYM[IDATTRIBUT(INCOM)]
	THEN
	BEGIN
		IF (NEWSYM[IDADDR] _ .COMSYM[IDADDR] + .NEWITEM[EQLDISPL] - .GRPDISPL) LSS 0
		   THEN
			BEGIN
				EXTERNAL FATLERR,ISN,E33;
				COMBLPTR _ .COMSYM[IDCOMMON];
				RETURN FATLERR(COMBLPTR[COMNAME],.ISN,E33<0,0> );
			END;
		NEWSYM[IDATTRIBUT(INCOM)] _ 1; !PUT SYMBOL INCOMMON
		COMBLPTR _ .COMSYM[IDCOMMON];
		LASCOMSYM _ .COMBLPTR[COMLAST]; !LAST SYMBOL IN COMMON BLOCK
		LASCOMSYM[IDCOLINK] _ .NEWSYM; !POINT TO NEW SYMBOL
		NEWSYM[IDCOLINK] _ 0;
		NEWSYM[IDCOMMON] _ .COMBLPTR; !SYMBOL POINTS TO COMMON BLOCK
		COMBLPTR[COMLAST] _ .NEWSYM;
		SYMSIZ _ IF .NEWSYM[IDDIM] NEQ 0
			 THEN (DIMPTR _ .NEWSYM[IDDIM]; .DIMPTR[ARASIZ])
			 ELSE IF .NEWSYM[DBLFLG] THEN 2 ELSE 1;
		IF (.NEWITEM[EQLDISPL] + .SYMSIZ) GTR .ELIM
		THEN ELIM _ (.NEWITEM[EQLDISPL] + .SYMSIZ);
		IF .COMBLPTR[COMSIZE] LSS ( .NEWSYM[IDADDR] + .SYMSIZ)
		THEN
			COMBLPTR[COMSIZE] _ (.NEWSYM[IDADDR] + .SYMSIZ);
	END
	ELSE IF (.NEWSYM[IDADDR] - .NEWITEM[EQLDISPL])
		  NEQ (.COMSYM[IDADDR] - .GRPDISPL)
		THEN ( EQERRLIST(.NEWGRP);
			NEWGRP[EQVAVAIL] _ 3; RETURN -1
		     );
   IF .NEWITEM[EQLLINK] EQL 0
	THEN RETURN .ELIM
	ELSE NEWITEM _ .NEWITEM[EQLLINK];
END;  !OF WHILE 1
END;  !OF SUBROUTINE GROUPTO COMMON
ROUTINE LINKGROUPS(GROUP1,GROUP2,G1SYM)=
BEGIN
!LINK ITEMS IN GROUP2 INTO GROUP1 WHEN EITHER GROUP IS IN COMMON
!TO ALLOW FOR FURTHER SEARCHING OF GROUP1 BY LATER GROUPS
!
MAP BASE GROUP1 :GROUP2 :G1SYM;
LOCAL BASE G1ITEM :G2ITEM :NEXG2ITEM;
G2ITEM _ .GROUP2[EQVFIRST];
WHILE 1 DO
BEGIN
	NEXG2ITEM _ .G2ITEM[EQLLINK];
	IF .G1SYM NEQ .G2ITEM[EQLID]
	THEN (G1ITEM _ .GROUP1[EQVLAST];
		G1ITEM[EQLLINK] _ .G2ITEM;
		GROUP1[EQVLAST] _ .G2ITEM;
		G2ITEM[EQLLINK] _ 0;
	      );
	IF (G2ITEM _ .NEXG2ITEM) EQL 0 THEN RETURN .VREG;
END;  !OF WHILE 1
END;  !OF LINKGROUPS
ROUTINE ELISTSRCH(ECLASS,EGROUP)=
BEGIN
%SEARCH EACH ITEM IN GROUP POINTED TO BY EGROUP AGAINST ALL ITEMS IN 
CLASS POINTED TO BY ECLASS. WHEN MATCH IS FOUND IF AT ALL, THEN LINK
ITEMS IN EGROUP INTO ECLASS IF NEITHER EGROUP NOR ECLASS IS IN COMMON.
 IF EITHER (BUT NOT BOTH)ARE IN COMMON THEN ADD NEW ITEMS
NOT IN COMMON INTO COMMON BLOCK OF WHICH ECLASS OR EGROUP ITEMS ARE MEMBERS.
 ERRORS OCCUR IF BOTH ECLASS AND EGROUP ARE IN COMMON.
%
LABEL ELIS1,ELIS2;
LOCAL	EGSYM,	!SYMBOL BEING SEARCHED IN GROUP
	EGSYMPTR,	!PTR TO SYMBOL TABLE OF SYMBOL BING SEARCHED
	EGITEM,	!PTR TO CURRENT EQUIVLIST ITEM IN GROUP
	CITEM,	!PTR TO LIST ITEM IN CLASS ECLASS
	CSYMPTR;	!PTR TO SYMBOL TABLE OF ITEM IN ECLASS

MAP BASE ECLASS :EGROUP :EGSYMPTR :CITEM :CSYMPTR :EGITEM;
!
XTRAC;	!FOR DEBUGGING TRACE
!
EGITEM _ .EGROUP[EQVFIRST];	!FIRST LIST ITEM IN EGROUP

IF 
ELIS1: (WHILE 1 DO
       BEGIN
	!SEARCH FOR MATCH OF ITEM IN ECLASS WITH ITEM IN EGROUP
	EGSYMPTR _ .EGITEM[EQLID]; EGSYM _ .EGSYMPTR[IDSYMBOL]; !GET THE SYMBOL
	CITEM _  .ECLASS[EQVFIRST]; !THE PTR TO FIRST LIST ITEM IN ECLASS
 ELIS2: WHILE 1 DO %2%
	BEGIN
		CSYMPTR _ .CITEM[EQLID]; !SYMBOL TABLE PTR
		IF .EGSYM EQL .CSYMPTR [IDSYMBOL]
		THEN LEAVE ELIS1 WITH (-1);
		IF .CITEM[EQLLINK] EQL 0
		THEN LEAVE ELIS2
		ELSE CITEM _ .CITEM[EQLLINK];
	END; !OF %2%
	IF .EGITEM[EQLLINK] EQL 0
	THEN LEAVE ELIS1 WITH  (0)
	ELSE EGITEM _ .EGITEM[EQLLINK];
       END !OF WHILE %1%
  )  EQL 0 THEN RETURN 0; !RETURN 0 IF NO MATCH BETWEEN ECLASS AND EGROUP
!
!WE GET HERE IF AN ITEM IN EGROUP MATCHES AN ITEM IN ECLASS
!CITEM POINTS TO THE ITEM IN ECLASS AND EGITEM POINTS TO THE
!ITEM IN EGROUP. WE NOW CHECK FOR COMMON EQUIVALENCE INTERACTION
!AND DECIDE WHETHER TO LINK THE NEW ITEMS INTO ECLASS OR TO ADD NEW ITEMS TO
!THE COMMON BLOCK OF WHICH ECLASS OR EGROUP (BUT NOT BOTH) IS A PART
!
BEGIN LOCAL EGDISPL,ELIM,ECDISPL;
	IF .CSYMPTR[IDATTRIBUT(INCOM)] THEN IF NOT .ECLASS[EQVINCOM]
	THEN BEGIN
		ECLASS[EQVINCOM] _ 1;
		IF
		ECLASS[EQVLIMIT] _ GROUPTOCOMMON(.CSYMPTR,.ECLASS,.ECLASS[EQVLIMIT],.CITEM[EQLDISPL])
		LSS 0 THEN RETURN -1
	     END;
!
!CSYMPTR CONTAINS PTR TO MATCHED SYMBOL IN ECLASS
!EGSYMPTR CONTAINS PTR TO MATCHED SYMBOL IN EGROUP
!
ELIM _ .ECLASS[EQVLIMIT];	!LIMIT OF GROUP
EGDISPL _ .EGITEM[EQLDISPL];
ECDISPL _ .CITEM[EQLDISPL];
EGITEM _ .EGROUP[EQVFIRST];
EGSYMPTR _ .EGITEM[EQLID]; !SET PTR TO FIRST ITEM IN GROUP 

!
!TEST FOR GROUP OR CLASS IN COMMON
!
IF .ECLASS[EQVINCOM] OR .EGROUP[EQVINCOM]
  THEN
   BEGIN
	EXTERNAL ISN,FATLERR,E48;
!	IF .ECLASS[EQVINCOM] AND .EGROUP[EQVINCOM]
!	THEN ( IF .ECLASS[EQVHEAD] NEQ .EGROUP[EQVHEAD]
!		 THEN (FATLERR(.ISN,E48<0,0>); RETURN -1;); !TWO COMMON ITEMS EQUIVALENCED
!	     )
!	ELSE
	 IF .EGROUP[EQVINCOM]
	  THEN( !ASSIGN COMMON ADDRESSES TO ECLASS
		ELIM _ .EGROUP[EQVLIMIT];
		EGDISPL _ .CITEM[EQLDISPL]; ECDISPL _ .EGITEM[EQLDISPL];
		CSYMPTR _ .EGITEM[EQLID];
		EGITEM _ .ECLASS[EQVFIRST]; EGSYMPTR _ .EGITEM[EQLID];
	      );
	WHILE 1 DO %1%
	BEGIN
  !NOW CHECK NEW COMMON ADDRESS NOW AND LINK NEW ITEM INTO EXISTING COMMON BLOCK
	IF .CSYMPTR NEQ .EGSYMPTR
	THEN
	  IF NOT (.ECLASS[EQVINCOM] AND .EGROUP[EQVINCOM])
	  THEN IF NOT .EGSYMPTR[IDATTRIBUT(INCOM)]
	     THEN
	        BEGIN LOCAL BASE CLCOMPTR :GPCOMPTR :COMSYM :ESYM;
			LOCAL EGSYMSIZ;
			EXTERNAL FATLERR,E33,ISN;
		  IF (EGSYMPTR[IDADDR] _ .CSYMPTR[IDADDR] + .EGITEM[EQLDISPL] -.EGDISPL) LSS 0
			THEN (MAP BASE R1;
				R1 _ .CSYMPTR[IDCOMMON];
				RETURN FATLERR(R1[COMNAME],.ISN,E33<0,0>)
		     );
			 !ERROR EQUIVALENCE ITEM EXTENDS COMMON BACKWARD
	
		  EGSYMPTR[IDATTRIBUT(INCOM)] _ 1; !MAKE SYMBOL IN COMMON
		  CLCOMPTR _ .CSYMPTR[IDCOMMON]; !PTR TO COMMON BLOCK HDR
		  COMSYM _ .CLCOMPTR[COMLAST];	!PTR TO LAST SYMBOL IN BLOCK
		  COMSYM[IDCOLINK] _ .EGSYMPTR; !LINK IN NEW SYMBOL
		  CLCOMPTR[COMLAST] _ .EGSYMPTR;
		  EGSYMPTR[IDCOLINK] _ 0; !NEW END OF LINK
		  EGSYMPTR[IDCOMMON] _ .CLCOMPTR; !SYMBOL TO POINT TO BLOCK
	!  COMPUTE NEW BLOCK SIZE
	!  
		  EGSYMSIZ _ IF .EGSYMPTR[IDDIM] NEQ 0
				THEN (ESYM _ .EGSYMPTR[IDDIM]; .ESYM[ARASIZ])
				ELSE IF .EGSYMPTR[DBLFLG] THEN 2 ELSE 1;
		  IF (.EGITEM[EQLDISPL] + .EGSYMSIZ)  GTR .ELIM
			THEN ELIM _ (.EGITEM[EQLDISPL] + .EGSYMSIZ);
		  IF .CLCOMPTR[COMSIZE] LSS (R1 _ .EGSYMPTR[IDADDR] + .EGSYMSIZ)
		   THEN CLCOMPTR[COMSIZE] _ .R1;
	       END
	    ELSE IF (.EGSYMPTR[IDADDR]-.EGITEM[EQLDISPL])
			NEQ (.CSYMPTR[IDADDR]-.EGDISPL)
			THEN (EQERRLIST(.EGROUP); EGROUP[EQVAVAIL] _ 3; RETURN -1);
!
!TESTING FOR END OF CHAIN OF GROUP GOING INTO COMMON
	  IF .EGITEM[EQLLINK] NEQ 0
	   THEN (EGITEM _ .EGITEM[EQLLINK]; EGSYMPTR _ .EGITEM[EQLID])
	   ELSE (
		  LINKGROUPS(.ECLASS,.EGROUP,.CSYMPTR);
		  ECLASS[EQVINCOM] _ 1;
		  !THIS IS A SUCCESSFUL TRIP - RETURN 1!
		  EGROUP[EQVAVAIL] _ 2; EGROUP[EQVINCOM]_1;RETURN 1
		);
	END; !OF LOOP%1%
   END; !END OF IF INCOMMON
!
!HERE IF NEITHER GROUP NOR CLASS IN COMMON
!LINK ITEMS IN EGROUP INTO ECLASS, MARK EACH GROUP UNAVAILABLE
!CHECK FOR ERRORS OF FORM
! EQUIVALENCE (A(5),B(2)),(C(2),B(2)),(C(2),A(4))
!
EGITEM _ .EGROUP[EQVFIRST];
WHILE 1 DO
BEGIN LOCAL ENEXITEM,NEWDISPL;
	ENEXITEM _ .EGITEM[EQLLINK];  !PTR TO NEXT ITEM IN GROUP TO BE LINKED TO CLASS
	EGSYMPTR _ .EGITEM[EQLID];
	EGSYM _ .EGSYMPTR[IDSYMBOL];

!NOW SEARCH FOR EGSYM IN ECLASS
!
	CITEM _ .ECLASS[EQVFIRST];	!PTR TO FIRST ITEM IN CLASS
	NEWDISPL _ .ECDISPL + .EGITEM[EQLDISPL] -.EGDISPL;
	IF WHILE 1 DO
	   BEGIN   %2%
		CSYMPTR _ .CITEM[EQLID];
		IF .EGSYM EQL .CSYMPTR[IDSYMBOL]
		  THEN EXITLOOP (-1);
		IF .CITEM[EQLLINK] EQL 0
		  THEN EXITLOOP (0)
		  ELSE CITEM _ .CITEM[EQLLINK]
	   END  !OF %2%
	NEQ 0
	  THEN	!MAKE SURE DISPLACEMENTS OF MATCHING ITMES ARE OK
	    (	IF .NEWDISPL NEQ .CITEM[EQLDISPL]
		  THEN (EQERRLIST(.EGROUP); !INCONSISTENT OR CONFLICTING EQUIVALENCES
			EGROUP[EQVAVAIL] _ 3; RETURN -1
		       );
	    )
	  ELSE	(CITEM[EQLLINK] _ .EGITEM;
		);
	EGITEM[EQLLINK] _ 0;	!CLEAR LINK
	EGITEM[EQLDISPL] _ .NEWDISPL;
	IF .NEWDISPL LSS .ECLASS[EQVADDR]
	  THEN ECLASS[EQVADDR] _ .NEWDISPL;
!
!NOW COMPUTE NEW EQVLIMIT
!
	BEGIN LOCAL BASE ESYM, EQSIZ;
	  EQSIZ _ IF .EGSYMPTR[IDDIM] NEQ 0
			THEN (ESYM _ .EGSYMPTR[IDDIM]; .ESYM[ARASIZ])
			ELSE IF .EGSYMPTR[DBLFLG] THEN 2 ELSE 1;
	  IF (.EGITEM[EQLDISPL] + .EQSIZ) GTR .ECLASS[EQVLIMIT]
		THEN ECLASS[EQVLIMIT] _ (.EGITEM[EQLDISPL] + .EQSIZ);
	END;
	IF .ENEXITEM EQL 0 THEN RETURN 1  !GOOD RETURN (ALLITEMS IN EGROUP LINKED TO ECLASS)
		 ELSE EGITEM _ .ENEXITEM;
END; !OF %1%
END;
END;	!OF ROUTINE ELISTSRCH
ROUTINE EQCALLOC(ECLASS)=
BEGIN
%
ALLOCATE RELOCATABLE ADDRESSES TO AN EQUIVALENCE CLASS (ECLASS)
%
EXTERNAL LOWLOC;	!THE LOW SEG AVAILABLE LOCATION
MAP BASE ECLASS;
LOCAL BASE CITEM :CSYMPTR;
LOCAL TLOC;
OWN CNT;
%
THE ADDRESS OF ANITEM IN ECLASS IS COMPUTED AS FOLLOWS
 ADDR _ .LOWLOC + (RELATIVE DISPLACEMENT OF ITEM IN ECLASS (CITEM[EQLDISPL] 
		- SMALLEST RELATIVE DISPLACEMENT IN ECLASS (ECLASS[EQVADDR])
%
CNT _ 0;
IF .FLGREG<LISTING> THEN( HEADCHK();  STRNGOUT(PLIT '?M?J( ?0'));
TLOC _ .LOWLOC - .ECLASS[EQVADDR];
CITEM _ .ECLASS[EQVFIRST];
WHILE 1 DO
BEGIN
	CSYMPTR _ .CITEM[EQLID];	!PTR TO SYMBOL
	CSYMPTR[IDADDR] _ .CITEM[EQLDISPL] + .TLOC;
	IF .FLGREG<LISTING>
	THEN(LISTSYM(.CSYMPTR);
	     IF .CNT LSS 5 THEN CNT _ .CNT+1
		ELSE (CNT _ 0; CRLF; HEADCHK());
	    );
	IF .CITEM[EQLLINK] EQL 0
	  THEN( IF .FLGREG<LISTING> THEN STRNGOUT(PLIT')?M?J'); HEADCHK();  EXITLOOP) ELSE CITEM _ .CITEM[EQLLINK];
END;
LOWLOC _ .LOWLOC + .ECLASS[EQVLIMIT] - .ECLASS[EQVADDR];
!
!LOWLOC + SPAN OF THE CLASS
!
END;	!OF EQCALOC
ROUTINE GRPSCAN=
BEGIN
!
!SCAN ALL GROUPS FOR ITEMS IN COMMON BUT GROUP WAS NOT FLAGGED
!
EXTERNAL EQVPTR;
LOCAL BASE ECLASS :ELIST :EITEM : LAST;
ECLASS _ .EQVPTR<LEFT>;
WHILE 1 DO
BEGIN
	LAST _ ELIST _ .ECLASS[EQVFIRST];
	IF NOT .ECLASS[EQVINCOM] 
	THEN
	UNTIL  .ELIST  EQL  0
	DO
	BEGIN
		EITEM _ .ELIST[EQLID];
		IF .EITEM[IDATTRIBUT(INCOM)]
		THEN 
		BEGIN
			EXTERNAL E48,FATLERR;
			% CHECK FOR MORE THAN ONE COMMON VAR%
			IF .ECLASS[EQVINCOM]  
			THEN	( FATLERR(.ISN,E48<0,0>); EXITLOOP );
			ECLASS[EQVINCOM] _ 1;
			ECLASS[EQVHEAD] _ .ELIST;
			IF .LAST NEQ .ELIST
			THEN
			BEGIN
				%MOVE IT TO TOP OF THE LIST%
				LAST[EQLLINK] _ .ELIST[EQLLINK];
				ELIST[EQLLINK] _ .ECLASS[EQVFIRST];
				!IF THE COMMON ELEMENT WAS THE LAST ONE IN THE GROUP,
				! THEN THE PTR TO IT [EQVLAST] MUST BE CHANGED TOO
				ECLASS[EQVFIRST] _ .ELIST;
				IF .ECLASS[EQVLAST] EQL .ELIST
				THEN ECLASS[EQVLAST]_.LAST
			END
		END;
		LAST _ .ELIST;
		ELIST _ .ELIST[EQLLINK]
	END;
	IF (ECLASS _ .ECLASS[EQVLINK]) EQL 0 THEN RETURN .VREG;
END;
END;
ROUTINE PROCEQUIV=
BEGIN
%PROCESSES EQUIVALNCE GROUPS AS DECLARED IN THE SOURCE -N RESOLVING
IMPLICIT EQUIVALENCES AND EQUIVALENCES INTO COMMON. CHECKS FOR
ALLOCATION ERRORS DUE TO IMPROPER EQUIVALENCES. ASSIGNS TEMPORARY
ADDRESSES TO EQUIVALENCE VARIABLES AND NEW VARIABLES EQUIVALENCED INTO COMMON.
%
EXTERNAL EQVPTR,	!PTR TO FIRST AND LAST EQUIVALENCE GROUPS
	ARRXPN,	!FOR EXPANDING ARRAY REFERENCES IN EQUIVALENCE ITEMS
	ZOUTMSG,	!MESSAGE OUTPUTTER
	ELISTSRCH,	!ROUTINE THAT SEARCHES FOR A MATCH OF ONE ITEM
			!IN A CLASS IN ANY AVAILABLE GROUP
	EQCALLOC;	!ALLOCATION OF EQUIVALENCE CLASSES
LOCAL BASE EQVCPTR,	!PTR TO CURRENT EQUIV CLASS HEADER
	ECOMMPTR,	!PTR COMMON ITEM IF GROUP IS IN COMMON
	ECOMMHDR,	!PTR TO COMMON BLOCK HDR
%[735]%	HDRFLG,	!FLAG TO KEEP TRACK OF WHETHER EQUIVALENCE LISTING
%[735]%		! HEADER HAS BEEN OUTPUT YET.
	LCLHD;	!PTR TO LOCAL HEAD OF A GROUP FOR ALLOCATION PURPOSES
REGISTER BASE EQLPTR;
LABEL COMN1,LOOP2;
LOCAL SAVEBOUNDSFLG;	!TO SAVE THE VALUE OF THE "BOUNDS" SWITCH WHILE
			! PROCESSING EQUIVALENCE STMNTS


	SAVEBOUNDSFLG_.FLGREG<BOUNDS>;	!SAVE THE VALUE OF THE "BOUNDS" SWITCH
					! (THAT SPECIFIES WHETHER ARRAY BOUNDS
					! CHECKING IS TO BE PERFORMED)
	FLGREG<BOUNDS>_0;	!TURN OFF THE BOUNDS FLAG WHILE PROCESSING
				! EQUIVALENCE STATEMENTS

%1120%	HDRFLG_0;		!Remember that no header has been output yet

!
!THE FIRST STEP IS TO COMPUTE RELATIVE DISPLACEMENTS OF EACH ITEM IN
!AND EQUIVALENCE GROUP. THIS IS SIMPLY 1 MINUS THE SUBSCRIPT
!VALUE OF EACH ITEM IN THE GROUP.
!I.E A(1) HAS DISPLACEMENT 0 AND A(4) HAS DISPLACEMENT -3
!
!
!SCAN GROUPS FOR IN COMMON ITEMS
!
GRPSCAN();
!
EQVCPTR _ .EQVPTR<LEFT>;	!PTR TO FIRST GROUP
WHILE 1 DO	%1%
BEGIN
	ISN _ .EQVCPTR[EQVISN];	!SET ISN INCASE OF ERRORS
	ECOMMPTR _ 0;	!INITIALIZING
	!IF GROUP IS IN COMMON THEN FIND THE ELEMENT IN COMMON
    COMN1: IF .EQVCPTR[EQVINCOM]
	THEN(	LOCAL BASE COMPTR;
			EQLPTR _ .EQVCPTR[EQVHEAD]; !PTR TO LIST ITEM THAT IS IN COMMON
			COMPTR_ .EQLPTR[EQLID];
			ECOMMPTR _ .EQLPTR; !PTR TO COMMON ITEM EQL LIST ITEM
			ECOMMHDR _ .COMPTR[IDCOMMON];
			LCLHD _ .EQLPTR[EQLID];
	     )
	ELSE LCLHD _ 0;
    EQLPTR _ .EQVCPTR[EQVFIRST]; !PTR TO FIRST ITEM IN GROUP
    R2 _ R1 _ 0;	!EQVLIMIT IN R2, SMALLEST DISPLACEMENT IN R1
    LOOP2: WHILE 1 DO %2%
       BEGIN LOCAL BASE ESYM, EQSIZ;
	IF .EQLPTR[EQLINDIC] NEQ 0
	THEN (LOCAL BASE PT1:PT2:PT3;
		EXTERNAL  E53,E103;
		PT1 _ .EQLPTR[EQLID];
		IF .PT1[IDDIM] EQL 0 THEN
		BEGIN
			EXTERNAL ISN,FATLERR,E93;
 			FLGREG<BOUNDS>_.SAVEBOUNDSFLG;
			RETURN FATLERR(.ISN,E93<0,0>);
		END;
		EQLPTR[EQLINDIC] _ 0;
		IF .EQLPTR[EQLLIST]^(-18)  NEQ  0
		THEN
		BEGIN	%MULTIPLE SUBSCRIPTS%
			 PT1 _ ARRXPN(.EQLPTR[EQLID],.EQLPTR[EQLLIST]);
			IF .PT1[ARG2PTR] NEQ  0
			THEN	RETURN FATLERR(.ISN,E53<0,0>);	!NON-CONSTANT SUBSCRIPT
			EQLPTR[EQLDISPL] _ -(EXTSIGN(.PT1[TARGET])); !GET - DISPLACEMENT
		END
		ELSE
		BEGIN	%SINGLE SUBSCRIPT%
			PT1 _ @.EQLPTR[EQLLIST];	!POINTER TO SUBSCRIPT
			IF .PT1[OPR1]  NEQ  CONSTFL OR .PT1[VALTYPE] NEQ  INTEGER
			THEN	RETURN FATLERR(.ISN,E53<0,0>);	!NON-CONSTANT SUBSCRIPT
			%NOW GENERATE THE OFFSET%
			EQLPTR[EQLDISPL] _ -.PT1[CONST2]	!CONSTANT VALUE
					+( PT3 _ .EQLPTR[EQLID];
					    PT2 _ .PT3[IDDIM]; 
					   PT2 _ .PT2[DIMENL(0)];
					   .PT2[CONST2]	%OFFSET%
					 );
			IF .EQLPTR[EQLDISPL] LEQ -(2^18)  
			   OR  .EQLPTR[EQLDISPL] GEQ 2^18
			THEN	RETURN FATLERR(.ISN, E103<0,0>);	!OUT OF RANGE
			IF .PT3[DBLFLG]  THEN EQLPTR[EQLDISPL] _ .EQLPTR[EQLDISPL]*2;
		END
	     );
!
!
!NOW CHECK FOR NEW EQVLIMIT (R2) FOR THIS GROUP
	   ESYM _ .EQLPTR[EQLID]; !PTR TO SYMBOL TABLE
	!
	   EQSIZ _ IF .ESYM[IDDIM] NEQ 0
			THEN (ESYM _.ESYM[IDDIM]; .ESYM[ARASIZ])
			ELSE IF .ESYM[DBLFLG] THEN 2 ELSE 1;
	   IF (.EQLPTR[EQLDISPL] + .EQSIZ) GTR .R2 %EQVLIMIT%
		THEN R2 _ (.EQLPTR[EQLDISPL] +.EQSIZ);
!
!NOW CHECK FOR NEW MIN(R(I)) RELATIVE DISPLACEMENT
!
	IF .EQLPTR[EQLDISPL] LSS .R1
		THEN (R1 _ .EQLPTR[EQLDISPL]; LCLHD _ .EQLPTR[EQLID]);
	IF .ECOMMPTR NEQ 0
	  THEN IF .EQLPTR NEQ .ECOMMPTR
		THEN(	LOCAL BASE LINK:COM;
			MAP BASE ECOMMHDR :ECOMMPTR;
			LINK _ .EQLPTR[EQLID];
			COM _ .ECOMMPTR[EQLID];	!PTR TO ITEM IN CO MMON
			IF NOT .LINK[IDATTRIBUT(INCOM)] 
			THEN(
				EXTERNAL FATLERR,ISN,E33;
				LINK _ .ECOMMHDR[COMLAST];
				ECOMMHDR[COMLAST] _ .EQLPTR[EQLID];
				LINK _ LINK[IDCOLINK] _ .EQLPTR[EQLID]; !PTR TO SYMBOL TABLES NODE
				LINK[IDATTRIBUT(INCOM)] _ 1; !SET IN COMMON
				LINK[IDCOMMON] _ .ECOMMHDR;
				LINK[IDCOLINK] _ 0;
				IF (LINK[IDADDR] _ (.EQLPTR[EQLDISPL] - .ECOMMPTR[EQLDISPL] + .COM[IDADDR]) ) LSS 0
				THEN ( FATLERR(ECOMMHDR[COMNAME],.ISN,E33<0,0>);
					LEAVE LOOP2;
				     );
				IF .ECOMMHDR[COMSIZE] LSS (.LINK[IDADDR] + .EQSIZ)
				THEN ECOMMHDR[COMSIZE] _(.LINK[IDADDR] + .EQSIZ);
			)
		         ELSE IF (.COM[IDADDR]-.ECOMMPTR[EQLDISPL]) NEQ (.LINK[IDADDR]-.EQLPTR[EQLDISPL])
			!IF BOTH THE GROUP AND THE ELEMENT ARE IN
			! COMMON, MAKE SURE IT IS THE SAME COMMON
			! BLOCK!  OTHERWISE AN ERROR FOR SURE.
			 OR (.COM[IDCOMMON] NEQ .LINK[IDCOMMON])
				THEN (EQERRLIST(.EQVCPTR); EQVCPTR[EQVAVAIL] _ 3;LEAVE LOOP2);
	!
	!CHECKING THE DECLARATIONS FOR VIOLATING BEGINNING OF COMMON BLOCK
	!
		    );
!
!CHECKING FOR END OF CHAIN OF ITEMS
!
	IF .EQLPTR[EQLLINK] EQL 0
	THEN EXITLOOP	!END OF CHAIN
	ELSE EQLPTR _ .EQLPTR[EQLLINK]
    END; !OF WHILE %2%
!
    EQVCPTR[EQVADDR] _ .R1;	!LOWEST RELATIVE DISPLACEMENT

!    EQVCPTR[EQVHEAD] _ .LCLHD;	!PTR TO HED OF GROUP

    EQVCPTR[EQVLIMIT] _ .R2;	!SPAN OF GROUP RELATIVE TO 0
!
!REAL SPAN (#OF WORDS OCCUPIED BY ALL ELEMNTS OF GROUP)
!IS EQVLIMIT - EQVADDR
!
    IF .EQVCPTR[EQVLINK] EQL 0
    THEN EXITLOOP	!END OF CHAIN OF GROUPS
    ELSE EQVCPTR _ .EQVCPTR[EQVLINK]
END; !OF %1%
!
!NOW START TO MAKE EQUIVALENCE CLASSES BY COMBINING GROUPS IF POSSIBLE
!
EQVCPTR _ .EQVPTR<LEFT>;	!START WITH FIRST GROUP
WHILE 1 DO	%1%
BEGIN
    WHILE 1 DO	%2% !GROUP(I) BECOMING A CLASS
    BEGIN
	IF .EQVCPTR[EQVAVAIL] EQL 0 !GROUP AVAILABLE FOR CLASS
	THEN ( MACRO EQGPPTR = EQLPTR$;
		ISN _ .EQVCPTR[EQVISN];	!SET ISN INCASE OF ERRORS
		EQVCPTR[EQVAVAIL] _ 2; !MAKE GROUP A CLASS
		EQGPPTR _ .EQVCPTR; !BEGIN SRCH OF OTHER GROUPS ON CURRENT GROUP
		DO
		BEGIN
		  IF .EQGPPTR[EQVAVAIL] EQL 0
		  THEN (
			IF (ELISTSRCH(.EQVCPTR,.EQGPPTR)) GTR 0
		THEN ( EQGPPTR[EQVAVAIL] _ 2;
			EQGPPTR _ .EQVCPTR );	!SEE IF ANY OF THE REJECTS FIT NOW
			!
			!IF ERROR OCCURRED IN ELSTSRCH THEN EQGPPTR[EQVAVAIL]
			!WILL BE SET TO 3 (ERROR)
			!
		       );
		END
		    WHILE (EQGPPTR _ .EQGPPTR[EQVLINK]) NEQ 0;
		IF NOT .EQVCPTR[EQVINCOM]
		  THEN IF .EQVCPTR[EQVAVAIL] NEQ 3
%[735]%			THEN ( IF .HDRFLG EQL 0 THEN LSTHDR(4,2,PLIT'?M?JEQUIVALENCED VARIABLES?M?J?0');
%[735]%				EQCALLOC(.EQVCPTR); !ALLOCATE CLASS POINTED TO BY EQVCPTR
%[735]%				HDRFLG_1);
	      ); !END OF IF AVAIL TEST
	  IF .EQVCPTR[EQVLINK] EQL 0
		THEN EXITLOOP  !NO MORE GROUPS TO PROCESS INTO CLASS
		ELSE EQVCPTR _ .EQVCPTR[EQVLINK]; !NEXT GROUP TO BE A CLASS
	END; !OF LOOP %2%
	IF (EQVCPTR _ .EQVCPTR[EQVLINK]) EQL 0 THEN (FLGREG<BOUNDS>_.SAVEBOUNDSFLG;  RETURN);
!
!ALL GROUPS PROCESSED IF RETURN TAKEN
!
END; ! OF LOOP %1%
	FLGREG<BOUNDS>_.SAVEBOUNDSFLG;	!RESTORE THE "BOUNDS" SWITCH
END; !OF ROUTINE PROCEQUIV


GLOBAL ROUTINE ALCCON=
BEGIN
	!ALLOCATE (USING HILOC) ALL THE CONSTANTS THAT HAVE
	!THE FLAG CNTOBEALCFLG SET.  THIS FLAG IS SET BY CALLS TO
	!ALOCONST.
	EXTERNAL LOWLOC,HILOC,RDATWD,ZOUTBLOCK,C2H,C2L;

%[1006]%	EXTERNAL KISNGL;

	EXTERNAL LITPOINTER;
	BIND HI=R1,LOW=R2;
	MACHOP ADDI=#271,TLZE=#623,TLO=#661,LSH=#242,DFN=#131;
MACRO EXPON=27,8$;
MACRO RELCONST(CXPTR)=	 !DUMPS CONSTANTS ONTO REL FIE
BEGIN
MAP BASE CXPTR;
	IF .CXPTR[VALTP1] EQL INTEG1
	 THEN RDATWD _ .CXPTR[CONST2]
	 ELSE RDATWD _ .CXPTR[CONST1];	!HIGH ORDER FOR REAL OR DOUBLE
	ZOUTBLOCK(RCODE,RELN);
	HILOC_.HILOC+1;
	IF .CXPTR[DBLFLG]	!IF DOUBLE OR COMPLEX CONSTANT
	 THEN ( RDATWD _ .CXPTR[CONST2]; ZOUTBLOCK(RCODE,RELN);
			HILOC_ .HILOC+1;
		);
END$;
	EXTERNAL ALODIMCONSTS;	!ROUTINE TO SET "CNTOBEALCFLG" IN ALL
				! CONSTANTS USED FOR DIMENSIONING ARRAYS
				! THAT ARE TO HAVE BOUNDS CHECKING PERFORMED ON THEM
	LOCAL BASE CPTR,SAVHILOC;


	%(***ALLOCATE CORE FOR ALL CONSTS USED IN DIMENSIONING ARRAYS THAT WILL
		HAVE BOUNDS CHECKING PERFORMED ON THEM
	*****)%
	ALODIMCONSTS();

	SAVHILOC _ .HILOC;
	HILOC _ .LOWLOC;	!RESET HILOC
	INCR I FROM 0 TO CSIZ-1 DO
	BEGIN
	IF .CONTBL[.I] NEQ 0 THEN
	BEGIN
		CPTR_.CONTBL[.I];
		WHILE .CPTR NEQ 0 DO
		BEGIN
			!NOW CHECK FOR KA-10 DP CONSTANT O/P
			IF .CPTR[CONST1] NEQ 0
			THEN
				IF .CPTR[VALTYPE] EQL REAL
				!WHEN ROUNDING TO SINGLE PRECISION, ZERO SECOND WORD
					THEN (CPTR[CONST1] _ KISNGL(.CPTR[CONST1],.CPTR[CONST2]);
						CPTR[CONST2]_0);
			IF .CPTR[CNTOBEALCFLG] THEN
			BEGIN
				CPTR[IDADDR]_.HILOC;
				%NOW PUT CONSTANT OUT IN REL FILE
				REMEMBER THAT THIS ROUTINE IS EXECUTED WITHIN
				A TEST FOR THE REL FILE GENERATION%

				RELCONST(CPTR);		!IN MACRO ABOVE
			END;
			CPTR_.CPTR[CLINK];
		END;
		END;
	END;
	IF (CPTR _ .LITPOINTER<LEFT>) NEQ 0
	THEN DO
		(IF .CPTR[CNTOBEALCFLG] THEN
		 BEGIN
			CPTR[LITADDR] _ .HILOC;
			INCR I FROM 0 TO .CPTR[LITSIZ]-1 DO
			  (RDATWD _ .(CPTR[LIT1]+.I);
			   ZOUTBLOCK(RCODE,RELN);
			   HILOC _ .HILOC+1;	!INCREMENTING FOR ZOUTBLOCK
			  );
		  END;
		) WHILE (CPTR _ .CPTR[LITLINK]) NEQ 0;
	LOWLOC _ .HILOC;
	HILOC _ .SAVHILOC;	!RESTORING
END;
GLOBAL ROUTINE ALCTMPS=
BEGIN
	!ROUTINE CLEANS UP ALL THE ALLOCATION OF VARIABLES.
	!THIS IS A THREE STEP PROCESS.
	!	1. GO THROUGH THE SYMBOL TABLE AND ALLOCATE ALL
	!	  THOSE PREVIOUSLY UNALLOCATED. THIS IS PRIMARILY
	!	  THE TEMPS GENERATED FOR REGISTER SAVE/RESTORE
	!	  FOR A SUBROUTINE OR FUNCTION.
	!	2. THE SECOND REASON WENT AWAY. HURRAY!
	!	3. THE TEMPS GENERATED IN THE LOCAL REGISTER
	!	  ALLOCATION PROCESS.

	EXTERNAL SYMTBL,LOWLOC,ADJHEAD,ANCHOR,PROGNAME;
%[735]%	LOCAL CNT,HDRFLG;

%[735]%	ROUTINE HDRTMP=
%[735]%	LSTHDR(4,3,PLIT'?M?JTEMPORARIES?M?J?M?J?0');

	!FIRST THE SYMBOL TABLE

%[735]%		HDRFLG _ CNT _ 0;
		INCR K FROM 0 TO SSIZ-1 DO
		BEGIN
			REGISTER BASE T;
			T_.SYMTBL[.K];
			WHILE .T NEQ 0 DO
			BEGIN
			     IF .T[IDADDR] EQL 0
				THEN IF NOT .T[IDATTRIBUT(INCOM)]  AND .T[OPRSP1] NEQ FNNAME1
				AND NOT .T[IDATTRIBUT(NOALLOC)]				 AND NOT .T[IDATTRIBUT(COMBL)] THEN
				BEGIN
					T[IDADDR]_.LOWLOC;
					LOWLOC_.LOWLOC+1+.T[DBLFLG];
					IF .FLGREG<LISTING> THEN 
%[735]%					   (	IF .HDRFLG EQL 0 THEN (HDRFLG_1;HDRTMP());
%[735]%						LISTSYM(.T);
						IF (CNT _ .CNT+1) GTR 5 THEN (CNT_0; CRLF; HEADCHK());
					   );
				END;
				T_.T[CLINK];
			END;
		END;

	!NOW (FOR EITHER SUBPROGRAM OR MAIN PROGRAM, THE TEMPS
	!GENERATED BY LOCAL REGISTER ALLOCATION

	WHILE .ANCHOR NEQ 0 DO
	BEGIN
		MAP BASE ANCHOR;
		ANCHOR[IDADDR]_.LOWLOC;
		LOWLOC_.LOWLOC+1;
		IF .FLGREG<LISTING>
%[735]%		 THEN ( IF .HDRFLG EQL 0 THEN (HDRFLG_1;HDRTMP());
%[735]%			 LISTSYM(.ANCHOR);
			IF (CNT _ .CNT+1) GTR 5 THEN (CNT_0; CRLF; HEADCHK());
		      );
		!**NOTE**
		!THESE ARE ALSO SINGLE CELL. NXTTMP TAKES
		!CARE OF GETTING TWO FOR A DOUBLE WORD QUANTITY
		ANCHOR_.ANCHOR[CLINK];
	END;
	IF .FLGREG<LISTING>  THEN  (CRLF; HEADCHK());
END;




GLOBAL ROUTINE HISEGBLK=
BEGIN
!ROUTINE GENERATES A HISEG BLOCK IN THE THE REL FILE
!WORD 1 OF THE HISEG BLOCK IS THE TWOSEG PSEUDO OP ID
!WORD 2 IS THE SIZE OF THE LOWSEG IN WORDS IN THE LEFT HALF
!	AND ZERO IN THE RIGHT HALF
!WORD 2 IS ONLY USEFUL IF WE WISH TO LOAD EXECUTABLE CODE IN THE LOWSEG
!	INSTEAD OF THE HISEG

%1133%	EXTERNAL CHDSTART,RADIX50;

EXTERNAL RDATWD,ZOUTBLOCK,LOWLOC;
	HILOC _ #400000; !USUALLY THAT
	IF .LOWLOC GEQ (#400000-#1000)  !BIG LOW SEG
	THEN HILOC_(.LOWLOC+#777+#1000)AND NOT #777; !ROUND UP

%1133%	CHDSTART _ .HILOC;	! Start of character descriptors

	RDATWD_.HILOC^18 + .HILOC; !IN BOTH HALVES
	ZOUTBLOCK(RHISEG,RELRI);
	RDATWD _ .LOWLOC^18 + 0;
	ZOUTBLOCK(RHISEG,RELN);
END;	!OF HISEGBLK
GLOBAL ROUTINE RELINIT= !INITIALIZES REL FILE
BEGIN
%
GENERATES BLOCKS	4 - ENTRY
			6 - NAME
			3 - HISEG
%
EXTERNAL RELDATA,RELOCWD,PROGNAME,MULENTRY,HILOC;
EXTERNAL INIRLBUFFS;	!TO INIT REL FILE BUFFERS
MAP BASE MULENTRY;	!PTR TO CHAIN OF MULTIPLE ENTRIES OF THIS SUBPROGRAM

%[1003]%	BIND	KSCPU = 1^33,	! KS10 cpu type
%[1003]%		KLCPU = 1^32,	! KL10
%[1003]%		KICPU = 1^31,	! KI10
%[1003]%		KACPU = 1^30,	! KA10 - no longer supported
%[1003]%		FTNID = #10^18,	! compiled /NOGFLOATING
%[1003]%		GFTNID =#23^18;	! compiled /GFLOATING
!
	INIRLBUFFS();	!INITIALIZE THE REL FILE BUFFERS

!INIT FIRST BLOCK
!
	 R2 _.PROGNAME;
	WHILE 1 DO
	(
		RDATWD _ RADIX50();
		ZOUTBLOCK(RENTRY,RELN);
		IF .MULENTRY NEQ 0
		THEN (R2 _ .MULENTRY[IDSYMBOL]; MULENTRY _ .MULENTRY[IDENTLNK])
		ELSE EXITLOOP;
	);
	RDATWD _ (R2 _ .PROGNAME; RADIX50());
	ZOUTBLOCK(RNAME,RELN);  !NAME BLOCK

![1003] Output compiler and processor bits to .REL file based on /GFLOATING
%[1003]%	IF .GFLOAT
%[1003]%	THEN	RDATWD _ KLCPU + GFTNID
%[1003]%	ELSE	RDATWD _ KSCPU + KLCPU + KICPU + FTNID;
	ZOUTBLOCK(RNAME,RELN);	!THE FORTRAN-IV IDENTIFER
!NOW FOR HISEG
	.VREG
END;
END
ELUDOM