Google
 

Trailing-Edge - PDP-10 Archives - FORTRAN-10_V7wLink_Feb83 - 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) DIGITAL EQUIPMENT CORPORATION 1973, 1983
!AUTHOR: F. INFANTE/MD/DCE/JNG/TFV/CDM/AHM/RVM/EGM

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

GLOBAL BIND OUTMOV = 7^24 + 0^18 + #1703;	! Version Date:	17-DEC-82

%(

***** 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.

***** Begin version 6A *****

97	1146	EGM	5-Jan-82	20-17060
	Pass the ISN of the illegal Equivalance group for error IED.

1151	EGM	25-Mar-81
	Report ?Program too large for COMMON 512P and up

***** Begin Version 7 *****

81	1246	CDM	1246		------
	Edit SUBPROGLIST so that inline functions names are not printed
	out in listings.

82	1232	TFV	24-Jun-81	------
	Rewrite ALLSCAA and ALCCON to handle character data and character
	constants.  Output character data to the .REL file.  Write LSCHD to
	output the descriptors to the low seg for dummy args; write HSCHD to
	output descriptors to the high seg for non-dummy arg character data;
	also write HSLITD to output descriptors to the high seg for character	
	constants. Also add a new section to the .LST file for character data.
	Write LISTCHD to list character variable and array names, descriptor
	locations, location and character position for the start of the data,
	and the length of the data.

83	1261	CKS	17-Sep-81
	Modify common and equivalence allocation to support type CHARACTER.
	Have all equivalence processing done in characters instead of words.
	Convert back to words at the end.

84	1262	CKS	22-Sep-81
	Allow substrings in character EQUIVALENCE classes

85	1264	CDM	24-Sep-81
	Revise edit to that "SUBPROGRAMS CALLED" is not put on program
	listings for inline functions.

88	1272	RVM	15-Oct-81
	Convert REAL constants from DOUBLE PRECISION, even if the constant
	is part of a MOVEI.

89	1274	TFV	16-Oct-81	------
	Fix ALCQVARS to handle multi-word .Q variables.

90	1406	TFV	27-Oct-81	------
	Write HSDDESC to  output .Dnnnn compile-time-constant  character
	descriptors to the  .REL file.   Either one  word (byte  pointer
	only) or two words (byte pointer and length) are output based on
	the flag IDGENLENFLG.   One word .Dnnnn  variables are used  for
	SUBSTRINGs with  constant lower  bounds and  non-constant  upper
	bounds.   Use  BPGEN to create byte  pointers that are output to
	the .REL file.

91	1424	RVM	19-Nov-81
	Precede the formats in the object program by a count of the number
	of words in the format (in other words, make formats look like
	BLISS-10 PLIT's).  This is needed for assignable formats.

92	1434	TFV	14-Dec-81	------
	Fix multi-entry character functions.  All the entry points share the
	same descriptor.  The  descriptor is  generated in  ALLSCAA for  the
	main entry point.  Fixup the other entry points so that their IDADDR
	fields point to the descriptor for the main entry point.  Fix  HSCHD
	to generate descriptors  for character functions  that are  declared
	external.

93	1443	RVM	17-Dec-81
	ALLFORM never thought that there could be backwards references to
	format statements, and so never set up the SNSTATUS field.  With
	ASSIGNed FORMATs, there can be backwards references.

94	1437	CDM	16-Dec-81
	Create and initialize new global variable HIORIGIN to store the
	origin of the Hi-seg.

95	1450	CKS	30-Dec-81
	Detect the error in EQUIVALENCE (A(1),A(2))

96	1451	CKS	30-Dec-81
	Fix HSDDESC to handle common variables as subnodes of .D descriptors.

98	1454	RVM	7-Jan-82
	Consolidate the routines ALLFORM and DMPFORMAT into one routine that
	both allocates addresses to the formats and (if needed) dumps the
	formats to the .REL file.  The new routine is called DUMPFORMAT.

99	1455	TFV	5-Jan-82	------
	Fix ALLSCAA  to  allocate character  statement  function  names.
	They have  an extra  argument.   It is  the descriptor  for  the
	result.  It is stored into the space allocated for the statement
	function name.

1511	CDM	17-Mar-82
	Count the number of COMMON blocks for a SAVE statement with no
	arguments.  (All common blocks must be output in the rel block
	for SAVE  processing).  Also  error processing  for  variables
	which suddenly become in common through equivalencing.

1512	AHM	26-Mar-82
	Change all calls  to ZOUTBLOCK  that used  RSYMBOL (rel  block
	type 2) to call ZSYMBOL instead.

1522	TFV	29-Mar-82
	Fix error  diagnostic  for  length star  variables  and  arrays.
	Length star  is legal  only for  dummy arguments  and  character
	parameters.  Cause an ICE if a .Dnnnn variable has a length less
	than 1.

1525	AHM	1-Apr-82
	Various changes for psected REL files.  Suppress generation of
	the type 3 HISEG block.  Generate type 24 psect header  blocks
	for each psect.  Put in a type 17 .REQUEST FORLIB:FORLIB block
	for development to read  in a private  FORLIB that is  psected
	instead of being TWOSEG.  Turn off  KS bit in the type 6  name
	block when compiling /EXTENDED.

1526	AHM	7-Apr-82
	Pave the way for psected rel files by converting all calls  to
	ZOUTBLOCK for outputting  RCODE (type  1) rel  blocks to  call
	ZCODE instead.  Use the proper relocation counter to  allocate
	space for each  psect instead  of always using  HILOC to  tell
	ZOUTBLOCK what address  is being  output.  Fix  bug caused  by
	mixing edits 1261  and 1151 which  caused rejection of  common
	blocks longer than 1/5th of a section.

1527	CKS	29-Apr-82
	Do not allocate storage for PARAMETER variables.  They get into
	the symbol table as scalars when they appear in type declaration
	statements, but no storage should be allocated for them.

1531	CDM	14-May-82
	Make changes for new use of NUMSAVPTR and change error message
	E192 to E197 for SAVE error processing.

1534	CKS	17-May-82
	Fix output of character constants in the listing.  Use uparrow
	format instead of sending the control character directly.

1537	AHM	20-May-82
	Prepend some innocuous entries to  the BPLH UPLIT so that  bad
	negative character addresses propagated  from users trying  to
	extend common blocks backward don't  get junk listings of  the
	byte pointers.

1544	AHM	26-May-82
	Output type 22 default psect index blocks for the .DATA. psect
	before type 21 or 1004 sparse data blocks so that they have  a
	chance to work while  the new psected  sparse data blocks  are
	not in LINK.  This edit is only for V8 development and will be
	removed when the LINK support is finally in.

1547	AHM	1-Jun-82
	Make PROCCOM change the size of a COMMON block from characters
	to words before it is added into the total size of all  COMMON
	blocks.

1564	AHM	21-Jun-82
	Don't put out a .REQUEST FORLIB:FORLIB block in RELINIT  under
	/EXTEND -  it  isn't  needed  anymore.   Also,  uncomment  the
	section 1 psect origins.

1567	CDM	24-Jun-82
	Don't output .Dnnn variables if NOALLOC is lit.

1615	AHM	16-Aug-82
	Change the  default psect  index to  .DATA. before  outputting
	common block  sizes  in  ALLCOM.   LINK  will  be  changed  to
	allocate common  blocks  in  the default  psect  when  reading
	psected .REL files.

1627	CKS	31-Aug-82
	Do not allocate .D variables to hold the result of CHAR function when
	CHAR(constant-expr) in a PARAMETER statement has been replaced by a
	simple constant.

1630	AHM	1-Sep-82
	Fix bug introduced by edit 1615.  Don't output a default psect
	index if there is no .REL file being generated.

1666	TFV	8-Nov-82
	Fix RELINIT to always use FORTRAN  for the compiler id.  The  id
	for GFLOATING FORTRAN is no  longer used.  Type coercion is  now
	used for DP actuals passed to GFLOATING formals and vice  versa.

1675	RVM	11-Nov-82	Q10-03032
	Implement a suggestion to include more information in the
	warning message E168.

1703	CDM	17-Dec-82
	Do not output any processor type to rel file.  V5A only puts out
	KI, and V7 will not work on a KI, so if we tell Link the  truth,
	users with libraries will get Link-time warnings.

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

)%

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

FORWARD
	CHADDR2BP(1),
	SIZEINCHARS(1),
	LSTHDR(3),
	OUTDATA(3),
	LISTSYM(1),
	SUBPROGLIST,
	ALLSCAA,
	ALLCOM,
	ALLOCAT,
	DUMPFORMAT,		! Allocates FORMATs and dumps them to .REL file
	PROCCOM,
	EQERRLIST(1),
	GROUPTOCOMMON(4),
	LINKGROUPS(3),
	ELISTSRCH(2),
	EQCALLOC(1),
	GRPSCAN,
	PROCEQUIV,
	ALCCON,
	HSLITD,
	HSCHD,
	HSDDESC,
	HDRCHD,
	TABOUT,
	ZOUTBP(1),
	LISTCHD(2),
	ALCQVARS,
	HDRTMP,
	HISEGBLK,
	RELINIT;

EXTERNAL
	ALODIMCONSTS,	! Routine to set "CNTOBEALCFLG" in all constants used
			! for dimensioning arrays that are to have bounds
			! checking performed on them
	ARRXPN,		! For expanding array references in EQUIVALENCE items
	C2H,
	C2L,
%1522%	CGERR,		! Routine to report an internal compiler error
	CHAROUT,
%1245%	CHDSTART,
%1261%	CNSTEVAL,	! For evaluating subscript expression if necessary	
	COMBLKPTR,
%1274%	COMTSIZ,	! Current total size of COMMON including blank common
	DANCHOR,	! Pointer to the start of the .Dnnnn variables
	DMPMAINRLBF,	! Routine to output the contents of the main .REL file
			! buffer and reiinitialize it
%1525%	DMPRLBLOCK,	! Outputs data to the object and listing files
	E33,
	E48,
	E49,
	E53,
	E93,
	E103,
%1261%	E162,
%1261%	E165,
	E166,
	E167,
	E168,
	E194,
%1531%	E197,		! "<foo> EQUIVALENCE-d to COMMON is illegal"
	ENDSCAA,
%1434%	ENTRY,		! Pointer to a sixbit name for an identifer
	EQVPTR,		! Pointer to first and last EQUIVALENCE groups
	FATLERR,
	FORMPTR,
%735%	HDRFLG,		! Scalars and arrays listing header flag
	HEADCHK,	! Checks for end of listng page
%[735]%	HEADING,
	HILOC,		! Next available address in the high seg
%1437%	HIORIGIN,	! Start of Hi-seg
	INIRLBUFFS,	! To init .REL file buffers
	ISN,
%1006%	KISNGL,		! KISNGL is now in UTIL.BLI
	LITPOINTER,
	LOWLOC,		! Next available address in the low seg
	LSTOUT,
RELBUFF	MAINRLBF,	! Main .REL file buffer
BASE	MULENTRY,	! Pointer to the list of entries for this subprogram
%1434%	NAME,		! Table to search for tblsearch lookups
%1511%	NUMSAVCOMMON,	! Pointer to SAVE-d common blocks
	PAGELINE,
	PROGNAME,
%1274%	QANCHOR,
%1274%	QMAX,
	RADIX50,
	RDATWD,
	RELBLOCK,
	RELDATA,
	RELOCWD,
	RELOUT,
%1511%	SAVALL,		! SAVE statement with no args given
	STRNGOUT,
%1434%	TBLSEARCH,	! Routine to lookup symbol table entries
%1245%	TCNT,
	WARNERR,
%1526%	ZCODE,		! Outputs a word using type 1 or 1010 rel blocks
	ZOUDECIMAL,
	ZOUOFFSET,
	ZOUTBLOCK,
	ZOUTMSG,	! Message outputter
	ZOUTOCT,
	ZOUTSYM,
%1512%	ZSYMBOL;	! Outputs type 2 or 1070 rel blocks

MACRO MODULO (A,B) =		! [1261] Positive remainder of A / B
BEGIN
	REGISTER T1;
	T1 _ (A) MOD (B);
	IF .T1 LSS 0 THEN T1 _ .T1 + (B);
	.T1
END$;

BIND VECTOR BPLH = 4 + UPLIT (0<29,7>,0<22,7>,0<15,7>,0<8,7>,	![1537] -4:-1
			0<36,7>,0<29,7>,0<22,7>,0<15,7>,0<8,7>);
				! LEFT HALF OF BYTE POINTER TO BYTE 1,2,...,5

ROUTINE CHADDR2BP (A) =		! [1261] Convert character address A to
				!        equivalent byte pointer
(.A/5) OR .BPLH [.A MOD 5];


ROUTINE SIZEINCHARS (SYMPTR) =  ! [1261] Find size of scalar or array, given
				!        address of its symbol table entry
BEGIN
	MAP BASE SYMPTR;
	IF .SYMPTR[IDDIM] NEQ 0
	THEN
	BEGIN !ARRAY
		REGISTER BASE DIMPTR;	
		DIMPTR _ .SYMPTR[IDDIM];
		IF .SYMPTR[VALTYPE] EQL CHARACTER
		THEN .DIMPTR[ARASIZ]	! ARASIZ chars for character array
		ELSE .DIMPTR[ARASIZ] * CHARSPERWORD	! ARASIZ words for numeric array
	END !ARRAY
	ELSE
	BEGIN !SCALAR
		IF .SYMPTR[VALTYPE] EQL CHARACTER
		THEN .SYMPTR[IDCHLEN]	! IDCHLEN chars for character scalar
		ELSE	IF .SYMPTR[DBLFLG]
			THEN 2 * CHARSPERWORD		! 10 chars for double word numeric
			ELSE CHARSPERWORD		! 5 chars for single word numeric

	END	! SCALAR

END;	! of SIZEINCHARS

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]%		IF .PAGELINE LEQ .MINLINE
%[735]%		THEN %NO ROOM ON THIS PAGE% HEADING();
%[735]%		PAGELINE _ .PAGELINE-.HDRLINES;
%[735]%		STRNGOUT(.HDRPTR);

