Google
 

Trailing-Edge - PDP-10 Archives - FORTRAN-10_Alpha_31-jul-86 - outmod.bli
There are 26 other files named outmod.bli in the archive. Click here to see a list.

!COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1973, 1986
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR ANY  OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF THE  SOFTWARE  IS  HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT  NOTICE
!AND  SHOULD  NOT  BE  CONSTRUED  AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY  OF  ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.

!AUTHOR: F. INFANTE/MD/DCE/JNG/TFV/CDM/AHM/RVM/EGM/PLB/AlB/MEM

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

GLOBAL BIND OUTMOV = #11^24 + 0^18 + #4530;	! Version Date:	17-Feb-86

%(

***** 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 V7 Development *****

1733	RJD	21-Mar-83	SPR 10-33670
	Set ISN to zero when in ALCCON as any over/underflows that
	may occur at that time are not associated with a particular
	line number.


***** Begin Version 10 *****

2207	CDM	21-Jul-83
	Reformat and  comment equivalence  routines ALLOCAT,  EQERRLIST,
	LINKGROUPS,  ELISTSEARCH,  GRPSCAN,  PROCEQUIV.   Delete   macro
	EQGPPTR which was defined to be EQLPTR in PROCEQUIV.

2210	AHM	27-Jul-83
	Rename DUMPFORMAT to DMPFORMAT to reserve DUMP?? for SIX12.

2216	PLB	27-Sep-83
	Modify ZOUTBP and CHADDR2BP to handle OWGBPs, Depending on
	state of OWGBPSECTION global; Create routine BPADD to replace
	MACRO from TABLES.

2232	RVM	8-Nov-83
	Allocate variables into the proper psect.  The IDADDR and
	IDPSCHARS now get their values based on the IDPSECT and
	IDPSCHARS fields, respectively.  IDPSECT and IDPSCHARS contain
	"psect indexes," which are indexes into the vector PSECTS.
	The PSECTS vector contains the next allocated offsets into the
	low and high segments (/NOEXTEND) or the next allocated
	offsets into .DATA., .CODE., or .LARG. psects (/EXTEND).
	Pretty much, this edit consisted of replacing LOWLOC and
	LARGELOC by PSECTS[.SYMBOL[IDPSECT]].

2233	AlB	9-Nov-83
	Move the calculation of the total size of common from PROCCOM
	to ALLCOM, so that this total will reflect any influence by
	the EQUIVALENCE statement.  Changes to ALLOCAT, PROCCOM, ALLCOM.

2235	AlB	10-Nov-83
	1. Worry about the effect of extended addressing on EQUIVALENCE
	   and COMMON processing.  Essentially, if any variable is
	   equivalenced to a common variable, the former variable takes
	   the psect of the common block.  If any equivalence group
	   contains all non-common, then the psect for all items in that
	   group becomes .LARG. if any one of the items is .LARG., and
	   .DATA. otherwise.
	2. Clean up some WHILE 1 DO code to better illustrate what is
	   happening. (Change to UNTIL x EQL 0 DO).
	3. Replace all literal values associated with EQVAVAIL with
	   named constants.
	4. Change reference to LOWLOC to refer to PSECTS table.  This is
	   code that was not changed by Edit 2232.

	Changes to ALLCOM, PROCCOM, ELISTSRCH, EQCALLOC, GRPSCAN and
		PROCEQUIV

2236	AlB	11-Nov-83
	Remove the code which jams PSDATA into COMPSECT.  That code now
	resides in NEWENTRY of module SRCA.
	Routine affected: PROCCOM

2266	AHM	13-Jan-84
	Change the origin of the .CODE. psect (CODEORG) in RELINIT
	from 1,,140 to 1,,1000 so that the program's fake JOBDAT page
	is not read only.

2271	AlB	18-Jan-84
	1) If single subscript used on multi-dimensioned array in EQUIVALENCE,
	   put out compatibility warning.
	2) Do range checking on that single subscript.
	3) Generate compatibility warning if logical and numeric data are
	   in the same EQUIVALENCE list.
	4) Change the 'Char and Non-Char' warning to be generated only if
	   we are doing compatibility flagging (COMMON and EQUIVALENCE).

	Routines:
		ALLCOM	EQCALLOC	PROCEQUIV

2310	CDM	13-Feb-84
	Output type 1131  rel block  for PSECT  redirection of  segments
	into psects.  The command scanner sets the names for the  psects
	and the code generator dumps the rel block.  Discontinue putting
	out type 22 blocks in same region of code.

2311	PLB	19-Feb-84	WAR IS PEACE
	Modify symbol listings under /EXTEND

2322	CDM	27-Apr-84
	Fix array subscript calculations for /EXTEND to use a full  word
	to calculate  arithmetic.  In  PROCEQUIV  and BLDDIM,  check  an
	array reference against  the correct  maximum size  of an  array
	declaration  /EXTEND.   In   BLDDIM,  call   CNSTCM  for   array
	calculations to  give  underflow/overflow messages  for  illegal
	declarations.  Otherwise arrays  that are too  large may not  be
	detected since their size will overflow.

2330	AHM	28-Mar-84
	Remove all uses of global OWGBPSECTION.  Use EXTENDED flag to
	decide when to deal with OWGBPs instead of OWLBPs.  Use
	Z30CODE to generate all byte pointers.  Generate 30 bit
	additive fixups for OWGBPs that reference COMMON.  Use EFIWs
	for CHARACTER FUNCTION descriptors under /EXTEND to make
	multiple sections of code work.

2342	AHM	17-Apr-84
	Make DATA statements work for some variables in .LARG.  Make
	OUTDATA use the psect indices in the variables it is passed
	instead of always using .DATA.  This should allow numeric
	variables in the first section of .LARG. to be statically
	initialized by DATA statements.

2344	PLB	19-Apr-84
	Make ZOUTBP output 0(?) if BP to output is equal to zero.

2345	AHM	20-Apr-84
	Make HSCHD in OUTMOD use additive fixups to generate the
	indirect words for external CHARACTER function descriptors.
	This makes the code agree with the comments and design spec,
	and avoids a LINK bug with deferred 30 bit chained fixups.

2346	AHM	23-Apr-84
	Make ALLCOM keep separate totals of the sizes of small and
	large COMMON blocks in the new globals SCOMSZ and LCOMSZ.
	ALLCOM no longer has a return value, since no one cares about
	the sum of the sizes of all COMMON blocks.

2356	AHM	8-May-84
	Add support for individual specification of the psects for
	COMMON blocks.  Do it by putting the body of the outermost
	loop in ALLCOM in a new routine named ALCCOMMON, and having
	ALLCOM call it to walk the list of COMMON blocks once for each
	of .DATA. and .LARG.  Also, change the default psect origin
	for .DATA. to 1000140 and .CODE. to 1300000.  This way, the
	impure data areas have the lowest addresses in both section 0
	and non-zero sections.

2357	AHM	14-May-84
	Keep LINK from getting ?LNKIPX Invalid psect index when
	loading programs with COMMON blocks compiled /NOEXTEND.
	During COMMON block allocation (ALLCOM) only output type 22
	(RPSECTORG) REL blocks under /EXTEND.

2414	AlB	5-Jul-84
	When an array is referenced in an EQUIVALENCE statement, the
	subscripts are now checked for 'out of bounds'.  The check used
	to be done (badly) for the case of single subscripts with
	multi-dimensioned arrays; it was never done for multiple subscripts.

	The 'out of bounds' message is a warning only; old sources will
	still work, albeit with a warning.

2423	AHM	17-Jul-84
	Move OUTDATA to DATAST, where it can share secret OWNs for
	buffering Ultimate Sparse Data REL blocks.

2440	RVM	1-Aug-84
	Change the origin of the PSDATA psect from 1000140 to 1001000.
	FORDDT and FOROTS have reserved the first page of every section
	which contains code.

2446	MEM	31-JUL-84
	Have RELINIT produce type 1050 rel blocks when /EXTEND is given,
	instead of type 24 rel blocks. This will now store psect names up to
	72 characters.

2454	RVM	28-Aug-84
	Move the definition of DEFLON (the default value for LONAME)
	and DEFHIN (the default value for HINAME) from CMND20 into
	GLOBAL.  Then make OUTMOD use DEFLON and DEFHIN where in the
	twoseg redirection rel block.

2455	MEM	30-Aug-84
	Replace all occurrences of VAX with VMS.

2507	CDM	20-Dec-84
	Add enhancement for IMPLICIT NONE (edit 2473) after code inpsection.
	Check more cases, and add a symbol table walk at the back 
	end to catch unreferenced variables.

***** End V10 Development *****

2562	JB	9-Dec-85
	When using IMPLICIT NONE, a symbol in an EXTERNAL statement gets a
	warning that it must be explicitly declared. If the symbol isn't 
	used as a function in the same program it shouldn't get the warning
	because function types must be explicitly declared, whereas 
	subroutines needn't be. We added a check for this.

***** End Revision History *****
***** Begin V11 Development *****

4513	CDM	12-Sep-85
	Improvements to /STATISTICS for reporting symbol table size
	and COMMON block size.

4516	CDM	2-Oct-85
	Phase I.I for VMS long symbols.  Pass Sixbit to all error message
	routines, do not pass addresses of Sixbit anymore.  In later edits
	this will pass [length,,pointer to symbol] instead of a pointer to
	this to the error message routines.

4517	MEM	4-Oct-85
	Define OWGP&S2 and add routine BPADD2 for dealing with incremented
	bytepointers. In HSDDES we must check if we have an unincremented or
	incremented bytepointer and call the appropriate routine (BPADD or
 	BPADD2) to add any offset to the base address.

4520	MEM	17-Sep-85
	Change reference of CLINK to DLINK.

4527	CDM	1-Jan-86
	VMS Long symbols phase II.  Convert all internal symbols from
	one word of Sixbit to [length,,pointer].  The lengths will be one
	(word) until a later edit, which will store and use long symbols.

4530	MEM	17-Feb-86
	Add long symbol support: Adjust compiler listing to look nice with
	long symbols; Put out long common blocks, long entry blocks and
	long title blocks.

ENDV11
)%

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

FORWARD
	CHADDR2BP(1),
	SIZEINCHARS(1),
	LSTHDR(3),
	LISTSYM(1),
	SUBPROGLIST,
	ALLSCAA,
	ALLOCAT,
	ALLCOM,			! Allocates all the COMMON blocks
%2356%	ALCCOMMON,		! Allocates all COMMON blocks in a given psect
%2210%	DMPFORMAT,		! 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,
%2446%	TYPE1050,
%2310%	PSREDIRECT,	! Outputs PSECT redirection rel blocks
%2507%	CIMPLNONE;	! Check symbols for IMPLICIT NONE

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,
%2455%	CFLAGB,		! Put out "Fortran-77 or VMS: ...." flagger warning
%1522%	CGERR,		! Routine to report an internal compiler error
	CHAROUT,
%4527%	CMPSYM,		! Compare two [length,,pointer] symbols
%1245%	CHDSTART,
%1261%	CNSTEVAL,	! For evaluating subscript expression if necessary	
	COMBLKPTR,
	DANCHOR,	! Pointer to the start of the .Dnnnn variables
%2454%	DEFLON,		! Default name for the data psect
%2454%	DEFHIN,		! Default name for the code psect
	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"
%2455%	E249,		! "VMS incompatibility: Mixing Logical and Numeric in EQUIV"
%2271%	E274,		! "Extension to Fortran-77: Single dimension with multi.."
%2271%	E293,		! "Subscript out of range for array xxxx"
%2507%	E304,		! Warning - IMPLICIT NONE
	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
