Google
 

Trailing-Edge - PDP-10 Archives - BB-D480F-SB_FORTRAN10_V10 - act1.bli
There are 26 other files named act1.bli in the archive. Click here to see a list.


!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
!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: T.E. OSTEN/FJI/MD/SJW/JNG/DCE/TFV/CKS/AHM/CDM/RVM/SRM/TGS/AlB/MEM

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

GLOBAL BIND ACT1V = #10^24 + 0^18 + #2520;	! Version Date: 12-Feb-85

%(

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

69	-----	-----	MAKE USE COUNT FOR IMPLIED DO LOOP LABELS
			2 INSTEAD OF 1
70	-----	-----	GENERATE LABELS FOR DIMENSION BLOCKS FOR ARRAYS
			THAT ARE PROTECTED (ALSO - COMMENT OUT CODE IN
			"BLDARRAY" THAT APPEARS TO PROCESS MULTIPLE
			ARRAYS SPECIFIED BY THE SAME DIMENSION SPECIFICATION)
71	-----	-----	FIX OPERSP FIELD OF SLIST CALLS

72	-----	-----	MODIFY "BLDARRAY" TO GENERATE DIMENSION LABELS
			FOR ALL ARRAYS IF THE "BOUNDS" SWITCH WAS SPECIFIED.
			(WE HAVE DONE AWAY WITH THE "ISPROT" FLAG ON INDIVIDUAL
			ARRAYS)
76	-----	-----	DETECT UNDETECTED SUBSCRIPTED IMPLICIT DO INDICES

77	-----	-----	PUT PARAMETER STUFF IN NAMCHK AND NAMDEF.
			PUT *N OVERRIDE IN BLDARRAY.
			CHANGE NO PARAMETERS IN FUNCTION TO WARNING

78	-----	-----	IN FUNCGEN - NO LONGER SET FNNAME ON FUNCTIONS.
				  - PROGNAME IS NOW SET IN ACTION PNAMSET

79	-----	-----	MAKE A LINKED LIST OF ENTRY POINT NAMES IN FUNCGEN

80	-----	-----	ALLOW DIMENSION A(1:3)

81	-----	-----	DUMMIES CAN BE IN EXTERNAL STATEMENTS

82	-----	-----	CLEAR THE NOALOC BIT IN THE OTHER PLACE
			WHERE THE SPECIAL FORMAL ARRAY PSEUDOSYMBOL TABLE
			ENTRY IS GENERATED - FUNCGEN

83	-----	-----	CHANGE NAMDEF AND NAMCHK TO INTERPRET THE &/* EXTERNAL
			STATEMENT PROPERLY

84	-----	-----	FIX BLDARRAY SO THAT IT ACCEPTS THE TYPE INFORMATION
			FOR TYPE STATEMENTS BEFORE THE DIMENSION INFORMATION
			RATHER THAN AFTER

85	-----	-----	CHECK FOR DUPLICATE DUMMY ARGS IN FUNCTIONS,
			SUBROUTINES AND ENTRYS

86	----	-----	HAVE BLDDIM USE  DVARFLGS TO CLEAR THE FLAGS IN
			THE DIMENSION TABLE ENTRY.

87	-----	-----	DETECT THE CASE OF AN IMPLIED DO SPEC WITHOUT
			PRECEEDING VARIABLE LIST OF SOME SORT - DATALIST

88	-----	-----	ISSUE A WARNING MESSAGE WHEN LABEL INDICATORS 
			APPEAR IN THE FORMAL ARGUMENT LIST OF A FUNCTION
			FUNCGEN

89	-----	-----	FIX BLDARRAY SO THAT IT WILL REVERSE
			THE CALCULATED DIMENSIONS OF AN ARRAY WHICH
			HAS GONE TO DOUBLE PRECISION DUE TO
			AN IMPLICIT STATEMENT AND IS THEN EXPLICITLY TYPED
			TO SINGLE PRECISION

90	-----	-----	CHECK IN BLDDIM TO BE SURE THAT DIMENSIONS
			ARE WITHIN A RESPECTABLE RANGE

91	-----	-----	IN BLDDIM, CHANGE REFERENCE TO "DEBUG" FLAG
			TO "DBGDIMN" FLAG 

92	-----	-----	FUNCGEN - FIX DUPLICATE DUMMY PARAMETER CHECK SO
			IT REALLY WORKS

93	-----	-----	MAKE A CHECK FOR DO INDEX MODIFICATION IN NAMSET
			SO THAT ALL CASES ARE CHECKED

94	-----	-----	NAMSET WAS NOT CALLED FOR IMPLICIT DO INDICES

95	-----	-----	BLDDIM - CHECK FOR ZERO SINGLE DIMENSION

96	-----	-----	WITH THE ADVENT OF SIGNED PARAMETERS  - BULDDIM
			MUST BE PREPARED TO CHECK THE SIGN OF THE NUMBER
			NOT JUST WHETHER OR NOT A - WAS
			PRESENT

97	-----	-----	EXTEND NAMDEF TO DETECT REFERENCE TO DUMMY PARAMETERS
			BEFORE THEY HAVE BEEN DEFINED

***** Begin Version 4A *****

99	 230	-----	RESTORE NOALLOC BIT WHEN ADJUSTABLE DIMENSION
			IS NOT YET DEFINED, (MD)

100	232	-----	FIX BLDUNIT - IT NEEDED ONE MORE LEVEL OF
			INDIRECTION IN THE RECORD NUMBER PROCESSING., (MD)

101	235	-----	FIX NAMELIST PROBLEMS
			USING NEW PARAMETER NMLSTITM, (DT/MD)
102	265	15946	ADD CHECK FOR VARIABLE IN DATA STATEMENT TWICE, (JNT)
103	272	-----	CHANGE 102 TO ONLY CHECK SIMPLE VARIABLES, NOT ARRAYS,
			(JNT)

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

104	VER5	-----	SHARE .I OFFSET IN DIMENTRY FOR ARRAYS
			WITH VARIABLE UPPER BOUND (LINK DIM ENTRIES), (SJW)
105	410	-----	MAKE DTABPTR GLOBAL SO WILL BE INITIALIZED TO 0, (SJW)
106	414	QA625	FIX SHARING .I OFFSET SO ONLY SHARES DIM2 .I
			  IF DIM1 SAME, (SJW)
107	415	18964	DON'T DESTROY SYMBOL TABLE ENTRY FOR A FORMAL
			  FUNCTION IF A LATER ENTRY STATEMENT SEEN WITH
			  THE FUNCTION AS A PARAMETER.
108	423	QA709	FIX PATCH 414: DIMNUM=1 => ARRAY HAS 1 DIM NOT 2, (SJW)
109	460	19477	TEST FOR OVERSIZED DIMENSIONING CORRECTLY, (DCE)

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

110	567	22284	MAKE EXTERNAL STMNT APPLY TO ALL ENTRY POINT PARAMS
111	571	22378	FIX V5 OPTIMIZATION THAT SHARES 2ND OFFSET OF
			  FORMAL ARRAYS IF 1ST DIMENSIONS = SO ALL WILL
			  WORK IF ARRAY SUBSEQUENTLY TYPED DIFFERENTLY
			  (DIFFERENT # WORDS) THAN WHEN SHARING 1ST DONE, (SJW)
112	572	21825	CHECK IMPLIED DO INDEX FOR ALREADY ACTIVE (FROM
			  AN ENCLOSING IMPLIED OR REAL DO), (SJW)
113	601	Q20-26	FIX EDIT 572 TO CHECK IMPLIED DO INDEX IN DATA
			  STATEMENT FOR ALREADY ACTIVE FROM AN ENCLOSING
			  IMPLIED DO, (SJW)

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

114	627	23755	FIX EDIT 571 TO CORRECTLY ADJUST ALL DIMENSION
			TABLE MULTIPLICATIVE FACTORS BY THE RIGHT
			CONSTANT IF AN ARRAY IS LATER DISCOVERED TO
			REQUIRE A DIFFERENT NUMBER OF WORDS PER ENTRY
			THAN ORIGINALLY THOUGHT. EDIT 571 ONLY FIXED
			THE FIRST SUBSCRIPT., (JNG)
115	635	24868	FIX DATALIST TO RETURN -1 IF IT GETS E66
			(CANNOT INIT DUMMY PARAMETER IN DATA), (JNG)
116	663	25643	FIX TYPING OF FORMAL FUNCTIONS (EXTERNAL STMNTS), (DCE)
117	717	26560	GIVE REASONABLE ERROR MESSAGE FOR
			REPEATED PARAMETER STATEMENT, (DCE)
118	741	-----	ADD SLASHWARN ROUTINE, (DCE)

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

119	760	TFV	1-Jan-80	-----
	Add routines to handle keywords in I/O control lists

127	1132	AHM	22-Sep-81	Q10-06347
	Fix casing of some error message fragments.

128	1136	AHM	19-Oct-81	Q20-01652,Q20-01656
	Delete code that unjustifiably decremented SNREF for labels
	in BLDKEY, since it screwed up optimizations.

1155	EGM	9-Jun-82
	Allow BLDARRAY to continue processing ONEARRAY list after semantic
	errors are seen. This allows detection of multiple errors per
	statement, and frequently eliminates annoying 'not dimensioned'
	errors.

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

120	1202	DCE	1-Jul-80	-----
	Add code to handle expressions on output lists.  Separate out
	the routine LISTIO to handle the cases.  Also add routine CCONST
	to handle the especially difficult complex constants in I/O lists.
	Rework DATALIST to only include code for DATA lists (not I/O lists).
	Add BLDIOLSCLS routine as subsidiary routine.

121	1203	DCE	21-Nov-80	-----
	Fix up various problems with CCONST, especially with GFLOAT numbers.
	Change the way complex constants are handled with the new I/O list
	processing.

122	1212	TFV	29-Apr-81	------
	Change LITERAL to HOLLERITH in BLDIOLSCLS.

123	1213	TFV	20-May-81	------
	Fix BLDARRAY to handle character data.  Fetch the length from the
	stack.  It is deposited by ASTER.  Fix BLDDIM and BLDARRAY to calculate
	array size, array offset, and factors; character data uses character
	count not word count.  

124	1214	CKS	8-Jun-81
	Use DOIFSTK instead of LASDOLABEL<LEFT> to stack implied DOs.

125	1250	CKS	6-Aug-81
	Make BLDDIM always allocate a .I temp for factor 1 of adjustable 
	character arrays

126	1242	CKS	22-Sep-81
	Modify the code that calculates number of elements in an array to
	know about character arrays

129	1400	CKS	20-Oct-81
	In FUNCGEN, allow FUNCTION statements to have a null argument list

130	1407	CKS	27-Oct-81
	Fix BLDIOLSCLS so character constants in IO lists go out as DATACALLs
	not SLISTs.

131	1410	CKS	28-Oct-81
	Fix BLDARRAY to know about modified syntax of COMMON statement.  Other
	declarations call BLDARRAY with the syntax tree resulting from
	+ONEARRAY.  COMMON now calls it with the tree +(ONEARRAY), which
	contains an additional level of indirection.

132	1412	CKS	4-Nov-81
	Allow statement function and common block to have same name

133	1413	CDM	4-Nov-81
	Change FUNCGEN to use argument structure ARGUMENTLIST in the 
	assignments of argument nodes.

134	1416	CKS	9-Nov-81
	Add BLDSUBVAR to do semantics for SUBVARSPEC.  It returns a
	DATAOPR or ARRAYREF or SUBSTRING node.  Have DATALIST call
	BLDSUBVAR instead of BLDVAR so DATA statements can have substrings.

135	1422	TFV	12-Nov-81	------
	Change FUNCGEN  to  generate  an extra  argument  for  character
	functions.  It is the  first argument and is  the result of  the
	character function.  It points to the symbol table entry for the
	function name.

136	1423	CKS	19-Nov-81
	Don't allow character function names to be initialized by DATA
	statements.

137	1432	RVM	8-Dec-81
	Make routine BLDKEY allow integer variables to be values of the
	FMT= keyword in I/O statements.  Fix wrong error messages given
	when an asterisk or a name is incorrectly given as the value of
	a keyword.  Also, change the code so that it does not explicitly
	manipulate VREG.

138	1434	TFV	14-Dec-81
	Modify BLDARRAY to handle the case FUNCTION FOO(...) followed by
	CHARACTER*n FOO.  FOO  becomes a  character function  and a  new
	argument list is built using CHARGLIST.

139	1442	RVM	17-Dec-81
	Modify BLDFORMAT and KORFBLD to allow INTEGER variable format
	specifiers even without the FMT= keyword.

140	1444	CKS	18-Dec-81
	Attempt to READ into a substring gives "?Expression illegal in input
	list".  Change check to allow substrings in input lists.

141	1457	RVM	12-Jan-82
	Fix BLDFORMAT to allow INTEGER variable format specifiers in
	ENCODE/DECODE statements (Edit 1442 did not quite accomplish
	this).  Also, fix a poor error message that implies that name
	lists are legal format specifiers in ENCODE/DECODE statements.

142	1464	RVM	26-Jan-82
	Fix a error message to reflect the existence of the INTRINSIC
	statement.

143	1466	CDM	1-Feb-82
	Add code to FUNCGEN to link together entry statements.
	Also fix FUNCGEN so that it creates an argument list for  character
	functions's return values even if  the user specified no  arguments
	in the definition.

144	1471	RVM	5-Feb-82
	Make the macro SIZOFARRAY into a GLOBAL ROUTINE.  Also, rearrange its
	code and add some comments.

145	1473	SRM	8-Feb-82
	Set CHARUSED when NAMSET or NAMREF is called for character variables

1505	AHM	9-Mar-82
	Set the  psect  index to  PSDATA  when creating  symbol  table
	entries for various temps in TMPGEN and for the variable  that
	holds non-adjustable formal  array base  addresses in  FUNCGEN
	and BLDDIM.

1510	RVM	14-Feb-82
	Implement assumed-size arrays.  Modify BLDDIM to process an asterisk
	as the upper bound of the last dimension of an array.  Put a check
	in SIZOFARRAY to make sure it is not called to get the size of an
	assumed-size array.  Put a check in BLDIOLSCLS to make assumed-size
	arrays illegal in I/O lists.  As an extra to this edit, do some clean
	up of BLDDIM (it really needs it).

1511	CDM	17-Mar-82
	Error processing for common variables given in a SAVE statement.

1514	RVM	22-Mar-82
	Define mask in NAMDEF to disallow formal arguments as intrinsic
	functions.

1527	CKS	9-Apr-82
	Modify BLDDIM to read changed tree shape.  Dimension bounds can
	now be constant expressions.

1530	TFV	4-May-82
	Modify BLDIOLSCLS and DATALIST to  use symbols for the sizes  of
	IOLSLCS nodes.

1550	CKS	1-Jun-82
	Insert some SAVSPACE calls in LISTIO

1560	TFV	14-Jun-82
	Modify BLDDIM to  give an  array too large  error for  character
	arrays  greater  than  or  equal  to  CHARSPERWORD  *  2  **  18
	characters and numeric arrays greater than  or equal to 2 **  18
	words.

1575	TFV	7-Jul-82
	Modify BLDARRAY  to handle  'var *  len (subs)  * len'  in  type
	declarations.

1670	CKS	10-Nov-82
	Allow arbitrary expressions as adjustable array dimension bounds.

1715	RVM	12-Jan-83
	Add comment to NAMSET about the use of the STORD attribute.

***** End V7 Development *****

1741	CDM	7-APR-83
	Give error message for a implied DO index that is character.

1743	CDM	19-APR-83
	Fill in parent pointer for array expression node.

1754	CDM	26-May-83
	Remove incorrect error message saying that the use of a variable
	in an adjustably dimensioned array declaration is illegal before
	defining it  as a  dummy  in an  ENTRY  statement later  in  the
	program.  Also  start giving  error messages  (again) for  using
	variables in these declarations that  are not later declared  to
	be dummys or in common.

1767	CDM	20-Jul-83
	Correct   edit   1743   which    fills   in   parent    pointers
	indiscriminately without checking to see if they are expressions
	first.

1773	TGS	9-Aug-83	SPR:10-34064
	When checking in DATALIST for an illegal attempt to initialize a
	character function name in a DATA statement, do not issue a
	fatal error if a DATA statement initializes a character variable
	with the same name as a PROGRAM, SUBROUTINE or BLOCK DATA
	statement.  In this case IDATTRIBUT(FENTRYNAME) may have been
	set by PROGSTA and the variable be of type character even though
	no character function is being initialized.  Nail the illegal
	case down by also checking if FLGREG<PROGTYP> is FNPROG.

2051	TFV	27-Apr-84
	Fix FUNCGEN  to set  the character  length for  entry points  in
	character functions properly.  They  were inheriting the  length
	from the last CHARACTER declaration.


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

2224	RVM	3-Oct-83
	Set the PSECT fields for arrays to the proper values under
	/EXTEND.  Note that formal arrays can never be in .LARG. (but
	of course an actual corresponding to a foral can be), so never
	set the PSECT fields for these arrays to .LARG. and set the
	PSECT fields to .DATA. everytime an array becomes a formal.

2253	AlB	28-Dec-83
	Added compatibility flagging for return labels in argument list.
	Routine:
		FUNCGEN

2270	AlB	6-Jan-84
	Added VAX compatibility flagging to catch items with duplicated names.

	NAMELISTs, EXTERNALs, statement functions and PARAMETERs can no longer
	be the same name as an item in a NAMELIST list.

	NAMELIST and EXTERNAL names can no longer be same as variable names.

	PARAMETER names can no longer be same as an array name.

2276	AlB	26-Jan-84
	Fixed bug caused by Edit 2270: It was erroneously flagging the
	EXTERNAL items which were dummy arguments.

	Added routine COMPFLAG, which does compatibility flagging for
	conflicts between our intrinsic functions & subroutines, and
	those for VAX and Fortran-77.  This routine is called from NAMCHK.

2277	AlB	26-Jan-84
	Reworked COMPFLAG so that it was less stringent about complaints
	regarding those names which are intrinsic routines on VAX, but
	mean nothing to Fortran-10/20.

	Added one element to the set in the CASE statement in NAMDEF.
	INTRSCDEF was never in the CASE set, even though INTRSTA calls
	NAMDEF with INTRSCDEF as a type. This has been a bug since at
	least edit 1514.

	This new CASE set element does nothing unless compatibility
	flagging is being done.  If flagging is being done, it issues a
	flagger warning if the INTRINSIC routine name is not recognized
	by the VAX.

2300	AlB	27-Jan-84
	Changed the argument list for COMPFLAG in order to better specify
	that which we are checking in compatibility flagger.

	Changed the order of tests in COMPFLAG, so that only things which
	look like function names are tested.  This prevents the testing of
	all ordinary things, and thus speeds the flagger process considerably.

	Made some minor format modifications in order to conform to
	programming conventions.

2303	AlB	3-Feb-84
	Remove the CFFSNAME variable, and instead reference the symbol table
	to get name to stick into warning messages; WARNLEX will now print
	the correct name (or at least the 'dotted' version of that name).

	Added a test in NAMDEF to check to see if an INTRINSIC name was
	known to Fortran-77, and complain if not. This change, plus some
	rework to satisfy programming conventions, caused an entire rewrite
	of one element of the CASE set.

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.

2327	RVM	23-Mar-84
	Among other things, put CHARACTER variables into the proper
	PSECTS.  It turned out that setting the proper psects for
	variables turned out to be much more complicated than was first
	thought.  The distributed nature of FORTRAN's declaration syntax
	require the compiler to set the psects for a variable four times
	in some cases.  Thus a general purpose routine named SETPSECTS
	was created that will set the psect fields properly for any type
	of variable passed to it.  (Although all parts of the compiler
	could use SETPSECTS, not all do for the sensible reason that
	local knowledge about a variable make the extensive case analysis
	of SETPSECTS unnecessary in that case.)

	Make sure all formals are put in the .DATA. psect.

2340	AlB	13-Apr-84
	Removed the COMPFLAG tests which flag those functions which are
	intrinsic for us, but not VAX and/or ANSI.  This flagging is done
	at run-time, and need not be done by the compiler.

	Since this edit so totally eviscerated COMPFLAG, that routine was
	removed, and its one call was replaced by a single flagger test.

2343	RVM	18-Apr-84
	Make SETPSECTS know about COMMON variables.

2455	MEM	30-Aug-84
	Replace all references to VAX with VMS.

2473	CDM	29-Oct-84
	Add IMPLICIT NONE for the Military Standard MIL-STD-1753.

2504	CDM	27-Nov-84
	Make 127 dimensions of arrays work, as advertised in the Fortran
	manual.  STK was used as a temporary holding area for the array
	bounds information in BLDDIM, and since the size is static, was
	being run over into the CHNLTB channel table.  Don't use of STK for
	temporary storage.  This was done way back (according to V5
	sources) because BLDDIM had many RETURNs for error conditions.
	This would save on dynamic memory if an error occured.  There is
	only one RETURN in there currently, at the end of the routine.  The
	size of the the memory needed is not changed by processing the
	dimensions, so we'll get the memory needed early and forget using
	STK!

	Also clean up a little.  Remove binds to magic locations in STK
	which just happened to be locations in the array dimension table.
	This is what REQUIRE files are for!  Make them local variables
	where needed for temporary calculations, or replace with the
	structure reference into the dimension table when it is really
	wanted to be referenced.  Add in some old edit numbers from V5A
	sources.

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.

2520	CDM	12-Feb-85	QAR 853033
	Add to edit 2504.  Use correct pointer into array dimension
	table, not into the dimesions themselves.

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

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

)%

!++
! These are the action routines for the BNF.
!
! To return a value to the BNF, return:
!
!	-1	Didn't find what I wanted.
!
!	0	Success, I found what I wanted.
!--

SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE ASHELP.BLI;
SWITCHES LIST;
SWITCHES NOSPEC;


FORWARD
	NAMDEF(2),
	NAMSET(2),
	NAMREF(2),
	NAMCHK(2),
	FUNCGEN(2),
	TYPEGEN(1),
	TMPGEN(1),
	BLDDIM(1),
	AJDIMSTK(1),
	CHKCOMMON(1),
	CHKTYPE(1),
	BLDARRAY(1),
	BLKSRCH(1),
	BLDVAR(1),
	BLDSUBVAR(1),
	CCONST(2),
	SETPSECTS(1),		![2327] Set IDPSECT and IDPSCHARS for variable
	SIZOFARRAY(1),
	BLDIOLSCLS(1),
	LISTIO(1),
	DATALIST(1);

GLOBAL SETUSE;		!SET TO INDICATE WHETHER VARIABLE IS BEING
			!SET (ASSIGNED TO) OR USED (REFERENCED)
EXTERNAL
%2322%	ADDINT,		! Add two integers
	ARRXPND,
%2224%	BIGARY,		!The size the smallest array to put into .LARG.
	C1H,
	C1L,
	C2H,
	C2L,
%2253%	CFLEXB,		! Put out compatibility warning
%2276%	CFSRCLIB,	! Search table of incompatible functions/subroutines
	CGERR,
%1434%	CHARGLIST,	! Routine to build a character function argument list
			!  from  a non-character  function  argument list.
	CHLEN,		! CHLEN is used to hold the length for CHARACTER decl's
%1473%	CHARUSED,	! Global flag for character data is used
	CKDOINDEX,	! CHECK DO INDEX ALREADY ACTIVE
	CNSTCM,
	CNVNODE,
	COPRIX,
	COMBLKPTR,
	CORMAN,
	CREFIT,
	CURDOINDEX,	! PTR to current DO index variable
%2507%	DATASTA,	! Routine for processing DATA statements.
	DATASUBCHK,
	DIMSTK,
	DINODE DOIFSTK, ! Stack of open DO and IF stmts
	DOCHECK,	! Remove DO label from active DO list
	DOXPN,
	DTABPTR,	! Head of dim entry list
	E21,		! DO index already active message
	E115,		! Bad DO index message
	E125,
	E126,
	E128,		! Empty list, ie, (I=1,10)
	E129,
	E136,
	E137,		! Variable dimensions only allowed in subprograms
	E141,		! Array too large
	E145,
	E146,		! Expression illegal in input list
%1741%	E160,		! Can't assign numeric to character variable
	E174,
	E189,		! Only upper bound of last dimension may be asterisk
	E190,		! Assumed size arrays only allowed in subprograms
	E191,		! Assumed size arrays can not be used . . .
%1511%	E192,		! Illegal in SAVE statement message
%1575%	E205,		! Size modifier conflict in type declaration
%2276%	E238,		! Extension to Fortran-77: Not intrinsic in ANSI
%2455%	E273,		! VMS incompatibility: xxxxx same as entry point
%2455%	E276,		! VMS incompatibility: xxxxx same as namelist
%2455%	E279,		! VMS incompatibility: xxxxx same as variable or statement function
%2455%	E288,		! Fortran-77 or VMS: Return label $ (or &)
%2455%	E297,		! VMS incompatibility: Not intrinsic on VMS
%2473%	E304,		! Must declare variables with IMPLICIT NONE
	BASE ENTPREVIOUS,	! Address of the previous entry statement or 0.
%2507%	ENTRSTA,	! Routine for processing ENTRY statements.
%2473%  EQUISTA,	! Routine for processing EQUIVALENCE statements.
	FARRY,
	FATLEX,
	GENLAB,  ! Make a label table entry for a compiler generated label
	IDTYPE,
%2473%	IMPNONE,	! Flag to indicate if IMPLICIT NONE was given
%1754%	INADJDIM,	! We are in parsing a statement they could have
%1754%			! an adjustable dimensioned array declaration.
	INITLTEMP,
	KDPRL,
	KTYPCB,
	KTYPCG,
	LABREF,
	LASDOLABEL,	! Ptr to target of most recent DO stmt
	LEXLINE,
	MAKPR1,		! Make a expression node.
	MAKESUBSTR,
	MULENTRY,	! Pointer to first entry point name
%2322%	MULINT,		! Multiplies two integers
	NAME,
	NAMLSTOK,
	NEWENTRY,
	NONIOINIO,
	ONEPLIT,
	PROGNAME,
	SAVSPACE,
	SORCPTR,	! Pointer to the first program statement
	SP,
	STK,
	STMNDESC,	! Current statement description block.
%2322%	SUBINT,		! Subtracts two integers
	TBLSEARCH,
	TYPE,
	TMPCNT[4],
%2322%	VMSIZE;		! Size of virtual memory


	% THE FOLLOWING TABLE IS USED TO PRODUCE THE ERROR MESSAGES 
	  IT IS BASED UPON THE BIT POSITION OF THE CONFLICTING IDATTRIBUT
	  FIELD BIT %
	BIND DUMDUM  =  PLIT  (

%1464%	R18 NAMES R23 NAMES  'as INTRINSIC or EXTERNAL?0',
%1132%	R22 NAMES  'as dummy parameter?0',
%1132%	R19 NAMES 'in type statement?0',
%1132%	R24 NAMES 'in DATA statement?0',
%1132%	R26 NAMES 'in COMMON?0',
%1132%	R27 NAMES 'in EQUIVALENCE?0',
%1132%	R28 NAMES 'as an entry point name?0',
%2270%	R29 NAMES 'in NAMELIST?0',
%1132%	R33 NAMES 'as statement function?0',
%1132%	R34 NAMES 'as COMMON block?0',
%1132%	R35 NAMES 'as NAMELIST?0',

%1132%	AYORFN NAMES ' as an array or FUNCTION?0',
%1132%	AY NAMES 'as an array?0',
%1132%	FNN NAMES 'as a FUNCTION?0',
%2270%	IDENT NAMES 'as an identifier?0'
);


GLOBAL ROUTINE NAMDEF(TYPE,ID)=
BEGIN

	! Checks for inconsistencies for the symbol ID passed in  useage
	! TYPE.
	!
	! Arguments:
	! 	ID - pointer to symbol table entry 
	! 	TYPE - Indicator of use of symbol to check validity of.

	MAP BASE ID;


	! The following binds are used to make the symbol table attribute
	! field masks
	
	BIND
		NAMLST = 1^35,		! NAMELIST
		CMNBLK = 1^34,		! common block
		STFN = 1^33,		! statement function
		ENTPNT = 1^28,		! entry point
		EXTERN = 1^23,		! EXTERNAL
		EXTRSGN = 1^18,		! user function
		TYPED = 1^19,		! type statement
		EXTBTH = 1^18 + 1^23,
%2270%		NAMIN = 1^29,		! in NAMELIST
		EQVIN = 1^27,		! Equivalence
		COMIN = 1^26,		! in common block
		DATAIN = 1^24,		! in DATA
		DUMIEE = 1^22,		! dummy parameter
%2270%		DATADEF = NAMIN+EQVIN+COMIN+DATAIN, ! some kind of variable
%2455%		VMSVAR = DATADEF+STFN;	! Variable or statement function

	! The following are masks (indexed by TYPE) of the symbol  table
	! IDATRIBUTE field.  If  the TYPE  .and.  ID  are non-zero  then
	! there is a conflict indicating an error.
	
%2276%	BIND	DEFMASK = UPLIT (
	
		%ARRYDEF%	NAMLST + STFN + ENTPNT + EXTBTH,
		%ARRYDEFT%	NAMLST + STFN + ENTPNT + EXTBTH + TYPED,
%2270%		%STFNDEF%	NAMLST + STFN + ENTPNT + EXTBTH + DATADEF + DUMIEE,
%2276%		%EXTDEF%	NAMLST + STFN + ENTPNT + EXTBTH  + DATADEF,
%2270%		%NMLSTDEF%	NAMLST + STFN + ENTPNT + EXTBTH + DUMIEE + DATADEF,
		%VARARY%	NAMLST + STFN + EXTBTH + COMIN + DUMIEE,
		%IDDEFT%	NAMLST + TYPED,
%2270%		%IDDEFINE%	NAMLST + STFN + ENTPNT + DATADEF,	%DUMMY PARAMETERS%
		%ENTRYDEF%	NAMLST + STFN + ENTPNT + EXTBTH + CMNBLK + DUMIEE,
%2276%		%EXTDEFS%	NAMLST + STFN + ENTPNT + EXTBTH + CMNBLK  + DATADEF,
		%CMNBLK%	ENTPNT + EXTRSGN,
%2270%		%PARADEF%	NAMLST + CMNBLK + STFN + ENTPNT + EXTBTH + DATADEF + DUMIEE,
		%NMLSTITM%	NAMLST + STFN + EXTBTH + DUMIEE,
%2270%		%INTRSCDEF%	NAMLST + STFN + ENTPNT + EXTBTH  + DATADEF +  DUMIEE
	);
	
	!***************************************************************
	! NAMDEF is  referenced from  the  following routines  with  the
	! following types:
	!	
	! Semantic routine	-	types
	!	
	! TYPE STATEMENTS 		ARRYDEFT, IDDEFT
	! FUNCTION			ENTRYDEF, IDDEF
	! SUBROUTINE			ENTRYDEF, IDDEF
	! ENTRY				ENTRYDEF, IDDEF
	! PROGRAM			ENTRYDEF
	! BLOCKDATA			ENTRYDEF
	! DIMENSION			ARRYDEF
	! COMMON			VARARY, CMNBLK, ARYDEF
	! EXTERNAL			EXTDEF, EXTDEFS(LIB FUNCTION)
%2277%	! INTRINSIC			INTRSCDEF
	! NAMELIST			NMLSTDEF, VARARY
	! STATEMENT FUNCTION		STFNDEF
	! PARAMETER			PARADEF
	!	
	!
	! Note that  EQUIVALENCE and  DATA statements  reference  NAMSET
	! rather than NAMDEF.   This is done  mainly for convience.   If
	! they  could  be  changed  to  reference  NAMREF  it  might  be
	! possible, with  a  little  thought,  to  detect  instances  of
	! definition after reference.
	!***************************************************************

	! This mask defines  which types  can be  the same  as an  entry
	! point name as long as its not in a function

	BIND	OKSAMEASENTRY  = 1^ARRYDEF + 1^ARRYDEFT + 1^STFNDEF +
				1^EXTDEF + 1^NMLSTDEF + 1^IDDEFINE  ;


%2276%	BIND  PDEFAS  =  UPLIT  (
%2270%	R18,R19,0,0,R22,R23,R24,0,R26,R27,R28,R29,0,0,0,R33,R34,R35  );

	REGISTER R;

	IF .FLGREG<CROSSREF>   THEN  CREFIT( .ID, SETT );

	! Check the attributes.   If the intended  use and any  previous
	! definition in the symbol table conflict (the AND is non zero),
	! continue checking and assign to R.

	IF  ( R _ .DEFMASK[.TYPE]<LEFT> AND .ID[IDATTRIBUT(ALLOFTHEM)] )  NEQ 0
	THEN

  		! Allow statement functions ,  arrays , namelists ,  and
  		! possible library  functions to  be the  same as  entry
  		! point names providing that this is not a function.

		IF ( 1^(.TYPE) AND OKSAMEASENTRY )  EQL  0
			OR  .FLGREG<PROGTYP>  EQL  FNPROG
			OR    .R NEQ   ENTPNT^(-18)
		THEN

 			! Allow entry point definitions  to be the  same
 			! as namelist, statement functions, and possible
 			! library  functions  as  long  as  its  not   a
 			! function

			IF .TYPE NEQ  ENTRYDEF
			  OR  .FLGREG<PROGTYP>  EQL  FNPROG
			  OR ( .R NEQ  NAMLST^(-18)
				AND  .R  NEQ  STFN^(-18)
				AND  .R  NEQ  EXTERN^(-18)  )
			THEN
				! Its a conflicting definition - give error
				RETURN  FATLEX(  .PDEFAS[35-FIRSTONE(.R)], ID[IDSYMBOL], E34 );


%2270%	! We must do  just a bit  more checking.  If  we find a fatal error,
%2270%	! assign VREG a positive value: the PLIT to be inserted in the error
%2270%	! message.
%2455%	! VMS incompatibilities give VREG a negative value: the error message
%2270%	! number.
%2270%	! When the CASE statement is completed, VREG is checked and appropriate
%2270%	! action taken.

	VREG _ 0;
	VREG _  CASE  .TYPE  OF   SET

	%ARRYDEF%	BEGIN
				IF .ID[OPRSP1]  NEQ  VARIABL1 THEN  AYORFN
%2270%				ELSE
%2455%					IF FLAGVMS
%2455%					THEN	! Flagging VMS incompatibilities
%2270%						IF .ID[IDATTRIBUT(FENTRYNAME)]
%2270%						THEN -(E273<0,0>)	! Same name as entry point
			END;
	%ARRYDEFT%	BEGIN
				IF .ID[OPRSP1]  NEQ  VARIABL1  THEN  AYORFN
			END;
	%STFNDEF%	BEGIN
				IF .ID[OPRSP1]  NEQ  VARIABL1  THEN  AYORFN
%2270%				ELSE
%2455%					IF FLAGVMS
%2455%					THEN	! Flagging VMS incompatibilities
%2270%						IF .ID[IDATTRIBUT(FENTRYNAME)]
%2270%						THEN -(E273<0,0>)	! Same name as entry point
			END;
	%EXTDEFS%	BEGIN
				IF  .ID[OPRSP1]  EQL  ARRAYNM1  THEN  AY
			END;
	%NMLSTDEF%	BEGIN
				IF .ID[OPRSP1]  NEQ  VARIABL1  THEN  AYORFN
%2270%				ELSE
%2270%				IF NOT .ID[IDATTRIBUT(NOALLOC)] THEN IDENT
%2270%				ELSE
%2455%					IF FLAGVMS
%2455%					THEN	! Flagging VMS incompatibilities
%2270%						IF .ID[IDATTRIBUT(FENTRYNAME)]
%2270%						THEN -(E273<0,0>)	! Same name as entry point
			END;
	%VARARY%	BEGIN
				IF .ID[OPRSP1]  EQL  FNNAME1 THEN  FNN
			END;
	%IDDEFT%		BEGIN END;
	%IDDEF%	BEGIN
				%CHECK HERE TO SEE THAT DUMMY PARAMETERS
				 HAVE NEVER BEEN REFERENCED %
				IF NOT .ID[IDATTRIBUT(NOALLOC)]
				  AND NOT  .ID[IDATTRIBUT(DUMMY)]
				THEN	RETURN FATLEX(.ID[IDSYMBOL],E136<0,0>)
%2270%				ELSE
%2455%					IF FLAGVMS
%2270%					THEN	! Compatibility check
%2270%						IF .ID[IDATTRIBUT(FENTRYNAME)]
%2270%						THEN -(E273<0,0>)	! Same name as entry point

			 END;
%2270%	! Entry definition
%2270%	! It cannot be a function name.
%2270%	! If it is an entry into a function subprogram, it cannot be an array name.
%2455%	! If VMS incompatibilities are being checked, it cannot be a NAMELIST name
%2270%	! nor a variable.
	%ENTRYDEF%	BEGIN
%2270%				IF (R=.ID[OPRSP1]) EQL FNNAME1 AND NOT .ID[IDATTRIBUT(NOALLOC)]  THEN  FNN
%2270%				ELSE
%2270%				IF .FLGREG<PROGTYP> EQL FNPROG
%2270%				THEN	! It is in FUNCTION subprogram
%2270%					IF .R EQL ARRAYNM1
%2270%					THEN AY	! It is array
%2270%					ELSE
%2455%						IF FLAGVMS
%2270%						THEN	! Test for incompatibilities
%2270%							IF .ID[IDATTRIBUT(NAMNAM)]
%2270%							THEN -(E276<0,0>)
%2270%							ELSE 0
%2270%						ELSE 0
%2270%				ELSE	! It is not in FUNCTION subprogram
%2455%					IF FLAGVMS
%2270%					THEN	! Testing incompatibilities
%2270%						IF .R EQL ARRAYNM1 THEN -(E279<0,0>)
%2270%						ELSE
%2270%						IF .ID[IDATTRIBUT(NAMNAM)] THEN -(E276<0,0>)
%2270%						ELSE
%2455%							IF (.ID[IDATTRIBUT(ALLOFTHEM)] AND VMSVAR^(-18)) NEQ 0 OR
%2270%							    NOT .ID[IDATTRIBUT(NOALLOC)]
%2270%							THEN -(E279<0,0>)	! It is variable
			END;
	%EXTDEF%	BEGIN
				IF .ID[OPRSP1]  EQL  ARRAYNM1  THEN  AY
%2270%				ELSE
%2270%				IF NOT .ID[IDATTRIBUT(NOALLOC)] THEN IDENT
			END;
	%CMNBLK%	BEGIN
				IF .ID[OPRSP1]  EQL  FNNAME1 AND NOT .ID[IDATTRIBUT(NOALLOC)]  THEN FNN
			END;
	%PARADEF%	BEGIN
%2270%				IF .ID[OPRSP1] EQL ARRAYNM1
%2270%				THEN AY		! It is array
%2270%				ELSE
				IF NOT .ID[IDATTRIBUT(NOALLOC)]
%2270%				THEN IDENT	! It is identifier
				![717] IF ALREADY DEFINED AS PARAMETER (IF THIS IS A REDUNDANT
				![717] PARAMETER DEFINITION OR REDEFINITION) GIVE FATAL ERROR
%[717]%				ELSE IF .ID[IDATTRIBUT(PARAMT)] THEN .LEXNAM[CONSTLEX]
			END;
%2277%	%NMLSTITM%	BEGIN
				IF .ID[OPRSP1] EQL FNNAME1 THEN FNN
%2270%				ELSE
%2455%					IF FLAGVMS
%2270%					THEN	! Compatibility flagging
%2270%					IF .ID[IDATTRIBUT(FENTRYNAME)] AND
%2270%					   .FLGREG<PROGTYP> NEQ FNPROG
%2270%					THEN	! Same name as entry point
%2270%						-(E273<0,0>)
%2277%			END;

%2277%	%INTRSCDEF%	BEGIN
%2303%			    LOCAL VALBITS;	! Value reurned by CFSRCLIB
%2303%
%2303%			    IF FLAGEITHER
%2303%			    THEN IF (VALBITS = CFSRCLIB(.ID)) NEQ 0
%2303%			    THEN
%2303%			    BEGIN	! Compatibility checks
%2303%
%2455%				IF FLAGVMS	! See if VMS knows about it
%2455%				THEN IF (.VALBITS AND CFNOTFNVMS) NEQ 0
%2303%				THEN WARNLEX(ID[IDSYMBOL],E297<0,0>);
%2303%
%2303%				IF FLAGANSI	! See if ANSI knows about it
%2303%				THEN IF (.VALBITS AND CFNOTFNF77) NEQ 0
%2303%				THEN WARNLEX(ID[IDSYMBOL],E238<0,0>);
%2303%
%2303%			    END;	! Compatibility checks
%2303%
%2303%			    VREG = 0	!Pretend there was no error
			END
	
	TES;

	! If error was found above, then give error message now.
%2270%	IF .VREG GTR 0
%2270%	THEN	! Fatal error
%2270%		RETURN  FATLEX ( .VREG, ID[IDSYMBOL], E34 )
%2270%	ELSE
%2270%	IF .VREG LSS 0
%2270%	THEN	! Compatibility warning
%2270%	BEGIN
%2270%		WARNLEX(ID[IDSYMBOL],-.VREG);
%2270%		VREG=0	! Reset to pretend there was no error
%2270%	END
END;	! of NAMDEF

GLOBAL ROUTINE NAMSET(TYPE, ID)=	
BEGIN	% THE SYMBOL POINTED TO BY ID AND DEFINED BY TYPE IS 
	  BEING SET  %

	MAP BASE  ID;

	%CHECK FOR DO INDEX MODIFICATION%
	IF CKDOINDEX ( .ID )
	THEN	IF .LABOK(@STMNDESC)  EQL  0	!FORGET DATA AND EQUIV
		THEN	FATLEX(E77<0,0>);	!MODIFICATION WARNING

%1473%	! If variable being set is type character, set the CHARUSED
%1473%	!  flag
%1473%	IF .ID[VALTYPE] EQL CHARACTER
%1473%	THEN CHARUSED = TRUE;

	ID[IDATTRIBUT(STORD)] _ 1;
	IF  .FLGREG<CROSSREF>  THEN  CREFIT( .ID, SETT );
	RETURN  NAMCHK  ( .TYPE , .ID )

END;	! of NAMSET

GLOBAL ROUTINE NAMREF(TYPE, ID)=

BEGIN	% THE SYMBOL POINTED TO BY ID AND DEFINED BY TYPE IS BEING 
	  REFERENCED  %

	![1715] Note that this is not the only place that sets
	![1715] the STORD attribute.  The modules ACT1 and DOXPN
	![1715] also set it.

%1473%	MAP BASE  ID;

%1473%	! If variable being referenced is type character, set the CHARUSED
%1473%	!  flag
%1473%	IF .ID[VALTYPE] EQL CHARACTER
%1473%	THEN CHARUSED = TRUE;

	IF  .FLGREG<CROSSREF>  THEN CREFIT( .ID, USE );
	RETURN  NAMCHK ( .TYPE, .ID )

END;	! of NAMREF

GLOBAL ROUTINE NAMCHK(TYPE, ID)=

!++
!	Check to see if we have what we think we have and if not, output
!	an error message.
!--

BEGIN
	% THE FOLLOWING BINDS ARE USED TO MAKE THE SYMBOL TABLE ATTRIBUTE
	  FIELD MASKS  %
	
	BIND
		NAMLST = 1^35,
		CMNBLK = 1^34,
		STFN = 1^33,
		ENTPNT = 1^28,
		EXTERN = 1^23,
		EXTRSGN = 1^18,
		TYPED = 1^19,
		EXTBTH = 1^18 + 1^23,
		EQVIN = 1^27,
		COMIN = 1^26,
		DATAIN = 1^24,
		DUMIEE = 1^22;

BIND	DUMO  =  PLIT (

		VAORAY NAMES 'a variable or array?0',
		VARIB NAMES  'a scalar variable?0',
		AAY   NAMES  'an array?0',
		AFN   NAMES  'a subprogram name?0'	);

MAP	BASE ID;


%2507%	! If IMPLICIT NONE is given, then we must insure that the
%2507%	! variable is declared in a type statement,
%2507%	! Unless:
%2507%	!	- the warning has already been given for this symbol
%2507%	!	- the symbol is a subroutine name
%2507%	!	- the symbol is a library function name
%2507%	!	- we're parsing a DATA, ENTRY, or EQUIVALENCE statement

%2473%	IF .IMPNONE				! IMPLICIT NONE
%2473%	THEN IF NOT .ID[IDIMPLNONE]		! Message already given?
%2473%	THEN IF NOT .ID[IDATTRIBUT(INTYPE)]	! In declaration?
%2507%	THEN IF NOT .ID[IDSUBROUTINE]		! Subroutine
%2473%	THEN IF NOT (.ID[OPR1] EQL FNNAMFL	! External name
%2473%		     AND .ID[IDLIBFNFLG])	! library function
%2507%	THEN IF .STMNROUTINE(@STMNDESC) NEQ DATASTA<0,0> ! DATA
%2507%	THEN IF .STMNROUTINE(@STMNDESC) NEQ ENTRSTA<0,0> ! ENTRY
%2473%	THEN IF .STMNROUTINE(@STMNDESC) NEQ EQUISTA<0,0> ! EQUIVALENCE
%2473%	THEN
%2473%	BEGIN	! Give a warning, this symbol must be declared!
%2473%
%2473%		FATLERR(.ID[IDSYMBOL], .ISN, E304<0,0>);
%2473%		ID[IDIMPLNONE] = 1;		! Gave a message
%2473%
%2473%	END;	! Give a warning, this symbol must be declared!


	VREG _ 0;
	VREG _ CASE .TYPE OF SET

	BEGIN	%VARYREF%
		IF .ID[OPRSP1]  EQL FNNAME1
		  OR  .ID[IDATTRIBUT(NAMNAM)]
		THEN	VAORAY
	END;	%VARYREF%

	BEGIN	%VARIABL1%
		IF .ID[OPRSP1]  NEQ  VARIABL1
		  OR  .ID[IDATTRIBUT(NAMNAM)]
		THEN  VARIB
	END;	%VARIABL1%

	BEGIN	%ARRAYNM1%
		IF  .ID[OPRSP1]  NEQ  ARRAYNM1
		THEN     AAY
	END;	%ARRAYNM1%

	BEGIN	%FNNAME1%
		IF  .ID[OPRSP1]  EQL  FNNAME1
		THEN   
		BEGIN
			%CHECK TO SEE THAT POSSIBLE LIBRARY FUNCTIONS
			WHICH TURNED OUT NOT TO BE LIBRARY FUNCTIONS
			ARE NOT CONFLICTING WITH ANY GLOBAL NAMES %

%1412%			IF .ID[IDATTRIBUT(COMBL)]
%1412%			THEN	IF NOT .ID[IDATTRIBUT(SFN)]
%1412%				THEN FATLEX(R34,ID[IDSYMBOL],E34<0,0>);
%1412%			IF .ID[IDATTRIBUT(FENTRYNAME)]
%1412%			THEN FATLEX(R28,ID[IDSYMBOL],E34<0,0>);
			0
		END
		ELSE
		BEGIN
			IF .ID[OPRSP1]  EQL ARRAYNM1 OR NOT .ID[IDATTRIBUT(NOALLOC)] OR  ISDEFIND(ID)
				OR .ID[IDATTRIBUT(COMBL)]
			THEN	AFN	!ITS A VARIABLE OR ARRAY
			ELSE
			BEGIN
			 ID[OPERSP] _ IF .ID[IDATTRIBUT(DUMMY)] 
						THEN FORMLFN ELSE FNNAME;
			0
			END
		END
	END;	%FNNAME1%

	BEGIN	%NMLSTREF%
		%NO CONFLICTS HERE%
		0
	END;	%NMLSTREF%

	BEGIN	%PARAREF%
		RETURN  .ID[IDPARAVAL]
	END	%PARAREF%


	TES;

%2270%	! If error found, put out error message.
	IF  .VREG  NEQ   0
	THEN	RETURN  FATLEX (.VREG, ID[IDSYMBOL],E15<0,0> );

%2455%	!If flagging VMS incompatibilities, warn the user if this name is the
%2340%	!same as a non-function entry point
%2455%	IF FLAGVMS
%2340%	THEN IF .ID[IDATTRIBUT(FENTRYNAME)]
%2340%	THEN IF .FLGREG<PROGTYP> NEQ FNPROG
%2340%	THEN
%2340%	BEGIN
%2340%		WARNLEX(ID[IDSYMBOL],E273<0,0>);
%2340%		VREG=0	! Because WARNLEX clobbers it
%2340%	END;

%1754%	! Check if we should  mark the variable  "to be allocated".   If
%1754%	! parsing a type specification statement or DIMENSION statement,
%1754%	! then  this  ID  is  part  of  an  adjustable  dimension  array
%1754%	! declaration.  If it is not a dummy or in common yet (it may be
%1754%	! in a later COMMON or ENTRY statement), we should not  allocate
%1754%	! the variable  yet (error  message  processing on  whether  the
%1754%	! dummy is used before it is defined), and queue it up for later
%1754%	! checking that it does defined as either.
%1754%
%1754%	IF .INADJDIM
%1754%		AND NOT (.ID[IDATTRIBUT(DUMMY)] OR .ID[IDATTRIBUT(INCOM)])
%1754%	THEN	! Check later in  routine CKAJDI...
%1754%		AJDIMSTK(.ID)
%1754%	ELSE	! Indicate that  we  are using  this  name and  that  it
%1754%		! should be allocated.
		ID[IDATTRIBUT(NOALLOC)] = 0;

END;	! of NAMCHK

GLOBAL ROUTINE FUNCGEN(FPNT, TYPEFLG)=
BEGIN
	LOCAL BASE R1;
	REGISTER BASE T2;
		MAP BASE FPNT;
		REGISTER BASE T1:R2;

%1422%	LOCAL
%1422%		NUMARGS,	! The actual number of arguments for a function
%1422%		ARGOFFSET;	! Used when copying the argument list from STK

%1413%	LOCAL ARGUMENTLIST ARGNODE;
%1413%	LOCAL CNT;
	MACRO
		FCTN = 4$,
		ENT=1$;

	!----------------------------------------------------------------------
	! 
	!THIS ROUTINE IS CALLED WITH THE PARAMETER FPNT POINTING TO
	!THE LIST:
	!
	!IDENTIFIER (20^18+LOC) - SUBPROGRAM NAME
	!  CHLEN if TYPEFLG is 1
	!OPTION 0 - NO ARGUMENTS, ILLEGAL IF THIS IS A FUNCTION
	! OR
	!OPTION 1 - ARGUMENT LIST POINTER FOLLOWS
	!	OPTION 0 - NAME()
	!	OPTION 1 - NAME(ARGS)
	!		COUNT^18+LOC - POINTS TO LIST POINTER
	!			1^18+LOC - POINTS TO LIST OF
	!			CHOICE 1 - DUMMY ARGUMENT
	!				IDENTIFIER (20^18+LOC)
	!			CHOICE 2 - DUMMY LABEL
	!
	!THE LOCATION TYPE IS NON-ZERO (4) FOR A FUNCTION STATEMENT
	!AND ZERO FOR A SUBROUTINE OR ENTRY STATEMENT.   IF THE FUNCTION
	!WAS TYPED, IDTYPE WILL CONTAIN THE TYPE OTHERWISE IT CONTAINS -1
	!
	! TYPEFLG is 1 for the case 'datatype FUNCTION ...'
	! TYPEFLG is 0 for the cases 'FUNCTION ...', 'SUBROUTINE ...', and
	!    'ENTRY ...'
	!
	!----------------------------------------------------------------------

	R1_.FPNT[ELMNT];	!R1_LOC (SUBPROGRAM NAME)

%2507%	IF .FLGREG<PROGTYP> EQL SUPROG
%2507%	THEN R1[IDSUBROUTINE] = 1;	! Mark as subroutine name

	IF NAMDEF( ENTRYDEF, .R1) LSS 0 THEN RETURN .VREG;

%1213%	! Fetch info from tree based on TYPEFLG parameter

%1213%	IF .TYPEFLG EQL 1 
%1213%	THEN
%1213%	BEGIN
%1213%		! 'datatype FUNCTION ...' form

%1213%		CHLEN _ .FPNT[ELMNT1];	! character count for character data
%1213%		T1 _ .FPNT[ELMNT2];	! flag for arguments specified
%1213%		T2 _ .FPNT[ELMNT3];	! pointer to arg list
%1213%	END
%1213%	ELSE
%1213%	BEGIN
%1213%		! 'FUNCTION/SUBROUTINE/ENTRY ...' form

%1213%		T1 _ .FPNT[ELMNT1];	! flag for arguments specified
%1213%		T2 _ .FPNT[ELMNT2];	! pointer to arg list
%1213%	END;

%1400%	IF .T1 NEQ 0			! First option word says whether
%1400%	THEN				!   parens are present
%1400%	T1 _ .T2[ELMNT];		! If so, get next option, whether
					! anything is inside the parens

%1466%	! If we have  a charcter function,  we need a  return value (in  an
%1466%	! argument list) whether or not the user specified arguments in the
%1466%	! definition.

%1422%	IF .IDTYPE NEQ CHARACTER
%1422%	THEN
%1422%	BEGIN	! Not a character function

%1466%		NUMARGS = 0;	! No arguments needed for return value.
%1422%		ARGOFFSET = 1;	! Start copying at first argument

%1422%	END	! Not a character function
%1422%	ELSE
%1422%	BEGIN	! Character function

%1422%		! Character functions have the descriptor for the result as
%1422%		! their first argument

%1422%		NUMARGS = 1;	! Extra arg needed for return value
%1422%		ARGOFFSET = 2;	! Start copying at second argument

%1422%	END;	! Character function


%1466%	! Create the arument list.  If  no arguments are specified, but  it
%1466%	! is a character function, we still  need an argument list for  the
%1466%	! return value.

%1213%	IF .T1 EQL 0
	THEN
%1466%	BEGIN	! No arguments

%1466%		IF .IDTYPE EQL CHARACTER
%1466%		THEN
%1466%		BEGIN	! Arglist needed for return value
%1466%
%1466%			NAME<LEFT> = ARGLSTSIZE(.NUMARGS);
%1466%			ARGNODE = R2 = CORMAN();	! Get some space
%1466%			ARGNODE[ARGCOUNT] = .NUMARGS;	! Number of args
%1466%		END
%1466%		ELSE	! Arglist not needed
			
			R2_0;	! Pointer to arglist is zero.

	END	! No arguments
	ELSE
	BEGIN	! Has arguments
		!-------------------------------------------------------------
		!CREATE AN ARGUMENT LIST ON THE UNUSED PORTION OF THE
		!LEXEME STACK (STK[2] THRU STK[100]).  THIS IS NECESSARY
		!BECAUSE THE EXACT NUMBER OF ARGUMENTS IS NOT KNOWN.
		!THE ARGUMENT LIST PRODUCED BY SYNTAX CONTAINS 2 WORDS
		!(CHOICE 1) FOR EACH DUMMY ARGUMENT BUT ONLY 1 WORD
		!FOR EACH DUMMY LABEL (CHOICE 2).  THE PROPORTION OF
		!EACH ARGUMENT TYPE IS NOT KNOWN UNTIL THE LIST IS SCANNED.
		!------------------------------------------------------------

		T1_.T2[ELMNT1];
		SAVSPACE(1,@T2);
		T2_STK[3]<0,0>;	!T1_LOC(GENERATED ARG LIST),SET COUNT T2 TO LOC OF ARGLIST
		INCR ALST FROM @T1 TO @T1+.T1<LEFT>DO
		BEGIN
			MAP BASE ALST;
			T2_.T2+1;
			IF .ALST[ELMNT] EQL 1 THEN !DUMMY ARGUMENT
			BEGIN
				T2[ELMNT]_R2<RIGHT>_.ALST[ELMNT1];
				IF NAMDEF(IDDEFINE, .R2 ) LSS 0 THEN RETURN .VREG;
				IF .R2[OPRCLS] EQL DATAOPR THEN T2[P1AVALFLG] _ 1;
![663] WE ARE TRYING TO ASSIGN TYPE INFORMATION TO PARAMETERS OF
![663] SUBROUTINE AND ENTRY STATEMENTS.  THERE MAY BE INFORMATION
![663] ALREADY PRESENT REGARDING THESE VARIABLES, SO WE NEED TO BE
![663] VERY CAREFUL.  IF THE VARIABLE HAS ALREADY BEEN DIMENSIONED,
![663] THEN WE KNOW THAT IT IS A FORMLARRAY.  OTHERWISE, WE MIGHT
![663] HAVE SEEN IT PREVIOUSLY IN AN EARLIER SUBROUTINE OR ENTRY
![663] STATEMENT IN WHICH CASE WE NEED TO RETAIN THE SAME TYPE.
![663] SO IF IT IS EITHER A FORMLFN OR A FORMLVAR, RETAIN THAT TYPE
![663] INFORMATION.  FINALLY, IT MIGHT HAVE OCCURRED AS A FUNCTION
![663] NAME (AS IN AN EXTERNAL DECLARATION) - IN THIS CASE CHANGE
![663] THE TYPE TO FORMLFN SO THAT SPACE WILL BE ALLOCATED FOR THE
![663] VARIABLE NAME.  IF NONE OF THE ABOVE, THEN THE VARIABLE
![663] IS A SIMPLE ONE - FORMLVAR.
%[663]%				IF .R2[IDDIM] EQL 0 THEN
%[663]%				  (IF .R2[OPERSP] NEQ FORMLFN THEN
%[663]%					IF .R2[OPERSP] EQL FNNAME 
%[663]%					THEN R2[OPERSP]_FORMLFN
%[663]%					ELSE R2[OPERSP]_FORMLVAR)
%[663]%				ELSE
				BEGIN
					LOCAL BASE DIMPTR;
					R2[OPERSP] _ FORMLARRAY;
					DIMPTR _ .R2[IDDIM];
				 	IF .DIMPTR[ARADDRVAR] EQL 0
					THEN IF NOT  .DIMPTR[ADJDIMFLG]
					THEN
					BEGIN
						LOCAL BASE PTRVAR;
						ENTRY[0] _ .R2[IDSYMBOL];
						NAME _ IDTAB;
						PTRVAR _ NEWENTRY();
						PTRVAR[VALTYPE] _ INTEGER;
						PTRVAR[OPERSP] _ FORMLVAR;
						!LET THIS BE ALLOCATED
 						PTRVAR[IDATTRIBUT(NOALLOC)] _0;
						! The variable  that  holds
						! the array base is in  the
						! .DATA. psect
%1505%						PTRVAR[IDPSECT] = PSDATA;
						DIMPTR[ARADDRVAR] _ .PTRVAR;
					END;
				   END;
				R2[IDATTRIBUT(DUMMY)]_-1;  !DUMMY ARGUMENT

%2224%				!Formals are never in any PSECT but .DATA.
%2224%				R2[IDPSECT] = PSDATA;
%2327%				R2[IDPSCHARS] = PSOOPS;

%1511%				! Dummy  arguments   cannot  be   in   SAVE
%1511%				! statements.  If this was in a SAVE and is
%1511%				! in an ENTRY, give error.
%1511%				IF .R2[IDSAVVARIABLE]
%1511%				THEN FATLERR(.R2[IDSYMBOL],
%1511%					UPLIT(ASCIZ'Dummy variable'),.ISN,
%1511%					E192<0,0>);

				IF .FLGREG<PROGTYP> EQL FNPROG
				THEN IF .R2<RIGHT> EQL .R1<RIGHT>
				THEN	! ARGUMENT IS SAME AS FUNCTION
					FATLEX( R2[IDSYMBOL], E71<0,0>);
			END
			ELSE
			BEGIN
				 FLGREG<LABLDUM> _ 1;	!SET DUMMY LABLES FLAG
				 IF .FLGREG<PROGTYP>  EQL  FNPROG
				 THEN	WARNLEX (E129<0,0>);
					!ISSUE WARNING BECAUSE FUNCTIONS WITH
					! MULTIPLE RETURNS CANNOT BE REFERENCED
					! AS FUNCTIONS
				 T2[ELMNT]_0 !DUMMY LABEL
			END;
			IF .ALST[ELMNT] LEQ 2
%2253%			THEN	! Argument is neither $ nor &
%2253%				ALST=.ALST+1	! Skip by 1
%2253%			ELSE	! Argument is $ or &
%2253%				IF FLAGEITHER	! Compatibility flagger
%2253%				THEN
%2253%					IF .ALST[ELMNT] EQL 3
%2253%					THEN CFLEXB(UPLIT '$?0',E288<0,0>) ! $
%2253%					ELSE CFLEXB(UPLIT '&?0',E288<0,0>) ! &
		END;
		SAVSPACE(.T1<LEFT>,@T1);
		!--------------------------------------------------------------
		!THE FOLLOWING CODE SETS UP T1 AS THE BLT POINTER
		!(SOURCE ADDRESS ^18+ DESTINATION ADDRESS AND T2 AS THE FINAL
		!ADDRESS.  R2 POINTS TO THE BEGINNING OF THE ARG BLOCK CREATED.
		!ITS FIRST WORD CONTAINS THE ARG COUNT.
		!--------------------------------------------------------------
		STK[2]_0;	!LINK WORD
		T2_.T2-STK[3]<0,0>; !NUMBER OF ARGUMENTS

		% CHECK FOR DUPLICATE ARGUMENTS %
		INCR PRM FROM STK[4]<0,0> TO STK[4]<0,0>+.T2-2
		DO
		BEGIN
			MAP BASE PRM;
			LOCAL BASE PLST:ID1:ID2;
			IF ( ID1 _ @@PRM )  NEQ  0	!IE AN IDENTIFIER
			THEN
			BEGIN
				PLST _ .PRM+1;
				DO
				BEGIN
					IF ( ID2 _ @@PLST ) NEQ 0	!IDENTIFIER
					THEN
					BEGIN
						IF .ID1[IDSYMBOL] EQL  .ID2[IDSYMBOL]
						THEN	RETURN FATLEX(.ID1[IDSYMBOL],E87<0,0>)
					END
				END
				UNTIL	(PLST _ .PLST+1) EQL  STK[3]<0,0>+.T2+1;
			END;
		END;

%1466%		NUMARGS = .T2 + .NUMARGS;	! Total number of arguments

%1422%		NAME<LEFT> = ARGLSTSIZE(.NUMARGS); ! Size of arg block needed
%1422%		R2 = CORMAN();
%1413%		ARGNODE _ .R2;
%1422%		ARGNODE[ARGCOUNT] _ .NUMARGS;	! Number of arguments

%1422%		! Copy ARGNODEs from STK.  The first is in STK[4]

%1422%		INCR CNT FROM .ARGOFFSET TO .NUMARGS
%1422%		DO 	ARGNODE[.CNT,ARGFULL] = .STK[4 + .CNT - .ARGOFFSET];

	END;	! Has arguments

	NAME _ IDOFSTATEMENT _ ENTRDATA;
	NAME<RIGHT> _ SORTAB;
	T1 _ NEWENTRY();

%1422%	IF .IDTYPE EQL CHARACTER
%1422%	THEN
%1422%	BEGIN
%1422%		! First argument points to the symbol table entry for the
%1422%		! function name. It is used for the value returned by the
%1422%		! by the function.  Set the DUMMY IDATTRIBUT field.

%1422%		ARGNODE[1,ARGFULL] = .R1;
%1422%		R1[IDATTRIBUT(DUMMY)] = 1;

%2327%		! Put the return value, a dummy variable, into the proper
%2327%		! Psects.
%2327%		R1[IDPSECT] = PSDATA;
%2327%		R1[IDPSCHARS] = PSOOPS;

%1422%	END;

%1213%	! If this function has a type, set valtype and character count

%2051%	IF .TYPEFLG GTR 0
%1213%	THEN
%1213%	BEGIN
%1213%		R1[IDATTRIBUT(INTYPE)] _ -1;
%1213%		R1[VALTYPE] _ .IDTYPE;
%1213%		R1[IDCHLEN] _ .CHLEN;
%1213%	END;

	IF .TYPE EQL ENT THEN
	BEGIN
		T1[ENTNUM] _ -1;
		%LINK UP THE ENTRY POINTS FOR REL OUTPUT%
		R1[IDENTLNK] _ .MULENTRY;
		MULENTRY _ .R1;
	END;
	R1[IDATTRIBUT(FENTRYNAME)] _ 1; !SET ENTRY NAME BIT

	T1[ENTSYM] _ @R1;	! Symbol table entry
	T1[ENTLIST] _ @R2;	! Argument list

%1466%	! Set up the link  from one entry point  to the next.   ENTPREVIOUS
%1466%	! has the address of the last entry statement node. If first  entry
%1466%	! point, then set the global variable for the first time.

%1466%	IF .ENTPREVIOUS NEQ 0	! 1st entry point?
%1466%	THEN	ENTPREVIOUS[ENTLINK] _ .T1;
%1466%	ENTPREVIOUS _ .T1;	! For next entry processing
%1466%	T1[ENTLINK] _ 0;	! End of the link

	SAVSPACE(.FPNT<LEFT>,@FPNT);

END;	! of FUNCGEN

GLOBAL ROUTINE TYPEGEN(TLST)=
BEGIN
	LOCAL BASE T1;
	REGISTER BASE T2; REGISTER BASE R1:R2;
!-----------------------------------------------------------------------
!	THIS ROUTINE IS CALLED WITH THE PARAMETER TLST
!	POINTING TO A LIST OF ELEMTNTS. EACH
!	ELEMENT POINTS TO A LIST OF SCALAR OR ARRAY DEFINITIONS
!	(ONEARRAY) FOLLOWED BY AN OPTIONAL LIST OF VALUES. UNTIL
!	THE ROUTINES TO HANDLE DATA SPECIFICATIONS HAVE BEEN
!	WRITTEN THESE VALUE LISTS WILL BE IGNORED.
!-----------------------------------------------------------------------
	INCR DLST FROM @TLST TO @TLST+.TLST<LEFT> DO
	BEGIN
		MAP BASE DLST;
		R1_.DLST[ELMNT];
		!IF A VALUELIST IS PRESENT THEN BLDARRAY
		!MUST SAVE ALL THE SCALAR AND ARRAY NAMES IT FINDS, PROBABLY ON THE STACK
		IF BLDARRAY(.R1[ELMNT]) LSS 0 THEN RETURN .VREG;
		IF.R1[ELMNT1] NEQ 0 THEN				!OPTIONAL VALUELIST IS PRESENT
		BEGIN

%2455%		! Optional valuelist is a VMS extension. Should be done a la DATALIST.
%1213%		! The code has never worked, so make it a fatal error for now.
%1213%		FATLEX(E84<0,0>);	
%1213%		T1_.R1[ELMNT2];					!T1_LOC(VALUELIST) for savespace 

%1213%		! Comment out rest of optional valuelist code
!			T2_.T1[ELMNT1];					!T2_LOC(LIST OF CONSTANTS)
!			INCR CLST FROM @T2 TO @T2+.T2<LEFT> BY 2 DO
!			BEGIN
!				MAP BASE CLST;
!				IF .CLST[ELMNT] EQL 1 THEN		!CONSTANT POSSIBLY A REPEAT COUNT
!				BEGIN
!					R1_.CLST[ELMNT1];
!					IF .R1[ELMNT1] NEQ 0 THEN
!					BEGIN				!SAVE REPEATED CONSTANT SPACE
!						R2_.R1[ELMNT2];SAVSPACE(.R2<LEFT>,@R2)
!					END;
!					SAVSPACE(.R1<LEFT>,@R1);	!SAVE CONSTANT SPACE
!				END;
!			END; SAVSPACE(.T2<LEFT>,@T2);			!SAVE CONSTANT LIST SPACE
			SAVSPACE(.T1<LEFT>,.T1);			!SAVE VALUE LIST SPACE
		END
	END;
END;	! of TYPEGEN

GLOBAL ROUTINE TMPGEN(TYPE)=
BEGIN
	BIND TMPNAM=PLIT(
	%0%	SIXBIT 'TM.000',
	%1%	SIXBIT 'MF.000',
	%2%	SIXBIT 'OF.000',
	%3%	SIXBIT 'SZ.000');
	REGISTER BASE R3,R2,R1;MACHOP IDIVI=#231,LSHC=#246;
	R1_.TMPCNT[.TYPE]_.TMPCNT[.TYPE]+1;
	DECR I FROM 2 TO 0 DO (IDIVI(R1,10);LSHC(R2,-6));
	ENTRY[0]_.TMPNAM[.TYPE]+.R3<LEFT>;
	NAME_IDTAB;R3_TBLSEARCH();
%1505%	R3[IDPSECT] = PSDATA;		! Temps go in the .DATA. psect
	IF .TYPE EQL 0 THEN R3[OPR1]_VARFL;
	RETURN .R3
END;	! of TMPGEN

ROUTINE AJDIMSTK(PTR)=
BEGIN
	!***************************************************************
	! Save this variable name on a stack because it is currently not
	! in COMMON  or  a  dummy  but it  might  be  after  some  ENTRY
	! statements
	!***************************************************************

	REGISTER R1;

	NAME<LEFT> = 2;	!2 WORD ENTRIES
	R1 = CORMAN();

	IF .DIMSTK  EQL  0
	THEN DIMSTK<LEFT> = .R1;

	(.R1)<RIGHT> = .DIMSTK<RIGHT>;
	DIMSTK<RIGHT> = .R1;
	(.R1+1)<RIGHT> = .PTR;
	(.R1+1)<LEFT> = .LEXLINE

END;	! of AJDIMSTK


ROUTINE BLDDIM(SSLST)=		![1510] Do a lot of cleanup

!++
! FUNCTIONAL DESCRIPTION:
!
!	Builds array dimension table information.
!
! FORMAL PARAMETERS:
!
!	SSLST points to a list of subscripts of the form:
!
!	Option 0 - Subscript is upper bound, lower bound is one
!		Choice 1 - Subscript is a CONSTANT
!			CONSTANT (21^18+LOC)
!		Choice 2 - Subscript is an IDENTIFIER
!			IDENTIFIER (20^18+LOC)
!		Choice 3 - Subscript is an ASTERISK
!
!
!	Option 1 - Subscript is lower bound
!		COUNT^18+LOC - pointer to upper bound
!			DIVIDE
!			Choice 1 - Subscript is a CONSTANT
!				CONSTANT (21^18+LOC)
!			Choice 2 - Subscript is an IDENTIFIER
!				IDENTIFIER (20^18+LOC)
!			Choice 3 - Subscript is an ASTERISK
!
! IMPLICIT INPUTS:
!
!	Unknown
!
! IMPLICIT OUTPUTS:
!
!	Unknown
!
! ROUTINE VALUE:
!
!	Returns pointer to dimension information.
!
! SIDE EFFECTS:
!
!	Unknown
!
!--


BEGIN
	REGISTER
		BASE BOUND,	! An upper or lower bound for a dimension.
		BASE T1,	! Pointer to list of subscripts during the
				!  first part of this routine.  Used for dif-
				!  ferent things during second part of routine.
%1213%		BASE T2;	! Pointer to dimension table while the
				!  option list is scanned.  Used for different
				!  things during second part of this routine.

%1510%	LOCAL
%2504%		A0F,		! TEMP DFACTOR (0)
%2504%		AOFF,		! Temp ARAOFF
%2504%		BASE ARRDIMEN,	! Array dimension node
%2504%		ASIZE,		! TEMP ARASIZ
%1510%		ASSUMEDSIZE,	! Set to TRUE iff an array is assumed-size.
%1510%		DNUM,		! The number of dimensions
%1560%		SAVET1;		! Save T1 for SAVSPACE call

	MAP BASE FARRY;

	LABEL  LDECR, CHECKTHIS;

%1510%	MACRO ERR31  = FATLEX( FARRY[IDSYMBOL], E31<0,0> ) $,
%1510%	      ERR74  = FATLEX( FARRY[IDSYMBOL], E74<0,0> ) $,
%1510%	      ERR141 = FATLEX(.FARRY[IDSYMBOL], E141<0,0>) $,
%1510%	      ERR189 = FATLEX( FARRY[IDSYMBOL], E189<0,0>) $,
%1510%	      ERR190 = FATLEX(E190<0,0>) $,
%1510%	      ERR137 = FATLEX(E137<0,0>) $;

%1510%	BIND	INFINITY = 1^35-1;

	BIND ADJUSTABLE=STK[2];


!------------------------------------------------------------------------------
!Omitting the extra code to fetch constants and store values, the array
!size, array offset, and subscript multiplication factor are calculated
!in the following manner:
!
!IF .IDTYPE GEQ DOUBLPREC THEN WORDSIZE = 2 ELSE WORDSIZE = 1;
!ARRAYSIZE = .WORDSIZE;ARRAYOFFSET = 0;
!INCR I FROM 1 TO NUMBEROF DIMENSIONS DO
!BEGIN
!	FACTOR(.I) = .ARRAYSIZE;
!	ARRAYOFFSET = .ARRAYOFFSET+.FACTOR(.I)*.LOWERLIMIT(.I);
!	SUBSCRIPTSIZE = .UPPERLIMIT(.I)-.LOWERLIMIT(.I)+1;
!	ARRAYSIZE = .ARRAYSIZE*.SUBSCRIPTSIZE;
!END;
!
!For example:
!
!	DOUBLE PRECISION A(2:5,3:5,4:5)
!
!would produce
!
!FACTOR=		2	8	24
!ARRAYOFFSET=		4	28	124
!SUBSCRIPTSIZE=		4	3	2
!ARRAYSIZE=		8	24	48
!
!Thus using BLISS notation, the second element of A, A(3,3,4) is
!.(A+2*3+8*3+24*4-124) which equals .(A+2) .  The array size specifies
!the number of words occupied by the array, thus in the above example
!array A occupies locations A thru A+47.
!------------------------------------------------------------------------------


	! Initially clear some flags and stuff.

	ADJUSTABLE = AOFF = 0;
%1510%	ASSUMEDSIZE = FALSE;


%1213%	! Use character count for CHARACTER data, one or two words for others
%1250%	! If a character array has element length (*), it's adjustably
%1250%	! dimensioned, even if all array bounds are constants.

%1213%	IF .IDTYPE EQL CHARACTER
%1213%	THEN
%1250%		IF .CHLEN EQL LENSTAR
%1250%		THEN ADJUSTABLE = -1
%1213%		ELSE ASIZE = .CHLEN
%1213%	ELSE	IF .IDTYPE GEQ DOUBLPREC
%1213%		THEN ASIZE = 2
%1213%		ELSE ASIZE = 1;

	! Calculate number of dimensions

%1510%	DNUM = .SSLST<LEFT> + 1;

	! Create the array dimension table entry

%2504%	NAME<LEFT> = DIMSIZ + .DNUM * DIMSUBSIZE;	! Size of entry
	NAME<RIGHT> = DIMTAB;				! Type of entry
%2504%	ARRDIMEN = NEWENTRY();				! Entry
%2504%	ARRDIMEN[DIMNUM] = .DNUM;			! Num of dimensions


	! Address of first element.  This is incremented in the loop below
	! so that we are always looking at the "first" (0th) element
	! (apparently because this make more optimized code, not having a
	! variable for the index), even though it is really the Nth
	! element.  Ugh.

%2504%	T2 = .ARRDIMEN;

	INCR SS FROM @SSLST TO @SSLST+.SSLST<LEFT> DO
	BEGIN	! Loop through list of dimension bounds

		MAP BASE SS;

		T2[DVARFLGS(0)] = 0;
		T1 = .SS[ELMNT];

		BOUND = .T1[ELMNT];	! Get Ptr to upper or lower bounds

%1510%		! Make sure the bounds is asterisk or integer
%1510%		IF .BOUND NEQ ASTERISK^18
%1510%		THEN IF .BOUND[VALTYPE] NEQ INTEGER THEN ERR31;

		CASE .T1[ELMNT1] OF SET
		BEGIN	! Option 0 - lower limit is 1 by default

			! Store Lower Bound
			T2[DIMENL(0)] = .ONEPLIT;

%1527%			IF .BOUND<LEFT> EQL CONSTLEX
			THEN
			BEGIN	!Choice 1:  BOUND is a constant pointer

				! Don't allow upper bound to be lower than
				! lower bound.
				IF .BOUND[CONST2] LSS 1 THEN ERR74;
			END	! of choice 1:  BOUND is a constant pointer

%1670%			ELSE IF .BOUND<LEFT> EQL ASTERISK
			THEN
%1510%			BEGIN	! Choice 2:  BOUND is an asterisk
%1510%
%1510%				! Make sure that is is the last subscript.
%1510%				IF .SS NEQ .SSLST + .SSLST<LEFT>
%1510%				THEN ERR189;
%1510%
%1510%				! The upper bound is +infinity
%1510%				BOUND = MAKECNST(INTEGER, 0, INFINITY);
%1510%
%1510%				! The array is an Assumed Size Array
%1510%				ASSUMEDSIZE = TRUE;
%1510%			END	! Choice 2:  BOUND is an asterisk

%1670%			ELSE
			BEGIN	! Choice 3:  BOUND is an expression
				T2[DVARUBFLG(0)] = 1;
				ADJUSTABLE = -1;
			END;	! Choice 3:  BOUND is an expression

			! Store upper bound;
			T2[DIMENU(0)] = .BOUND;

			IF .ADJUSTABLE EQL 0
			THEN
			BEGIN

				T2[DFACTOR(0)] = MAKECNST(INTEGER, 0, .ASIZE);


%2322%				! AOFF <= .AOFF - .ASIZE
%2322%				AOFF = SUBINT(.AOFF, .ASIZE);

%1510%				IF NOT .ASSUMEDSIZE
%1510%				THEN
%1510%				BEGIN	! Calculate Array Size

%2322%					! Following program  is illegal  (array
%2322%					! DD has too many characters) and  will
%2322%					! overflow below:
%2322%					!   PARAMETER (LARGE="377777 777777)
%2322%					!   CHARACTER DD(LARGE)*(LARGE)
%2322%					!   END
%2322%
%2322%					! ASIZE <= .ASIZE * .BOUND[CONST2]
%2322%
%2322%					ASIZE = MULINT(.ASIZE,.BOUND[CONST2]);

%1510%				END	! of calculate array size
			END
			ELSE
			BEGIN
				T2[DVARFACTFLG(0)] = 1;
				T2[DFACTOR(0)] = 0;
			END;
		END;	! of option 0 - lower limit is 1 by default

		BEGIN	! Option 1 - both lower and upper limits are specified

%1527%			IF .BOUND<LEFT> EQL ASTERISK
%1527%			THEN
%1510%			BEGIN	! BOUND is an asterisk
%1510%				ERR189;
%1510%			END	! BOUND is an asterisk

%1670%			ELSE IF .BOUND<LEFT> EQL CONSTLEX
%1670%			THEN  .VREG  !do nothing

			ELSE
			BEGIN	! BOUND is an expression
				T2[DVARLBFLG(0)] = 1;
				ADJUSTABLE = -1;
			END;	! BOUND is an expression

			T2[DIMENL(0)] = .BOUND; !LOWER BOUND

			T1 = .T1[ELMNT2];	! Get ptr to upper bound block
			SAVET1 = .T1;	! Saving ptr for SAVSPACE call later

			!T1 now points to upper bound part

			BOUND = .T1[ELMNT1];

%1510%			! Make sure the bounds is asterisk or integer.
%1510%			IF .BOUND NEQ ASTERISK ^ 18
%1510%			THEN IF .BOUND[VALTYPE] NEQ INTEGER THEN ERR31;


%1527%			IF .BOUND<LEFT> EQL ASTERISK
%1527%			THEN
%1510%			BEGIN	! BOUND is an asterisk
%1510%
%1510%				! Make sure that is is the last subscript.
%1510%				IF .SS NEQ .SSLST + .SSLST<LEFT>
%1510%				THEN ERR189;
%1510%
%1510%				! The upper bound is +infinity
%1510%				BOUND = MAKECNST(INTEGER, 0, INFINITY);
%1510%
%1510%				! The array is an assumed size array.
%1510%				ASSUMEDSIZE = TRUE;
%1510%
%1510%			END	! BOUND is an asterisk

%1670%			ELSE IF .BOUND<LEFT> EQL CONSTLEX
%1670%			THEN .VREG	! do nothing

			ELSE
			BEGIN	! BOUND is an expression
				T2[DVARUBFLG(0)] = 1;
				ADJUSTABLE = -1;
			END;	! BOUND is an expression

			T2[DIMENU(0)] = .BOUND;

			IF .ADJUSTABLE EQL 0
			THEN
			BEGIN
				LOCAL BASE LOBOUND, BASE UPBOUND;

				LOBOUND = .T2[DIMENL(0)];
				UPBOUND = .T2[DIMENU(0)];

				! Make sure that the lower bounds is not
				! greater than the upper bounds.
				IF .LOBOUND[CONST2] GTR .UPBOUND[CONST2]
				THEN ERR74;

				T2[DFACTOR(0)] = MAKECNST(INTEGER, 0, .ASIZE);

%2322%				! Following program is illegal and gets
%2322%				! an overflow;
%2322%				!	PARAMETER (LARGE="377777 777777)
%2322%				!	CHARACTER A(LARGE-1:LARGE)*(LARGE)
%2322%				!	END
%2322%
%2322%				! AOFF <= .AOFF - (.ASIZE * .LOBOUND[CONST2])
%2322%
%2322%				AOFF = SUBINT(.AOFF, MULINT(.ASIZE,.LOBOUND[CONST2]) );

%1510%				IF NOT .ASSUMEDSIZE
%1510%				THEN
%1510%				BEGIN	! Calculate array size

%2322%					! Below programs are illegal and
%2322%					! overflow:
%2322%					!   PARAMETER (LARGE="377777 777777)
%2322%					!   CHARACTER A(2:LARGE)*(LARGE/2)
%2322%					!   END	! Overflow on multiplation
%2322%					! 
%2322%					!   PARAMETER (LARGE="377777 777777)
%2322%					!   PARAMETER (NEG = -LARGE)
%2322%					!   DIMENSION A(NEG:LARGE)
%2322%					!   END	! Overflow on subtraction
%2322%
%2322%					! ASIZE <= .ASIZE * (.UPBOUND[CONST2]
%2322%					!	- .LOBOUND[CONST2] + 1)
%2322%
%2322%					BOUND = SUBINT(.UPBOUND[CONST2],
%2322%						     .LOBOUND[CONST2]);
%2322%					ASIZE = MULINT(.ASIZE,
%2322%							ADDINT(.BOUND, 1));

%1510%				END	! of calculate array size
			END
			ELSE
			BEGIN
				T2[DVARFACTFLG(0)] = 1;
				T2[DFACTOR(0)] = 0;
			END;

			SAVSPACE(.SAVET1<LEFT>,.SAVET1);
		END	! of option 1-both lower and upper limits are specified
		TES;

		T1 = .SS[ELMNT];	!FOR SAVSPACE CALL
		SAVSPACE(.T1<LEFT>,.T1);

%2504%		T2 = .T2 + DIMSUBSIZE;	! Next subscript entry

	END;	! of loop through list of dimension bounds


	IF .ADJUSTABLE NEQ 0
	THEN
	BEGIN   !ADJUSTABLE
		!--------------------------------------------------------------
		! IF THE DIMENSIONS ARE ADJUSTABLE CREATE A SPECIAL SET OF
		! TEMPS TO BE USED BY ADJ. TO CALCULATE THE MULTIPLICATIVE
		! FACTORS. ALSO SET ADJDIMFLG
		!
		!FOR ADJ. THEY MUST BE IN A SPECIAL ORDER
		!ASIZE
		!OFFSET
		!FACTOR N-1
		! .
		! .
		! .
		!FACTOR 1
		!--------------------------------------------------------------

		LOCAL BASE  PTR;
		LOCAL DIMENTRY  E;

		!CHECK TO SEE IF ADJUSTABLES ARE LEGAL
		IF .FLGREG<PROGTYP>  NEQ  SUPROG THEN
		IF .FLGREG<PROGTYP>  NEQ  FNPROG
		THEN ERR137;

		! If this is not a dummy variable yet, push it on the the
		! stack for checking later.

		IF NOT .FARRY[IDATTRIBUT(DUMMY)] THEN AJDIMSTK(.FARRY);

		ASIZE = INITLTEMP(INTEGER);
%2504%		ARRDIMEN[ARAOFFSET] = INITLTEMP(INTEGER);

%1250%		! Use .I temp for CHARACTER data, one or two words for others

%1213%		IF .IDTYPE EQL CHARACTER
%1250%		THEN	A0F = INITLTEMP(INTEGER)
%1213%		ELSE	IF .FARRY[DBLFLG]	! One or two words
%1213%		THEN A0F = MAKECNST (INTEGER, 0, 2)
%1213%		ELSE A0F = .ONEPLIT;

%2504%		ARRDIMEN[DFACTOR(0)] = .A0F;

		! Process the dimensions in reverse order (last to first).
		! T2 is set up from the last INCR loop where we went from
		! first to last to point to the last.  Another "ugh", we
		! are still referencing each dimension as if it were the
		! first.

		DECR  I  FROM .DNUM - 1  TO 1
		DO
LDECR:		BEGIN	! For each subscript

%2504%			T2 = .T2 - DIMSUBSIZE;	! DIMSUBENTRY (I)

			IF .T2[DFACTOR(0)] NEQ 0
			THEN LEAVE LDECR;

			IF NOT .T2[DVARUBFLG (0)] OR
%414%			       .T2[DIMENL (0)] NEQ .ONEPLIT  OR
%414%			       .I NEQ 1
%[1250]%		       OR .IDTYPE EQL CHARACTER
			THEN
			BEGIN
				T2[DFACTOR (0)] = INITLTEMP (INTEGER);
				LEAVE LDECR;
			END;

%414%			!I == 1 => T2 [...(0)] IS FOR 2ND DIM
			PTR = .DTABPTR <RIGHT>;
			WHILE  .PTR NEQ 0 DO
			BEGIN
				E = .PTR;
CHECKTHIS:			BEGIN
%423%					IF .E [DIMNUM] LSS 2
					THEN LEAVE CHECKTHIS;
					IF NOT .E [ADJDIMFLG]
					THEN LEAVE CHECKTHIS;
					IF .E [DFACTOR (0)] NEQ .A0F	! SAME ELEMENT SIZE
					THEN LEAVE CHECKTHIS;

%414%					! If dim1 same, then share factor for dim2
%414%					IF .E[DIMENU (0)] EQL .T2[DIMENU (-1)]  AND
%414%				     		.E [DIMENL (0)] EQL .ONEPLIT
					THEN
					BEGIN
%571%						PTR = .E [DFACTOR (1)];
%571%						T2[DFACTOR (0)] = .PTR;
%571%						PTR [IDUSECNT] = .PTR [IDUSECNT] + 1;	! UPDATE SHARING COUNT
						LEAVE LDECR;
					END;
				END;	! OF CHECKTHIS

				PTR = .E [ARALINK];	! NEXT ENTRY
			END;	! Of WHILE .PTR NEQ 0

%571%			PTR = INITLTEMP (INTEGER);	! NO MATCH FOUND
%571%			T2 [DFACTOR (0)] = .PTR;
%571%			PTR [IDUSECNT] = 1;		! 1ST USAGE: NO SHARING
		END;	! Of LDECR

%2504%		T2 = .T2 - DIMSUBSIZE;		! SUBENTRY (0)

%[1250]% ! Numeric arrays have factor #1 constant.  (1 for single word arrays,
%[1250]% ! 2 for double word arrays.)  Character arrays have factor #1 stored
%[1250]% ! in a .I temp at runtime.  The .I temp is generated above.
%[1250]%	IF .IDTYPE EQL CHARACTER
%[1250]%	THEN T2[DVARFACTFLG(0)] = 1
		ELSE T2[DVARFACTFLG(0)] = 0;

%2520%		ARRDIMEN[ADJDIMFLG] = 1;

	END	!ADJUSTABLE
%2504%	ELSE ARRDIMEN[ARAOFFSET] = MAKECNST(INTEGER,0,.AOFF); !MAKE CONST NODE FOR OFFSET VALUE

%1510%	IF .ASSUMEDSIZE
%1510%	THEN
%1510%	BEGIN
%1510%		! Check if assumed-size arrays are legal
%1510%		IF .FLGREG<PROGTYP>  NEQ  SUPROG THEN
%1510%		IF .FLGREG<PROGTYP>  NEQ  FNPROG
%1510%		THEN ERR190;
%1510%
%1510%		! Check for Assumed Size Array not a DUMMY argument.
%1510%		! If isn't yet, then save it on the stack to be checked
%1510%		! later for being a DUMMY argument.
%1510%		IF NOT .FARRY[IDATTRIBUT(DUMMY)] THEN AJDIMSTK(.FARRY);
%1510%
%1510%		! Set the Assumed Size Array flag.
%2520%		ARRDIMEN[ASSUMESIZFLG] = 1
%1510%
%1510%	END;	! End of check if assumed-size arrays are legal

	SAVSPACE(.SSLST<LEFT>,.SSLST);


%2504%	ARRDIMEN[ARADLBL] = 0;			! "FOR SAFETY"

%2504%	ARRDIMEN[ARALINK] = .DTABPTR<RIGHT>;	! LINK THIS ENTRY INTO LIST
%2504%	DTABPTR<RIGHT> = .ARRDIMEN;		! NEW LIST HEAD


	IF .FARRY[OPERSP] EQL FORMLARRAY
	THEN
	(  IF .ADJUSTABLE EQL 0
	   THEN BEGIN
		!MAKE A POINTER VARIABLE TO BE A COPY OF ARRAY'S SYMBOL TABLE NODE
		!AND PUT IT IN THE DIMENSON NODE
		LOCAL BASE PTRVAR;
		ENTRY[0] = .FARRY[IDSYMBOL];
		NAME = IDTAB;
		PTRVAR = NEWENTRY();
		PTRVAR[IDATTRIBUT(NOALLOC)] = 0;	!LET THIS BE ALLOCATED
		PTRVAR[VALTYPE] = INTEGER;
		PTRVAR[OPERSP]  = FORMLVAR;	!MAKE IT A FORMAL DUMMY

! The variable that holds the array base is in the .DATA. psect

%1505%		PTRVAR[IDPSECT] = PSDATA;

%2504%		ARRDIMEN[ARADDRVAR] = .PTRVAR; !PTR VARIABLE TO DIMENSION NODE
	       END;
	)
%2504%	ELSE ARRDIMEN[ARADDRVAR] = 0;


%2224%	! Check the size of this array.  Complain if the array is
%2224%	! absurdly large to fit into virtual memory!

%2224%	IF NOT .ASSUMEDSIZE
%2224%	THEN
%2224%	BEGIN	! Check for total space needed for this array.  
%2224%
%2224%		IF .IDTYPE EQL CHARACTER
%2224%		THEN
%2224%		BEGIN	! Character array - Check number of characters
%2224%
%2322%			IF .ASIZE GEQ (CHARSPERWORD * .VMSIZE)
%2224%			THEN ERR141;
%2224%
%2224%		END	! Character array
%2224%		ELSE	! Numeric array
%2322%			IF .ASIZE GEQ .VMSIZE THEN ERR141;
%2224%	
%2224%	END;	! Check for total space needed for this array.  

%2504%	ARRDIMEN[ARASIZ] = .ASIZE;	! Size of array

%2504%	RETURN .ARRDIMEN;		! Ptr to dimension node

END;	! of BLDDIM

ROUTINE CHKCOMMON(T1)=
BEGIN
	! Checks common declarations

	MACRO
		ERR42=RETURN FATLEX(T1[IDSYMBOL], E42<0,0>)$,
		ERR34(X)=RETURN FATLEX(PLIT'X?0', T1[IDSYMBOL], E34<0,0>)$;

	MAP BASE T1;

	BIND BASE CBLOCK=STK[2];

%1511%	EXTERNAL E192;

	IF .T1[IDATTRIBUT(INCOM)]
	THEN ERR42
	ELSE IF .T1[IDATTRIBUT(DUMMY)] THEN ERR34(DUMMY);

%1511%	! If this variable was specified in a SAVE, then give an  error,
%1511%	! this isn't allowed.

%1511%	IF .T1[IDSAVVARIABLE]
%1511%	THEN FATLERR(.T1[IDSYMBOL], UPLIT(ASCIZ'COMMON variable'),
%1511%			ISN,E192<0,0>);

	T1[IDATTRIBUT(INCOM)] = 1;

	IF .CBLOCK<LEFT> EQL 0 THEN
	BEGIN
		CBLOCK<LEFT> = CBLOCK<RIGHT> = @T1;
	END
	ELSE
	BEGIN
		CBLOCK[IDCOLINK] = @T1;
		CBLOCK<RIGHT> = @T1;
	END;

END;	! of CHKCOMMON


ROUTINE CHKTYPE(OEPNT)=
BEGIN
	!***************************************************************
	! Check the type declarations for a ONEARRAY element.  OEPNT  is
	! the pointer to the syntactic tree for the type decalration.
	! The tree is:
	!	pointer to identifier		pointer to identifier
	!	chlen1				chlen1
	!	flag1				flag1
	!	type1				type1
	!	0 (no subscripts)		1 (subscripts)
	!	chlen2				pointer to subscripts
	!	flag2				chlen2
	!	type2				flag2
	!					type2
	!***************************************************************

%1575%	! Written by TFV on 7-Jul-82

	REGISTER BASE ID;

	BIND
		LEN1 = .(.OEPNT)[1],
		FLG1 = .(.OEPNT)[2],
		TYP1 = .(.OEPNT)[3],
		HASSUBS = .(.OEPNT)[4],
		LEN2 = .(.OEPNT)[5 + HASSUBS],
		FLG2 = .(.OEPNT)[6 + HASSUBS],
		TYP2 = .(.OEPNT)[7 + HASSUBS];

	ID = @.OEPNT;		! Pointer to identifier

	IDTYPE = TYP1;		! Set datatype to first one

	IF TYP1 NEQ TYP2
	THEN
	BEGIN	! The two types are different

		! If the user specified both, there is a conflict

		IF FLG1 NEQ 0
		THEN IF FLG2 NEQ 0
		THEN RETURN FATLEX(.ID[IDSYMBOL], E205<0,0>);

		IF FLG2 THEN IDTYPE = TYP2	! Set datatype to specified one

	END;	! The two types are different

	IF .IDTYPE EQL CHARACTER
	THEN
	BEGIN	! Check for identical character lengths

		CHLEN = LEN1;	! Set length for character data to first length

		! If both lengths were specified and differ, there is  a
		! conflict - give an error

		IF LEN1 NEQ LEN2
		THEN IF FLG1 NEQ 0
		THEN IF FLG2 NEQ 0
		THEN RETURN FATLEX(.ID[IDSYMBOL], E205<0,0>);

		IF FLG2 NEQ 0
		THEN CHLEN = LEN2; 	! Set length for character data to
					! specified length

	END;	! Check for identical character lengths

	RETURN

END;	! of CHKTYPE


GLOBAL ROUTINE BLDARRAY(LPNT)=
BEGIN

	REGISTER
%1213%		BASE T2,
		BASE T1;

	LOCAL
%1575%		HASSUBS,	! Option for subscripts specified
%1575%		BASE SPNT,	! Pointer to subscripts
		BASE R2,
		BASE R1,
		POINTER,
%1155%		BLDSTATUS,	!Deferred return status, 0=All OK,
%1155%				! -1=Error in 1 or more items
		BASE PTR,	!To march down dimension entry list
		DIMENTRY E,	!One element on that list
%1434%		BASE ENTNODE,
%1434%		BASE ENTIDSYM,
%1434%		ARGUMENTLIST ARGLIST;

	LABEL  OUT, CHECKTHIS;

	MACRO
		ERR4=(RETURN FATLEX(T1[IDSYMBOL], PLIT'VARIABLE', E4<0,0>))$,
		ERR41=(RETURN FATLEX(T1[IDSYMBOL], FARRY[IDSYMBOL],E41<0,0>))$;

	!----------------------------------------------------------------------
	! THE PARAMETER LPNT POINTS TO A LIST OF ONEARRAY'S, THAT IS TO SAY
	! EACH ELEMENT OF THE LIST POINTED TO BY LPNT IS A POINTER TO A LIST
	! OF THE FORM:
	!
	!IDENTIFIER (20^18+LOC) - FIRST ARRAY NAME
	!OPTION 0 OR OPTION 1 - ADDITIONAL ARRAY NAMES AND SUBSCRIPTS FOLLOW
	!	COUNT^18+LOC - LIST POINTER
	!VARIABLE TYPE - ONLY IF THIS IS A TYPE STATEMENT
	!
	! THE LOCATION IDTYPE CONTAINS THE VARIABLE TYPE TO BE SET IN EACH
	! ARRAY NAME. IF IDTYPE IS LESS THAN ZERO, NO TYPE IS SPECIFIED AND AN
	! OPTION 0 (NO SUBSCRIPTS) IS ILLEGAL. IDTYPE IS SET LESS THAN ZERO FOR
	! DIMENSION, AND GLOBAL STATEMENTS.
	! IDTYPE FOR TYPE STATEMENTS IS NOW IN THE TREE IN ORDER TO IMPLIMENT
	! THE *N TYPE OVERRIDE FEATURE.
	!----------------------------------------------------------------------

%1155%	BLDSTATUS_0;		!Assume all items are OK

	INCR OA FROM .LPNT TO .LPNT + .LPNT<LEFT> DO
	BEGIN	!Loop though list

		MAP BASE OA;	! OA stands for onearray

		R1 = .OA[ELMNT];

%1410%		IF .TYPE EQL 5		! If in a common statement,
%1410%		THEN R1 = .R1[ELMNT];	! Follow from +(onearray) to +onearray

		FARRY = T1 = .R1[ELMNT];

		IF .TYPE EQL  4		! Type statement
		THEN
		BEGIN
			! Call CHKTYPE to check any *size modifiers.  It
			! sets CHLEN and IDTYPE

			CHKTYPE(.R1);	

%1434%			! Setup for the case FUNCTION FOO(...)  followed
%1434%			! by CHARACTER*n FOO.  In that case FOO  becomes
%1434%			! a character  function  and needs  a  different
%1434%			! argument block.

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

%1434%				ENTNODE = .SORCPTR<RIGHT>;
%1434%				ENTIDSYM = .ENTNODE[ENTSYM];
%1434%				ARGLIST = .ENTNODE[ENTLIST];
%1434%			END
%1434%			ELSE ENTIDSYM = 0;

%1575%			HASSUBS = .R1[ELMNT4];	! Option word for subs
%1575%			SPNT = .R1[ELMNT5];	! Pointer to subs
		END
		ELSE
%1213%		BEGIN
%1213%			! Get datatype and character count from symbol table

%1213%			CHLEN = .T1[IDCHLEN];
%1213%			IDTYPE = .T1[VALTYPE];	
%1575%			HASSUBS = .R1[ELMNT1];	! Option word for subs
%1575%			SPNT = .R1[ELMNT2];	! Pointer to subs
%1213%		END;

%1575%		IF .HASSUBS EQL 0 THEN
		BEGIN
			! Option 0 - no subscripts

			CASE .TYPE OF SET
			ERR4;	! DIMENSION
			BEGIN	! GLOBAL
				!IF .T1[IDATTRIBUT(INCOM)]THEN ERR34(COMMON)
				!	ELSE IF .T1[IDATTRIBUT(INEXTERN)]THEN ERR34(EXTERNAL);
				!T1[IDATTRIBUT(INGLOB)]_1
			END;
			BEGIN	!EXTERNAL
				!GONE
			END;
			BEGIN	!PROTECT
				!GONE
			END;
			BEGIN	!Type declaration


%1213%				! OLDSIZE is the element size from the symbol
%1213%				! table entry.  NEWSIZE is the element size
%1213%				! from the type declaration

%1213%				LOCAL OLDSIZE, NEWSIZE;

				LABEL ADJ;
				IF .T1[IDDIM] NEQ 0
				THEN
				ADJ:BEGIN

%1213%					! Recompute  array  size,  array
%1213%					! offset,  and  factors  if  the
%1213%					! element   size   has   changed
%1213%					! including type changes to/from
%1213%					! character.

%1213%					! Compute new size for element

%1213%					IF .IDTYPE EQL CHARACTER
%1213%					THEN	NEWSIZE = .CHLEN
%1213%					ELSE	IF .IDTYPE GEQ DOUBLPREC
%1213%						THEN NEWSIZE = 2
%1213%						ELSE NEWSIZE = 1;

%1213%					! Compute old size for element

%1213%					IF .T1[VALTYPE] EQL CHARACTER
%1213%					THEN	OLDSIZE = .T1[IDCHLEN]
%1213%					ELSE	IF .T1[VALTYPE] GEQ DOUBLPREC
%1213%						THEN OLDSIZE = 2
%1213%						ELSE OLDSIZE = 1;

%1213%					! Don't recompute if old and new sizes are the same

%1213%					IF .OLDSIZE EQL .NEWSIZE THEN LEAVE ADJ;

					R2 = .T1[IDDIM];
					IF NOT .R2[ADJDIMFLG]
					THEN
					BEGIN
						R2[ARASIZ] = (.R2[ARASIZ]*.NEWSIZE ) / .OLDSIZE;
						T2 = .R2[ARAOFFSET];
						R2[ARAOFFSET] = MAKECNST(INTEGER,0,( .T2[CONST2] * .NEWSIZE ) / .OLDSIZE );
						DECR I FROM .R2[DIMNUM]-1 TO 0 DO
						BEGIN
						   T2 = .R2[DFACTOR(.I)];
						   R2[DFACTOR(.I)] = MAKECNST(INTEGER,0, ( .T2[CONST2] * .NEWSIZE ) / .OLDSIZE );
						END
					END
					ELSE
					BEGIN !DO ONLY FOR FIRST FACTOR IF ADJUSTABLE
%[627]%						DECR I FROM .R2[DIMNUM]-1 TO 0 DO
%[627]%							IF NOT .R2[DVARFACTFLG(.I)] THEN
%[627]%							BEGIN
%[627]%								T2 = .R2[DFACTOR(.I)];
%[627]%								R2[DFACTOR(.I)] = MAKECNST(INTEGER,0, ( .T2[CONST2] * .NEWSIZE ) / .OLDSIZE );
%[627]%							END;
	OUT:					BEGIN
						  IF .R2 [DIMNUM] LSS 2	
						    THEN LEAVE OUT;
						  IF NOT .R2 [DVARUBFLG (1)]
						    THEN LEAVE OUT;
						  IF .R2 [DIMENL (1)] NEQ .ONEPLIT
						    THEN LEAVE OUT;
						  T2 = .R2 [DFACTOR (1)];
						  T2 [IDUSECNT] = .T2 [IDUSECNT] - 1;
						  IF .T2 [IDUSECNT] EQL 0
						    THEN T2 [IDATTRIBUT (NOALLOC)] = 1;	! NOT SHARED NOW: DON'T ALLOC
						  PTR = .DTABPTR<RIGHT>;
						  WHILE .PTR NEQ 0
						    DO BEGIN
						      E = .PTR;
	CHECKTHIS:				      BEGIN
							IF .E EQL .R2		! DON'T SHARE WITH YOURSELF
							  THEN LEAVE CHECKTHIS;
							IF .E [DIMNUM] LSS 2
							  THEN LEAVE CHECKTHIS;
							IF NOT .E [ADJDIMFLG]
							  THEN LEAVE CHECKTHIS;
							IF .E [DFACTOR (0)] NEQ .R2 [DFACTOR (0)]	! SAME ELEMENT SIZE ?
							  THEN LEAVE CHECKTHIS;
							IF .E [DIMENU (0)] NEQ .R2 [DIMENU (0)]
							  THEN LEAVE CHECKTHIS;
							IF .E [DIMENL (0)] NEQ .ONEPLIT
							  THEN LEAVE CHECKTHIS;
	!		DIM 1 SAME: SHARE FACTOR FOR DIM2
							PTR = .E [DFACTOR (1)];
							R2 [DFACTOR (1)] = .PTR;
							PTR [IDUSECNT] = .PTR [IDUSECNT] + 1;	! UPDATE SHARING COUNT
							LEAVE OUT;
						      END;	! OF CHECKTHIS
						      PTR = .E [ARALINK];	! NEXT ENTRY
						    END;	! OF WHILE .PTR NEQ 0
						  IF .T2 [IDUSECNT] EQL 0	! NO MATCH FOUND
						    THEN T2 [IDATTRIBUT (NOALLOC)] = 0	! USE OLD .I WHICH WAS DEALLOCED
						    ELSE T2 = INITLTEMP (INTEGER);	! GET NEW .I TEMP
						  R2 [DFACTOR (1)] = .T2;
						  T2 [IDUSECNT] = 1;		! 1ST USAGE: NO SHARING
						END;	! OF OUT
					END
				END;	!ADJ BLOCK

%1155%				IF NAMDEF(IDDEFT, .T1) LSS 0
%1155%				THEN BLDSTATUS = .VREG
%1155%				ELSE
%1155%				BEGIN	!No semantic error
					T1[IDATTRIBUT(INTYPE)] = 1;
					T1[VALTYPE] = .IDTYPE;

%1434%					IF .IDTYPE EQL CHARACTER
%1434%					THEN
%1434%					BEGIN	! Character data

%1434%						! Put   length   for   CHARACTER
%1434%						! variables into  symbol  table.
%1434%						! If  this  is  the   subprogram
%1434%						! entry, call CHARGLIST to  redo
%1434%						! the argument list.

%1434%						T1[IDCHLEN] = .CHLEN;


%1434%						IF .FLGREG<PROGTYP> EQL FNPROG THEN
%1434%						IF .T1[IDSYMBOL] EQL .ENTIDSYM[IDSYMBOL]
%1434%						THEN
%1434%						BEGIN
%1434%							ENTNODE[ENTLIST] = ARGLIST = CHARGLIST(.ARGLIST);
%1434%							ARGLIST[1, ARGFULL] = .ENTIDSYM;
%1434%							ENTIDSYM[IDATTRIBUT(DUMMY)] = 1;
%1434%						END;
%1434%					END;	! Character data
%1155%				END;	! No semantics error
%2327%				!Set the psect fields for the declared variable
%2327%				SETPSECTS(.T1);
			END;	!Type declaration
			BEGIN	!COMMON
				IF NAMDEF( VARARY, .T1) LSS 0
%1155%				THEN BLDSTATUS = .VREG

%1155%				ELSE

				!CHECK COMMON DECLARATION
%1155%				IF CHKCOMMON(.T1) LSS 0	
%1155%				THEN BLDSTATUS = .VREG;
			END	!COMMON
			TES;
		END	! Option 0 - No subscripts
		ELSE

		BEGIN	!OPTION 1 - ARRAY NAMES AND SUBSCRIPTS
			MAP BASE FARRY;
			LOCAL SAVSTK;

			CASE @TYPE OF SET
			BEGIN	%DIMENSION%
				IF NAMDEF(ARRYDEF,.T1) LSS 0 
%1155%				THEN BLDSTATUS = .VREG
			END;
			BEGIN	!GLOBAL
				!IF .T1[IDATTRIBUT(INCOM)] THEN ERR34(COMMON)
				!	ELSE IF .T1[IDATTRIBUT(INEXTERN)] THEN ERR34(EXTERNAL);
				!T1[IDATTRIBUT(INGLOB)]_1
			END;
			BEGIN	!EXTERNAL
			END;
			BEGIN	!PROTECT
			END;
			BEGIN	!Type declaration
				IF NAMDEF(ARRYDEFT,.T1) LSS 0
%1155%				THEN BLDSTATUS = .VREG
%1155%				ELSE
%1155%				BEGIN	! NAMDEF didnt find error
					T1[IDATTRIBUT(INTYPE)] = 1;
					T1[VALTYPE] = .IDTYPE;
%1213%					! Put length for CHARACTER variables
%1213%					! into symbol table
%1213%					IF .IDTYPE EQL CHARACTER
%1213%					THEN T1[IDCHLEN] = .CHLEN;
%1155%				END;	! NAMDEF didnt find error

			END;	! Type declaration
			BEGIN	%COMMON%
				IF NAMDEF (ARRYDEF,.T1) LSS 0
%1155%				THEN BLDSTATUS = .VREG;
%1155%				!Check COMMON declarations
%1155%				IF CHKCOMMON(.T1) LSS 0 
%1155%				THEN BLDSTATUS = .VREG
			END	%COMMON%

			TES;

			IF .T1[OPERSP] EQL VARIABLE
			THEN T1[OPERSP] = ARRAYNAME
			ELSE T1[OPERSP] = FORMLARRAY;

			SAVSTK = .STK[2]; !SAVING COMMON LIST POINTERS IF PROCESSING COMMON LISTS

%1575%			IF (T2 = BLDDIM(.SPNT[ELMNT])) LSS 0
%1155%			THEN BLDSTATUS = .VREG
			ELSE
			BEGIN
				FARRY[IDDIM] = .T2;

%2327%				! Set psect fields for the new array
%2327%				SETPSECTS(.FARRY);

				IF .FLGREG<BOUNDS>	!IF SS BOUNDS CHECKING IS TO BE PERFORMED
							! ON ALL ARRAYS (USER "BOUNDS" SWITCH)
				OR .FLGREG<DBGDIMN>	!OR THE "DEBUG" SWITCH WAS SPECIFIED
				THEN T2[ARADLBL] = GENLAB();	!GENERATE A LABEL TO GO ON THE BLOCK
							! THAT WILL BE OUTPUT DESCRIBING THE DIMENSION
							! INFORMATION FOR THIS ARRAY
			END;
			STK[2] = .SAVSTK;

		END;	!OPTION 1 - ARRAY NAMES AND SUBSCRIPTS

		SAVSPACE(.R1<LEFT>,@R1);

	END;	!Loop through list

	SAVSPACE(.LPNT<LEFT>,@LPNT);

%1155%	RETURN .BLDSTATUS	!Deferred status
END;	! of BLDARRAY

GLOBAL ROUTINE BLKSRCH(BLKNAME)=
BEGIN
	REGISTER BASE R1:R2;
	!---------------------------------------------------------------------
	!THIS ROUTINE FINDS OR CREATES THE COMMON BLOCK "NAME" AND
	!RETURNS A POINTER TO IT.
	!---------------------------------------------------------------------
	R1_.COMBLKPTR<LEFT>;
	UNTIL .R1 EQL 0 DO
	BEGIN
		IF .R1[COMNAME] EQL .BLKNAME THEN RETURN .R1;
		R1_.R1[NEXCOMBLK];
	END;

	ENTRY[0]_.BLKNAME;
	NAME_COMTAB;
	R2_NEWENTRY();
	RETURN .R2

END;	! of BLKSRCH

GLOBAL ROUTINE BLDVAR(VPNT)=
BEGIN
	LOCAL  BASE T2;
	REGISTER  BASE	T1;REGISTER BASE R1:R2;

	!----------------------------------------------------------------------
	!THE PARAMETER VPNT POINTS TO THE LIST:
	!
	!IDENTIFIER (20^18+LOC) - THE SCALAR OR ARRAY VARIABLE
	!OPTION 0 OR OPTION 1 - SUBSCRIPTS FOLLOW
	!	1^18+LOC - POINTER TO SUBSCRIPT LIST POINTER
	!	COUNT^18+LOC - POINTER TO A LIST OF SUBSCRIPT EXPRESSIONS
	!----------------------------------------------------------------------

	T1_.VPNT;T2_.T1[ELMNT];!T2_LOC(IDENTIFIER)
	IF .T1[ELMNT1] EQL 0 THEN
	BEGIN	%SCALAR%
		IF .SETUSE EQL  SETT
		THEN	NAMSET(VARYREF, .T2)
		ELSE	NAMREF(VARYREF,.T2);
		IF .VREG LSS 0 THEN T2 _ -1
		ELSE T2<LEFT>_IDENTIFIER	! USED BY ASSISTA AND GOTO - EVERYONE ELSE WILL
						! ACCEPT AN UNSUBSCRIPTE ARRRAY REF HERE
	END
	ELSE
	BEGIN
		IF .SETUSE EQL  SETT
		THEN	NAMSET(ARRAYNM1, .T2)
		ELSE	NAMREF(ARRAYNM1, .T2);
		IF .VREG LSS 0 THEN RETURN .VREG;
		R1_.T1[ELMNT2];R2_.R1[ELMNT];SAVSPACE(0,@R1); !CHANGED 1 TO 0
		INCR SCR FROM @R2 TO @R2+.R2<LEFT> DO
		BEGIN
			MAP BASE SCR;MACRO SCRFLGS=0,0,LEFT$,SCRPTR=0,0,RIGHT$;
			R1_.SCR[ELMNT];			SCR[SCRPTR]_@R1;SCR[SCRFLGS]_0;
		END;
		IF (T2_ARRXPND(@T2,@R2)) GTR 0
		THEN	T2<LEFT>_ARRAYREF;
	END;
	SAVSPACE(.VPNT<LEFT>,@VPNT);
	RETURN .T2!RETURN POINTER TO SCALAR OR ARRAY EXPRESSION
END;	! of BLDVAR

GLOBAL ROUTINE BLDSUBVAR(VPNT)=	! [1416] New

! Like BLDVAR but BLDVAR handles VARIABLESPECs (ID or subscripted ID)
! and BLDSUBVAR handles SUBVARSPECs (ID or subscripted ID or substring of
! either of those).  Returns a DATAOPR or ARRAYREF or SUBSTRING node.

BEGIN

	!----------------------------------------------------------------------
	!THE PARAMETER VPNT POINTS TO THE LIST:
	!
	!IDENTIFIER (20^18+LOC) - THE SCALAR OR ARRAY VARIABLE
	!OPTION: 0 = JUST IDENTIFIER
	!	 1 = IDENTIFIER FOLLOWED BY LEFT PAREN
	!	 IF OPTION 1, POINTER TO 3-ITEM LIST:
	!	 - FIRST CONSTANT EXPRESSION
	!	 - OPTION: WHICH LEXEME FOLLOWS THE FIRST CONSTANT
	!	 - POINTER TO OTHER STUFF DEPENDING ON THE OPTION
	!	 OPTION 1, COLON	A(1:2)
	!	 	OTHER STUFF IS A 2-ITEM LIST
	!	 	- COLON LEXEME
	!	 	- POINTER TO UPPER BOUND CONSTANT EXPRESSION
	!	 OPTION 2, COMMA	A(1,2)   A(1,2)(3:4)   A(1,2,3)
	!	 	OTHER STUFF IS A 2 OR 3-ITEM LIST
	!	 	- POINTER TO LIST OF SUBSCRIPT EXPRESSIONS
	!	 	- OPTION.  0 = NO SUBSTRING EXPRESSIONS, 1 = SUBSTRING
	!	 	- PTR TO LIST OF SUBSTRING EXPRESSIONS IF OPTION 1
	!	 OPTION 3, RPAREN	A(1)   A(1)(2:3)
	!	 	OTHER STUFF IS A 1 OR 2-ITEM LIST
	!	 	- OPTION.  0 = NO SUBSTRING EXPRESSIONS, 1 = SUBSTRING
	!	 	- PTR TO LIST OF SUBSTRING EXPRESSIONS IF OPTION 1
	!	 SUBSTRING EXPRESSIONS, IF PRESENT, ARE A 3-ITEM LIST:
	!	 	- PTR TO LOWER BOUND CONSTANT EXPRESSION
	!	 	- COLON LEXEME
	!	 	- PTR TO UPPER BOUND CONSTANT EXPRESSION
	!----------------------------------------------------------------------

	MAP BASE R1:R2;
	REGISTER BASE R3:IDPTR;

	R1 _ .VPNT;
	IDPTR _ .R1[ELMNT];		! Get pointer to identifier
	IF .R1[ELMNT1] EQL 0		! Check option word
	THEN				! ID is not followed by (
	BEGIN	! Scalar
		IF .SETUSE EQL SETT
		THEN NAMSET(VARYREF,.IDPTR)
		ELSE NAMREF(VARYREF,.IDPTR);
		IF .VREG LSS 0 THEN IDPTR _ -1
		ELSE IDPTR<LEFT> _ IDENTIFIER;
	END	! Scalar
	ELSE				! ID is followed by (
	BEGIN	! Arrayref or substring
		R1 _ .R1[ELMNT2];	! point to list of stuff after (

		CASE .R1[ELMNT1]-1 OF	! see what follows first constant
		SET

		BEGIN	! option 1, colon - substring

			IF .SETUSE EQL SETT 	! define and check the variable name
			THEN NAMSET(VARIABL1,.IDPTR)
			ELSE NAMREF(VARIABL1,.IDPTR);
			IF .VREG LSS 0 THEN RETURN .VREG;

			STK[.SP+1] _ .R1[ELMNT]; ! put lower bound expression onto STK
			R2 _ .R1[ELMNT2];
			STK[.SP+2] _ .R2[ELMNT1]; ! put upper bound expression onto STK
			IDPTR _ MAKESUBSTR(.IDPTR); ! make substring node

		END;	! option 1, colon - substring

		BEGIN	! option 2, comma - subscript list

			IF .SETUSE EQL SETT	! define and check the name
			THEN NAMSET(ARRAYNM1,.IDPTR)
			ELSE NAMREF(ARRAYNM1,.IDPTR);
			IF .VREG LSS 0 THEN RETURN .VREG;

			R2 _ .R1[ELMNT2];	! get pointer to rest of subscripts
			R2 _ .R2[ELMNT];
			NAME<LEFT> _ .R2<LEFT> + 2; ! get space for all subscripts
			R3 _ CORMAN();
			R3<LEFT> _ .R2<LEFT> + 1; ! set up a pointer to all subscripts
			(.R3)<FULL> _ .R1[ELMNT];  ! copy first subscript
			INCR I FROM 0 TO .R2<LEFT> ! copy rest of subscripts
			DO (.R3+1)[.I] _ .(.R2)[.I];

			IDPTR _ ARRXPND(.IDPTR,.R3); ! build ARRAYREF node, 
					        ! also discard subscript list

			R2 _ .R1[ELMNT2];	! get pointer to other stuff again
			IF .R2[ELMNT1] NEQ 0	! check if substring is present
			THEN
			BEGIN	! substring of arrayref
				R3 _ .R2[ELMNT2];
				STK[.SP+1] _ .R3[ELMNT]; ! put lower bound on STK
				STK[.SP+2] _ .R3[ELMNT2]; ! put upper bound on STK
				IDPTR _ MAKESUBSTR(.IDPTR); ! make substring node
				SAVSPACE(.R3<LEFT>,.R3); ! discard substring bounds
			END;	! substring of arrayref
		END;	! option 2, comma - subscript list

		BEGIN	! option 3, right paren - single subscript

			IF .SETUSE EQL SETT	! define and check the name
			THEN NAMSET(ARRAYNM1,.IDPTR)
			ELSE NAMREF(ARRAYNM1,.IDPTR);
			IF .VREG LSS 0 THEN RETURN .VREG;

			NAME<LEFT> _ 1;	! Get a 1-word block for the subscript
			R3 _ CORMAN();
			(.R3)<FULL> _ .R1[ELMNT]; ! copy the subscript
			IDPTR _ ARRXPND(.IDPTR,.R3); ! build ARRAYREF node,
						! also discard subscript block

			R2 _ .R1[ELMNT2];	! check if substring is present
			IF .R2[ELMNT] NEQ 0
			THEN
			BEGIN	! substring of arrayref
				R3 _ .R2[ELMNT1];
				STK[.SP+1] _ .R3[ELMNT]; ! put lower bound on STK
				STK[.SP+2] _ .R3[ELMNT2]; ! put upper bound on STK
				IDPTR _ MAKESUBSTR(.IDPTR); ! make substring node
				SAVSPACE(.R3<LEFT>,.R3); ! discard substring bounds
			END;	! substring of arrayref
		END	! option 3, right paren - single subscript

		TES;

		SAVSPACE(.R2<LEFT>,.R2);
		SAVSPACE(.R1<LEFT>,.R1);

	END;	! Arrayref or substring
	SAVSPACE(.VPNT<LEFT>,.VPNT);
	RETURN .IDPTR;
END;	! of BLDSUBVAR

GLOBAL ROUTINE CCONST(C1PTR,C2PTR)=
BEGIN

!**;[1202] THIS ENTIRE ROUTINE (CCONST) ADDED BY EDIT 1202
!**;[1203] AND GREATLY CHANGED BY EDIT 1203

!	THIS ROUTINE ACCEPTS A POINTER TO A TWO-WORD LIST, AND DETERMINES
!	WHETHER IT IS ACTUALLY A COMPLEX CONSTANT IN DISGUISE.  IF SO, THEN
!	IT CREATES THE ACTUAL COMPLEX CONSTANT NODE, AND RETURNS A POINTER
!	TO IT AS THE RESULTING VALUE.  IF NOT, THEN A ZERO IS RETURNED.
!	OBSERVE THAT THE ONLY COMPONENTS CURRENTLY ALLOWED ARE OCTAL, INTEGER,
!	REAL, AND DOUBLE PRECISION CONSTANTS - OTHERS (LIKE DOUBLE OCTAL)
!	COULD POSSIBLY BE ADDED IF DESIRABLE (QUITE UGLY, HOWEVER!).

	MAP BASE C1PTR:C2PTR;	! POINTERS TO THE TWO CONSTANT NODES
	LOCAL REALPART,IMAGPART; ! ACTUAL ONE-WORD CONSTANT REPRESENTATIONS


	! MAKE SURE THAT WE HAVE TWO CONSTANTS...

	IF .C1PTR EQL 0 THEN RETURN 0;
	IF .C2PTR EQL 0 THEN RETURN 0;
	IF .C1PTR[OPRCLS] NEQ DATAOPR THEN RETURN 0;
	IF .C1PTR[OPERSP] NEQ CONSTANT THEN RETURN 0;
	IF .C2PTR[OPRCLS] NEQ DATAOPR THEN RETURN 0;
	IF .C2PTR[OPERSP] NEQ CONSTANT THEN RETURN 0;

	! SET UP THE FIRST CONSTANT INTO REALPART

	SELECT .C1PTR[VALTYPE] OF
	NSET

	OCTAL:	REALPART_.C1PTR[CONST2];

	INTEGER: BEGIN
		C1H_0; C1L_.C1PTR[CONST2];
		COPRIX_KKTPCNVIX(COMPLEX2,FROMINT);
		CNSTCM();
		REALPART_.C2H
		END;

	REAL:	BEGIN
		C1H_.C1PTR[CONST1]; C1L_.C1PTR[CONST2];
		COPRIX_KKTPCNVIX(COMPLEX2,FROMREAL);
		CNSTCM();
		REALPART_.C2H
		END;

	DOUBLPREC: BEGIN
		C1H_.C1PTR[CONST1]; C1L_.C1PTR[CONST2];
		COPRIX_KKTPCNVIX(COMPLEX2,FROMDBLPRC);
		CNSTCM();
		REALPART_.C2H
		END;

	OTHERWISE: RETURN 0;

	TESN;

	! SET UP THE SECOND CONSTANT INTO IMAGPART

	SELECT .C2PTR[VALTYPE] OF
	NSET

	OCTAL:	IMAGPART_.C2PTR[CONST2];

	INTEGER: BEGIN
		C1H_0; C1L_.C2PTR[CONST2];
		COPRIX_KKTPCNVIX(COMPLEX2,FROMINT);
		CNSTCM();
		IMAGPART_.C2H
		END;

	REAL:	BEGIN
		C1H_.C2PTR[CONST1]; C1L_.C2PTR[CONST2];
		COPRIX_KKTPCNVIX(COMPLEX2,FROMREAL);
		CNSTCM();
		IMAGPART_.C2H
		END;

	DOUBLPREC: BEGIN
		C1H_.C2PTR[CONST1]; C1L_.C2PTR[CONST2];
		COPRIX_KKTPCNVIX(COMPLEX2,FROMDBLPRC);
		CNSTCM();
		IMAGPART_.C2H
		END;

	OTHERWISE: RETURN 0;

	TESN;

	RETURN MAKECNST(COMPLEX,.REALPART,.IMAGPART);

END;	! of CCONST

GLOBAL ROUTINE SETPSECTS(XSTE) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	This routine sets the IDPSECT and IDPSCHARS fields in the
!	symbol table entry parameter.  The fields are set based on the
!	size of the variable or array represented by the symbol table
!	entry, the variable's type, and whether or not the variable is
!	in COMMON.  EQUIVALENCE associations are not taken into account
!	by this routine.
!
!	Be aware that the psect fields of a variable may change several
!	times as new information about a variable is discovered.  For
!	example:
!
!	    1.  A type declaration statement changes a variable's type from
!		its implicit type set when the variable was first seen in
!		the lexical analyzer to the new type specified.
!
!	    2.  A DIMENSION statement converts a scalar to an array.
!
!	    3.  A type declaration following a DIMENSION statement can
!		change the size of an array.
!
!	    4.  An ENTRY statement can cause a variable to become a formal
!		after all type specification statements have been seen.
!
!	Thus, when any of the above changes occurs, the psect fields
!	must be reset by either calling this routine or by handling the
!	situation locally.
!
!	This routine treats any variable that does not have
!	IDATTRIBUTE(DUMMY) set as non-formal variables.  Thus length
!	star character variables, adjustably dimensioned arrays, and
!	assumed size arrays that have not yet been seen in a FUNCTION,
!	SUBROUTINE, or ENTRY statement are treated as non-formals by
!	this routine.  This is harmless because their psect fields are
!	correctly set later in FUNCGEN.  Furthermore, the manipulation
!	of the IDCHLEN and ARASIZ of these variables by this routine
!	cannot cause address checks, underflows, or other side effects.
!
!	See the file PSECT-TABLE.MEM for the design for the values of
!	the psect fields.
!
! FORMAL PARAMETERS:
!
!	XSTE		Pointer to the symbol table entry 
!
! IMPLICIT INPUTS:
!
!	BIGARY		The minimum size in words of a .LARG. object.
!	XSTE[IDDIM]	The pointer to the dimension table entry for the
!			symbol, if the symbol is an array.
!
! IMPLICIT OUTPUTS:
!
!	The IDPSECT and IDPSCHARS fields in the symbol table entry.
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	None
!
!--


BEGIN					![2327] New Routine

REGISTER BASE STE, DIMENTRY DIMTBL, BASE COMBLK; ![2343]

	! Put pointer into a register for speed
	STE = .XSTE;

	! Only DATAOPR's need allocation
	IF .STE[OPRCLS] NEQ DATAOPR THEN CGERR();

	! Constants have no psect fields
	IF .STE[OPERSP] EQL CONSTANT THEN CGERR();

	! All formals are in .DATA.
	IF .STE[IDATTRIBUTE(DUMMY)]
	THEN
	BEGIN
		STE[IDPSECT] = PSDATA;
		STE[IDPSCHARS] = PSOOPS;
		RETURN
	END;


%2343%	! COMMON variables are another special case
%2343%	IF .STE[IDATTRIBUTE(INCOM)]
%2343%	THEN
%2343%	BEGIN	!COMMON variable

%2343%		! Get COMMON block of variable
%2343%		COMBLK = .STE[IDCOMMON];

%2343%		! If the COMMON block of this variable isn't set yet, then
%2343%		! we must be in the middle of COMMON statement semantic
%2343%		! processing, and COMMSTA can take care of things.
%2343%		IF .COMBLK EQL 0 THEN RETURN;

%2343%		!Put variable in same psect as its COMMON block
%2343%		IF .STE[VALTYPE] EQL CHARACTER
%2343%		THEN
%2343%		BEGIN	!Character
%2343%			STE[IDPSECT] = PSCODE;
%2343%			STE[IDPSCHARS] = .COMBLK[COMPSECT];
%2343%		END	!Character
%2343%		ELSE
%2343%		BEGIN	!Non-Character
%2343%			STE[IDPSECT] = .COMBLK[COMPSECT];
%2343%			STE[IDPSCHARS] = PSOOPS;
%2343%		END;	!Non-Character

%2343%		!All Done
%2343%		RETURN;

%2343%	END;	!COMMON variable


	!Set the psect fields for non-formal scalars and arrays.  See
	!definition of non-formal given in header.

	IF .STE[VALTYPE] EQL CHARACTER
	THEN
	BEGIN	!Character variable
		STE[IDPSECT] = PSCODE;		!This is definitely correct
		STE[IDPSCHARS] = PSDATA;	!Assume this for now
		IF .STE[OPERSP] EQL ARRAYNAME
		THEN
		BEGIN	!Character array
			DIMTBL = .STE[IDDIM];
			IF EXTENDED
			THEN IF CHWORDLEN(.DIMTBL[ARASIZ]) GEQ .BIGARY
			THEN STE[IDPSCHARS] = PSLARGE
		END	!Character array
		ELSE
		BEGIN	!Character scalar
			IF EXTENDED
			THEN IF CHWORDLEN(.STE[IDCHLEN]) GEQ .BIGARY
			THEN STE[IDPSCHARS] = PSLARGE
		END	!Character scalar
	END	!Character variable
	ELSE
	BEGIN	!Numeric variable
		STE[IDPSECT] = PSDATA;		!Assume this for now
		STE[IDPSCHARS] = PSOOPS;	!This is definitely correct
		IF .STE[OPERSP] EQL ARRAYNAME
		THEN
		BEGIN	!Numeric Array
			DIMTBL = .STE[IDDIM];
			IF EXTENDED
			THEN IF .DIMTBL[ARASIZ] GEQ .BIGARY
			THEN STE[IDPSECT] = PSLARGE
		END	!Numeric Array
	END;	!Numeric variable

END;	! of SETPSECTS

GLOBAL ROUTINE SIZOFARRAY(ARRAY)=	! [1471] Rewritten by RVM
BEGIN

!***********************************************************************
!	This routine returns an expression to calculate the number of
!	entries in an array.  If the size of the array can be determined
!	at compile time, then this expression will be a constant table
!	entry or an expression that will be evaluated to a constant by
!	the skeleton optimizer.  Otherwise, it will be a expression to
!	be evaluated at runtime.
!
!	Note that assumed size arrays cause this routine to give an ICE.
!
!***********************************************************************

	MAP BASE ARRAY;
	REGISTER BASE DIMTBL;

	DIMTBL = .ARRAY[IDDIM]; 	! Pointer to dimension table entry

%1510%	! Impossible to determine size of an assumed size array.

%1510%	IF .DIMTBL[ASSUMESIZFLG] THEN CGERR();

	IF .ARRAY[VALTYPE] EQL CHARACTER
	THEN
	BEGIN	! Character array.

		! Check for adjustably dimensioned array.

		IF NOT .DIMTBL[ADJDIMFLG]
		THEN RETURN MAKECNST(INTEGER,0,.DIMTBL[ARASIZ]/.ARRAY[IDCHLEN]);

		! Adjustably dimensioned character array.

		IF .ARRAY[IDCHLEN] NEQ LENSTAR
		THEN RETURN MAKPR1(0,ARITHMETIC,DIVOP,INTEGER,
	      		.DIMTBL[ARASIZ],MAKECNST(INTEGER,0,.ARRAY[IDCHLEN]));

		RETURN MAKPR1(0,ARITHMETIC,DIVOP,INTEGER,.DIMTBL[ARASIZ],.DIMTBL[DFACTOR(0)]);

	END;	! of character array.
	

	! Non-character array.

	IF NOT .ARRAY[DBLFLG]
	THEN
	BEGIN	! Non-character array with one word per element.

		! Check for adjustably dimensioned array.

		IF .DIMTBL[ADJDIMFLG] THEN RETURN .DIMTBL[ARASIZ];

		! Non-Character, non-adjustably dimensioned array
		!  with one word per element.

		RETURN MAKECNST(INTEGER, 0, .DIMTBL[ARASIZ]);

	END;	! of non-character array with one word per element.

	! The array must be a non-character array with 2 words per element.

	! Check for adjustably dimensioned case.

	IF NOT .DIMTBL[ADJDIMFLG]
	THEN RETURN MAKECNST(INTEGER,0,.DIMTBL[ARASIZ]/2);

	! Non-Character, non-adjustably dim'ed array with 2 words per element.

	RETURN MAKPR1(0,ARITHMETIC,DIVOP,INTEGER,.DIMTBL[ARASIZ],MAKECNST(INTEGER,0,2));


END;	! of SIZOFARRAY

ROUTINE BLDIOLSCLS(NODE)=
BEGIN
	!***************************************************************
	! This routine is passed an  expression node, and it creates  an
	! IOLSCLS node pointing to the data contained in the  expression
	! node.  If successful,  a pointer  is returned  to the  IOLSCLS
	! node.
	!***************************************************************

%1202%	! This entire routine is added by edit 1202

	MAP BASE NODE;		! An expression node in an iolist
	REGISTER BASE IONODE,	! The created IOLSCLS node
%1510%		 BASE DIMTBL;	! Dimension table of node (if it has one!)

%1743%	LOCAL	BASE TEMP;	! Temporary variable

	MACRO ERR146=(RETURN FATLEX(E146<0,0>))$;
%1510%	MACRO ERR191=(RETURN FATLEX(UPLIT 'in an I/O list?0',E191<0,0>)) $;

	! A few validity checks . . .

	! If NODE is the bare name of an array or formal array

%1510%	IF .NODE[OPR2] EQL OPR2C(DATAOPR, ARRAYNAME) ! If array or formal Array
%1510%	THEN
%1510%	BEGIN
%1510%		DIMTBL = .NODE[IDDIM];	      ! Get Dimension Table Entry
%1510%		IF .DIMTBL[ASSUMESIZFLG]      ! Don't allow Assumed Size Arrays
%1510%		THEN ERR191
%1510%	END;

	![rvm] There is an error here.There needs to be check for external name

	! And more validity check if we have an input statement...

	IF .TYPE EQL READD THEN ! MUST HAVE VARIABLE OR ARRAY  NAME
		IF .NODE[OPRCLS] EQL DATAOPR
		THEN
			(IF .NODE[OPRSP1] EQL VARIABL1 OR
			    .NODE[OPRSP1] EQL ARRAYNM1 THEN ! WE ARE OK !
				ELSE ERR146)
		ELSE
			IF .NODE[OPRCLS] EQL ARRAYREF THEN  ! WE ARE OK !
%1444%			ELSE IF .NODE[OPRCLS] EQL SUBSTRING THEN ! OK !
			     ELSE ERR146;

	! Build the IOLSCLS node

	NAME = IOLTAB;		! Iolist table

	IF .TYPE EQL READD
	THEN SETUSE = SETT	! Variables are set
	ELSE SETUSE = USE;	! variables are referenced

	IF .NODE[OPRCLS] EQL DATAOPR AND .NODE[IDDIM] NEQ 0
%1407%		AND .NODE[OPERSP] NEQ CONSTANT
	THEN
	BEGIN
%1530%		NAME<LEFT> = SLCSIZ;
		IDOFSTATEMENT = SLISTCALL;
	END
	ELSE	IDOFSTATEMENT = DATACALL;

	IONODE = NEWENTRY();			! Create the IOLSCLS node
	IONODE[OPERSP] = .IDOFSTATEMENT;	! DATACALL or SLISTCALL
	IONODE[OPRCLS] = IOLSCLS;
	IONODE[DCALLELEM] = .NODE;	! Insert pointer to the expression

	IF .IONODE[OPERSP] EQL SLISTCALL
	THEN
	BEGIN
		! Fix up OPERSP because newentry has set SRCID

		IONODE[SRCID] = 0;		! Clears OPERSP
		IONODE[OPERSP] = SLISTCALL;

		! Setup pointer to the number of elements in array

%1743%		IONODE[SCALLCT] = TEMP = SIZOFARRAY(.NODE);

		! Set the parent pointer unless it isn't an  expression.
%1767%		IF .TEMP[OPRCLS] NEQ DATAOPR
%1743%		THEN	TEMP[PARENT] = .IONODE;

	END;

	RETURN .IONODE

END;	! of BLDIOLSCLS

GLOBAL ROUTINE LISTIO(LPNT)=
BEGIN
	!***************************************************************
	! This routine is  used to  build  iolists for input and  output
	! statements, i.e., TYPE, WRITE, READ, etc..  It is called  with
	! LPNT pointing to a list of iolist  items;  each item  consists
	! of:
	!
	! choice-1
	! 	iolist item - either an expression  (including constants
	! 		and variables) or an array name.
	!
	! choice-2
	! 	list of iolist items - including implied DO loops
	!
	! An iolist chain  is created,  and a  pointer to  the chain  is
	! returned as  the value.   Notice that  the routine  is  called
	! recursively in order to build larger and larger chains!
	!***************************************************************

%1202%	! This entire routine is added by edit 1202


	MACRO ADDCONTNODE (X) =
	BEGIN
		T1 = .IOLBL [SNHDR];	! GET NODE FROM IOCONTNODE
		X [CLINK] = .T1;	! LINK IN CONT NODE AT END OF LOOP
		X<RIGHT> = .T1;		! POINT TO NEW END OF DATALIST
	END$;

	MACRO  ADDOLAB (X,Y) =		! PUT INDEX ON ACTIVE DO LIST
	BEGIN
		LOCAL DINODE TEMP;
		NAME<LEFT> = DISIZE; 	! MAKE NEW DO NODE
		TEMP = CORMAN ();
		TEMP[DITYPE] = DIDOTYPE; ! SET NODE TYPE TO DO
		TEMP[DISTMT] = 0; 	! NO DO STMT NODE TO POINT TO
		TEMP[LASTDOLBL] = X;	! SET LABEL OF TERMINAL STATEMENT
		TEMP[CURDONDX] = Y;	! SET LOOP INDEX
		LASDOLABEL = X;
		CURDOINDEX = Y;
		TEMP[DILINK] = .DOIFSTK; ! LINK NEW NODE INTO DOIFSTK
		TEMP[DIBLINK] = 0;
		IF .DOIFSTK NEQ 0 THEN DOIFSTK[DIBLINK] = .TEMP;
		DOIFSTK = .TEMP;
	END$;

	MACRO ERR38=(RETURN FATLEX(E38<0,0>))$; !INDEX VARIABLE NOT VARIABLE
	MACRO ERR44=(RETURN FATLEX(TDOSYM[IDSYMBOL],E44<0,0>))$; !NON-INTEGER LOOP PARAMETER

	MACRO IODONODE(X)=
	BEGIN
		IDOFSTATEMENT = NAME = DODATA;
		NAME<RIGHT> = IOLTAB;
		T1 = NEWENTRY();
		T1[CLINK] = .X<LEFT>;
		X<LEFT> = .T1;
		T1[OPRCLS] = STATEMENT;
		T1[DOLBL] = .IOLBL;	!PSEUDO LABEL MADE BY IOCONTNODE
		T2 = .IOLBL[SNDOLNK]; 
		IOLBL[SNDOLVL] = .IOLBL[SNDOLVL]+1;
		NAME<LEFT> = 1; IOLBL[SNDOLNK] = CORMAN();
		(.VREG)<LEFT>=.T1; (.VREG)<RIGHT>=.T2; !LINKING IN ENDING LBL TO DO NODE AND LABEL TABLE
	END$;

	MACRO IOCONTNODE =
	BEGIN	!CREATE A CONTINUE NODE IN THE LIST...
		IDOFSTATEMENT=NAME=CONTDATA;	!NODE IDENTIFICATION AND SIZE
		NAME<RIGHT> = IOLTAB;
		T1=NEWENTRY();	! CREATE THE NODE
		T1[OPRCLS]=STATEMENT; !IDENTIFY IT
		IOLBL=T1[SRCLBL]=GENLAB();
		IOLBL[SNREFNO]=2;	!REFERENCE COUNT OF 2
		IOLBL[SNHDR]=.T1	!PTR TO CONTINUE IN LABEL TABLE NODE
	END$;

	REGISTER BASE R1:R2:T1;	!ALL THE FAST TEMPORARIES!

	LOCAL BASE T2;
	LOCAL BASE LISTLINK; ! PTR TO FIRST<LEFT> AND LAST<RIGHT> NODES IN THIS IOLIST CHAIN.

	LISTLINK=0;	!INITIALIZE THE LIST POINTER

	INCR DATLST FROM @LPNT TO @LPNT+.LPNT<LEFT> BY 2 DO
	BEGIN	!TREAT EACH ELEMENT IN THE LIST...

		MAP BASE DATLST;

		IF .DATLST[ELMNT] EQL 1 THEN ! AN EXPRESSION
		BEGIN
			R1=.DATLST[ELMNT1]; ! GET PTR TO EXPRESSION

			R1=BLDIOLSCLS(.R1);	! BUILD THE IOLSCLS NODE
			IF .R1 LSS 0 THEN RETURN .R1; ! SOMETHING FAILED

			IF .LISTLINK EQL 0
				THEN LISTLINK<LEFT>=LISTLINK<RIGHT>=.R1
				ELSE (LISTLINK[CLINK] = .R1;	! TIE IN AT THE
					LISTLINK<RIGHT> = .R1);	! END OF THE LIST
		END

		ELSE	! A LIST OF ELEMENTS OR LIST WITH LOOPPART

		BEGIN
			LOCAL BASE IOLBL;	! LABEL OF CONTINUE ENDING DO LOOP
			LOCAL BASE LNKLST;	! KEEP SEPARATE LIST TEMPORARILY
			LOCAL BASE DONOD;	! PTR TO CREATED DO LOOP NODE
			LOCAL BASE TDOSYM;	! DO INDEX SYMBOL TABLE PTR

			LNKLST=0;

			R1=.DATLST[ELMNT1]; ! PTR TO (LIST PTR, LOOP PTR) PAIR
			R2=.R1[ELMNT];      ! PTR TO LIST ITSELF

		! THERE ARE TWO CHOICES HERE - A LIST WITH A DO LOOP, AND ONE
		! WITHOUT A DO LOOP.  THE PROCESSING MUST HAPPEN IN STAGES -
		! IF THERE IS A DO LOOP, THEN THE LOOP VARIABLE IS ACTUALLY THE
		! LAST ELEMENT OF THE LIST, SO WE MUST REMOVE IT AND HANDLE IT
		! FIRST.  THEN WE HANDLE THE ELEMENTS OF THE LIST.  FINALLY WE
		! HAVE A BUNCH OF CLEANUP WORK TO DO IN THE CASE THAT THERE WAS
		! A LOOP - THIS WORK MUST OCCUR AFTER PROCESSING THE LIST.

			IF .R1[ELMNT1] NEQ 0
			THEN	! IMPLIED DO LOOP - R2 POINTS TO LIST
			BEGIN
				IF .R2<LEFT> EQL 1
					THEN RETURN FATLEX(E128<0,0>); !NO ELEMENTS FOR LIST!
				T1=@R2+.R2<LEFT>;	! PTR TO LAST LIST ELMNT (LOOP INDEX)
				T2=TDOSYM=.T1[ELMNT];	! GET THE DO INDEX VARIABLE
				IOCONTNODE;		! GET A CONTINUE NODE

				!CHECK OUT IMPLICIT DO INDICES...
				!I.E., A(I), I+1=2,10  OR  A(I,J),B(I)=1,10

				IF .T2[OPRCLS] NEQ DATAOPR THEN ERR38;
				IF .T2[OPRSP1] NEQ VARIABL1 THEN ERR38; !VARIABLE OR FORMAL VARIABLE

%1741%				! Implied DO index can NOT be character
%1741%				IF .T2[VALTYPE] EQL CHARACTER
%1741%				THEN	RETURN FATLERR(.T2[IDSYMBOL], .ISN,
%1741%						E160<0,0>);	! Complain

				IF NAMSET(VARIABL1,.T2) LSS 0 
					THEN RETURN .VREG; ! THIS CREFS THE VARIABLE, ETC.
				IF CKDOINDEX(.T2) THEN	! DO INDEX ALREADY ACTIVE
					RETURN FATLEX(T2[IDSYMBOL],E21<0,0>);
				ADDOLAB(.IOLBL,.T2);	! THIS INDEX CURRENTLY MOST ACTIVE
				R2<LEFT>=.R2<LEFT>-2;	! REMOVE THE DO VARIABLE FROM
							! LIST OF ELEMENTS SO IT DOESN'T
							! GET PROCESSED AS IOLISTNODE

%1550%				SAVSPACE(1,.R2+.R2<LEFT>+1); ! SAVE THE 2 WORDS
			END;

				! HERE IS THE RECURSIVE CALL TO GET THE LIST
				! THIS IS THE ONLY RECURSIVE CALL IN THE ROUTINE

			IF(LNKLST = LISTIO(.R2)) LSS 0 THEN !ERROR IN LIST
			BEGIN
				T2=.VREG;
				IF .R1[ELMNT1] NEQ 0	!IMPLIED DO LOOP
					THEN DOCHECK(.IOLBL); !REMOVE LABEL FROM ACTIVE DO LIST
				RETURN .T2
			END;

			! DONE WITH THE LIST, NOW TIME TO CLEAN UP THE LOOP,
			! IN THE CASE THAT THERE INDEED WAS A LOOP...

			IF .R1[ELMNT1] NEQ 0 THEN ! IMPLIED DO LOOP
			BEGIN
				DOCHECK(.IOLBL);	!REMOVE LABEL FROM ACTIVE DO LIST
				ADDCONTNODE(LNKLST);	!LINK IN CONTINUE NODE
				IODONODE(LNKLST);	!GENERATE A DO LOOP NODE
				DONOD=.LNKLST<LEFT>;	!SET UP BY IODONODE
	
				! NOW IT IS TIME TO FILL IN ALL THE VALUES FOR THE
				! DO LOOP NODE - INITIAL, FINAL, AND INCREMENT,
				! CHECKING EACH FOR REASONABLENESS AS WE GO.

				DONOD[DOSYM]=.TDOSYM;
				R2=.R1[ELMNT2];		!PTR TO BLOCK OR PTRS FOR
							!INITIAL, FINAL, AND INCREMENT
				SAVSPACE(.R1<LEFT>,.R1);! PTRS TO LIST, INCREMENT BLOCK

				DONOD[DOM1]=.R2[ELMNT];	! INITIAL LOOP VALUE
				DONOD[DOM2]=.R2[ELMNT1]; ! FINAL LOOP VALUE
				IF .R2[ELMNT2] EQL 0 THEN ! IMPLIED INCREMENT OF ONE
					DONOD[DOM3]=.ONEPLIT
				ELSE DONOD[DOM3]=.R2[ELMNT2]; ! LOOP INCREMENT

				SAVSPACE(.R2<LEFT>,.R2);! PTRS TO LOOP VALUES
			END
%1550%			ELSE
%1550%			BEGIN
%1550%				SAVSPACE(.R1<LEFT>,.R1);
%1550%			END;

			IF .LISTLINK EQL 0 THEN LISTLINK=.LNKLST
				ELSE (LISTLINK[CLINK]=.LNKLST<LEFT>;
					LISTLINK<RIGHT>= .LNKLST<RIGHT>);
		END;

	END;

%1550%	SAVSPACE(.LPNT<LEFT>,.LPNT);

	RETURN .LISTLINK
END;	! of LISTIO

GLOBAL ROUTINE DATALIST(LPNT)=
BEGIN
	LOCAL  BASE T2;
	REGISTER BASE T1;REGISTER BASE R1:R2;

	MACRO ADDOLAB (X,Y) =
	BEGIN
		LOCAL DINODE TEMP;
		NAME<LEFT> _ DISIZE; 	! MAKE NEW DO NODE
		TEMP _ CORMAN ();
		TEMP[DITYPE] _ DIDOTYPE; ! SET NODE TYPE TO DO
		TEMP[DISTMT] _ 0; 	! NO DO STMT NODE TO POINT TO
		TEMP[LASTDOLBL] _ X;	! SET LABEL OF TERMINAL STATEMENT
		TEMP[CURDONDX] _ Y;	! SET LOOP INDEX
		LASDOLABEL _ X;
		CURDOINDEX _ Y;
		TEMP[DILINK] _ .DOIFSTK; ! LINK NEW NODE INTO DOIFSTK
		TEMP[DIBLINK] _ 0;
		IF .DOIFSTK NEQ 0 THEN DOIFSTK[DIBLINK] _ .TEMP;
		DOIFSTK _ .TEMP;
	END$;

	LOCAL SAVEBOUNDSFLG;	! TO SAVE THE VALUE OF THE "BOUNDS"
				! SWITCH WHILE PROCESSING THE DATA
				! LIST FOR A DATA STMNT
	MACRO
	ERR38=(RETURN FATLEX(E38<0,0>))$, !INDEX VARIABLE NOT VARIABLE
	ERR44=RETURN FATLEX(TDOSYM[IDSYMBOL],E44<0,0>)$;
	!
	!MACROS FOR DATALIST NODE GENERATION FOR IOLISTS,DATA LISTS
	!
	MACRO IODATANODE(X)=
%[635]%	BEGIN
		NAME _ IOLTAB;	!IOLIST TABLE
		R1_X;
		T2 _ .R1[ELMNT];
		SETUSE _ SETT;

		! Check the variable to see if it's already been in a DATA
		! statement.  If so, warn the user that he's initializing the
		! same variable twice.  Don't do this check for arrays (which
		! can be initialized element by element) or character variables
		! (which can be initialized char by char with substrings).

		IF .T2[IDATTRIBUT(INDATA)] EQL 1	!SEE IF IT'S
%1416%		THEN IF .T2[VALTYPE] NEQ CHARACTER	!NOT CHARACTER AND
		THEN IF .T2[IDDIM] EQL 0		!NOT AN ARRAY BUT
		THEN		!ALREADY IN A DATA STATEMENT
		FATLEX(T2[IDSYMBOL],E139<0,0>);	!WARN HIM
		T2[IDATTRIBUT(INDATA)] _ 1;

%1423%		IF .T2[IDATTRIBUTE(FENTRYNAME)]	     ! Check for function name
%1423%		THEN IF .T2[VALTYPE] EQL CHARACTER   ! of type character
%1773%		THEN IF .FLGREG<PROGTYP> EQL FNPROG  ! with FNPROG set

%1423%		THEN RETURN FATLEX(T2[IDSYMBOL],E174<0,0>); ! Yes, error,
				   ! "Can't initialize character function name"
					
%[635]%		IF .T2[IDATTRIBUT(DUMMY)] THEN RETURN FATLEX( T2[IDSYMBOL],E66<0,0>);

		IDOFSTATEMENT _  IF .R1[ELMNT1] NEQ 0 THEN DATACALL
					ELSE (R1_.R1[ELMNT]; !PTR TO SYMBOL
%1530%						IF .R1[IDDIM] NEQ 0 THEN (NAME<LEFT>_ SLCSIZ;SLISTCALL) ELSE DATACALL
					    );
		R1_NEWENTRY();
		R1[OPERSP] _ .IDOFSTATEMENT;  !DATACALL OR SLISTCALL
		IF .LISTLINK EQL 0
		  THEN (LISTLINK<LEFT>_LISTLINK<RIGHT>_.R1)
		  ELSE (LISTLINK[CLINK] _ .R1; LISTLINK<RIGHT>_.R1);
		R1[OPRCLS] _ IOLSCLS;	!IOLIST CLASS
%1416%		R1[DCALLELEM] _ BLDSUBVAR(X);
		IF .VREG LSS 0 THEN (R1[DCALLELEM] _ 0; RETURN .VREG); !VREG IS -1 IF BLDVAR FOUND AN ERROR
		IF .R1[OPERSP] EQL SLISTCALL
		THEN
		BEGIN
%1743%			LOCAL BASE TEMP;
			!FIX UP OPERSP BECAUSE NEWENTRY
			!HAS SET SRCID
			R1[SRCID]_0;
			R1[OPERSP]_SLISTCALL;
%1743%			!Ptr to node containing num of elements in array
%1767%			R1[SCALLCT] = TEMP = SIZOFARRAY(.R1[DCALLELEM]);
%1743%			! Fix parent ptr if neccesarry.
%1767%			IF .TEMP[OPRCLS] NEQ DATAOPR
%1743%			THEN TEMP[PARENT] = .R1;
		END;
	END$;
	MACRO IODONODE(X)=
	BEGIN
		IDOFSTATEMENT_NAME_DODATA;
		NAME<RIGHT> _ IOLTAB;
		T1_NEWENTRY();
		T1[CLINK]_ .X<LEFT>; X<LEFT>_ .T1;
		T1[OPRCLS]_STATEMENT;
		T1[DOLBL] _ .IOLBL;	!PSEUDO LABEL MADE BY IOCONTNODE
		T2_.IOLBL[SNDOLNK]; 
		IOLBL[SNDOLVL] _ .IOLBL[SNDOLVL]+1;
		NAME<LEFT> _ 1; IOLBL[SNDOLNK] _ CORMAN();
		(.VREG)<LEFT>_.T1; (.VREG)<RIGHT>_.T2; !LINKING IN ENDING LBL TO DO NODE AND LABEL TABLE
	END$;
	MACRO IOCONTNODE =
	BEGIN
		IDOFSTATEMENT_NAME_CONTDATA;	!NODE IDENTIFICATION AND SIZE
		NAME<RIGHT> _ IOLTAB;
		T1_NEWENTRY();
		T1[OPRCLS]_STATEMENT;
		IOLBL _ T1[SRCLBL]_ GENLAB();
		IOLBL[SNREFNO]_2;	!REFERENCE COUNT OF 2
		IOLBL[SNHDR] _ .T1	!PTR TO CONTINUE IN LABEL TABLE NODE
	END$;

	MACRO ADDCONTNODE (X) =
 BEGIN
		T1 _ .IOLBL [SNHDR];	! GET NODE FROM IOCONTNODE
		X [CLINK] _ .T1;	! LINK IN CONT NODE AT END OF LOOP
		X<RIGHT> _ .T1;		! POINT TO NEW END OF DATALIST
	END$;

	LOCAL BASE LISTLINK;	!PTR TO FIRST<LEFT> AND LAST<RIGHT> NODES IN DATALIST CHAIN
	!---------------------------------------------------------------------
	!THIS ROUTINE IS CALLED WITH LPNT POINTING TO A LIST OF
	!DATAITEMS.  EACH DATAITEM CONSISTS OF:
	!
	!CHOICE-1
	!	DATAITEM-(LOC)
	!CHOICE-2
	!	LIST-(COUNT^18+LOC)
	!		DATAITEM
	!	OPTION-0 OR
	!	OPTION-1
	!		LOOPPART
	!---------------------------------------------------------------------
	SAVEBOUNDSFLG_.FLGREG<BOUNDS>;	!PRESERVE THE VALUE OF THE "BOUNDS"
			! SWITCH (USED BY THE USER TO REQUEST ARRAY BOUNDS CHECKING)
	FLGREG<BOUNDS>_0;	!TURN OFF THE BOUNDS FLAG UNTIL ARE THROUGH WITH THIS STMNT
				! (ELSE THE ARRAY SS CALC WILL BE TURNED INTO A CALL TO
				! A RUN-TIME FUNCTION)
	LISTLINK_0;	!INITIALIZING FOR LIST INPARENS
	INCR DATLST FROM @LPNT TO @ LPNT+.LPNT<LEFT> BY 2 DO
	BEGIN
		MAP BASE DATLST;
		IF .DATLST[ELMNT] EQL 1 THEN	!A DATAITEM
		BEGIN
			IODATANODE(.DATLST[ELMNT1]);
		END
		ELSE	!AN IMPLIED DO LOOP OR LIST ENCLOSED IN PARENS
		BEGIN
			LOCAL BASE LNKLST; !TEMPORARY HOLDER OF LINKLIST
			LOCAL BASE TDOSYM; !TEMPORARY HOLDER OF DO INDEX SYMBOL PTR
			LOCAL  BASE DONOD:IOLBL;	!LABEL OF CONTINUE ENDING IMPLIED DO LOOP
			LNKLST _ 0;  !INIT LOCAL
			R1_.DATLST[ELMNT1];R2_.R1[ELMNT];  !R2_LOC(DATAITEM LIST)
			IF .R1[ELMNT1] NEQ 0
			 THEN (!IMPLIED DO LOOP COMING UP ; R2 HAS PTR  TO IMPLIED  DO LIST
				%FIRST CHECK TO SEE THAT THERE HAVE BEEN
				 SOME VARIABLES FOR THIS DO SPEC %
				IF .R2<LEFT>  EQL  1  
				THEN	RETURN FATLEX (E128<0,0>);
				T1_@R2+.R2<LEFT>;
				T2 _ .T1[ELMNT];
				IOCONTNODE ;		! GEN A CONTINUE NODE
				%DON'T LET SUBSCRIPTED IMPLICIT DO INDECES GO UNDETECTED%
				IF .T2[ELMNT1]  NEQ  0  THEN RETURN FATLEX(E115<0,0>);
				T2 _ TDOSYM _ .T2[ELMNT];
				IF .T2[OPRCLS] NEQ DATAOPR THEN ERR38
				  ELSE IF .T2[OPRSP1] NEQ VARIABL1 THEN ERR38;
				IF .T2[VALTYPE] NEQ INTEGER THEN RETURN FATLEX(E104<0,0>);
				STK[SP_.SP+1] _.T2; !SAV PTR TO INDEX SYMBOL ON STACK
				IF CKDOINDEX (.T2)
				  THEN RETURN FATLEX (T2 [IDSYMBOL], E21<0,0>);	! DO INDEX ALREADY ACTIVE
				ADDOLAB (.IOLBL, .T2);	! THIS INDEX IS CURRENTLY MOST ACTIVE

				R2<LEFT>_.R2<LEFT>-2; !RESET LIST PTR SO THAT LAST ITEM (INDEX PTR)
							!DOESN'T GET PROCESSED AS AN IODATANODE
				);
			IF (LNKLST _ DATALIST (.R2)) LSS 0
			  THEN BEGIN
			    T2 _ .VREG;
			    IF .R1 [ELMNT1] NEQ 0	! IMPLIED DO LOOP
			      THEN DOCHECK (.IOLBL);	! REMOVE LABEL FROM ACTIVE DO LIST
			    RETURN .T2;
			  END;
			IF .R1[ELMNT1] NEQ 0 THEN	!IMPLIED DO LOOP
			BEGIN
				DOCHECK (.IOLBL);	! REMOVE LABEL FROM ACTIVE DO LIST
				ADDCONTNODE (LNKLST);	! LINK IN CONT NODE
				IODONODE(LNKLST);	!GEN A DO LOOP NODE
				DONOD_.LNKLST<LEFT>; !SET UP BY IODONODE
				DONOD[DOSYM]_.TDOSYM;	!STK[2]_LOC(INDEX VARIABLE)
				R2_.R1[ELMNT2]; SAVSPACE(.R1<LEFT>,.R1); !R2_LOC(LOOPPART)
				R1_.R2[ELMNT];
				!R1 POINTS TO INITIAL VALUE
				IF .R1[OPR1] NEQ CONSTFL THEN ERR44;
				IF .R1[VALTYPE] NEQ INTEGER THEN ERR44;
				DONOD[DOM1]_@R1;R1_.R2[ELMNT1];	!_LOC(INITIAL VALUE)
				!R1 POINTS TO FINAL VALUE
				IF .R1[OPR1] NEQ CONSTFL THEN ERR44;
				IF .R1[VALTYPE] NEQ INTEGER THEN ERR44;
				DONOD[DOM2]_@R1;	!_LOC(FINAL VALUE)
				IF .R2[ELMNT2] EQL 0 THEN	!INPLIED INCREMENT OF 1
					DONOD[DOM3]_.ONEPLIT
				ELSE	!INCREMENT SPECIFIED
				BEGIN
					T1_.R2[ELMNT3];R1_.T1[ELMNT];SAVSPACE(0,.T1);
					IF .R1[OPR1] NEQ CONSTFL THEN ERR44;
					IF .R1[VALTYPE] NEQ INTEGER THEN ERR44;
					DONOD[DOM3]_.R1<RIGHT>;
				END;
				IF .SP GTR 0
					THEN (	DATASUBCHK(.DONOD[CLINK],.SP,STK[1]<0,0>);
						SP _ .SP-1;
					     );
				SAVSPACE(.R2<LEFT>,.R2);
			END;
			IF .LISTLINK EQL 0
			THEN LISTLINK_.LNKLST
			ELSE (LISTLINK[CLINK]_.LNKLST<LEFT>;
				LISTLINK<RIGHT> _ .LNKLST<RIGHT>
			     );
		END;
	END;
	FLGREG<BOUNDS>_.SAVEBOUNDSFLG;	!RESTORE THE "BOUNDS" FLAG TO ITS ORIGINAL VAL
	RETURN .LISTLINK	!POINTS TO FIRST ELEMENT IN LIST
END;	! of DATALIST