%[735]%	END;	! of LSTHDR

GLOBAL ROUTINE OUTDATA(SYMADDR,SYMVALUE,SYMPT)=
BEGIN

! Instructs  the  loader  about  initialization  of  lowseg  data   as
! specified in DATA statements.   SYMPT is the  pointer to the  symbol
! being initialized.  SYMVALUE is the value to store.  SYMADDR is  the
! allocated address of the symbol.

MAP BASE R2:SYMPT;

	IF NOT .FLGREG<OBJECT>		! Producing REL file ?
	THEN RETURN;			! No

%1544%	IF EXTENDED			! Psected object code ?
	THEN				! Yes
	BEGIN
		! Set the  default psect  before we  dump  the
		! data.  Note that all the data are in  .DATA.

		RDATWD = PXDATA;		! Index for .DATA.
		ZOUTBLOCK(RPSECTORG,RELN)	! Psect index rel block
%1544%	END;

	IF .SYMPT[IDATTRIBUT(INCOM)]
	THEN
	BEGIN					! Do special fixup
		IF .MAINRLBF[RDATCNT] GTR RBLKSIZ-5	! 3 words left ?
		THEN DMPMAINRLBF();			! No, make room

		R2 _ .SYMPT[IDCOMMON];		! Pointer to COMMON block node
		R2 _ .R2[COMNAME];		! Fetch the block name
		RDATWD _ RGLOBREQ+RADIX50();	! Convert to a symbol request
		ZOUTBLOCK(RDATBLK,RELN);	! Put it out
		RDATWD _ (1^18)+.SYMADDR<RIGHT>;! One word at /COMMON/+SYMADDR
		ZOUTBLOCK(RDATBLK,RELN)		! Output count and offset
	END
	ELSE
	BEGIN
		IF .MAINRLBF[RDATCNT] GTR RBLKSIZ-4	! 2 words left ?
		THEN DMPMAINRLBF();			! No, make room

		RDATWD _ (1^18)+.SYMADDR<RIGHT>;! One word at SYMADDR
		ZOUTBLOCK(RDATBLK,RELRI);	! Output count and address
	END;

	RDATWD _ .SYMVALUE;			! The value to be stored
	ZOUTBLOCK(RDATBLK,RELN)			! Output it

END;	! of OUTDATA

GLOBAL ROUTINE LISTSYM(PTR)=
BEGIN
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
%1261%		IF .PTR[VALTYPE] NEQ CHARACTER 	! If numeric, list address
		THEN (R2<LEFT> _ .PTR[IDADDR]; ZOUTOCT())
%1261%		ELSE ZOUTBP(.PTR[IDCHBP]);	! If character, list addr(pos)
		CHR_#11;LSTOUT();!TAB

END;	! of LISTSYM


ROUTINE SUBPROGLIST=
BEGIN
!
!Lists called subprograms on list device in allocation summary
!
%[735]% LOCAL BASE SYMPTR,COUNT;