%2310%	HINAME,		! Name of the high (code) PSECT in SIXBIT.
%1437%	HIORIGIN,	! Start of Hi-seg
%2507%	IMPNONE,	! Flag for IMPLICIT NONE
	INIRLBUFFS,	! To init .REL file buffers
	ISN,
%1006%	KISNGL,		! KISNGL is now in UTIL.BLI
%2356%	LCOMP,		! Flag for at least one COMMON block in .LARG.
%2346%	LCOMSZ,		! Sum of the sizes of all large COMMON blocks in words
	LITPOINTER,
%2310%	LONAME,		! Name of the low (data) PSECT in SIXBIT.
%4530%	LONGREL,	! =1 if putting out rel blocks for long symbols
%4530%	LONGUSED,	! =1 if long symbols used
	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
%4513%	NCOMMON,	! Number of COMMON block entries
%1511%	NUMSAVCOMMON,	! Pointer to SAVE-d common blocks
%4527%	ONEWPTR,	! Returns [1,,pointer] for Sixbit argument
	PAGELINE,
	PROGNAME,
%2232%	PSECTS,		! Vector of next available address for each PSECT
%1274%	QANCHOR,
%1274%	QMAX,
	RADIX50,
	RDATWD,
	RELBLOCK,
	RELDATA,
	RELOCWD,
	RELOUT,
%1511%	SAVALL,		! SAVE statement with no args given
%2356%	SCOMP,		! Flag for at least one COMMON block in .DATA.
%2346%	SCOMSZ,		! Sum of the sizes of all small COMMON blocks in words
%2507%	SRCHLIB,	! Searches if a name is a library function
	STRNGOUT,
%2507%	SYMTBL,		! Hashed symbol table
%1434%	TBLSEARCH,	! Routine to lookup symbol table entries
%1245%	TCNT,
%2322%	VMSIZE,		! Size of virtual memory
	WARNERR,
%2330%	Z30CODE,	! Outputs a word using type 1 or 1030 rel blocks
%1526%	ZCODE,		! Outputs a word using type 1 or 1010 rel blocks
%4530%	ZNEWBLOCK,	! Outputs a word using type 1002,1003,1070 rel blocks
	ZOUDECIMAL,
	ZOUOFFSET,
%2311%	ZOUTADDR,	! OUTPUT LONG ADDR IN R2
	ZOUTBLOCK,
	ZOUTMSG,	! Message outputter
	ZOUTOCT,	! OUTPUT HALFWORD IN R2<LH>
	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$;

! LEFT HALF OF OWL BYTE POINTER INDEX BY BYTE NUMBER -4:4
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>); ! 0:4


%2216%	! P&S FIELD OF OWG BYTE POINTERS INDEXED BY BYTE NUMBER -4:4
%2311%	BIND VECTOR OWGP&S = 4 + UPLIT (#62^30,#63^30,#64^30,#65^30, ! -4:-1
%2311%			#61^30,#62^30,#63^30,#64^30,#65^30); !0:4
%4517%	BIND VECTOR OWGP&S2 = 4 + UPLIT (#63^30,#64^30,#65^30,#66^30, ! -4:-1
%4517%			#62^30,#63^30,#64^30,#65^30,#66^30); !0:4

ROUTINE CHADDR2BP (A) =		! [1261] Convert character address A to
				!        equivalent byte pointer

%2330%	IF EXTENDED		!CHECK IF MAKING OWG BPs
%2330%	THEN	(.A/5) OR .OWGP&S[.A MOD 5]	!YES
%2216%	ELSE	(.A/5) OR .BPLH[.A MOD 5]; !NO, USE OWL LEFT HALF


GLOBAL ROUTINE BPADD (BP,N)=	![2216] DO ADJBP FOR OWL OR **7-BIT** OWGBP
BEGIN
! Example:  XXX = BPADD(.SYM[IDCHBP],.SYM[IDCHLEN])
!           PTR = BPADD(.PTR,-1)
! BP = byte pointer
! N = value to increment BP by
	IF .N NEQ 0		!NON-ZERO ADJUSTMENT?
	THEN			!YES, CHECK IF USING OWG/OWL
%2330%		IF EXTENDED	!/EXTEND?
		THEN		!YES!, ADJUST OWG
		BEGIN		!OWG
			! UGLY BUT VERY FAST CODE
			VREG = .BP<0,30>; !GET 30 BIT ADDR
			VREG = .VREG * 5; !MAKE CHARACTER ADDR
			VREG = .VREG + .N; !ADD OFFSET
			VREG = .VREG - #61; !SUBTRACT OWG OFFSET
	    		VREG = .VREG + .BP<30,6>; !ADD OWG P&S FIELD
			RETURN .OWGP&S[.VREG MOD 5] OR (.VREG/5) !CONVERT BACK
		END		!OWG
		ELSE		!NOT EXTENDED
		BEGIN		!OWL
			MACHOP ADJBP=#133;
			REGISTER T1;
			T1 _ .N;
			RETURN ADJBP(T1,BP)
		END
	ELSE			!ADJUST BY ZERO
	RETURN .BP;		!RETURN UNCHANGED (ADJBP CONONICALIZES THO)

END;	! of BPADD
GLOBAL ROUTINE BPADD2 (BP,N)=

!++
! FUNCTIONAL DESCRIPTION:
!
! 	DO ADJBP FOR OWL OR **7-BIT** OWGBP
!	This BP will not be incremented before used (i.e. it is for LDB/DPB)
!
! FORMAL PARAMETERS:
!
!	BP		bytepointer
!
!	N		offset
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	Adjusted bytepointer
!
! SIDE EFFECTS:
!
!	None
!
!--

BEGIN	! [4517] Copied from BPADD
	IF .N NEQ 0		!NON-ZERO ADJUSTMENT?
	THEN			!YES, CHECK IF USING OWG/OWL
		IF EXTENDED	!/EXTEND?
		THEN		!YES!, ADJUST OWG
		BEGIN		!OWG
			! UGLY BUT VERY FAST CODE
			VREG = .BP<0,30>; !GET 30 BIT ADDR
			VREG = .VREG * 5; !MAKE CHARACTER ADDR
			VREG = .VREG + .N; !ADD OFFSET
%4517%			VREG = .VREG - #62; !SUBTRACT OWG OFFSET
	    		VREG = .VREG + .BP<30,6>; !ADD OWG P&S FIELD
%4517%			RETURN .OWGP&S2[.VREG MOD 5] OR (.VREG/5) !CONVERT BACK
		END		!OWG
		ELSE		!NOT EXTENDED
		BEGIN		!OWL
			MACHOP ADJBP=#133;
			REGISTER T1;
			T1 _ .N;
			RETURN ADJBP(T1,BP)
		END
	ELSE			!ADJUST BY ZERO
	RETURN .BP;		!RETURN UNCHANGED (ADJBP CONONICALIZES THO)
END;	! Of BPADD2

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 LISTSYM(PTR)=
BEGIN
	MAP BASE PTR;
	LABEL BLNK;

	R2 _ .PTR[IDSYMBOL];
%2311%	% NOTE INSTANCES OF  LARGE, NO EXPLICIT DEFINITION %

	BLNK:BEGIN
%2311%		IF .PTR[VALTYPE] EQL CHARACTER
%2311%		THEN
%2311%		BEGIN	!CHECK FOR LARGE CHARACTER
%2311%			IF .PTR[IDPSCHARS] EQL PSLARGE
%2311%			THEN ( CHAROUT( "!" ); LEAVE BLNK ); !FLAG IT
%2311%		END	!CHECK FOR LARGE CHARACTER
%2311%		ELSE	!CHECK FOR LARGE NUMBERIC
%2311%		IF .PTR[IDPSECT] EQL PSLARGE !VARIABLE IN .LARG. ?
%2311%		THEN	( CHAROUT( "!" ); LEAVE BLNK ); !YES, FLAG IT

		IF NOT .PTR[IDATTRIBUT(INTYPE)]
		THEN IF .PTR[OPRSP1] NEQ ARRAYNM1
%4527%		THEN IF .PTR[IDDOT] NEQ SIXBIT"." !Forget compler defined vars
		THEN (CHAROUT( "*" ); LEAVE BLNK);

		CHAROUT( " " );
	END;	%BLNK%
	ZOUTSYM();
%4530%	IF NOT .LONGUSED
%4530%	THEN
%4530%	BEGIN
		CHR _ #11; LSTOUT(); !TAB
%4530%	END;
%2311%	IF .PTR[VALTYPE] NEQ CHARACTER 
%2311%	THEN
%2311%	BEGIN		!LIST ADDR FOR NUMERIC
%2311%		IF EXTENDED
%2311%		THEN
%2311%		BEGIN	!EXTENDED
%2311%			R2 _ .PTR[IDADDR]; !GET NUMERIC ADDR
%2311%			ZOUTADDR(); !OUTPUT LONG ADDR
%2311%			IF .PTR[IDADDR] LSS 1^21 !TOO SMALL?
%2311%			THEN (CHR_#11; LSTOUT()) !ADD A TAB
%2311%		END	!EXTENDED
%2311%		ELSE
%2311%		BEGIN	!NOT EXTENDED
%2311%			R2<LEFT> _ .PTR[IDADDR]; !GET ADDR<RH>
%2311%			ZOUTOCT() !OUTPUT 18 BITS
%2311%		END	!NOT EXTENDED
%2311%	END		!LIST ADDR FOR NUMERIC
%2311%	ELSE
%2311%	ZOUTBP(.PTR[IDCHBP]); !IF CHAR, 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;
%2311% LOCAL HOWIDE;		!NUMBER OF SYMBOLS / LISTING LINE

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
%2311%	IF EXTENDED
%2311%	THEN
%2311%	LSTHDR(5,4,PLIT '
?JSCALARS AND ARRAYS [ "*" NO EXPLICIT DEFINITION - "%" NOT REFERENCED ]
?J                   [ "!" VARIABLE STORED IN .LARG. ]?M?J?M?J?0')
%2311%	ELSE
%[735]%	LSTHDR(4,3,PLIT '?M?JSCALARS AND ARRAYS [ "*" NO EXPLICIT DEFINITION - "%" NOT REFERENCED ]?M?J?M?J?0');

%2311%	IF .FLGREG<LISTING>	!IF LISTING
%2311%	THEN
%4530%	HOWIDE = IF .LONGUSED THEN 1 !2 SYMBOLS / LINE
%4530%		 ELSE IF EXTENDED THEN 2 !3 /EXTENDED SYMBOLS / LINE 1; 	
%2311%		 ELSE 4;	!FIVE OTHERWISE
%[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
%4530%						IF NOT .LONGUSED
%4530%						THEN
%4530%						BEGIN
							CHAROUT(#11);	! Tab
%2311%							IF EXTENDED !/EXTEND?
%2311%							THEN CHAROUT(#11); !ONE MORE
%4530%						END;
%2311%						IF .SCNT LSS .HOWIDE
						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 data
						! either in the .DATA. psect
						! (low segment /NOEXTEND) or in
						! the .LARG. psect. Descriptor
						! is allocated in high seg
						! after hisg seg is inited.

%2232%						PTR[IDCHBP] = BPGEN(.PSECTS[.PTR[IDPSCHARS]])
					ELSE
						! Dummy character data get descriptor
						! allocated to lowseg and pointed to
						! by IDADDR. Other data types get
						! IDADDR pointing to low seg data
						! under /NOEXTEND or the .DATA. or
						! .LARG. psect under /EXTEND.

%2232%						PTR[IDADDR] _ .PSECTS[.PTR[IDPSECT]];
					
					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 under
							! /NOEXTEND or in the .DATA. or .LARGE. psects under
							! /EXTEND.  Character data size is in characters, others
							! are in words

							IF .PTR[VALTYPE] EQL CHARACTER
%2232%							THEN PSECTS[.PTR[IDPSCHARS]] _ .PSECTS[.PTR[IDPSCHARS]]
									+ CHWORDLEN(.ARRAPT[ARASIZ])
%2232%							ELSE PSECTS[.PTR[IDPSECT]] _ .PSECTS[.PTR[IDPSECT]]
									+ .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
%4527%									CMPSYM(.PTR[IDSYMBOL], .PROGNAME)
%1434%								THEN	LSCHD()

							END
							ELSE
								! Non-dummy character scalars are allocated in the
								! low seg./NOEXTEND or in the .DATA. or .LARG.
								! psect/EXTEND.  Character data size is in
								! characters

%2232%								PSECTS[.PTR[IDPSCHARS]] _ .PSECTS[.PTR[IDPSCHARS]]
									+ CHWORDLEN(.PTR[IDCHLEN]);

						END	! Character scalar
						ELSE
						BEGIN	! Non-character scalar

							! Output one or two words based on variable size

							IF .PTR[DBLFLG]
							THEN PSECTS[.PTR[IDPSECT]] _ .PSECTS[.PTR[IDPSECT]] + 2
							ELSE PSECTS[.PTR[IDPSECT]] _ .PSECTS[.PTR[IDPSECT]] + 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);

%2311%					IF .SCNT LSS .HOWIDE
					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
!***********************************************************************

! 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
!
! (The complete list of this fields can be found in FIRST.)
! 
! 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 EQVCLASS.  The one that remains a group
!   has EQVAVAIL set to EQVIGNORE.  At the end of this processing, the groups
!   with EQVAVAIL = EQVCLASS 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.

ROUTINE ALLOCAT=
BEGIN
!***********************************************************************
! Allocates 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.
!***********************************************************************


%2507%	! Output warning messages for any symbols not declared in type
%2507%	! statements that should be and haven't gottten warning messages
%2507%	! yet.  This catches unallocated variables (which haven't been
%2507%	! referenced).  We do this here, since we want the messages before
%2507%	! other things in the listing, such as EQUIVALENCE and COMMON
%2507%	! tables.

%2507%	IF .IMPNONE THEN CIMPLNONE();


%2233%	PROCCOM();			! Compute size of each COMMON block

	IF .EQVPTR NEQ 0 THEN PROCEQUIV();	! Process equivalence groups

%2233%	IF .COMBLKPTR NEQ 0		! If we have common,
%2346%	THEN ALLCOM();	 		!  allocate it 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 ALLCOM=

!++
! FUNCTIONAL DESCRIPTION:
!
!	Allocates relative addresses to all variables declared in
!	COMMON, and computes the total size of all COMMON blocks.  The
!	type 20 (RCOMMON) REL blocks will be output to the REL file
!	with the COMMON blocks grouped together by psect.
!
! FORMAL PARAMETERS:
!
!	None
!
! IMPLICIT INPUTS:
!
!	F2<EXTENDFLAG>	True if program is compiled with /EXTEND.
!
!	FLGREG<OBJECT>	True if an object file is being generated.
!
!	LCOMP		True if there are large COMMON blocks.
!
!	SAVALL		True if a SAVE without arguments was seen.
!
!	SCOMP		True if there are small COMMON blocks.
!
! IMPLICIT OUTPUTS:
!
!	LCOMSZ		Updated sum of sizes of large common blocks.
!
!	NUMSAVCOMMON	Number of COMMON blocks that need to be saved.
!			(SAVALL causes this to be recomputed).
!
!	RDATWD		Smashed by object file I/O.
!
!	SCOMSZ		Updated sum of sizes of small common blocks.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	Outputs type 22 (RPSECTORG) REL blocks to the object file.
!	Also, outputs headers to the listing file.
!
!--


![2356] Rewritten for support of COMMON blocks in different psects

BEGIN

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

%1511%	IF .SAVALL
%1511%	THEN NUMSAVCOMMON = 0;

%2356%	IF .LCOMP			! Large COMMONs?
%2311%	THEN LSTHDR(5,3,		! Yes, print larger legend
%2311%		PLIT'?M?JCOMMON BLOCKS  [ "!" STORED IN .LARG. ]?M?J?0')
%735%	ELSE LSTHDR(5,3,PLIT'?M?JCOMMON BLOCKS?M?J?0');

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

	IF .SCOMP			! Are there any small COMMON blocks?
	THEN				! Yes, process them
	BEGIN	! Small
%1630%		IF .FLGREG<OBJECT>	! Object file ?
%2357%			AND EXTENDED	!  and /EXTEND?
%1615%		THEN			! Yes, have to set default psect
%1615%		BEGIN	! OBJECT
%1615%			RDATWD = PXDATA;	! Select .DATA.
%1615%			ZOUTBLOCK(RPSECTORG,RELN);	! Psect index rel block
%1615%		END;	! OBJECT

%2346%		SCOMSZ = ALCCOMMON(PSDATA);	! Allocate small COMMON blocks
	END;	! Small

	IF .LCOMP			! Are there any large COMMON blocks?
	THEN				! Yes, process them
	BEGIN	! Large
		IF .FLGREG<OBJECT>	! Object file ?
%2357%			AND EXTENDED	!  and /EXTEND?
		THEN			! Yes, have to set default psect
		BEGIN	! OBJECT
			RDATWD = PXLARGE;	! Select .LARG.
			ZOUTBLOCK(RPSECTORG,RELN);
		END;	! OBJECT

%2346%		LCOMSZ = ALCCOMMON(PSLARGE);	! Allocate large COMMON blocks
	END;	! Large

END;	! of ALLCOM

GLOBAL ROUTINE ALCCOMMON(PSECT)=

!++
! FUNCTIONAL DESCRIPTION:
!
!	Assigns relative addresses to all COMMON variables declared in
!	a given psect.  Outputs the block sizes to the object and
!	listing files.  Also lists the names and offsets of the
!	variables.  Totals the sizes of the COMMON blocks.
!
!	The addresses of the variables and arrays in a COMMON block
!	are relative 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 order of appearance to LOADER.  In the relocatable
!	binary, references to COMMON variables will use additive
!	global fixups.
!
! FORMAL PARAMETERS:
!
!	PSECT		Psect that is undergoing COMMON allocation.
!
! IMPLICIT INPUTS:
!
!	COMBLKPTR	Pointers to first and last COMMMON blocks.
!			Many of the fields are used in this routine.
!
!	F2<EXTENDFLAG>	True if program is compiled with /EXTEND.
!
!	FLGREG<LISTING>	True if a listing file is being generated.
!
!	FLGREG<OBJECT>	True if an object file is being generated.
!
!	NUMSAVCOMMON	Number of COMMON blocks in SAVE statements.
!
!	SAVALL		True if a SAVE without arguments was seen.
!
! IMPLICIT OUTPUTS:
!
!	CHR (C)		Smashed during listing file I/O.
!
!	COMBLOCK[COMSIZE] COMMON block gets its size converted from
!			units of characters to words.
!
!	ISN		Smashed during compatibility flagging
!
!	NUMSAVCOMMON	Updated number of COMMON blocks in SAVE statements.
!
!	R1, R2		Smashed during listing file I/O.
!
!	RDATWD		Smashed during object file I/O.
!
! ROUTINE VALUE:
!
!	Total number of words used for COMMON in the given psect.
!
! SIDE EFFECTS:
!
!	Outputs type 20 (RCOMMON) or type 1074 (LONGCOMMON) REL blocks to 
!	the object file. Also, outputs COMMON block information to the listing 
!	file.
!
!--


![2356] Added for support of COMMON blocks in different psects

BEGIN

REGISTER
BASE	CCOMPTR,			! Runs through list of COMMONs
BASE	CSYMPTR,			! Runs through IDCOLINK variable list
	ICNT;				! Listing column counter

LOCAL
%1261%	FLAGWRD,			! Contains flags defined below
	TOTAL;				! Total size of COMMONs in this psect

BIND
%1261%	CHARSEEN = FLAGWRD<0,1>,	! Block contains CHARACTER data
%1261%	NUMSEEN = FLAGWRD<1,1>;		! Block contains numeric data

	TOTAL = 0;			! No COMMONs allocated yet
	CCOMPTR = .FIRCOMBLK;		! Pointer to first COMMON block

%2235%	WHILE .CCOMPTR NEQ 0		! Loop over all COMMON blocks
	DO
	BEGIN	! CCOMPTR NEQ 0

%4513%		NCOMMON = .NCOMMON + 1;	! Count the number of COMMON entries.

		IF .CCOMPTR[COMPSECT] EQL .PSECT	! In the right psect?
		THEN			! Yes
		BEGIN	! [COMPSECT] EQL .PSECT

			! First, process the COMMON block itself

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

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

%1261%			! Convert COMSIZE back to words
%2346%			CCOMPTR[COMSIZE] = CHWORDLEN(.CCOMPTR[COMSIZE]);

			TOTAL = .TOTAL+.CCOMPTR[COMSIZE];	! Total blocks

			IF .FLGREG<LISTING>	! Output name of block
			THEN
			BEGIN	! LISTING
				CRLF;
				HEADCHK();
				CHAROUT("/");
				R2 = .CCOMPTR[COMNAME];
				ZOUTSYM();
				CHAROUT("/");
				CHAROUT("(");
				R1 = .CCOMPTR[COMSIZE];
				ZOUOFFSET();
%2356%				IF .PSECT EQL PSLARGE	! COMMON in .LARG.?
%2311%				THEN CHAROUT("!");	! Flag as such
				CHAROUT(")");
				CRLF;
				HEADCHK();
%2346%				ICNT = 0;
			END;	! LISTING

			IF .FLGREG<OBJECT>	! Relocatable binary?
			THEN			! Yes, necessary
			BEGIN	! OBJECT
				R2 = .CCOMPTR[COMNAME];		! For radix 50

%4530%				IF .LONGUSED AND .LONGREL
%4530%				THEN
%4530%				BEGIN
%4530%					DMPMAINRLBF();	! Output the contents of
					!  MAINRLBF and reinitialize it
%4530%					MAINRLBF[RTYPE] = RLONGCOMMON;
%4530%					RDATWD<LEFT> = .PSECT; ! psect
%4530%					RDATWD<RIGHT> = .R2<SYMLENGTH>;! length of name
%4530%					ZNEWBLOCK(RLONGCOMMON);
%4530%					RDATWD = .CCOMPTR[COMSIZE];
%4530%					ZNEWBLOCK(RLONGCOMMON);
%4530%					INCR I FROM 0 TO .R2<SYMLENGTH>-1
%4530%					DO 
%4530%					BEGIN
%4530%						RDATWD = @(.R2<SYMPOINTER>)[.I]<0,36>;
%4530%						ZNEWBLOCK(RLONGCOMMON);
%4530%					END;
%4530%				END	!Long common name
%4530%				ELSE
%4530%				BEGIN
%4530%					R2 = @(.CCOMPTR[COMNAME]);	! For radix 50
					RDATWD = RGLOBDEF+RADIX50();	! conversion
					ZOUTBLOCK(RCOMMON,RELN);
					RDATWD = .CCOMPTR[COMSIZE];
					ZOUTBLOCK(RCOMMON,RELN);
%4530%				END;
			END;	! OBJECT

			! Next, process all the variables in the COMMON block

%1261%			FLAGWRD = 0;	! Clear CHARSEEN and NUMSEEN
%1261%			CSYMPTR = .CCOMPTR[COMFIRST];	! Point to first symbol
%1261%			DO				!  in COMMON block
%1261%			BEGIN	! CSYMPTR NEQ NIL
%1261%
%1261%				! Convert IDADDR from characters to words
%1261%
%1261%				IF .CSYMPTR[VALTYPE] NEQ CHARACTER
%1261%				THEN
%1261%			     	BEGIN	! NUMERIC
%1261%					NUMSEEN = 1;

%1261%					! Must be word aligned
%1261%			     		IF .CSYMPTR[IDADDR] MOD CHARSPERWORD
%1261%						NEQ 0
%1261%			     		THEN FATLERR(.CSYMPTR[IDSYMBOL],
%1261%							E167<0,0>);

%1261%					! Convert character address
%1261%					!  to word address
%1261%				      	CSYMPTR[IDADDR] =
%1261%						.CSYMPTR[IDADDR]/CHARSPERWORD;
%2356%					CSYMPTR[IDPSECT] = .PSECT;
%1261%			     	END   ! NUMERIC
%1261%				ELSE
%1261%			     	BEGIN ! CHARACTER
%1261%					CHARSEEN = 1;

%1261%					! Convert char address to byte
%1261%					! pointer and clear IDADDR,
%1261%					! which will be used for
%1261%					! address of descriptor

%1261%			     		CSYMPTR[IDCHBP] =
%1261%						CHADDR2BP(.CSYMPTR[IDADDR]);
%1261%				      	CSYMPTR[IDADDR] = 0;
%2356%					CSYMPTR[IDPSCHARS] = .PSECT;
%1261%			     	END;  ! CHARACTER

				! Now list the symbol

				IF .FLGREG<LISTING>
				THEN
				BEGIN	! LISTING
%2311%				LOCAL HOWIDE;	! Symbols / line

%4530%					HOWIDE = IF .LONGUSED THEN 2	! Longnames
%4530%						ELSE IF EXTENDED THEN 3 ! Only 3 fit
%2311%			 			ELSE 5; !  5 like good ole days

					R2 = .CSYMPTR[IDSYMBOL];
					ZOUTSYM();	! Output the name
%4530%					IF NOT .LONGUSED THEN CHAROUT("?I");	! Tab

%1261%					IF .CSYMPTR[VALTYPE] NEQ CHARACTER
					THEN
%2311%					BEGIN	! NUMERIC
%2311%						R1 = .CSYMPTR[IDADDR];
%2311%						ZOUOFFSET();

%2311%						IF EXTENDED
%2311%						THEN IF .CSYMPTR[IDADDR]
%2311%							LSS #1^18
%2311%						THEN CHAROUT("?I");	! Tab
%2311%					END	! NUMERIC
%1261%					ELSE
%2311%					BEGIN	! CHARACTER
						CHAROUT("+");

						! List the byte pointer

						ZOUTBP(.CSYMPTR[IDCHBP]);

%2311%						IF EXTENDED
%2330%						THEN IF .CSYMPTR[IDCHBP]
								<OWGBPADDR>
%2330%							LSS #1000
%2311%						THEN CHAROUT("?I");	! Tab
%2311%					END;	! CHARACTER

					ICNT = .ICNT+1;

%2311%					IF .ICNT EQL .HOWIDE	! Enough on
					THEN			!  this line?
					BEGIN	! EQL HOWIDE
						ICNT = 0;	! New line
						CRLF;
						HEADCHK();
					END	! EQL HOWIDE
					ELSE CHAROUT("?I");	! No, tab over

				END;	! LISTING

				CSYMPTR = .CSYMPTR[IDCOLINK];
%1261%			END	! CSYMPTR NEQ 0
%1261%			WHILE .CSYMPTR NEQ 0;	! Loop through all symbols in
						!  this COMMON block

			! If doing any compatibility checking,
			! complain if block contains both character &
			! numeric variables

%2271%			IF FLAGEITHER
%2271%			THEN IF .CHARSEEN AND .NUMSEEN
%2271%			THEN
%2271%			BEGIN	! MIXED
%2271%				ISN=0;	! Call flagger with no line number
%2271%				CFLAGB(UPLIT 'mixed in COMMON?0',E168<0,0>)
%2271%			END;	! MIXED

			IF .FLGREG<LISTING>	! Listing file?
			THEN			! Yes, finish up COMMON block
			BEGIN	! LISTING
				CRLF;		! Be sure to output CRLF after
				HEADCHK();	!  last COMMON block name
			END;	! LISTING
		END;	! [COMPSECT] EQL .PSECT

%2235%		CCOMPTR = .CCOMPTR[NEXCOMBLK]	! Loop until all blocks seen
%2235%	END;

	RETURN .TOTAL;			! Return amount of space in COMMON
END;	! of ALCCOMMON

GLOBAL ROUTINE DMPFORMAT =	![2210]
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 DMPFORMAT	![2210]

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

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

XTRAC;

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

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

END; ! of ROUTINE

ROUTINE EQERRLIST(GROUP)=
BEGIN
!***********************************************************************
! Error routine to list the group of EQUIVALENCE variables in conflict.
!***********************************************************************

	MAP BASE GROUP:R2;
	LOCAL BASE SYMPTR;

%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');

	SYMPTR _ .GROUP[EQVFIRST];
	WHILE 1 DO
	BEGIN
		R2 _ .SYMPTR[EQLID];	! Symbol table entry
		R2 _ .R2[IDSYMBOL];	! SIXBIT value of id
		ZOUTSYM();
		IF (SYMPTR _ .SYMPTR[EQLLINK]) EQL 0
		THEN
		BEGIN	! End of the symbols
			STRNGOUT(PLIT')?M?J');
			HEADCHK();
			EXITLOOP
		END
		ELSE
		BEGIN	! More symbols to come
			C _ ",";
			LSTOUT()
		END;
	END;

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];
%4516%			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);
%2235%			NEWGRP[EQVAVAIL] _ EQVERROR; 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 equivalence 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,	! List item in group 1
		BASE G2ITEM,	! List item in group 2
		BASE NEXG2ITEM;	! Next item in group 2


	G2ITEM _ .GROUP2[EQVFIRST];	! First GROUP2 list
	WHILE 1 DO
	BEGIN	! Each GROUP2 list

		NEXG2ITEM _ .G2ITEM[EQLLINK];	! Save next symbol in list
		IF .G1SYM NEQ .G2ITEM[EQLID]	! Symbols equal
		THEN
		BEGIN	! Make this the last list in GROUP1.
			G1ITEM _ .GROUP1[EQVLAST];
			G1ITEM[EQLLINK] _ .G2ITEM;
			GROUP1[EQVLAST] _ .G2ITEM;
			G2ITEM[EQLLINK] _ 0;
		END;
		IF (G2ITEM _ .NEXG2ITEM) EQL 0 THEN RETURN .VREG;

	END;	! Each GROUP2 list

END;	! of LINKGROUPS

ROUTINE ELISTSRCH(ECLASS,EGROUP)=
BEGIN
!***********************************************************************
! Tries to find overlap in the equivalence groups ECLASS and EGROUP.
! Searches each item in group EGROUP against all items in group  ECLASS.
! If a match  is found, links  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.

! Returns:
!	1	Successful, match found.
!	0	Unsuccessful.
!	<0	Error in processing, illegal condition found.

%1511%	! Massive reformatting and indenting

%2235%	LABEL ELIS1;

LOCAL	EGSYM,		!SYMBOL BEING SEARCHED IN GROUP
	EGSYMPTR,	!PTR TO SYMBOL TABLE OF SYMBOL BEING 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

	! Search for  match  of item  in  ECLASS with  item  in  EGROUP.
	! Return to caller if we find no match.
%2235%	!The search is terminated if a match is found

%2235%	ELIS1:	UNTIL .EGITEM EQL 0 DO
		BEGIN	! For each item in EGROUP

			EGSYMPTR _ .EGITEM[EQLID];	! Symbol table entry
			EGSYM _ .EGSYMPTR[IDSYMBOL];	! SIXBIT symbol
			CITEM _  .ECLASS[EQVFIRST]; 	! First item in ECLASS

%2235%			UNTIL .CITEM EQL 0 DO
			BEGIN	! For each group in ECLASS

				CSYMPTR _ .CITEM[EQLID]; !SYMBOL TABLE PTR


				! If symbols are equal, then we found
				! a common symbol between EGROUP and
				! ECLASS.
				IF .EGSYM EQL .CSYMPTR [IDSYMBOL]
				THEN LEAVE ELIS1;	! Exit the search

%2235%				CITEM = .CITEM[EQLLINK]	!Next class item
%2235%			END;	! For each item in ECLASS

%2235%			IF (EGITEM = .EGITEM[EQLLINK]) EQL 0
			THEN RETURN 0	!No match between ECLASS and EGROUP

%2235%		END;	! For each item in 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;

%2235%	IF .EGROUP[EQVSMALL] THEN ECLASS[EQVSMALL] = 1; !Copy 'small' flag
%2235%	IF .EGROUP[EQVLARGE] THEN ECLASS[EQVLARGE] = 1; !Copy 'large' flag

	IF .CSYMPTR[IDATTRIBUT(INCOM)] THEN 
	IF NOT .ECLASS[EQVINCOM]
	THEN
	BEGIN
		ECLASS[EQVINCOM] _ 1;
%2235%		ECLASS[EQVPSECT] = .EGROUP[EQVPSECT];	!Psect for the common
%2235%		IF (ECLASS[EQVLIMIT] = GROUPTOCOMMON(.CSYMPTR,.ECLASS,.ECLASS[EQVLIMIT],.CITEM[EQLDISPL])) LSS 0
		THEN RETURN -1
	END;
	!
	!CSYMPTR CONTAINS PTR TO MATCHED SYMBOL IN ECLASS
	!
	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	! One group in common

	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	!Error equivalence item extends common backward

				MAP BASE R1;
				R1 _ .CSYMPTR[IDCOMMON];
%4516%				RETURN FATLERR(.R1[COMNAME],.ISN,E33<0,0>)
			END;

%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	! Testing for  end of  chain of  group
				! going into common

				EQERRLIST(.EGROUP);
%2235%				EGROUP[EQVAVAIL] _ EQVERROR; ! Error in group
				RETURN -1		! Error
			END;

		IF .EGITEM[EQLLINK] NEQ 0
		THEN
		BEGIN
			EGITEM _ .EGITEM[EQLLINK];
			EGSYMPTR _ .EGITEM[EQLID];
		END
		ELSE
		BEGIN	! Link ECLASS  and EGROUP  with common  symbol
			! CSYMPTR.
			LINKGROUPS(.ECLASS,.EGROUP,.CSYMPTR);
			ECLASS[EQVINCOM] _ 1;	! In common
%2235%			EGROUP[EQVAVAIL] = EQVIGNORE;	! Has been searched
			EGROUP[EQVINCOM]_1;	! In common
			RETURN 1	! Success!!  Merged groups
		END;

	END; !OF LOOP%1%

END;	! One group in common


! Here if neither EGROUP nor ECLASS 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))
! (This tries to equivalence A(4) to A(5), which is quite illegal!)

EGITEM _ .EGROUP[EQVFIRST];	! First list of EGROUP.

WHILE 1 DO
BEGIN	! For each EGROUP

	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;

	! Find the matching id's and make sure that the displacements
	! are equal.
	IF	WHILE 1 DO
		BEGIN   %2%

			CSYMPTR _ .CITEM[EQLID];	! Symbol id

			! Check if symbols match
			IF .EGSYM EQL .CSYMPTR[IDSYMBOL]
			THEN EXITLOOP (-1);	! They do - Give a true

			! End of ECLASS?
			IF .CITEM[EQLLINK] EQL 0
			THEN EXITLOOP (0)		! Give a false
			ELSE CITEM _ .CITEM[EQLLINK]	! Next symbol

		END  !OF %2%

		NEQ 0

	THEN
	BEGIN	! Make sure displacements of matching items are ok

		! This is where we catch such things as equivalencing
		! A(4) and A(5) to each other.
		IF .NEWDISPL NEQ .CITEM[EQLDISPL]
		THEN
		BEGIN	! Displacements not equal.
			EQERRLIST(.EGROUP); ! Conflicting equivalences
%2235%			EGROUP[EQVAVAIL] = EQVERROR;
			RETURN -1
		END;

	END	! Make sure displacements of matching items are ok
	ELSE	! Put the item from the group into the class.
		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 (all items in EGROUP linked to ECLASS)
	ELSE	EGITEM _ .ENEXITEM;

END;	! For each EGROUP item
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;

%2311% LOCAL HOWIDE;	!SYMBOLS PER LISTING LINE
%2235% LOCAL SECTION;	!The psect for this group
%1261% LOCAL FLAGWRD;
%2271% BIND
%2271%		CHARSEEN = FLAGWRD<0,1>, ! Block contains Character data
%2271%		NUMSEEN = FLAGWRD<1,1>,  ! Block contains Numeric data
%2271%		LOGSEEN = FLAGWRD<2,1>;	 ! Block contains Logical data

%
THE ADDRESS OF ANITEM IN ECLASS IS COMPUTED AS FOLLOWS
 ADDR _ .PSECTS[.SECTION] + (RELATIVE DISPLACEMENT OF ITEM IN ECLASS (CITEM[EQLDISPL] 
		- SMALLEST RELATIVE DISPLACEMENT IN ECLASS (ECLASS[EQVADDR])
%
%2235%	IF .ECLASS[EQVLARGE]
%2235%	THEN SECTION = ECLASS[EQVPSECT] = PSLARGE
%2235%	ELSE SECTION = ECLASS[EQVPSECT] = PSDATA;
CNT _ 0;
IF .FLGREG<LISTING>
THEN
BEGIN
%4530%	HOWIDE = IF .LONGUSED THEN 1 !CAN ONLY FIT 2 SYMBOLS / LINE 
%4530%		 ELSE IF EXTENDED THEN 2 !CAN ONLY FIT 3 SYMBOLS / LINE W/ /EXTEND
%2311%	         ELSE 5;	!DO SIX THE REST OF THE TIME
	HEADCHK();
	STRNGOUT(PLIT '?M?J( ?0')
END;
%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);

%2235%	TLOC = .PSECTS[.SECTION] * CHARSPERWORD - .ECLASS[EQVADDR];

%2271%	FLAGWRD = 0;			! Clear CHARSEEN, NUMSEEN and LOGSEEN
CITEM _ .ECLASS[EQVFIRST];
%2235%	UNTIL .CITEM EQL 0 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
%2235%		CSYMPTR[IDPSECT] = .SECTION; !The psect
%2271%		IF .CSYMPTR[VALTYPE] EQL LOGICAL
%2271%		THEN LOGSEEN = 1	! Class contains logical data
%2271%		ELSE NUMSEEN = 1;	! Class contains numeric data
%1261%	END
%1261%	ELSE
%1261%	BEGIN !CHARACTER
%1261%		CSYMPTR[IDCHBP] _ CHADDR2BP(.CSYMPTR[IDADDR]);  ! CONVERT TO BYTE POINTER
%1261%	      	CSYMPTR[IDADDR] _ 0;	! AND CLEAR IDADDR, DESCRIPTOR ADDRESS
%2235%		CSYMPTR[IDPSCHARS] = .SECTION; !The psect
%2235%	      	CHARSEEN = 1;		! Remember class contains character data
%1261%	END;  !CHARACTER

	IF .FLGREG<LISTING>
	THEN(LISTSYM(.CSYMPTR);
%2311%	     IF .CNT LSS .HOWIDE THEN CNT _ .CNT+1
		ELSE (CNT _ 0; CRLF; HEADCHK());
	    );
%2235%	CITEM = .CITEM[EQLLINK]	!Next item
%2235%	END; !of loop through the items

%2235%	IF .FLGREG<LISTING>
%2235%	THEN (STRNGOUT(PLIT')?M?J'); HEADCHK());

%2271%	IF FLAGEITHER
%2271%	THEN
%2271%	BEGIN	! Doing compatibility checks
%2271%		ISN=0;	! ISN for any errors (error appears after allocation listing)
%2271%		IF .CHARSEEN AND (.NUMSEEN OR .LOGSEEN)
%2271%		THEN	! List contains both Char and Non-Char
%2271%			CFLAGB(UPLIT 'EQUIVALENCE-d?0',E168<0,0>);

%2455%		IF FLAGVMS	! Compatibility check for VMS
%2271%		THEN	IF .LOGSEEN AND .NUMSEEN ! Mixing logical and numeric
%2271%			THEN WARNERR(.ISN,E249<0,0>);
%2271%	END;	! Doing compatibility checks

%2235%	PSECTS[.SECTION] = .PSECTS[.SECTION] +
%2235%			CHWORDLEN(.ECLASS[EQVLIMIT] - .ECLASS[EQVADDR]);
!
!PSECTS[SECTION] + SPAN OF THE CLASS
!
END;	! of EQCALLOC

ROUTINE GRPSCAN=
BEGIN
!***********************************************************************
! Mark all equivalence groups that have an item (list) in COMMON.
! Force psect of groups with element in common to have the common psect.
! Set the EQVSMALL and EQVLARGE flags in group header entries.
!***********************************************************************

LOCAL BASE ECLASS :ELIST :EITEM : LAST;
%2235%	LOCAL BASE COMPTR;	!Pointer to common block

ECLASS _ .EQVPTR<LEFT>;		! First equivalence group
%2235%	UNTIL .ECLASS EQL 0 DO
BEGIN	! Walk through all groups

	LAST _ ELIST _ .ECLASS[EQVFIRST];
	IF NOT .ECLASS[EQVINCOM] 
	THEN	! Group not already marked as in common

		UNTIL  .ELIST  EQL  0
		DO
		BEGIN	! For each symbol in the group

			EITEM _ .ELIST[EQLID];	! Symbol
			IF .EITEM[IDATTRIBUT(INCOM)]
			THEN 
			BEGIN	! Symbol is in common

				! Check for more than one common var
				! in this group.
				IF .ECLASS[EQVINCOM]  
				THEN
				BEGIN
					FATLERR(.ISN,E48<0,0>);
					EXITLOOP;
				END;


%2235%				!Force psect to match common
%2235%				COMPTR = .EITEM[IDCOMMON];
%2235%				ECLASS[EQVPSECT] = .COMPTR[COMPSECT];

				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;	! Symbol is in common

%2235%			! Set either 'small' or 'large' flag in group header
%2235%			! depending upon psect for the item
%2235%			IF (.EITEM[VALTYPE] EQL CHARACTER
%2235%				AND .EITEM[IDPSCHARS] EQL PSLARGE)
%2235%			   OR (.EITEM[VALTYPE] NEQ CHARACTER
%2235%				AND .EITEM[IDPSECT] EQL PSLARGE)
%2235%			THEN ECLASS[EQVLARGE] = 1
%2235%			ELSE ECLASS[EQVSMALL] = 1;

			LAST _ .ELIST;
			ELIST _ .ELIST[EQLLINK]

		END;	! For each symbol in the group

%2235%	ECLASS = .ECLASS[EQVLINK]	!Walk through
%2235%	END;				!  all groups

END;	! of GRPSCAN

ROUTINE PROCEQUIV=

!++
! FUNCTIONAL DESCRIPTION:
!
!	Processes  equivalence  groups  as  declared   in  the   source.
!	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.
!
!	- 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
!	EQVCLASS.  The  one that  remains a  group has  EQVAVAIL set  to
!	EQVIGNORE.  At  the  end of  this  processing, the  groups  with
!	EQVAVAIL = EQVCLASS are the ones that contain all the info  from
!	all the equivalence statements.
!	- call EQCALLOC to allocate the classes
!
! FORMAL PARAMETERS:
!
!	None
!
! IMPLICIT INPUTS:
!
!	Unknown
!
! IMPLICIT OUTPUTS:
!
!	Unknown
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	Unknown
!
!--


BEGIN

LOCAL	BASE EQVCPTR,	!PTR TO CURRENT EQUIV CLASS HEADER
	ECOMMPTR,	!PTR COMMON ITEM IF GROUP IS IN COMMON
	ECOMMHDR,	!PTR TO COMMON BLOCK HDR
	BASE EQLPT2,	!OTHER PTR TO EQUIV LIST NODE
	BASE LCLHD,	!PTR TO LOCAL HEAD OF A GROUP FOR ALLOCATION PURPOSES
	SAVEBOUNDSFLG,	!TO SAVE THE VALUE OF THE "BOUNDS" SWITCH WHILE
			! PROCESSING EQUIVALENCE STMNTS
%2235%	BASE SYMPTR;	!Ptr to symbol table entry

REGISTER BASE EQLPTR;	!PTR TO EQUIV LIST NODE

%2235%	LABEL LOOP2;


	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.


! Make sure that every group that has a symbol in COMMON is marked.

GRPSCAN();


EQVCPTR _ .EQVPTR<LEFT>;	! Ptr to first group

%2235%	UNTIL .EQVCPTR EQL 0 DO
BEGIN	! For each equivalence group

	ISN _ .EQVCPTR[EQVISN];		! Set ISN in case of errors
	ECOMMPTR _ 0;			! Initializing

	!If group is in common then find the element in common
%2235%	IF .EQVCPTR[EQVINCOM]
	THEN
	BEGIN	! Group has element in common
		EQLPTR _ .EQVCPTR[EQVHEAD]; ! Ptr to list item that's in common
		LCLHD _ .EQLPTR[EQLID];	! Symbol table entry
		ECOMMPTR _ .EQLPTR; 	! Ptr to common item eql list item
		ECOMMHDR _ .LCLHD[IDCOMMON];	! Common table entry
	END
	ELSE	LCLHD _ 0;

	EQLPTR _ .EQVCPTR[EQVFIRST];	! Ptr to first item in group
	R2 _ 0;		! EQVLIMIT in R2
	R1 _ 0;		! Smallest displacement in R1

%2235%	LOOP2:
%2235%	UNTIL .EQLPTR EQL 0 DO
	BEGIN	! For each list in ECLASS
	  LOCAL BASE ESYM, EQSIZ;
	  IF .EQLPTR[EQLINDIC] NEQ 0
	  THEN
	  BEGIN	! Has dimensions

%2414%		LOCAL BASE PT1:PT2:PT3:PTL:PTU:PTS; ! Scratch pointers
%2414%		LOCAL NUMELM;		! Number of elements
		PT1 _ .EQLPTR[EQLID];	! Symbol table

		IF .PT1[IDDIM] EQL 0 THEN
		BEGIN	! Not declared with dimensions - error!
 			FLGREG<BOUNDS>_.SAVEBOUNDSFLG;
			RETURN FATLERR(.ISN,E93<0,0>);
		END;

		EQLPTR[EQLINDIC] _ 0;
		IF .EQLPTR[EQLLIST]^(-18)  NEQ  0
		THEN
		BEGIN	! Multiple subscripts

%2414%			! Check the constant subscripts to verify that
%2414%			! they are within bounds.
%2414%			PT3=.EQLPTR[EQLID];	! Pointer to symbol
%2414%			PT1=.EQLPTR[EQLLIST];	! Pointer to subscripts
%2414%			PT2=.PT3[IDDIM];	! Dimension table
%2414%			INCR I FROM 0 TO .PT2[DIMNUM]-1
%2414%			DO
%2414%			BEGIN ! Loop for subscript check
%2414%				PTL=.PT2[DIMENL(.I)];	! Lower bound
%2414%				PTU=.PT2[DIMENU(.I)];	! Upper bound
%2414%				PTS=@(.PT1+.I);		! Subscript
%2414%				IF .PTS[CONST2] LSS .PTL[CONST2] OR
%2414%				   .PTS[CONST2] GTR .PTU[CONST2]
%2414%				THEN ! Subscript out of range
%4516%					WARNERR(.PT3[IDSYMBOL],.ISN,E293<0,0>);
%2414%			END; ! Loop for subscript check

			! 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	EQLPTR[EQLDISPL] _ -CNSTEVAL(.PT1[ARG2PTR]) 
%1261%					      - EXTSIGN(.PT1[TARGADDR]);


%1261%			! If noncharacter, convert words to chars
%1261%			IF .PT3[VALTYPE] NEQ CHARACTER
%2271%			THEN EQLPTR[EQLDISPL] = .EQLPTR[EQLDISPL] * CHARSPERWORD;

%2322%			! Check if the array reference is too large  for
%2322%			! the  amount  of  addressable  memory  on   the
%2322%			! machine.  /EXTEND  allows larger  arrays.   If
%2322%			! too large, give a fatal error message.
%2322%
%2322%			IF .EQLPTR[EQLDISPL] LEQ -(.VMSIZE * CHARSPERWORD)
%2322%			   OR  .EQLPTR[EQLDISPL] GEQ (.VMSIZE * CHARSPERWORD)
%4516%			THEN	RETURN FATLERR(.PT3[IDSYMBOL], .ISN, E103<0,0>);

		END	! Multiple subscripts
		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
			PT3 _ .EQLPTR[EQLID];	! Symbol table
			PT2 _ .PT3[IDDIM]; 	! Dimension table
%2271%			IF FLAGANSI
%2271%			THEN	! Compatibility checks
%2271%				IF .PT2[DIMNUM] NEQ 1	! Should be single dimension
%4516%				THEN WARNERR(.PT3[IDSYMBOL],.ISN,E274<0,0>);

%2414%			! Compute size of array, and check to see if the
%2414%			! subscript is within range.
%2414%			! The subscript is considered to be within range
%2414%			! if it is not less than the lower bound of the
%2414%			! first dimension, and not greater than the number
%2414%			! of elements offset by that first lower bound.

%2414%			NUMELM=1; ! Will hold the computed number of elements
%2414%			DECR I FROM .PT2[DIMNUM]-1 TO 0
%2414%			DO
%2414%			BEGIN ! Loop to compute number of elements
%2414%				PTL=.PT2[DIMENL(.I)]; ! Lower bound
%2414%				PTU=.PT2[DIMENU(.I)]; ! Upper bound
%2414%				NUMELM=.NUMELM*(.PTU[CONST2]-.PTL[CONST2]+1);
%2414%			END; ! Loop to compute number of elements
%2414%			IF .PT1[CONST2] GTR (.NUMELM+.PTL[CONST2]-1) OR
%2414%			   .PT1[CONST2] LSS .PTL[CONST2]
%2414%			THEN !Subscript out of range
%4516%				WARNERR(.PT3[IDSYMBOL],.ISN,E293<0,0>);

			EQLPTR[EQLDISPL] _ - .PT1[CONST2]	!CONSTANT VALUE
					   + .PTL[CONST2];	!OFFSET


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

%2322%			! Check if the array reference is too large  for
%2322%			! the  amount  of  addressable  memory  on   the
%2322%			! machine.  /EXTEND  allows larger  arrays.   If
%2322%			! too large, give a fatal error message.
%2322%
%2322%			IF .EQLPTR[EQLDISPL] LEQ -(.VMSIZE * CHARSPERWORD)
%2322%			   OR  .EQLPTR[EQLDISPL] GEQ (.VMSIZE * CHARSPERWORD)
%4516%			THEN	RETURN FATLERR(.PT3[IDSYMBOL], .ISN, E103<0,0>);

		END	! Single subscript

	     END;	! Has dimensions

	   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	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
	BEGIN
		R1 _ .EQLPTR[EQLDISPL];	! New smallest displacement
		LCLHD _ .EQLPTR[EQLID];
	END;
	IF .ECOMMPTR NEQ 0 THEN
	IF .EQLPTR NEQ .ECOMMPTR
	THEN
	BEGIN
		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
		BEGIN	! Not in common

			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],.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
			BEGIN
%4516%				FATLERR(.ECOMMHDR[COMNAME],.ISN,E33<0,0>);
				LEAVE LOOP2;
			END;
			IF .ECOMMHDR[COMSIZE] LSS (.LINK[IDADDR] + .EQSIZ)
			THEN ECOMMHDR[COMSIZE] _ (.LINK[IDADDR] + .EQSIZ);
		END	! Not in common
		ELSE	! Checking  the  declarations  for   violating
			! beginning of common block

			 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.
				OR (.COM[IDCOMMON] NEQ .LINK[IDCOMMON])
			THEN
			BEGIN
				EQERRLIST(.EQVCPTR);	! List out vars
%2235%				EQVCPTR[EQVAVAIL] = EQVERROR;
				LEAVE LOOP2;
			END;

	END;

%2235%	EQLPTR = .EQLPTR[EQLLINK]	!Next list item
%2235%	END; ! For each list in ECLASS

	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
%2235%				EQVCPTR[EQVAVAIL] = EQVERROR;! mark group to prevent
%1450%							!   further processing
%1450%			END;
%1450%			EQLPT2 _ .EQLPT2[EQLLINK]; 
%1450%		END;
%1450%		EQLPTR _ .EQLPTR[EQLLINK];
%1450%	END;

%2235%	EQVCPTR = .EQVCPTR[EQVLINK]	!Next group
%2235%	END; ! For each equivalence group
! Now start to make equivalence classes by combining groups if possible

EQVCPTR _ .EQVPTR<LEFT>;	! Start with first group
%2235%	UNTIL .EQVCPTR EQL 0 DO
%2235%	BEGIN	! Walk through each equivalence group

%2235%	IF .EQVCPTR[EQVAVAIL] EQL EQVGROUP
	THEN
	BEGIN	! Group available for Class

		ISN _ .EQVCPTR[EQVISN];	! Set ISN in case of errors
%2235%		EQVCPTR[EQVAVAIL] = EQVCLASS;	! Make Group a Class
		EQLPTR _ .EQVCPTR;	! Begin search of other groups on current Group
		DO
		BEGIN	! Walk through all groups after EQVCPTR

%2235%			IF .EQLPTR[EQVAVAIL] EQL EQVGROUP
			THEN
			BEGIN	! Ok to search this group

				! Try to combine the groups into a single one.
				IF (ELISTSRCH(.EQVCPTR,.EQLPTR)) GTR 0
				THEN
				BEGIN	! Groups were combined
%2235%					EQLPTR[EQVAVAIL] = EQVIGNORE; ! Have searched
					EQLPTR _ .EQVCPTR ;	!SEE IF ANY OF THE REJECTS FIT NOW
				END;

				! If error  occurred  in  ELSTSRCH  then
%2235%				! EQLPTR[EQVAVAIL] will  be  set  to EQVERROR

		       END;	! Ok to search this group

		END	! Walk through all groups after EQVCPTR
		WHILE (EQLPTR _ .EQLPTR[EQVLINK]) NEQ 0;


		IF NOT .EQVCPTR[EQVINCOM]
%2235%		THEN IF .EQVCPTR[EQVAVAIL] EQL EQVCLASS
%[735]%		THEN
%[735]%		BEGIN	! No error in searching, not in common
%[735]%			IF .HDRFLG EQL 0
%2311%			THEN
%2311%			IF EXTENDED
%2311%			THEN
%2311%			LSTHDR(4,2,PLIT'?M?JEQUIVALENCED VARIABLES  [ "!" VARIABLE STORED IN .LARG. ]?M?J?0')
%2311%			ELSE
%[735]%			LSTHDR(4,2,PLIT'?M?JEQUIVALENCED VARIABLES?M?J?0');
%[735]%			EQCALLOC(.EQVCPTR); ! Allocate Class
%[735]%			HDRFLG_1;
%[735]%		END;

	END;	! Group available for Class

%2235%	EQVCPTR = .EQVCPTR[EQVLINK]	!Next class or group
%2235%	END; ! Walk through each equivalence group

	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;

%1733%	! The over/underflows that may occur in this routine are not associated
%1733%	! with any particular  line, so set  ISN to zero  (which means no  line
%1733%	! number is known).   It is  safe to do  this because  this routine  is
%1733%	! called so late in the back end.

%1733%	ISN = 0;


	! 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

				![2330] Output byte pointer to hiseg,
				![2330] relocating address field to lowseg

%2330%				Z30CODE(PSDATA,PSCODE);
			   	HILOC _ .HILOC + 1;

				RDATWD _ .CPTR[LITLEN];	! Length of constant

				![2330] Output length to hiseg without
				![2330] relocation

%2330%				Z30CODE(PSABS,PSCODE);
			   	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
%4527%			CMPSYM(.PTR[IDSYMBOL], .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

							! Output byte pointer,
							!  no relocation

%2330%							Z30CODE(PSABS,PSCODE);

							! Get pointer to
							!  COMMON block

%1261%							R2 _ .PTR[IDCOMMON];

							![2330] Output additive
							![2330]  fixup for
							![2330]  descriptor at
							![2330]  HILOC - use
							![2330]  EXTENDED flag
							![2330]  to decide on
							![2330]  18 or 30 bit.

%2330%							IF EXTENDED
%2330%							THEN ZSYMBOL(
%2330%								GLB30ADDFIX,
%2330%								.R2[COMNAME],
%2330%								.HILOC,
%2330%								PSCODE)
%1512%							ELSE ZSYMBOL(
%1512%								GLB18ADDFIX,
%1512%								.R2[COMNAME],
%1512%								.HILOC,
%1512%								PSCODE);
%1261%						END 	! COMMON
%2330%						ELSE		! NOT INCOM
%2330%						BEGIN	! NOT COMMON
							![2330] Output BP to
							![2330]  high seg with
							![2330]  relocation

%2330%							Z30CODE(
%1526%							.PTR[IDPSCHARS],
%1526%								PSCODE);
%2330%						END	! NOT COMMON
%1434%					END
%1434%					ELSE
%1434%					BEGIN	! function is declared external

						![2330] Store address at HILOC
						![2330] with additive fixup.
						![2330] Use an IFIW under
						![2330] /NOEXTEND to keep
						![2330] things section
						![2330] independant, in case
						![2330] someone wants to
						![2330] execute by mapping into
						![2330] a non-zero section.

%2330%						IF EXTENDED	! N sections?
%2330%						THEN
%2330%						BEGIN	! EXTENDED
%2330%							RDATWD = 0;	! EFIW
%2330%							Z30CODE(PSABS,PSCODE);
%2345%							ZSYMBOL(GLB30ADDFIX,
%2330%								.PTR[IDSYMBOL],
%2330%								.HILOC,PSCODE);
%2330%						END	! EXTENDED
%2330%						ELSE	! One section, use IFIW
%2330%						BEGIN	! NOT EXTENDED
%1434%							RDATWD = 1^35;	! IFIW
%2330%							Z30CODE(PSABS,PSCODE);
%2345%							ZSYMBOL(GLB18ADDFIX,
%1512%								.PTR[IDSYMBOL],
%1512%								.HILOC,PSCODE);
%2330%						END;	! NOT EXTENDED
%1434%					END;

					HILOC _ .HILOC + 1;

					! Length of character scalar or array

					RDATWD _ .PTR[IDCHLEN];

					! Output length to high seg with no
					!  relocation

%2330%					Z30CODE(PSABS,PSCODE);

					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
%4517%		THEN
%4517%		BEGIN
%4517%			! If IDINCR = 0 then the instruction will be 
%4517%			! incremented before being used (unlike LDB/DPB)
%4517%
%4517%			IF .DPTR[IDINCR] EQL 0	
%4517%			THEN RDATWD = BPADD(.SUBNODE[IDCHBP],.DPTR[IDBPOFFSET])
%4517%			ELSE RDATWD = BPADD2(.SUBNODE[IDCHBP],.DPTR[IDBPOFFSET]);
%4517%		END
		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
%2330%				Z30CODE(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

%2330%				IF EXTENDED	! /EXTEND?
%2330%				THEN ZSYMBOL(GLB30ADDFIX,.R2[COMNAME],
%2330%					.HILOC,PSCODE)
%2330%				ELSE ZSYMBOL(GLB18ADDFIX,.R2[COMNAME],
%1512%					.HILOC,PSCODE);

%1451%			END
%2330%			ELSE Z30CODE(.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>
%2330%			THEN Z30CODE(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

%4520%		DPTR = .DPTR[DLINK]	! 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

%4530%	IF .LONGUSED
%4530%	THEN
%4530%	BEGIN
%4530%		IF EXTENDED
%4530%		THEN
%4530%		LSTHDR(7, 6, PLIT '?M?JCHARACTER DATA [ "*" NO EXPLICIT DEFINITION - "!" VARIABLE STORED IN .LARG. ]
?J NAME ?I?I?I?IDESCRIPTOR ADDRESS ?ISTART OF DATA ?ILENGTH
?J?I?I?I?I?I?I?IADDR(POSITION)?M?J?M?J?0')
%4530%		ELSE
%4530%		LSTHDR(7, 6, PLIT '?M?JCHARACTER DATA [ "*" NO EXPLICIT DEFINITION ] 
?J NAME ?I?I?I?IDESCRIPTOR ADDRESS ?ISTART OF DATA ?ILENGTH
?J?I?I?I?I?I?I?IADDR(POSITION)?M?J?M?J?0')
%4530%	END
%4530%	ELSE IF EXTENDED
%2311%	THEN
%2311%	LSTHDR(7, 6, PLIT '?M?JCHARACTER DATA [ "*" NO EXPLICIT DEFINITION - "!" VARIABLE STORED IN .LARG. ]
?J NAME ?I?IDESCRIPTOR ADDRESS ?ISTART OF DATA ?ILENGTH
?J?I?I?I?I?IADDR(POSITION)?M?J?M?J?0')
%2311%	ELSE
	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

	REGISTER BASE BP;
	MAP
		BASE R2,
		BASE OBP;


	! Output the start address of character data as addr(charpos)
%2330%	IF NOT EXTENDED		! Local byte pointers?
%2216%	THEN
		! Convert #010700,,FOO-1 TO #440700,,FOO
		IF .OBP<LEFT> EQL #010700
		THEN	BP = #440700 ^ 18 + .OBP<RIGHT> + 1
		ELSE	BP = .OBP
%2216%	ELSE	! Convert #66ssss,,FOO-1 TO #61ssss,,FOO
%2216%		IF .OBP<30,6> EQL #66
%2216%		THEN	BP = #61^30 + .OBP<0,30> + 1
%2216%		ELSE	BP = .OBP;

%2330%	IF EXTENDED		! Global byte pointers?
%2311%	THEN
%2311%	BEGIN			!/EXTEND
%2311%		R2 _ .BP<0,30>;	!GET LONG ADDR
%2311%		ZOUTADDR();	!OUTPUT IT
%2311%	END			!/EXTEND
%2311%	ELSE
%2311%	BEGIN			!NO /EXTEND
		R2<LEFT> _ .BP<RIGHT>; ! Get the address of data
		ZOUTOCT()	! Output it
%2311%	END;			!NO /EXTEND

	CHAROUT("(");		! Output a (

%2344%	IF .OBP NEQ 0		! Was the BP good?
%2344%	THEN
%2344%	BEGIN			! Good BP

%2330%		IF NOT EXTENDED	! Local byte pointers?
%2216%		THEN		! Yes
%2216%		BEGIN		! NOT EXTENDED
			R1 _ .BP<30,6>;	! Get P field of byte pointer
			R1 _ (43 - .R1) / 7; ! Compute charpos 1-5
%2216%		END		! NOT EXTENDED
%2216%		ELSE		! No, global byte pointers
%2216%		BEGIN		! EXTENDED
%2216%	 		R1 _ .OBP<30,6>; ! Get P&S field of byte pointer
%2311%			R1 _ (.R1-#60); ! Compute charpos 1-5
%2216%		END;		! EXTENDED
%2344%		ZOUDECIMAL()	! Output byte offset
%2344%	END			! Good BP
%2344%	ELSE CHAROUT("??");	! No, bad BP, be silly

	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;
%4530%	LOCAL MAXCONST;		! Maximum length of a constant
%4527%	REGISTER TMP;


	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
%4530%		IF .LONGUSED THEN MAXCONST = 34
%4530%		ELSE MAXCONST = 11;
%4530%		WHILE (.CC GTR 0) AND (.COL LEQ .MAXCONST)! print up to maxconst 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
%4530%		IF .LONGUSED
%4530%		THEN WHILE (COL=.COL+1) LEQ .MAXCONST
%4530%		DO CHAROUT(" ")
%4530%		ELSE 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

%2311%		! Output "!" if stored in .LARG. else,
		! output "*" if not explicitly defined.
%2311%		! (IE; Large overrides not defined)
%2311%		! Information can be lost when a variable is
%2311%		! by IMPLICIT CHARACTER*<bignumber>.

%2311%		IF .PTR[IDPSCHARS] EQL PSLARGE !IF LARGE CHARACTER DATA
%2311%		THEN	CHAROUT("!")	! FLAG FROM LARGE PSECT W/ A BANG!
%2311%		ELSE
		IF NOT .PTR[IDATTRIBUT(INTYPE)] AND .PTR[OPRSP1] NEQ ARRAYNM1
		THEN
		BEGIN	! Don't output "*" for .Dnnnn variables

%4527%			TMP = @@R2<SYMPOINTER>;	! First word of symbol
%4527%			IF .TMP<SYM1STCHAR> NEQ SIXBIT "." THEN CHAROUT("*")

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

		ZOUTSYM();		! Output it
%4530%		IF NOT .LONGUSED THEN 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
%4530%	IF NOT .LONGUSED THEN 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);		!OUTPUT BP
%2330%				IF EXTENDED		! Global byte pointers?
%2311%				THEN			!IF /EXTENDED
%2311%				(IF .BP<0,30> LSS #10000 !CHECK 30 BITS OF OWG
%2311%				 THEN TABOUT())		!OUTPUT TAB IF NEEDED
%2311%				ELSE			!IF /NOEXTEND
%2311%				(IF .BP<RIGHT> LSS #10000 !CHECK 18 BITS
%2311%				 THEN TABOUT());	! Output an extra TAB

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

		ZOUTBP(.BP);
%2330%		IF EXTENDED	! Global byte pointers?
%2311%		THEN
%2311%		(IF .BP<0,30> LSS #10000
%2311%		  THEN TABOUT())
%2311%		ELSE
		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

%2311%	LOCAL HOWIDE;		!NUMBER OF SYMBOLS / LISTING LINE
%1274%	REGISTER LEN,BASE SYMPTR;

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

%2311%	IF .FLGREG<LISTING>
%2311%	THEN
%4530%	HOWIDE = IF .LONGUSED THEN 2 !THIS MANY SYMBOLS / LINE WITH LONGSYMBOL NAMES
%4530%		 ELSE IF EXTENDED THEN 3 !THIS MANY SYMBOLS / LINE UNDER /EXTEND
%2311%		 ELSE 5;	!OTHERWISE DO MORE

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

%2311%			IF .TCNT GTR .HOWIDE
			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

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

END;	! of HISEGBLK

GLOBAL ROUTINE RELINIT=
BEGIN
!++
!********************************************************
! Initializes .REL file, generating these LINK blocks
!
!		4	- ENTRY
!		6 	- NAME
![2446]		1050	- PSECT HEADER 
!		1131 	- Segment redirection (/EXTEND only)
!
!********************************************************
!--

LOCAL
	INDEX,		! last psect index
	NAME[2];	! Holds single word psect names

REGISTER
%1434%	BASE ENT;

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

%2440%	DATAORG = #1001000,
%2356%	CODEORG = #1300000,
%1525%	LARGEORG = #2000000;

	INIRLBUFFS();	! Initialize the .REL file buffers

	! Initialize the entry block

%4530%	IF .LONGREL AND .LONGUSED
%4530%	THEN
%4530%	BEGIN	!Long symbols
%4530%		INCR I FROM 0 TO .PROGNAME<SYMLENGTH>-1
%4530%		DO
%4530%		BEGIN
%4530%			RDATWD = @(.PROGNAME<SYMPOINTER>)[.I]<0,36>;	! And get the name in SIXBIT
%4530%			ZNEWBLOCK(RLONGENTRY)
%4530%		END;
%4530%	END	!Long symbols
%4530%	ELSE
%4530%	BEGIN	!Short symbols
%4530%		R2 = @(.PROGNAME<SYMPOINTER>)<0,36>;
%1434%		RDATWD = RADIX50();
%1434%		ZOUTBLOCK(RENTRY,RELN);
%4530%	END;	!Short symbols

%1434%	ENT = .MULENTRY;	! Now any entry points
%1434%	WHILE .ENT NEQ 0 DO
%1434%	BEGIN
%4530%		IF .LONGREL AND .LONGUSED
%4530%		THEN	
%4530%		BEGIN	!Long symbols

%4530%			! Check if there is enough room in the buffer for
%4530%			! all of the long entry name
%4530%			IF (.MAINRLBF[RDATCNT] + .R2<SYMLENGTH> + 1) GTR RBLKSIZ
%4530%			THEN
%4530%			BEGIN	
%4530%				DMPMAINRLBF();	! Output the contents of
%4530%						!  MAINRLBF and reinitialize it
%4530%				MAINRLBF[RTYPE] = RLONGENTRY;
%4530%			END;
%4530%			! Loop to store entry name in buffer
%4530%			INCR I FROM 0 TO .R2<SYMLENGTH>-1
%4530%			DO
%4530%			BEGIN
%4530%				RDATWD = @(.R2<SYMPOINTER>)[.I]<0,36>;	! And get the name in SIXBIT
%4530%				ZNEWBLOCK(RLONGENTRY)
%4530%			END;
%4530%		END	!Long symbols
%4530%		ELSE
%4530%		BEGIN	!Short symbols
%4530%			R2 = @(.R2<SYMPOINTER>)<0,36>; !r2 = first word of long name
%1434%			RDATWD = RADIX50();
%1434%			ZOUTBLOCK(RENTRY,RELN);
%4530%		END;	!Short symbols
%1434%		ENT = .ENT[IDENTLNK];
%1434%	END;


%4530%	IF .LONGREL AND .LONGUSED
%4530%	THEN
%4530%	BEGIN	!Long symbols
%4530%		RDATWD<LEFT> = 1;
%4530%		RDATWD<RIGHT> = .PROGNAME<SYMLENGTH>;	!Length of name
%4530%		ZNEWBLOCK(RLONGTITLE);
%4530%		INCR I FROM 0 TO .PROGNAME<SYMLENGTH>-1
%4530%		DO
%4530%		BEGIN
%4530%			RDATWD = @(.PROGNAME<SYMPOINTER>)[.I]<0,36>;	! And get the name in SIXBIT
%4530%			ZNEWBLOCK(RLONGTITLE);
%4530%		END;
%4530%		RDATWD<LEFT> = 3;
%4530%		RDATWD<RIGHT> = 1; 	! count of words in compiler name
%4530%		ZNEWBLOCK(RLONGTITLE);
%4530%		RDATWD = FTNID;
%4530%		ZNEWBLOCK(RLONGTITLE);
%4530%	END	!Long symbols
%4530%	ELSE
%4530%	BEGIN	!Short symbols
%4530%		R2 = @(.PROGNAME<SYMPOINTER>)<0,36>; !first word of long symbol

		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
%4530%	END;	!Short symbols

%1525%	IF EXTENDED
	THEN
	BEGIN	! /EXTEND switch given

		! Define  the  psect  names,  attributes,  indices   and
		! origins.

		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,
%2446%		! the following paragraphs should be changed.

%2446%		NAME[0] = 1;
%2446%		NAME[1] = SIXBIT '.LARG.';	

%2446%		TYPE1050(HINAME,PXCODE,PACODE,CODEORG);
%2446%		TYPE1050(LONAME,PXDATA,PADATA,DATAORG);
%2446%		TYPE1050(NAME,PXLARGE,PALARGE,LARGEORG);

%2446%		INDEX = PXLARGE; ! last psect index	
%2446%		IF (.HINAME[0] NEQ 1) OR (.HINAME[1] NEQ SIXBIT ".CODE.")
%2446%		THEN
%2446%		BEGIN
%2446%			NAME[1] = SIXBIT '.CODE.';
%2446%			TYPE1050(NAME,INDEX=.INDEX+1,PACODE,CODEORG);
%2446%		END;	
%2446%		IF (.LONAME[0] NEQ 1) OR (.LONAME[1] NEQ SIXBIT ".DATA.")
%2446%		THEN
%2446%		BEGIN
%2446%			NAME[1] = SIXBIT '.DATA.';
%2446%			TYPE1050(NAME,INDEX=.INDEX+1,PADATA,DATAORG);
%2446%		END;	

%2310%		! Output PSECT redirection information rel block
%2310%
%2310% 		PSREDIRECT();

%1525%	END;	! /EXTEND switch given

END;	! of RELINIT


GLOBAL ROUTINE TYPE1050(NAME,INDEX,ATTRIB,ORIGIN)=
!++				
! FUNCTIONAL DESCRIPTION:
!
!	This routine puts out a type 1050 rel block
!
! FORMAL PARAMETERS:
!
!	NAME		word 0    = number of words in psect name
!			word 1-12 = psect name
!	INDEX		psect index
!	ATTRIB		psect attributes
!	ORIGIN		psect origin
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	None
!
!--


! New [2446] MEM
BEGIN

STRUCTURE
	PVECTOR[WD]=	! Structure for a pointer to a vector
		(@.PVECTOR + .WD);

MAP
	PVECTOR NAME;

LOCAL
	MYRELBUF[17],	! Holds various REL block types
			! 13 words are needed for the psect name and long count
			! plus words for block type / long count, index, 
			! 		attributes, origin
	NAMELEN,	! number of words in the psect name
	ATTINDX;	! index into MYRELBLOCK of attributes

	MYRELBUF[1] = .INDEX;	
	NAMELEN = .NAME[0];		! number of words in psect name
	IF .NAMELEN EQL 1
	THEN
	BEGIN
		MYRELBUF[2] = .NAME[1];
		MYRELBUF[3] = .ATTRIB;
		MYRELBUF[4] = .ORIGIN;

		! Don't specify an origin if it is not .DATA.,.CODE. or .LARG.
		IF (.NAME[1] NEQ SIXBIT '.DATA.') AND
		   (.NAME[1] NEQ SIXBIT '.CODE.') AND
		   (.NAME[1] NEQ SIXBIT '.LARG.')
		THEN
		BEGIN
			MYRELBUF[0] = RLONGPSECTHEAD^18 OR 3;
			DMPRLBLOCK(MYRELBUF,4);
		END
	        ELSE
		BEGIN
			MYRELBUF[0] = RLONGPSECTHEAD^18 OR 4;
			DMPRLBLOCK(MYRELBUF,5);
		END;
	END
	ELSE
	BEGIN
		MYRELBUF[2] = .NAMELEN;
		INCR I FROM 1 TO .NAMELEN DO MYRELBUF[.I+2] = .NAME[.I];

		ATTINDX = 3 + .NAMELEN;
	 	MYRELBUF[.ATTINDX] = .ATTRIB;

		MYRELBUF[0] = RLONGPSECTHEAD^18 OR 
				(.ATTINDX);		! type & count

		DMPRLBLOCK(MYRELBUF,.ATTINDX+1);
	END;	
END;


GLOBAL ROUTINE PSREDIRECT=		![2310] New

!++
! FUNCTIONAL DESCRIPTION:
!
!	Output a  type  1131  PSECT  redirection  block  for  LINK  when
!	compiling /EXTEND.  This will make all low  segment code go into
!	a specific PSECT and all high segment code go into another  (the
!	names can  be  given  by  the  user).   The  caller  decides  if
!	compilation is done /EXTEND.
!
! FORMAL PARAMETERS:
!
!	None
!
! IMPLICIT INPUTS:
!
!	DEFLON		Default name of the low (data) PSECT.  Word 0 is
!			the count of the number of SIXBIT words in name.
!
!	DEFHIN		Default name of the high (code) PSECT.  Word 0 is
!			the count of the number of SIXBIT words in name.
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	Outputs a rel block.
!
!--


BEGIN

LOCAL	HEADERWD;
	
	! Make sure we've finished dumping out other rel blocks.

	DMPMAINRLBF();

	! Dump our  block.  Output  1 word  at a  time.  The  names  and
	! lengths of the PSECT's may vary, so we must use variables.

%2454%	HEADERWD = RREDIRECT^18 OR (.DEFLON[0]+.DEFHIN[0]+2);
%2446%	DMPRLBLOCK(HEADERWD, 1);		! Header; 1131,,count

%2454%	DMPRLBLOCK(DEFLON, .DEFLON[0]+1);	! Count and Name of data psect

%2454%	DMPRLBLOCK(DEFHIN, .DEFHIN[0]+1);	! Count and Name of code psect
	

END;	! of PSREDIRECT
ROUTINE CIMPLNONE=	! [2507] New

!++
! FUNCTIONAL DESCRIPTION:
!
!	Walk the symbol table to check for any symbols that should be
!	output for IMPLICIT NONE that haven't been yet.  We primarily
!	will catch the unallocated variables at this point.
!
! FORMAL PARAMETERS:
!
!	None
!
! IMPLICIT INPUTS:
!
!	E304		Warning for IMPLICIT NONE
!
!	SYMTBL		Hashed symbol table entries
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	None
!
!--


BEGIN

	REGISTER BASE SYM;	! The symbol table entry


	! Go through every symbol in the symbol table.

	DECR CNT FROM SSIZ-1 TO 0
	DO
	BEGIN	! Walk each hash bucket in the symbol table

		SYM = .SYMTBL[.CNT];	! This hash entry

		! If this isn't zero, then there's a symbol here.  The
		! entries are linked together within a hash bucket, so walk
		! all of them in this bucket and check them.

		WHILE (.SYM NEQ 0)
		DO
		BEGIN	! Contents of each bucket in the symbol table

			! If IMPLICIT NONE is given, then we must insure that 
			! the variable is declared in a type statement,
			! Unless:
			!	- The warning has already been given for
			!	this symbol
			!	- The symbol was in a type statement
			!	- The symbol is a Fortran temporary (has
			!	"."  as first char)
			!	- The symbol is a NAMELIST name
			!	- The symbol is a COMMON block name, but not
			!	in a COMMON statement;
			!		COMMON /FOO/ A,FOO,B
			!	- The symbol is a subroutine name, and not
			!	also a variable name (can only happen in a
			!	subroutine program)
			!	- The symbol is a valid subroutine name
			!	(for the form of calling a function)
			!	- The symbol is a library function
			!	- The symbol is a function entry name and
			!	we're compiling a MAIN program (so the name
			!	is a main program name)
			!	- The symbol has a library function name
			!	(The symbol table reference for the
			!	original undotted name appears just like a
			!	variable)

			! This is structured to not slow down the majority
			! of cases, since the entire symbol table is
			! walked.  IF THEN's generate faster code than
			! IF AND's.

			IF NOT .SYM[IDIMPLNONE]		! Message already given
			THEN IF NOT .SYM[IDATTRIBUT(INTYPE)]	! Declared
			THEN IF .SYM[IDDOT] NEQ SIXBIT"."	! Dotted name
			THEN IF NOT .SYM[IDATTRIBUT(NAMNAM)]	! NAMELIST
			THEN IF NOT (.SYM[IDATTRIBUT(COMBL)]	! COMMON block
					AND NOT .SYM[IDATTRIBUT(INCOM)])
			THEN IF NOT (.SYM[IDSUBROUTINE]		! Subroutine
				AND .SYM[IDATTRIBUT(NOALLOC)])	! or var?
			THEN IF NOT (.SYM[OPR1] EQL FNNAMFL	! External name
				     AND (.SYM[IDLIBFNFLG]	! library fn
					OR .SYM[IDSUBROUTINE]))	! subroutine
%2562%			THEN IF NOT (.SYM[OPR1] EQL FNNAMFL	! EXTERNAL name
%2562%					AND .SYM[IDATTRIBUT(INEXTERN)]	! used
%2562%					AND NOT .SYM[IDFUNCTION]) ! as funct.
			THEN IF NOT (.FLGREG<PROGTYP> EQL MAPROG ! Main program
					AND .SYM[IDATTRIBUT(FENTRYNAME)])
			THEN IF SRCHLIB(.SYM) EQL -1	! Not lib fn, undotted
							! name would appear to
							! be a variable
			THEN
			BEGIN	! Give a warning, this symbol must be declared!

				FATLERR(.SYM[IDSYMBOL], 0, E304<0,0>);
				SYM[IDIMPLNONE] = 1;		! Gave message

			END;	! Give a warning, this symbol must be declared!

			SYM = .SYM[CLINK];	! Next linked symbol (or 0)

		END;	! Contents of each bucket in the symbol table

	END;	! Walk each hash bucket in the symbol table

END;	! of CIMPLNONE

END
ELUDOM