%[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
!1246			Output function name only if not an inline function.
			IF .SYMPTR[OPRSP1] EQL FNNAME1
			THEN IF NOT .SYMPTR[IDATTRIBUT(NOALLOC)]
%1264%				AND NOT .SYMPTR[IDINLINFLG]
				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 SUBPROGLIST

ROUTINE ALLSCAA=
BEGIN

	! 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.
	! Allocates low seg descriptors for character dummy args.  Also
	! generates scalar and array section of .LST file for non-character
	! data.  This is done all at once since scanning the symbol table can
	! be slow.

%1232%	! Routine rewritten by TFV, 24-Jun-81
%1232%	! Character data allocation added and block structure fixed up

OWN PTR,SCNT;
LOCAL BASE ARRAPT;

LABEL L1,L2;
MAP BASE PTR;

ROUTINE LSCHD=
BEGIN
	! Outputs lowseg descriptor for character dummy args.   IDADDR
	! points to  descriptor.   We init  the  count word  with  the
	! length unless dummy is length *

	LOWLOC _ .LOWLOC + 1;	! Byte pointer to character data copied in at 
				! subroutine/function entrance; skip a word

	! If length *, actual length copied in at  subroutine/function
	! entrance.  Otherwise init the length word in the .REL  file.

	IF .PTR[IDCHLEN] NEQ LENSTAR AND .FLGREG<OBJECT>
%1526%	THEN IF EXTENDED
%1526%	THEN	! Use type 1010 blocks
%1526%	BEGIN
%1526%		DMPMAINRLBF();			! Storing in different location
						! Can't let this get appended
						! to a previous type 1010 block
%1526%		RDATWD _ .PTR[IDCHLEN];		! Use declared length
%1526%		ZCODE(PSABS,PSDATA);		! Output length to .DATA. using
						! code block with no relocation
%1526%		DMPMAINRLBF()			! Can't let this get prepended
						! to the next type 1010 block
%1526%	END
%1526%	ELSE ! NOT EXTENDED
	BEGIN	! Use type 21 blocks
		IF .MAINRLBF[RDATCNT] GTR RBLKSIZ-4
		THEN DMPMAINRLBF();		! No room left in buffer for
						! 2 words

		RDATWD _ (1^18) + .LOWLOC;	! count,,relocatable address
						! of descriptor length word

		ZOUTBLOCK(RDATBLK,RELRI);	! Output using  sparse  data
						! block,    relocate     the
						! address

		RDATWD _ .PTR[IDCHLEN];		! Use declared length

		ZOUTBLOCK(RDATBLK,RELN);	! Output length  to low  seg
						! using  sparse  data  block
						! with no relocation

	END;

	LOWLOC _ .LOWLOC + 1		! Increment    LOWLOC    since    we
					! outputted or skipped a word

END;	! of LSCHD

%[735]%	ROUTINE HDRSAA=		! Routine to output scalar and array banner
%[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	! Walk through hash table entries
	BEGIN
		PTR _ .SYMTBL[.I];	! Entry for this hash
		WHILE .PTR NEQ 0 DO	! Walk down linked list of symbols
		BEGIN
			IF NOT  .PTR[IDATTRIBUT(INCOM)]
			AND NOT .PTR[IDATTRIBUT(NAMNAM)]
%1527%			AND NOT .PTR[IDATTRIBUT(PARAMT)]
%1455%			AND (NOT .PTR[OPERSP] EQL FNNAME OR
%1455%				(.PTR[VALTYPE] EQL CHARACTER AND .PTR[IDATTRIBUT(SFN)]))
			THEN

			! Neither  in  common,  namelist,  parameter, nor
			! function name.  Allocate  character statement  
			! function names.

			IF  .PTR[IDATTRIBUT(NOALLOC)]
			THEN
			BEGIN
				! Note names which have been declared but never
				! referenced  and thus never allocated.
				! List never allocated character variables also

				IF .FLGREG<LISTING>
				THEN
				BEGIN	! Output symbol to listing with '%'

					IF .PTR[OPRSP1]  EQL ARRAYNM1
					OR  .PTR[IDATTRIBUT(INTYPE)]
					OR  .PTR[IDATTRIBUT(DUMMY)]
					THEN
					BEGIN	! Declared in dimension, type, or as dummy arg
%[703]%						IF .SCNT LEQ 0 THEN HEADCHK();
%[735]%						IF .HDRFLG EQL 0
						THEN
						BEGIN
							! Output Scalar and array banner
							HDRFLG_1;
							HDRSAA();
						END;

						R2_.PTR[IDSYMBOL];
						CHAROUT("%");	! Flag never referenced with '%'
						ZOUTSYM();
						CHAROUT(#11);	! Tab
						CHAROUT(#11);	! Tab
![473], LISTING FOR SCALARS AND ARRAYS IS A BIT TOO WIDE
%[703]%						IF .SCNT LSS 4
						THEN SCNT _ .SCNT+1
						ELSE
						BEGIN
							SCNT _ 0;
							CRLF;
						END;

					END	! Declared in dimension, type, or dummy arg
				END	! Output symbol to listing with '%'
			END
			ELSE
			BEGIN
				! Symbol is defined and referenced so allocate
				! space for it. Not in common, namelist, nor
				! function name. Non-dummy character data gets
				! allocated in the lowseg; descriptor in hiseg
				! Dummy character data gets IDADDR pointing to
				! the descriptor in the lowseg.  
				! Other data has IDADDR pointing to data

				IF NOT .PTR[IDATTRIBUT(INEQV)]
				
				! Equivalenced vars are listed but not allocated here
				THEN
				BEGIN	! Not equivalenced

					IF .PTR[VALTYPE] EQL CHARACTER AND NOT .PTR[IDATTRIBUT(DUMMY)]
					THEN
						! Non-dummy arg character data.
						! Byte pointer points to lowseg
						! data. Descriptor is allocated
						! in high seg after hisg seg is
						! inited.

%1406%						PTR[IDCHBP] = BPGEN(.LOWLOC)
					ELSE
						! Dummy character data get descriptor
						! allocated to lowseg and pointed
						! to by IDADDR. Other data types
						! get IDADDR pointing to low seg data.

						PTR[IDADDR] _ .LOWLOC;
					
					IF .PTR[OPRSP1] EQL ARRAYNM1
					THEN
					BEGIN
						! Arrays

						ARRAPT _ .PTR[IDDIM]; ! Ptr to dimension node
						IF  .PTR[IDATTRIBUT(DUMMY)]
						THEN
						BEGIN
							! Dummy array arg

							IF NOT .ARRAPT[ADJDIMFLG] AND .PTR[VALTYPE] NEQ CHARACTER
							THEN 
							BEGIN
								! Non-adjustably dimensioned
								! Non-character dummy
								! arrays get pointer
								! to base address for array

								LOCAL BASE PTRVAR;
								PTRVAR _ .ARRAPT[ARADDRVAR];
								PTRVAR[IDADDR] _ .LOWLOC;
							END;

							IF .PTR[VALTYPE] EQL CHARACTER
							THEN
								! Output low seg descriptor for
								!  character dummy arrays

								LSCHD()

							ELSE
								! allocate space for base address
								! for non-character dummy array

								LOWLOC _ .LOWLOC + 1;
						END
						ELSE
						BEGIN
							! Non-dummy arrays are allocated in the low seg
							! Character data size is in characters, others are in words

							IF .PTR[VALTYPE] EQL CHARACTER
%1406%							THEN LOWLOC _ .LOWLOC + CHWORDLEN(.ARRAPT[ARASIZ])
							ELSE LOWLOC _ .LOWLOC + .ARRAPT[ARASIZ];
						END
					END	! Arrays
					ELSE
					BEGIN
						! Scalars

						IF .PTR[VALTYPE] EQL CHARACTER
						THEN
						BEGIN
							! Character scalar

							IF .PTR[IDATTRIBUT(DUMMY)]
							THEN
							BEGIN
								! Output low seg descriptor
								! for character dummy scalars.
								! Only output descriptor for
								! the main entry point for multi-entry
								! character functions

%1434%								IF NOT .PTR[IDATTRIBUT(FENTRYNAME)] OR
%1434%									.PTR[IDSYMBOL] EQL .PROGNAME
%1434%								THEN	LSCHD()

							END
							ELSE
								! Non-dummy character scalars are allocated in
								! the low seg. Character data size is in characters

%1406%								LOWLOC _ .LOWLOC + CHWORDLEN(.PTR[IDCHLEN]);

						END	! Character scalar
						ELSE
						BEGIN	! Non-character scalar

							! Output one or two words based on variable size

							IF .PTR[DBLFLG]
							THEN LOWLOC _ .LOWLOC + 2
							ELSE LOWLOC _ .LOWLOC + 1;
						END;	! Non-character scalar
					END;	! Scalars
				END;	! Not equivalenced

				IF .FLGREG<LISTING> AND .PTR[VALTYPE] NEQ CHARACTER
				THEN
				BEGIN
					! List non-character scalars and arrays


%[703]%					IF .SCNT LEQ 0 THEN HEADCHK();

%[735]%					IF .HDRFLG EQL 0
					THEN
					BEGIN
						! Output scalar and array banner
						HDRFLG_1;
						HDRSAA();
					END;

%[703]%					LISTSYM(.PTR);

%[703]%					IF .SCNT LSS 4
					THEN SCNT_.SCNT+1
					ELSE
					BEGIN
						SCNT_0;
						CRLF;
					END;

				END;	! List non-character scalars and arrays
			END;	! Symbol is defined and referenced so allocate space for it.
			PTR _ .PTR[CLINK];	! Next linked list entry
		END;	! Walk down linked list

	END;	! Walk through hash table entries

%[703]%	IF .FLGREG<LISTING>  THEN IF .SCNT NEQ 0 THEN CRLF;

	ENDSCAA_.LOWLOC;	!LOC AFTER LAST ARRAY/SCALAR

END;	! of ALLSCAA

!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.
%



! EQUIVALENCE processing is rather hairy to describe.  The following description
! of the problem is adapted from Aho and Ullman, Principles of Compiler Design.
! (The algorithm is the not from that book, however.)
! 
! 
! The first algorithms for processing equivalence statements appeard in
! assemblers rather than compilers.  Since these algorithms can be a bit
! complex, especially when interactions between COMMON and EQUIVALENCE
! statements are considered, let us treat first a situation typical of an
! assembly language, where the only EQUIVALENCE statements are of the form
! 
! 	EQUIVALENCE A,B+offset
! 
! where A and B are the names of locations.  The effect of this statement is to
! make A denote the location which is OFFSET memory units beyond the location
! for B.
! 
! A sequence of EQUIVALENCE statements groups names into equivalence sets whose
! positions relative to one another are all defined by the EQUIVALENCE
! statements.  For example, the sequence of EQUIVALENCE statements
! 
! 	EQUIVALENCE A,B+100
! 	EQUIVALENCE C,D-40
! 	EQUIVALENCE A,C+30
! 	EQUIVALENCE E,F
! 
! groups names into the sets {A,B,C,D} and {E,F}.  E and F denote the same
! location.  C is 70 locations after B; A is 30 after C and D is 10 after A.
! 
!    0			 	   70          100    110
!   ------------------------------------------------------------
!   !                                                          !
!   ------------------------------------------------------------
!    B                                C            A      D	
! 
! To compute the equivalence sets we represent each set as a linked list.  We
! then look for variables which occur in more than one set and combine the sets.
! This is repeated until we get a collection of disjoint equivalence classes.
! 
! In the above example, we start with
! 
! 	{A,B+100}
! 	{C,D-40}
! 	{A,C+30}
! 	{E,F}
! 
! First notice that A appears in the first and third sets.  Combine these to
! give
! 
! 	{A,B+100,C+30}
! 	{C,D-40}
! 	{E,F}
! 
! Now C occurs in the first and second sets.  If C = D-40 then C+30 = D-10 so we
! get
! 
! 	{A,B+100,C+30,D-10}
! 	{E,F}
! 
! These sets are disjoint, so we're done.
! 
! The last union contains the calculation "if C=D-40 then C+30=D-10".  In
! general, this situation occurs when the offsets in the first set are from one
! variable, A, and the offsets in the second set are from a different variable,
! C.  We must first rewrite the offsets in the second set so that everything is
! in terms of A.  In the terminology used by the compiler, each set has a
! "head", the first element in the set.  The offsets in the set are offsets from
! the head.  When we union two sets, we must rewrite the offsets in one set in
! terms of the head of the other set.
! 
! There are several additional features that must be appended to this algorithm
! to make it work for FORTRAN.  First, we must determine whether an equivalence
! set is in COMMON, which is true if any variable in the set has been declared
! in a COMMON statement.  Second, in an assembly language, one member of an
! equivalence set will pin down the entire set to reality by being a label of a
! statement, thus allowing the addresses denoted by all names in the set to be
! computed relative to that one location.  In Fortran, however, it is the
! compiler's job to determine storage locations, so an equivalence set not in
! COMMON may be viewed as "floating" until the compiler determines the position
! of the whole set.  To do so correctly, the compiler needs to know the extent
! of the equivalence set, that is, the number of locations which the names in
! the set collectively occupy.  To handle this problem we attach to each set two
! fields, LOW and HIGH, giving the offsets relative to the leader of the lowest
! and highest locations used by any member of the equivalence set.
! 
! When we merge two sets containing the same variable, we must compute LOW and
! HIGH for the merged set.
! 
! 
! LOW1                                                   HIGH1
! ------------------------------------------------------------
! !                               X                          !
! ------------------------------------------------------------
!                                 ^
!                                 ^
! 	------------------------------------------------------------
! 	!                       X                                  !
! 	------------------------------------------------------------
!         LOW2                                                   HIGH2
! 
! LOW = min(LOW1,LOW2+offs)                        HIGH = max(HIGH1,HIGH2+offs)
! 
! where offs is the number added to the offsets of set 2 to convert them from
! being relative to the set 2 head to being relative to the set 1 head.
! 
! 
! In the compiler, there are several additional little whizzies to make life
! interesting.  For variables in COMMON, the offsets aren't allowed to go
! negative, so the algorithms all have to be careful that the head of each set
! is the element of the set with the lowest address.
! 
! As usual, the compiler data structures contain several fields which change
! meaning dynamically as the code goes from place to place.  A summary of most
! of the relevant fields follows.
! 
! All offsets and lengths are calculated in characters.  (There are 5 characters
! per word.  Address 0 contains characters 0-4, address 1 contains characters
! 5-9, and so on.)  These character addresses are converted back to word
! addresses at the very end.
! 
! Equivalence group node, one for each parenthesized list in an EQUIVALENCE stmt
! 
! EQVHEAD	pointer to equiv list node of head of set
! EQVFIRST	pointer to equiv list node of first element of set
! EQVLAST	pointer to equiv list node of last element of set
! EQVADDR	character displacement of class head from 0, like LOW above
! EQVLIMIT	like HIGH above (chars required to allocate storage for the
! 		class is EQVLIMIT-EQVADDR)
! EQVALIGN	contains 0 if this group can start on any byte in a word,
! 		or 1-5 if the group must start on that byte in order for the
! 		numeric variables in the group to land on word boundaries
! 		when addresses are assigned.
! 
! Equivalence list node, one for each element of an equivalence group
! 
! EQLID		pointer to symbol table entry of identifier
! EQLDISPL	character displacement of this symbol from group head
! 
! 
! Things are organized so that, after all the calculations are complete and the
! dust settles, the address to be assigned to a name is EQLDISPL + the address
! of the equivalence class.  EQVADDR is set to the minimum EQLDISPL in the
! class.  Thus, to actually allocate storage for a class, EQVLIMIT-EQVADDR chars
! are allocated, a variable (TLOC) is set to LOWLOC-EQVADDR, and then the
! address of each variable is given by TLOC + EQLDISPL.
! 
! 
! 
! Organization of common/equivalence processing:
! 
! 
! ALLOCAT is the driver routine.  It calls PROCCOM, PROCEQUIV, ALLCOM.
! 
! PROCCOM goes through the COMMON statements and assigns addresses to each
! variable that is explicitly declared in COMMON.
! 
! PROCEQUIV goes through the EQUIVALENCE statements and 
! - finds groups that are in COMMON because one of their members is declared
!   in common.  Sets EQVINCOM flag in such groups.  [using GRPSCAN]
! - sets EQLDISPL for array elements to the word offset from the base address
!   of the array to the given element.  EQLDISPL for non-array elements is 0.
! - sets EQVLIMIT to max(EQVLIMIT,EQLDISPL+ARASIZ) where ARASIZ is the declared
!   size of the array or 1 (or 2) for scalars
! - sets LCLHD to {either the (unique?) element of the group declared in common
!   or} the one with the minimum EQLDISPL.  At this point, EQLDISPL is the
!   offset from the start of the array.
! - if the group contains a symbol declared in COMMON, check all other symbols
!   to see that if they are also declared in common that they are in the same
!   block and have the same offset.  If they are not also declared in common,
!   declare them in the same COMMON block as the equivalenced variable.  Add
!   them to the linked list of variables in the common block.  Give them all the
!   same IDADDR (offset from start of common) field.
! - Set in the group node: EQVADDR = min(EQLDISPL) over the group, EQVHEAD =
!   symbol with the min EQLDISPL, EQVLIMIT = number of words in group
! - finds variables which occur in more than group and unions the groups 
!   together into classes.  [ELISTSRCH]   When two groups are found which 
!   contain the same variable, one of them is chosen to be a "class", ie, the
!   one that gets the other unioned into it.  The one that is the "class" has
!   a magic field, EQVAVAIL, set to 2.  The one that remains a group has 
!   EQVAVAIL set to 0.  At the end of this processing, the groups with
!   EQVAVAIL = 2 are the ones that contain all the info from all the 
!   equivalence statements.
! - call EQCALLOC to allocate the classes
! 
! ALLCOM is misnamed; it doesn't allocate anything but does print the common
! block info on the listing.  It also converts all of the common block offsets
! from characters to words.




GLOBAL 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;
REGISTER BASE CSYMPTR;
LOCAL BASE CCOMPTR;

%1261% LOCAL FLAGWRD;
%1261% BIND CHARSEEN = FLAGWRD<0,1>, ! BLOCK CONTAINS CHARACTER DATA
%1261%	    NUMSEEN = FLAGWRD<1,1>;  ! BLOCK CONTAINS NUMERIC DATA

%1630%	IF EXTENDED AND .FLGREG<OBJECT>		! Psected object code ?
%1615%	THEN					! Yes
%1615%	BEGIN

! Set the default psect before we define the common blocks.  LINK will
! allocate common blocks in the  default psect when reading a  psected
! rel file.  We assume that all variables are in .DATA. for now.

%1615%		RDATWD = PXDATA;		! Index for .DATA.
%1615%		ZOUTBLOCK(RPSECTORG,RELN)	! Psect index rel block
%1615%	END;

ICNT _ 0;

%1511%	! If bare  SAVE,  then zero  count.   May have  specified  non-bare
%1511%	! COMMON, and that would mess up our count.

%1511%	IF .SAVALL EQL TRUE
%1511%	THEN NUMSAVCOMMON = 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

%1511%	! Bare SAVE statement.   Save the number  of commons processed  for
%1511%	! later output of the rel block.

%1511%	IF .SAVALL
%1531%	THEN NUMSAVCOMMON = .NUMSAVCOMMON + 1;

%1261%	! CONVERT COMSIZE BACK TO WORDS
%1406%	CCOMPTR[COMSIZE] _ CHWORDLEN(.CCOMPTR[COMSIZE]);

	!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(RCOMMON,RELN);
		RDATWD_ .CCOMPTR[COMSIZE]; ZOUTBLOCK(RCOMMON,RELN);
	     );

%1261%	!CONVERT IDADDR FROM CHARACTERS TO WORDS
%1261%
%1261%	FLAGWRD _ 0;			! CLEAR CHARSEEN AND NUMSEEN
%1261%	CSYMPTR _ .CCOMPTR[COMFIRST];	! POINT TO FIRST SYMBOL IN COMMON BLOCK
%1261%	DO
%1261%	BEGIN
%1261%		IF .CSYMPTR[VALTYPE] NEQ CHARACTER
%1261%		THEN
%1261%	     	BEGIN !NUMERIC
%1261%			NUMSEEN _ 1;
%1261%	     		IF .CSYMPTR[IDADDR] MOD CHARSPERWORD NEQ 0
%1261%	     		THEN FATLERR(.CSYMPTR[IDSYMBOL],E167<0,0>);
%1261%						  ! "Must be word aligned"
%1261%		      	CSYMPTR[IDADDR] _ .CSYMPTR[IDADDR] / CHARSPERWORD;
%1261%	     			! CONVERT CHAR ADDRESS TO WORD ADDRESS
%1261%	     	END   !NUMERIC
%1261%		ELSE
%1261%	     	BEGIN !CHARACTER
%1261%			CHARSEEN _ 1;
%1261%	     		CSYMPTR[IDCHBP] _ CHADDR2BP(.CSYMPTR[IDADDR]);
%1261%					! CONVERT CHAR ADDRESS TO BYTE POINTER
%1261%		      	CSYMPTR[IDADDR] _ 0; ! AND CLEAR IDADDR, WHICH WILL BE
%1261%					     ! USED FOR ADDRESS OF DESCRIPTOR
%1261%	     	END;  !CHARACTER
%1261%	END
%1261%	WHILE (CSYMPTR _ .CSYMPTR[IDCOLINK]) NEQ 0; ! LOOP THROUGH ALL SYMBOLS
						    ! IN THIS COMMON BLOCK

%1261%	IF .CHARSEEN AND .NUMSEEN 	! IF BLOCK CONTAINS BOTH CHAR & NUMERIC
%1675%	THEN WARNERR(UPLIT 'mixed in COMMON?0',0,E168<0,0>);

	!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
%1261%		IF .CSYMPTR[VALTYPE] NEQ CHARACTER
		THEN (R1 _ .CSYMPTR[IDADDR]; ZOUOFFSET())
%1261%		ELSE (CHAROUT("+"); ZOUTBP(.CSYMPTR[IDCHBP]));
		!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 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.
%

%1547%	COMTSIZ = PROCCOM(); 	! Compute size of 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


END;	! of ALLOCAT

GLOBAL ROUTINE DUMPFORMAT =
BEGIN

![1424]	Rewritten by RVM on 19-Nov-81

%(**********************************************************************

   This routine allocates address to formats and dumps the formats
   preceded by their size words to the .REL file (if there is a .REL
   file).  Formats are allocated after all other low segment data.

   Note that this routine should be called after the optimizer has
   done its work.  This routine does setup the values in the label
   table entries for the format labels.  This conflicts with the
   optimizer, who thinks it can freely use the fields in the label
   table for its own use.

   After the routine is called, LOWLOC is the address of the first
   word not used in the low segment.

**********************************************************************)%

%1454%	REGISTER RELFILE, BASE FORMAT, BASE STMTLABEL;

	!(*** Get pointer to first format in the linked list of formats ***)
	FORMAT = .FORMPTR<LEFT>;

%1454%	!(*** Get the flag that tells if we need a .REL file ***)
%1454%	RELFILE = .FLGREG<OBJECT>;

%1454%	!(*** Dump out the code block immediately ***)
%1454%	IF .RELFILE THEN DMPMAINRLBF();

	!(*** Loop until the end of the linked list of formats is reached ***)
	WHILE .FORMAT NEQ 0
	DO
	BEGIN	!Loop through linked list of all formats

%1454%		!(*** Fill in the address word of the FORMAT entry with	 ***)
%1454%		!(***  the address of the format text.			 ***)
%1454%		!(*** Then fill in the label table entry for the format  ***)
%1454%		!(***  label.						 ***)

%1454%		STMTLABEL = .FORMAT[SRCLBL];
%1526%		STMTLABEL[SNADDR] = FORMAT[FORADDR] = .LOWLOC + 1;
%1454%		STMTLABEL[SNDEFINED] = TRUE;	      !* Label is defined
%1454%		STMTLABEL[SNSTATUS] = OUTPBUFF;	      !* Label is nailed down

%1454%		!(*** Now, if there is a .REL file, dump the format	 ***)
%1454%		IF .RELFILE
%1454%		THEN
%1454%		BEGIN
			RDATWD = .FORMAT[FORSIZ];	! Fetch size word
%1526%			ZCODE(PSABS,PSDATA);		! Output it
%1526%			LOWLOC = .LOWLOC+1;		! Point to next word

			!(*** Loop to dump the format string ***)
			INCR I FROM 0 TO .FORMAT[FORSIZ] - 1
			DO
			BEGIN	!Dump FORMAT string
				RDATWD = @(.FORMAT[FORSTRING])[.I];
%1526%				ZCODE(PSABS,PSDATA);
%1526%				LOWLOC = .LOWLOC + 1
			END; ! of dump the format string

%1454%		END ! of dump FORMAT to .REL file
%1526%		ELSE LOWLOC = .LOWLOC + .FORMAT[FORSIZ] + 1;	!* Bump LOWLOC

		!(*** Get next format in linked list ***)
		FORMAT = .FORMAT[FMTLINK];

	END; ! of loop through linked list of all formats

%1454%	!(*** Dump out the code block immediately. ***)
%1454%	IF .RELFILE THEN DMPMAINRLBF()

END; ! of DUMPFORMAT

ROUTINE PROCCOM=
BEGIN

! Makes  a  pass  through  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.   Also RETURNS  the
! total number of words of COMMON the program unit uses.

REGISTER
	CBLKSIZ,	! Size of current COMMON block
	TCOMSIZ,	! Size of all COMMON blocks
BASE	CCOMPTR:	! Pointer to current COMMON block
	CSYMPTR;	! Pointer to current STE

XTRAC;

TCOMSIZ = 0;				! Total size of all COMMON blocks
CCOMPTR = .FIRCOMBLK;			! Pointer to first COMMON block

WHILE .CCOMPTR NEQ 0 DO			! Loop on list of COMMON blocks
BEGIN
	CBLKSIZ = 0;			! Clear size of this COMMON block
	CSYMPTR = .CCOMPTR[COMFIRST];	! Get first STE in COMMON block

	WHILE .CSYMPTR NEQ 0		! Loop on list of symbols in block
	DO
	BEGIN

! If numeric  (non-character)  variables are  encountered,  place  the
! start of the variable on a  word boundary by rounding the offset  up
! to be a multiple of 5 characters.

%1261%		IF .CSYMPTR[VALTYPE] NEQ CHARACTER	! Numeric variable?
%1261%		THEN CBLKSIZ = CHWORDLEN(.CBLKSIZ)*CHARSPERWORD;
					! Yes, round up
					! 500 Washington St, Hoboken
					! A taste treat that can't be beat

%1261%		CSYMPTR[IDADDR] = .CBLKSIZ;	! Set offset of this variable
%1261%		CBLKSIZ = .CBLKSIZ + SIZEINCHARS(.CSYMPTR);
%1261%				! Increment offset by size of this variable

		CSYMPTR = .CSYMPTR[IDCOLINK]	! Point to next variable
	END;				! Loop back for more variables

	CCOMPTR[COMSIZE] = .CBLKSIZ;	! Save the size of this common block
%1547%	TCOMSIZ = .TCOMSIZ + CHWORDLEN(.CBLKSIZ);	! Add it to the total

	CCOMPTR = .CCOMPTR[NEXCOMBLK]	! Point to the next common block
END;					! Loop back for more common blocks

RETURN .TCOMSIZ
END; ! of ROUTINE

ROUTINE EQERRLIST(GROUP)=
BEGIN
!LIST THE GROUP OF EQUIVALENCE VARIABLES IN CONFLICT
!
MAP BASE GROUP:R2;
LOCAL BASE SYMPTR;
	SYMPTR _ .GROUP[EQVFIRST];
%1146%	FATLERR(.GROUP[EQVISN],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
			COMBLPTR _ .COMSYM[IDCOMMON];
			RETURN FATLERR(COMBLPTR[COMNAME],.ISN,E33<0,0> );
		END;

%1511%		! Give error if this symbol is in SAVE, can't also be in
%1511%		! COMMON
%1511%		IF .NEWSYM[IDSAVVARIABLE]
%1511%		THEN FATLERR(.NEWSYM[IDSYMBOL],
%1531%			.ISN,E197<0,0>);

		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 GROUPTOCOMMON

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.
%

%1511%	! Massive reformatting and indenting

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


ELIS1:	BEGIN
		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 RETURN 0	!No match between ECLASS and EGROUP
			ELSE EGITEM _ .EGITEM[EQLLINK];

		END !OF WHILE %1%
	END;
!  )  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 

%1261% ! Check that alignment requirements of class and group match each other.
%1261% ! The required condition is
%1261% ! CLASS-ALIGNMENT + CLASS-DISPL = GROUP-ALIGNMENT + GROUP-DISPL (mod 5)
%1261%
%1261%	IF .ECLASS[EQVALIGN] EQL 0	! If class has no alignment requirement
%1261%	THEN IF .EGROUP[EQVALIGN] NEQ 0	! but group does
%1261%	THEN				! give group's requirement to class too
%1261%	ECLASS[EQVALIGN] _ 1 +
%1261%			MODULO(.EGROUP[EQVALIGN] + .EGDISPL - .ECDISPL - 1, CHARSPERWORD);
%1261%
%1261%	IF .EGROUP[EQVALIGN] NEQ 0 	! If group has an alignment requirement
%1261%	THEN				! check if things will still be aligned
%1261%					! when group is merged with class
%1261%	IF (.ECDISPL + .ECLASS[EQVALIGN] - .EGDISPL - .EGROUP[EQVALIGN]) MOD CHARSPERWORD
%1261%		NEQ 0
%1261%	THEN FATLERR(.ISN,E166<0,0>);	!"Numeric var must be word aligned"


!
!TEST FOR GROUP OR CLASS IN COMMON
!
IF .ECLASS[EQVINCOM] OR .EGROUP[EQVINCOM]
THEN
BEGIN
	IF .EGROUP[EQVINCOM]
	THEN
	BEGIN	!ASSIGN COMMON ADDRESSES TO ECLASS
		ELIM _ .EGROUP[EQVLIMIT];
		EGDISPL _ .CITEM[EQLDISPL]; ECDISPL _ .EGITEM[EQLDISPL];
		CSYMPTR _ .EGITEM[EQLID];
		EGITEM _ .ECLASS[EQVFIRST]; EGSYMPTR _ .EGITEM[EQLID];
	END;

	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;
			IF (EGSYMPTR[IDADDR] _ .CSYMPTR[IDADDR] + .EGITEM[EQLDISPL] -.EGDISPL) LSS 0
			THEN 
			BEGIN
				MAP BASE R1;
				R1 _ .CSYMPTR[IDCOMMON];
				RETURN FATLERR(R1[COMNAME],.ISN,E33<0,0>)
			END;
			!ERROR EQUIVALENCE ITEM EXTENDS COMMON BACKWARD

%1511%			! Give error if  this symbol is  in SAVE,  can't
%1511%			! also be in COMMON
%1511%			IF .EGSYMPTR[IDSAVVARIABLE]
%1511%			THEN FATLERR(.EGSYMPTR[IDSYMBOL],
%1531%				.ISN,E197<0,0>);

			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

%1261%			EGSYMSIZ _ SIZEINCHARS(.EGSYMPTR);
			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
			BEGIN	
				EQERRLIST(.EGROUP);
				EGROUP[EQVAVAIL] _ 3;
				RETURN -1
			END;

		!TESTING FOR END OF CHAIN OF GROUP GOING INTO COMMON
		IF .EGITEM[EQLLINK] NEQ 0
		THEN
		BEGIN
			EGITEM _ .EGITEM[EQLLINK];
			EGSYMPTR _ .EGITEM[EQLID];
		END
		ELSE
		BEGIN
			LINKGROUPS(.ECLASS,.EGROUP,.CSYMPTR);
			ECLASS[EQVINCOM] _ 1;
			!THIS IS A SUCCESSFUL TRIP - RETURN 1!
			EGROUP[EQVAVAIL] _ 2;
			EGROUP[EQVINCOM]_1;
			RETURN 1
		END;
	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
	BEGIN
		IF .NEWDISPL NEQ .CITEM[EQLDISPL]
		THEN
		BEGIN
			EQERRLIST(.EGROUP); !INCONSISTENT OR CONFLICTING EQUIVALENCES
			EGROUP[EQVAVAIL] _ 3;
			RETURN -1
		END;
	END
	ELSE	CITEM[EQLLINK] _ .EGITEM;


	EGITEM[EQLLINK] _ 0;	!CLEAR LINK
	EGITEM[EQLDISPL] _ .NEWDISPL;

	IF .NEWDISPL LSS .ECLASS[EQVADDR]
	THEN ECLASS[EQVADDR] _ .NEWDISPL;
	BEGIN	!NOW COMPUTE NEW EQVLIMIT
		LOCAL BASE ESYM, EQSIZ;
%1261%		EQSIZ _ SIZEINCHARS(.EGSYMPTR);
		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 ELISTSRCH

ROUTINE EQCALLOC(ECLASS)=
BEGIN
%
ALLOCATE RELOCATABLE ADDRESSES TO AN EQUIVALENCE CLASS (ECLASS)
%
MAP BASE ECLASS;
LOCAL BASE CITEM :CSYMPTR;
LOCAL TLOC;
OWN CNT;

%1261% LOCAL FLAGWRD;
%1261% BIND CHARSEEN = FLAGWRD<0,1>, ! BLOCK CONTAINS CHARACTER DATA
%1261%	    NUMSEEN = FLAGWRD<1,1>;  ! BLOCK CONTAINS NUMERIC DATA

%
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'));
%1261% ! TLOC is the CHARACTER address of the beginning of this equivalence class
%1261%	IF .ECLASS[EQVALIGN] NEQ 0	! If class must be aligned on a
%1261%	THEN				! particular byte
%1261%	ECLASS[EQVADDR] _ .ECLASS[EQVADDR] -
%1261%		MODULO (.ECLASS[EQVADDR] + .ECLASS[EQVALIGN] - 1, CHARSPERWORD);

%1261%	TLOC _ .LOWLOC * CHARSPERWORD - .ECLASS[EQVADDR];

%1261%	FLAGWRD _ 0;			! CLEAR CHARSEEN & NUMSEEN
CITEM _ .ECLASS[EQVFIRST];
WHILE 1 DO
BEGIN
	CSYMPTR _ .CITEM[EQLID];	!PTR TO SYMBOL
	CSYMPTR[IDADDR] _ .CITEM[EQLDISPL] + .TLOC;

%1261%	IF .CSYMPTR[VALTYPE] NEQ CHARACTER 	! CONVERT FROM CHAR ADDRESS
%1261%	THEN
%1261%	BEGIN
%1261%		CSYMPTR[IDADDR] _ .CSYMPTR[IDADDR] / CHARSPERWORD;  ! CONVERT TO WORD ADDRESS
%1261%		CHARSEEN _ 1;		! REMEMBER CLASS CONTAINS CHAR DATA
%1261%	END  !NUMERIC
%1261%	ELSE
%1261%	BEGIN !CHARACTER
%1261%		CSYMPTR[IDCHBP] _ CHADDR2BP(.CSYMPTR[IDADDR]);  ! CONVERT TO BYTE POINTER
%1261%	      	CSYMPTR[IDADDR] _ 0;	! AND CLEAR IDADDR, DESCRIPTOR ADDRESS
%1261%	      	NUMSEEN _ 1;		! REMEMBER CLASS CONTAINS NUMERIC DATA
%1261%	END;  !CHARACTER

	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;

%1261%	IF .CHARSEEN AND .NUMSEEN	! IF CLASS CONTAINS BOTH CHAR & NUMERIC
%1675%	THEN WARNERR(UPLIT 'EQUIVALENCE-d?0',.ISN,E168<0,0>);

%1406%	LOWLOC _ .LOWLOC + CHWORDLEN(.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
!
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
			% 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;	! of GRPSCAN

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.
%

LOCAL BASE EQVCPTR,	!PTR TO CURRENT EQUIV CLASS HEADER
	ECOMMPTR,	!PTR COMMON ITEM IF GROUP IS IN COMMON
	ECOMMHDR,	!PTR TO COMMON BLOCK HDR
	LCLHD;		!PTR TO LOCAL HEAD OF A GROUP FOR ALLOCATION PURPOSES

REGISTER BASE EQLPTR;	!PTR TO EQUIV LIST NODE
LOCAL BASE EQLPT2;	!OTHER PTR TO EQUIV LIST NODE

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;
		PT1 _ .EQLPTR[EQLID];
		IF .PT1[IDDIM] EQL 0 THEN
		BEGIN
 			FLGREG<BOUNDS>_.SAVEBOUNDSFLG;
			RETURN FATLERR(.ISN,E93<0,0>);
		END;
		EQLPTR[EQLINDIC] _ 0;
		IF .EQLPTR[EQLLIST]^(-18)  NEQ  0
		THEN
		BEGIN	%MULTIPLE SUBSCRIPTS%
			! SET EQLDISPL TO NEGATIVE OF SUBSCRIPT EXPRESSION
			 PT1 _ ARRXPN(.EQLPTR[EQLID],.EQLPTR[EQLLIST]);
			IF .PT1[ARG2PTR] EQL 0
			THEN
			EQLPTR[EQLDISPL] _ -(EXTSIGN(.PT1[TARGADDR]))
%1261%			ELSE
%1261%			EQLPTR[EQLDISPL] _ -CNSTEVAL(.PT1[ARG2PTR]) 
%1261%					      - EXTSIGN(.PT1[TARGADDR]);

%1261%		PT3 _ .EQLPTR[EQLID];			! GET PTR TO SYMBOL
%1261%		IF .PT3[VALTYPE] NEQ CHARACTER		! IF NONCHARACTER,
%1261%		THEN EQLPTR[EQLDISPL] _ .EQLPTR[EQLDISPL] * 5; ! CONVERT WORDS
%1261%							       ! TO CHARS
		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 -(1^18)  
			   OR  .EQLPTR[EQLDISPL] GEQ 1^18
			THEN	RETURN FATLERR(.ISN, E103<0,0>);	!OUT OF RANGE
%1261%			IF .PT3[VALTYPE] EQL CHARACTER ! MULTIPLY BY ELEMENT
%1261%			THEN			       ! LENGTH IN CHARACTERS
%1261%			EQLPTR[EQLDISPL] _ .EQLPTR[EQLDISPL] * .PT3[IDCHLEN]
%1261%			ELSE
%1261%			IF .PT3[DBLFLG]
%1261%			THEN EQLPTR[EQLDISPL] _ .EQLPTR[EQLDISPL] * 2 * CHARSPERWORD
%1261%			ELSE
%1261%			EQLPTR[EQLDISPL] _ .EQLPTR[EQLDISPL] * CHARSPERWORD;
		END
	     );

	   ESYM _ .EQLPTR[EQLID]; !PTR TO SYMBOL TABLE

%1262% ! ADD IN SUBSTRING OFFSET FOR CHARACTER VARIABLES
%1262%	IF .EQLPTR[EQLSSTRING]		! IF THIS LIST ELEMENT IS A SUBSTRING
%1262%	THEN
%1262%	IF .ESYM[VALTYPE] NEQ CHARACTER	! BASE IDENTIFIER MUST BE CHARACTER
%1262%	THEN FATLERR(.ISN,E162<0,0>)	! "Substring of non-CHARACTER"
%1262%	ELSE
%1262%	IF .EQLPTR[EQLLOWER] LSS 0 OR .EQLPTR[EQLLOWER] GEQ .ESYM[IDCHLEN]
%1262%	THEN FATLERR(.ISN,E165<0,0>);	! "Substring bound out of range"

%1262%	EQLPTR[EQLDISPL] _ .EQLPTR[EQLDISPL] - .EQLPTR[EQLLOWER];


%1261%	! IF EQUIVALENCED VARIABLE IS NUMERIC, THIS GROUP MUST BE WORD ALIGNED
%1261%	IF .ESYM[VALTYPE] NEQ CHARACTER
%1261%	THEN EQVCPTR[EQVALIGN] _ 1;

!
!
!NOW CHECK FOR NEW EQVLIMIT (R2) FOR THIS GROUP
	!
%1261%	   EQSIZ _ SIZEINCHARS(.ESYM);
	   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(
				LINK _ .ECOMMHDR[COMLAST];
				ECOMMHDR[COMLAST] _ .EQLPTR[EQLID];
				LINK _ LINK[IDCOLINK] _ .EQLPTR[EQLID]; !PTR TO SYMBOL TABLES NODE

%1511%				! Can't be in both SAVE and Common
%1511%				IF .LINK[IDSAVVARIABLE]
%1511%				THEN	FATLERR(.LINK[IDSYMBOL],
%1531%					.ISN,E197<0,0>);

				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
!

%1450%	! Check for EQUIVALENCE (A(1),A(2))

%1450%	EQLPTR _ .EQVCPTR[EQVFIRST];		  ! Step through all variables
%1450%	WHILE .EQLPTR NEQ 0 DO			  !   in equivalence list
%1450%	BEGIN
%1450%		EQLPT2 _ .EQLPTR[EQLLINK];	  ! Step through all subsequent
%1450%		WHILE .EQLPT2 NEQ 0 DO		  !   variables in list
%1450%		BEGIN				  ! Look for duplicates
%1450%			IF .EQLPTR[EQLID] EQL .EQLPT2[EQLID] ! If variable is
%1450%			THEN			             ! the same
%1450%			IF .EQLPTR[EQLDISPL] NEQ .EQLPT2[EQLDISPL] ! displ must
%1450%			THEN				     ! also be the same
%1450%			BEGIN
%1450%				EQERRLIST(.EQVCPTR);	! error, type message
%1450%				EQVCPTR[EQVAVAIL] _ 3;	! mark group to prevent
%1450%							!   further processing
%1450%			END;
%1450%			EQLPT2 _ .EQLPT2[EQLLINK]; 
%1450%		END;
%1450%		EQLPTR _ .EQLPTR[EQLLINK];
%1450%	END;


    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 PROCEQUIV

GLOBAL ROUTINE ALCCON=
BEGIN
	! Allocate all the constants that have the flag CNTOBEALCFLG set.
	! this flag is set by calls to ALOCONST.  

%1232%	! Rewritten by TFV, 17-Jun-81
%1232%	! Fixup block structure and allocate hollerith and character constants

	BIND HI=R1,LOW=R2;
	MACHOP ADDI=#271,TLZE=#623,TLO=#661,LSH=#242,DFN=#131;
MACRO EXPON=27,8$;

	REGISTER BASE CPTR;

	! Set CNTOBEALCFLG for all consts used in dimensioning arrays that will
	! have bounds checking performed on them

	ALODIMCONSTS();

	INCR I FROM 0 TO CSIZ-1 DO	! Walk through hash table entries
	BEGIN
		CPTR_.CONTBL[.I];	! Get next hash table entry
		WHILE .CPTR NEQ 0 DO	! Walk down linked list for each hash
		BEGIN

%1272%			! Convert real constants from DP to SP form, even if
%1272%			! the constant lives in a MOVEI.

			IF .CPTR[CONST1] NEQ 0
			THEN
 			BEGIN

				! Convert real constants from DP to SP
				! form, 0 is a special case

				IF .CPTR[VALTYPE] EQL REAL
				THEN
				BEGIN

					! When  rounding   to   single
					! precision, zero second word

					CPTR[CONST1] _ KISNGL(.CPTR[CONST1],
							.CPTR[CONST2]);
					CPTR[CONST2]_0;
				END;
			END;

%1272%			IF .CPTR[CNTOBEALCFLG] THEN
%1272%			BEGIN
%1272%				! Constant to be allocated

%1526%				CPTR[IDADDR]_.LOWLOC;

				! Now put  constant out  in REL  file.
				! Remember  that   this   routine   is
				! executed within a test for the  .REL
				! file generation

				IF .CPTR[VALTP1] EQL INTEG1	! Output first or only word of data
				THEN RDATWD _ .CPTR[CONST2]	! Only word 
				ELSE RDATWD _ .CPTR[CONST1];	! High order for double or complex

				! Output to low seg with no relocation

				IF .FLGREG<OBJECT>
%1526%				THEN ZCODE(PSABS,PSDATA);

%1526%				LOWLOC _ .LOWLOC + 1;

				IF .CPTR[DBLFLG]
				THEN
				BEGIN
					! Output low order word for double and complex

					RDATWD _ .CPTR[CONST2];

					! Output to low seg with no relocation

					IF .FLGREG<OBJECT>
%1526%					THEN ZCODE(PSABS,PSDATA);

%1526%					LOWLOC _ .LOWLOC + 1
				END

			END;	! Constant to be allocated

			CPTR_.CPTR[CLINK]	! Get next linked list item

		END;	! Walk down linked list for each hash

	END;	! Walk through hash table entries

	! Output HOLLERITH and  CHARACTER constants  to lowseg.   They
	! are in writable storage since they can be actuals passed  to
	! dummy arrays and  updated.  FORTRAN 66  also allows  reading
	! into FORMAT  specs.   LINK  will  fixup  character  constant
	! actuals passed to non-character dummy args by converting the
	! character  constant   to  hollerith.    This  is   done   by
	! substituting a pointer to the actual constant for a  pointer
	! to the  character  descriptor.  Because  of  this  character
	! constants must look  the same as  hollerith; they are  blank
	! filled to a full word and followed by a zero word (ASCIZ).

	CPTR _ .LITPOINTER<LEFT>;

	WHILE .CPTR NEQ 0 DO	! walk down linked list
	BEGIN
		IF .CPTR[CNTOBEALCFLG]
		THEN
		BEGIN
			! Literal to be allocated

			! LITADDR points to the literal in the lowseg.
			! Character  constants  will  have   character
			! descriptors  generated  in   the  high   seg
			! pointing to  the low  seg data  and  LITADDR
			! will be modified to point to the descriptor.

%1526%			CPTR[LITADDR] _ .LOWLOC;

			IF .FLGREG<OBJECT>
			THEN
			BEGIN
				INCR I FROM 0 TO .CPTR[LITSIZ] - 1 DO
				BEGIN
					! Output LITSIZ words

					RDATWD _ .(CPTR[LIT1] + .I);	! Get next word
%1526%					ZCODE(PSABS,PSDATA);
%1526%			   		LOWLOC _ .LOWLOC + 1;
				END
			END
%1526%			ELSE	LOWLOC _ .LOWLOC + .CPTR[LITSIZ];

		END;	! Literal to be allocated

		CPTR _ .CPTR[LITLINK]	! Get next linked list item

	END	! of walk down linked list

END;	! of ALCCON

GLOBAL ROUTINE HSLITD=
BEGIN

%1232%	! Written by TFV, 17-Jun-81

! Output hiseg  descriptors  for character  constants.   Called  after
! hiseg is inited.  Fixup IDADDR  to point to descriptor.   Descriptor
! points to lowseg character constant data.

REGISTER
	BASE CPTR,
	BP;

	CPTR _ .LITPOINTER<LEFT>;

	WHILE .CPTR NEQ 0 DO	! walk down linked list
	BEGIN
		IF .CPTR[CNTOBEALCFLG] AND .CPTR[LITOPER] EQL CHARCONST
		THEN
		BEGIN
			! Character constant to be allocated

			! LITADDR points to the character descriptor generated
			! in the high seg which points to the low seg data.

%1406%			BP = RDATWD = BPGEN(.CPTR[LITADDR]);	! Byte pointer to low seg data
			CPTR[LITADDR] _ .HILOC;		! Pointer to descriptor

			IF .FLGREG<OBJECT>
			THEN
			BEGIN	! .REL being generated

%1526%				ZCODE(PSDATA,PSCODE);	! Output byte pointer to hiseg, relocating right half to lowseg
			   	HILOC _ .HILOC + 1;

				RDATWD _ .CPTR[LITLEN];	! Length of character constant
%1526%				ZCODE(PSABS,PSCODE);	! Output length to hiseg without relocation
			   	HILOC _ .HILOC + 1;

			END ! of .REL being generated
			ELSE HILOC _ .HILOC + 2;

			! List symbol name, descriptor address, lowseg
			! data position, and length

			IF .FLGREG<LISTING> AND .FLGREG<MACROCODE>
			THEN LISTCHD(.CPTR,.BP);

		END;	! Literal to be allocated

		CPTR _ .CPTR[LITLINK]	! Get next linked list item

	END;	! Walk down linked list

END;	! of HSLITD

GLOBAL ROUTINE HSCHD=
BEGIN

REGISTER
	BASE PTR,
%1434%	BASE ENT,
%1434%	BASE FUNC;

MAP
%1261%	BASE R2;

%1232%	! Written by TFV, 17-Jun-81

! Generate hiseg  descriptors  for  non-dummy  character  scalars  and
! arrays.  Called  after  the  hiseg  is inited.   Only  called  if  a
! character declaration or an implicit character declaration has  been
! seen.  Calls LISTCHD  to list  the character  data name,  descriptor
! location, start of character data, and length.

	DECR I FROM SSIZ-1 TO 0 DO	! Walk through hash table entries
	BEGIN
	    PTR = .SYMTBL[.I];	! Entry for this hash
	    WHILE .PTR NEQ 0 DO	! Walk down linked list of symbols
	    BEGIN

%1422%	! Generate descriptors  for character  variables and  for  the
%1422%	! function name and  entry points for  this program unit,  but
%1422%	! not  for  functions  it  calls.   Generate  descriptors  for
%1422%	! character functions  that are  declared external.   Generate
%1422%	! only one descriptor for multi-entry character functions.

		IF .PTR[VALTYPE] EQL CHARACTER THEN
%1422%		IF NOT .PTR[IDATTRIBUT(NOALLOC)] THEN
%1434%		IF (.PTR[IDATTRIBUT(FENTRYNAME)] AND .PTR[IDSYMBOL] EQL .PROGNAME) OR
%1434%		   (.PTR[OPERSP] EQL FNNAME AND (.PTR[IDATTRIBUT(INEXTERN)] OR .PTR[IDATTRIBUT(SFN)])) OR
%1434%		   (NOT .PTR[IDATTRIBUT(FENTRYNAME)] AND .PTR[OPERSP] NEQ FNNAME)
		THEN
		BEGIN
			IF NOT .PTR[IDATTRIBUT(DUMMY)]
			THEN
			BEGIN
				! Non-dummy arg character scalars  and
				! arrays have a  hiseg descriptor,  so
				! generate  it.    Point   IDADDR   to
				! descriptor.  Descriptor  is  in  the
				! .CODE. psect

				PTR[IDADDR] = .HILOC;
				PTR[IDPSECT] = PSCODE;

				IF .FLGREG<OBJECT>
				THEN
				BEGIN	! .REL being generated

%1434%					IF NOT .PTR[IDATTRIBUT(INEXTERN)]
%1434%					THEN
%1434%					BEGIN
						! Byte pointer to low seg data

						RDATWD = .PTR[IDCHBP];

%1261%						IF .PTR[IDATTRIBUT(INCOM)]
%1261%						THEN ! Output byte pointer with
%1261%						     ! a RH fixup request
%1261%						BEGIN	! COMMON
%1526%							ZCODE(PSABS,PSCODE); ! output the byte pointer, no relocation
%1261%							R2 _ .PTR[IDCOMMON]; ! get pointer to common block
%1512%							ZSYMBOL(GLB18ADDFIX,.R2[COMNAME],.HILOC,PSCODE)	! Fixup is for descriptor at HILOC
%1261%						END 	! COMMON
%1526%						ELSE ZCODE(.PTR[IDPSCHARS],PSCODE);	! Output BP to high seg with RH relocation
%1434%					END
%1434%					ELSE
%1434%					BEGIN	! function is declared external

%1434%						RDATWD = 1^35;	! IFIW bit
%1526%						ZCODE(PSABS,PSCODE);
%1512%						ZSYMBOL(GLB18CHNFIX,.PTR[IDSYMBOL],.HILOC,PSCODE) ! Fixup descriptor at HILOC
%1434%					END;

					HILOC _ .HILOC + 1;

					RDATWD _ .PTR[IDCHLEN];	! Length of character scalar or array

%1526%					ZCODE(PSABS,PSCODE);	! Output length to high
								!  seg with no relocation
					HILOC _ .HILOC + 1
				END	! of .REL being generated
				ELSE	HILOC _ .HILOC + 2

			END;	! Non- dummy

			! List symbol name, descriptor address, low seg data position, and length

			IF .FLGREG<LISTING>
			THEN LISTCHD(.PTR,.PTR[IDCHBP]);

%1522%			! Check for  illegal  length  star  declaration.
%1522%			! Length star is legal only for dummy  arguments
%1522%			! and character	parameters.

%1522%			IF NOT .PTR[IDATTRIBUT(DUMMY)]
%1522%			THEN IF .PTR[IDCHLEN] EQL LENSTAR
%1522%			THEN FATLERR(.PTR[IDSYMBOL],0,E194<0,0>)

		END;	! Character

		PTR _ .PTR[CLINK];	! Next linked list entry

	    END	! Walk down linked list

	END;	! Walk through hash table entries

%1434%	! Now setup all character entry points to use the descriptor  of
%1434%	! the main entry point

%1434%	IF .FLGREG<PROGTYP> EQL FNPROG THEN
%1434%	IF .MULENTRY NEQ 0
%1434%	THEN
%1434%	BEGIN

%1434%		ENTRY = .PROGNAME;	! Lookup the symbol table  entry
%1434%					! for the function name
%1434%		NAME = IDTAB;		! It's an identifier
%1434%		FUNC = TBLSEARCH();	! Search for it

%1434%		IF .FUNC[VALTYPE] EQL CHARACTER
%1434%		THEN
%1434%		BEGIN	! Multi-entry character function

%1434%			ENT = .MULENTRY;	! Linked list of entry points

%1434%			! Copy IDADDR field of function name into IDADDR fields for the entry points

%1434%			DO ENT[IDADDR] = .FUNC[IDADDR]
%1434%			WHILE (ENT = .ENT[IDENTLNK]) NEQ 0;

%1434%		END;	! Multi-entry character function

%1434%	END;

END;	! of HSCHD

GLOBAL ROUTINE HSDDESC=
BEGIN

%1406%	! Written by TFV on 27-Oct-81

	! Output .Dnnnn compile-time-constant character descriptors to the
	! .REL file.  Either  one word  (byte pointer only)  or two  words
	! (byte  pointer  and  length)  are  output  based  on  the   flag
	! IDGENLENFLG.  One word .Dnnnn variables are used for  SUBSTRINGs
	! with constant lower bounds and non-constant upper bounds.   Fill
	! in the IDADDR  field with  the address of  the descriptor.   Use
	! LISTCHD to output the descriptor to the .LST file.

	REGISTER BASE DPTR: SUBNODE;
	MAP BASE R2;

	DPTR = .DANCHOR;	! Start at first .Dnnnn variable

	WHILE .DPTR NEQ 0 DO	! Walk down linked list
	BEGIN

%1567%	IF NOT .DPTR[IDATTRIBUT(NOALLOC)]
%1627%	THEN IF .DPTR[IDADDR] NEQ 0	! skip .D's allocated for function
%1627%					! return values where the function was
%1627%					! CHAR(constant) in a parameter stmt
%1567%	THEN
%1567%	BEGIN	! Do only if we want to allocate this .Dnnn

		! Get the  subnode  for  the data  from  either  a  .Qnnnn
		! variable (function calls and concatenation) or a  symbol
		! table entry for a scalar (substring) or array (arrayref)

		SUBNODE = .DPTR[IDADDR];

		DPTR[IDPSECT] = PSCODE;		! Descriptor is in the hiseg
		DPTR[IDPSCHARS] = .SUBNODE[IDPSCHARS];	! Psect for the data

		! Form the byte pointer from the byte pointer in the subnode

		IF .DPTR[IDBPOFFSET] NEQ 0
		THEN RDATWD = BPADD(SUBNODE[IDCHBP],.DPTR[IDBPOFFSET])
		ELSE RDATWD = .SUBNODE[IDCHBP];


		DPTR[IDCHBP] = .RDATWD;		! Put byte pointer in IDCHBP
		DPTR[IDADDR] = .HILOC;		! Location of the descriptor

		! Output byte pointer

		IF .FLGREG<OBJECT> THEN
%1451%		BEGIN	! generating .REL file
%1451%			IF .SUBNODE[IDATTRIBUT(INCOM)]
%1451%			THEN			! If byte pointer is in common
%1451%			BEGIN			! Output with RH fixup request
%1526%				ZCODE(PSABS,PSCODE);	! Output byte pointer,
%1451%							!  no relocation
%1451%				R2 _ .SUBNODE[IDCOMMON]; ! COMMON block name

! Output RH additive fixup request to LINK for word at HILOC

%1512%				ZSYMBOL(GLB18ADDFIX,.R2[COMNAME],.HILOC,PSCODE)
%1451%			END
%1526%			ELSE ZCODE(.DPTR[IDPSCHARS],PSCODE)	! Use RH relocation
%1451%		END;	! generating .REL file
			
	   	HILOC = .HILOC + 1;

		IF .DPTR[IDGENLENFLG]
		THEN
		BEGIN	! Output length to hiseg with no relocation

			! SUBSTRING nodes with a constant lower bound and
			! non-constant upper bound only use the byte pointer

			RDATWD = .DPTR[IDCHLEN];

			IF .FLGREG<OBJECT>
%1526%			THEN ZCODE(PSABS,PSCODE);

		   	HILOC = .HILOC + 1;

		END;	! of outputting length

		! List symbol name, descriptor address, lowseg data position,
		! and length

		IF .FLGREG<LISTING> AND .FLGREG<MACROCODE>
		THEN LISTCHD(.DPTR,.DPTR[IDCHBP]);

%1522%		! Cause  an  internal  compiler  error  if  the   .Dnnnn
%1522%		! variable has a length less than 1.

%1522%		IF .DPTR[IDGENLENFLG] THEN
%1522%		IF .DPTR[IDCHLEN] LEQ 0 THEN CGERR();

%1567%	END;	! Want to allocate

		DPTR = .DPTR[CLINK]	! Get next linked list entry

	END	! Walk down linked list

END;	! of HSDDESC

GLOBAL ROUTINE HDRCHD=
BEGIN

%1232%	! Written by TFV, 17-Jun-81

	! Output header to .LST file for character data section

	LSTHDR(7, 6, PLIT '?M?JCHARACTER DATA [ "*" NO EXPLICIT DEFINITION ] 
?J NAME ?I?IDESCRIPTOR ADDRESS ?ISTART OF DATA ?ILENGTH
?J?I?I?I?I?IADDR(POSITION)?M?J?M?J?0');

END;	! of HDRCHD

GLOBAL ROUTINE TABOUT=
BEGIN

%1232%	! Written by TFV, 17-Jun-81

	! Output a tab to the listing

	CHR _ #11;	! TAB
	LSTOUT();

END;	! of TABOUT

GLOBAL ROUTINE ZOUTBP(OBP)=
BEGIN

%1232%	! Written by TFV, 17-Jun-81

	! Output the start address of character data as addr(charpos)

	REGISTER BASE BP;
	MAP
		BASE R2,
		BASE OBP;

	! Convert #010700,,FOO-1 TO #440700,,FOO

	IF .OBP<LEFT> EQL #010700
	THEN	BP = #440700 ^ 18 + .OBP<RIGHT> + 1
	ELSE	BP = .OBP;

	R2<LEFT> _ .BP<RIGHT>;	! Get the address of data
	ZOUTOCT();		! Output it

	CHAROUT("(");		! Output a (

	R1 _ .BP<30,6>;		! Get P field of byte pointer

	R1 _ (43 - .R1) / 7; 	! Compute charpos 1-5
	ZOUDECIMAL();		! Output it

	CHAROUT(")");		! Output a )

END;	! of ZOUTBP

GLOBAL ROUTINE LISTCHD(PTR,BP)=
BEGIN

%1232%	! Written by TFV, 17-Jun-81

	! Output character data name, descriptor address, start of data, and length

	MAP BASE PTR:R2;

	IF .HDRFLG EQL 0	! Output header if needed
	THEN
	BEGIN	! Output character data banner

		HDRFLG_1;
		HDRCHD();

	END;	! Output character data banner

	! Output variable name or TAB for constants

	IF .PTR[OPERATOR] EQL CHARCONST
	THEN
	BEGIN	! Character constant
%1534%		REGISTER COL,CC,C;
%1534%		LOCAL CP;

		! Output 'cccccc' to listing
%1534%		CHAROUT("'");				! start with '
%1534%		COL = 2;				! we are now at col 2
%1534%		CP = PTR[LITC1];			! set character pointer
%1534%		CC = .PTR[LITLEN];			! and character count
%1534%		WHILE (.CC GTR 0) AND (.COL LEQ 11)	! print up to 10 chars
%1534%		DO
%1534%		BEGIN
%1534%			C = SCANI(CP);			! get char from string
%1534%			IF .C EQL #177 THEN C = -1;	! print rubout as ^?
%1534%			IF .C LSS #40			! control char?
%1534%			THEN (CHAROUT("^"); CHAROUT(.C+#100); COL = .COL + 1)
%1534%			ELSE CHAROUT(.C);		! no, print normally
%1534%			COL = .COL + 1;			! increment col count
%1534%			CC = .CC - 1;			! decrement char count
%1534%		END;
%1534%
%1534%		CHAROUT("'");				! print closing '
%1534%		IF .CC GTR 0 THEN STRNGOUT(UPLIT ASCIZ '...');
%1534%							! print dots if whole
%1534%							! constant didn't get
%1534%							! printed
%1534%		IF .COL LSS 8 THEN TABOUT();		! print extra tab to 
%1534%							! line up tab stops

	END	! Character constant
	ELSE
	BEGIN	! Character variable

		R2 _ .PTR[IDSYMBOL];	! Name of variable

		! Output "*" if not explicitly defined 

		IF NOT .PTR[IDATTRIBUT(INTYPE)] AND .PTR[OPRSP1] NEQ ARRAYNM1
		THEN
		BEGIN	! Don't output "*" for .Dnnnn variables

			IF .R2<30,6> NEQ SIXBIT "." THEN CHAROUT("*")

		END	! Don't output "*" for .Dnnnn variables
		ELSE	CHAROUT(" ");

		ZOUTSYM();		! Output it
		TABOUT();		! Output a TAB

	END;	! Character variable

	TABOUT();	! Output a TAB

	! Output descriptor address

	IF .PTR[OPERATOR] NEQ CHARCONST AND .PTR[IDPSECT] EQL PSDATA
	THEN
	BEGIN	! It's a lowseg address

		R2<LEFT> _ .PTR[IDADDR];	! Lowseg address
		ZOUTOCT();			! Output it to listing
		TABOUT();			! Output extra TAB

	END	! It's a lowseg address
	ELSE
	BEGIN	! It's a hiseg address

		STRNGOUT(UPLIT ASCIZ '.HSCHD');	! Address of start of hiseg descriptors
		R1 _ .PTR[IDADDR] - .CHDSTART;	! Offset from .HSCHD
		ZOUOFFSET();			! Output + offset

	END;	! It's a hiseg address

	TABOUT();	! Output a TAB
	TABOUT();	! Output another TAB

	! Output start of character data as addr(charpos)
	! charpos is 1 for first char, 5 for last in word

%1434%	IF .PTR[OPERATOR] NEQ CHARCONST
%1434%	THEN
%1434%	BEGIN
%1434%		IF .PTR[IDATTRIBUT(DUMMY)]
		THEN	STRNGOUT(UPLIT ASCIZ '(argument)')	! Dummy argument
%1434%		ELSE	IF .PTR[IDATTRIBUT(INEXTERN)]
%1434%			THEN	STRNGOUT(UPLIT ASCIZ '(external)')	! External function
%1434%			ELSE
			BEGIN	! Output character constant data address

				ZOUTBP(.BP);

				IF .BP<RIGHT> LSS #10000
				THEN TABOUT();	! Output an extra TAB

			END;	! Output character constant data address
%1434%	END
%1434%	ELSE
	BEGIN	! Output character constant data address

		ZOUTBP(.BP);

		IF .BP<RIGHT> LSS #10000
		THEN TABOUT();	! Output an extra TAB

	END;	! Output character constant data address

	
	TABOUT();	! Output a TAB

	! Output the length

	IF .PTR[OPERATOR] EQL CHARCONST
	THEN	R1 _ .PTR[LITLEN]
	ELSE	R1 _ .PTR[IDCHLEN];

	IF .R1 EQL LENSTAR	! Is it length *
	THEN	STRNGOUT(UPLIT ASCIZ '(*)')	! Output a (*)
	ELSE	ZOUDECIMAL();	! Output the length

	CRLF;		! Output a CRLF
	HEADCHK();	! Check for bottom of listing page

END;	! of LISTCHD

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

GLOBAL ROUTINE ALCQVARS=
BEGIN
	! Routine cleans up the allocation of .Qnnnn variables.
	! These are the temps generated by the local register allocator

%1274%	REGISTER LEN,BASE SYMPTR;

	! Now (for either subprogram or main program, allocate and list
	! the temps generated by local register allocation

%1274%	SYMPTR = .QANCHOR;	! Start at the beginning

%1274%	WHILE .SYMPTR NEQ 0 DO
	BEGIN
%1274%		LEN = .SYMPTR[IDADDR];		! Address in .Q space for this variable
%1274%		SYMPTR[IDADDR] = .LOWLOC + .LEN;	! Actual address for this variable
%1406%		SYMPTR[IDCHBP] = BPGEN(.SYMPTR[IDADDR]);	! Setup byte pointer

		IF .FLGREG<LISTING>
%[735]%		THEN
		BEGIN
			IF .HDRFLG EQL 0
			THEN
			BEGIN
				HDRFLG = 1;
				HDRTMP();
			END;

%1274%			LISTSYM(.SYMPTR);

			TCNT = .TCNT + 1;

			IF .TCNT GTR 5
			THEN
			BEGIN
				TCNT = 0;
				CRLF;
				HEADCHK();
			END
		END;

%1274%		SYMPTR = .SYMPTR[CLINK];	! Next .Q to allocate

	END;	! WHILE .SYMPTR NEQ 0

%1274%	LOWLOC = .LOWLOC + .QMAX;	! Set up lowloc to after end of .Q space
	IF .FLGREG<LISTING>
	THEN
	BEGIN
		CRLF;
		HEADCHK();
	END;

END;	! of ALCQVARS

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

%1526%	CHDSTART = HILOC = 0;		! First free location in .CODE.
%1245%					!  and start of character descriptors

%470%	IF .LOWLOC LSS #400000-#1000	! Will the lowseg overlap the hiseg ?
%1526%	THEN HIORIGIN = #400000		! No, start at halfway point
%1526%	ELSE HIORIGIN = (.LOWLOC+#777+#1000) AND #777000;	! Yes, round up

	IF .FLGREG<OBJECT>
	THEN
	BEGIN
%1525%		IF EXTENDED		! Psected compilation ?
%1525%		THEN DMPMAINRLBF()	! Yes, flush out lowseg constants
%1525%		ELSE			! No, define segments
%1525%		BEGIN
%1526%			RDATWD = .HIORIGIN^18 + .HIORIGIN; ! In both halves
			ZOUTBLOCK(RHISEG,RELRI);
			RDATWD = .LOWLOC^18 + 0;
			ZOUTBLOCK(RHISEG,RELN)
%1525%		END;

%1245%		! Output symbol .HSCHD for character data listing section

%1512%		ZSYMBOL(LOCSUPDEF,SIXBIT '.HSCHD',.CHDSTART,PSCODE)
	END;

END;	! of HISEGBLK

GLOBAL ROUTINE RELINIT=
BEGIN
	!********************************************************
	!Initializes .REL file, generating these LINK blocks
	!		4 - ENTRY
%1525%	!		24- PSECT HEADER
%1526%	!		22- PSECT INDEX
	!		6 - NAME
	!********************************************************

REGISTER
%1434%	BASE ENT;
LOCAL
	MYRELBUF[5];	! Holds various REL block types

BIND

! Various bits for the name block

%1003%	KSCPU = 1^33,	! KS10 cpu type
%1003%	KLCPU = 1^32,	! KL10
%1666%	FTNID = #10^18,	! FORTRAN compiler id

! Origins for the various segments

%1525%	DATAORG = #1300000,
%1525%	CODEORG = #1000140,
%1525%	LARGEORG = #2000000;

	INIRLBUFFS();	! Initialize the .REL file buffers

	! Initialize the entry block

%1434%	R2 = .PROGNAME;		! First the program name
%1434%	RDATWD = RADIX50();
%1434%	ZOUTBLOCK(RENTRY,RELN);

%1434%	ENT = .MULENTRY;	! Now any entry points
%1434%	WHILE .ENT NEQ 0 DO
%1434%	BEGIN
%1434%		R2 = .ENT[IDSYMBOL];	! Get the entry name
%1434%		RDATWD = RADIX50();
%1434%		ZOUTBLOCK(RENTRY,RELN);
%1434%		ENT = .ENT[IDENTLNK];
%1434%	END;

![1525] Define the psect names, attributes, indices and origins.  Load
![1525] a private  psected FORLIB  for  good measure  during  extended
![1525] addressing development.  And set a default psect index so that
![1525] LINK doesn't mistake us for lowly TWOSEGged code.

%1525%	IF EXTENDED
	THEN
	BEGIN
		DMPMAINRLBF();			! Make sure the type 4 blocks
						!  gets out first

		! Note that  LINK has  a hidden  restriction that  you
		! must define psects in increasing psect index  order.
		! If the values of PXCODE, PXDATA and PXLARGE  change,
		! the following three paragraps should be changed.

		MYRELBUF[0] = RPSECTHEAD^18 OR 3;	! Type and count
		MYRELBUF[1] = 0;		! No relocation
		MYRELBUF[2] = SIXBIT '.CODE.';	! Psect name
		MYRELBUF[3] = RPSSINGLE OR RPSNONZERO OR RPSCONCAT OR RPSRONLY
			OR PXCODE;		! Psect attributes and index
		MYRELBUF[4] = CODEORG;		! Psect origin
		DMPRLBLOCK(MYRELBUF,5);

		MYRELBUF[2] = SIXBIT '.DATA.';
		MYRELBUF[3] = RPSSINGLE OR RPSNONZERO OR RPSCONCAT OR RPSWRITE
			OR PXDATA;
		MYRELBUF[4] = DATAORG;
		DMPRLBLOCK(MYRELBUF,5);

		MYRELBUF[2] = SIXBIT '.LARG.';
		MYRELBUF[3] = RPSNONZERO OR RPSCONCAT OR RPSWRITE OR PXLARGE;
		MYRELBUF[4] = LARGEORG;
		DMPRLBLOCK(MYRELBUF,5);

		! Before we get a chance to output a type 6 name block
		! later on and declare  our Fortranness to LINK,  this
		! is the  opportunity to  set a  default psect  index.
		! The only reason for setting a default index here  is
		! that if  LINK  sees  a Fortran  REL  file  that  has
		! selected a default psect index,  it will not try  to
		! force high segment code into the low segment.   This
		! is helpful, since we don't have a low segment.

		RDATWD = PXCODE;		! Select the code psect
		ZOUTBLOCK(RPSECTORG,RELN)	!  as the default
%1525%	END;

	R2 = .PROGNAME;
	RDATWD = RADIX50();
	ZOUTBLOCK(RNAME,RELN);  !NAME BLOCK

![1003] Output compiler type to .REL file.

%1666%	RDATWD = FTNID;

%1703%	! To include a processor  type into the  rel file, include  some
%1703%	! part(s) of the below  lines to the  assignment to RDATWD.   We
%1703%	! are not specifying any processor, since V5A specified only KI,
%1703%	! and V7 will not  run on a  KI. If we tell  the truth, then  V7
%1703%	! users with a V5A library will get Link-time warnings.
%1703%	![1525]	KS processors are non-extended and non-gfloating.
%1703%	!  OR KLCPU OR
%1703%	! 	(IF NOT .GFLOAT AND NOT EXTENDED THEN KSCPU ELSE 0);

%1666%	ZOUTBLOCK(RNAME,RELN)	! FORTRAN compiler id and CPU bits

END;	! of RELINIT

END
ELUDOM