Google
 

Trailing-Edge - PDP-10 Archives - fortv11 - arrxpn.bli
There are 12 other files named arrxpn.bli in the archive. Click here to see a list.
!COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1972, 1987
!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: S. MURPHY/NEA/SJW/TFV/CKS/AHM/AlB/CDM/MEM

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

!	REQUIRES FIRST, TABLES

GLOBAL BIND ARRXPV = #11^24 + 0^18 + #4532;	! Version Date: 19-Feb-86


%(

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

47	-----	-----	FIX BUG IN "PROARRXPN" TO CONVER SUBSCRIPTS OF
			PROTECTED ARRAYS TO INTEGER
48	-----	-----	CHANGE ERROR CALLS TO FATLERR/WARNERR
49	-----	-----	MAKE ONLIST A LOCAL ROUTINE
50	-----	-----	49 IS NOT ENOUGH. CHANGE THE ROUTINE NAME
			SO THAT WE CAN STILL ASSEMBLE WITH MACRO
51	-----	-----	MAKE PROARRXPN RESET BTTMMSTFLG SO THAT SUBPROGRAMS
			THAT ARE BOTTOM-MOST WILL SAVE/RESTORE 16 ANYWAY.
52	VER5	-----	MAKE SUBSCRIPT EXPR TRESS LEFT BALANCED

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

53	761	TFV	1-Mar-80	-----
	Add KTYPCG for type conversions under /GFLOATING.

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

54	1250	CKS	6-Aug-81
	Modify for CHARACTER arrays.  Explicitly add the constant part of
	the subscript expression into the expression node; leave TARGET alone.
	Don't add the base address of a character formal array to the subscript
	expression.

55	1416	CKS	9-Nov-81
	Check substring bounds as well as subscripts in DATASUBCHK.
	Also allow ** in subscript and substring expressions.

56	1436	SRM	16-Dec-81
	Set CHARUSED if there is a ref to a character array element

1503	AHM	8-Mar-82
	Cancel part of edit 1250 by making array bounds checking  call
	the routine PROAR. (again).   The name had  been PROTA. for  a
	while, but different names were not necessary after all.

1505	AHM	9-Mar-82
	Set the psect of the symbol table entry for PROAR. to .CODE.

1551	AHM	3-Jun-82
	Remove edit 1505 from this module because external  references
	will not have a psect index set in the STE.

1554	CKS	7-Jun-82
	Add routine PROSUB to generate call to PROSB., the substring
	bound checking routine.

1714	CKS	11-Jan-83
	Copy ARRAYREF nodes properly in COPYEXPR.

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

1766	CDM	15-Jul-83
	Compiler puts constant array ref offset calculations in TARGADDR
	whenever possible.  TARGADDR  is a  half word  quantity (17  bit
	plus 1 bit for  sign) which can not  store large numbers.   Some
	large positive  numbers  may  be  truncated  and  appear  to  be
	negative when  retrieved, since  the  retrieved offset  is  sign
	extended.  (Also negative numbers can appear to be positive  the
	same way.)  Before  storing into TARGADDR,  check if the  offset
	will fit.
	Removed OWN variables SSVARFLG  (replaced its use with  existing
	SSVARPTR) and SSCONSTPTR (never referenced) in ARRXPN.


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

2253	AlB	28-Dec-83
	Compatibility flagging of non-integer subscripts.
	Routines:
		ARRXPND, PROARRXPN

2271	AlB	18-Jan-84
	Compatibility flagging to check to see if substring bounds in a
	DATA statement are constants.  ANSI-77 specifies that one cannot
	use implied DO-loops which modify the substring bounds, so the
	bound cannot be a non-constant expression.
	Routines:
		DATASUBCHK	LEGLDATASUB

2463	AHM	8-Oct-84
	Use new OPERSP symbol ARREFSMALL when creating all ARRAYREF
	nodes in ARRXPND and PROARRXPN.

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

2561	CDM	21-NOV-85
	When using IMPLICIT NONE with /DEBUG:BOUNDS or /DEBUG:ALL, PROAR.
	and PROSB. get warnings for not being explicitly defined. We are
	now making sure that the compiler knows they are library functions
	and not user symbols.

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

***** Begin Version 11 *****

4515	CDM	20-Sep-85
	Phase I for VMS long symbols.  Create routine ONEWPTR for Sixbit
	symbols.  For now, return what is passed it.  For phase II, return
	[1,,pointer to symbol].

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

4524	CDM	21-Nov-85
	Additions to edit 2561. Fill in IDLIBFNFLG for FDDT. 

4527	CDM	1-Jan-86
	VMS Long symbols phase II.  Convert all internal symbols from
	one word of Sixbit to [length,,pointer].

4532	MEM	19-Feb-86
	Set ARGPARENT in arg block for PROSB. call.

ENDV11
)%


FORWARD
	ARRXPND,
	PROARRXPN,		!ROUTINE TO CREATE AN ARRAYREF NODE IN WHICH
				! THE SS IS A CALL TO THE LIBRARY ROUTINE
				! "PROAR.". USED FOR PROTECTED ARRAYS.	
	LEGLDATASUB,
	ONLST,
%1554%	PROSUB,
%1554%	COPYEXPR;


EXTERNAL
	CHARUSED,		! Flag for character operator used
				! in program
	CNSTCMB,
	CNVNODE,
	CORMAN,
	E173,			!ERROR MESSAGE POINTERS
	E26,
	E27,
%2253%	E260,			!Extension to Fortran-77: Non-integer subscript
%2271%	E272,			!Extension to Fortran-77: Non-constant substring bounds
	ENTRY,
	FATLERR,
	ISN,
	KTYPCB,
	KTYPCG,
	MAKEPR,			!ROUTINE TO BUILD AN EXPRESSION NODE
	MAKPR1,
	NAME,
%4515%	ONEWPTR,	! Returns [1,,pointer] to Sixbit argument
	SAVSPACE,		!RETURNS CORE TO FREE STORAGE
%2253%	TBLSEARCH,
%2253%	WARNERR;		!Put out warning message

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

GLOBAL ROUTINE ARRXPND(ARRNAMENTRY,SSLSTPTR)=
%(********
	THIS ROUTINE EXPANDS AN ARRAY ADDRESS CALCULATION.
	IT IS CALLED WITH THE ARGUMENTS
		ARRNAMENTRY - PTR TO THE SYMBOL TABLE ENTRY FOR THE ARRAY
				NAME
		SSLSTPTR- LH CONTAINS THE NUMBER OF SUBSCRIPTS MINUS 1
			RH IS A   PTR TO A LIST OF SUBSCRIPTS OF THE FORM
				PTR1
				PTR2
				.
				.
				.
				PTRN
			WHERE CT SPECIFIES THE NUMBER OF SUBSCRIPTS
			PTR1-PTRN ARE POINTERS TO EXPRESSION NODES FOR
			SUBSCRIPTS 1-N.

	THE  ROUTINE  FIRST  CHECKS  THAT  THE  NUMBER  OF   SUBSCRIPTS,
	SSLSTPTR<LEFT>+1, IS EQUAL TO THE NUMBER OF DIMENSIONS. IF  NOT,
	THEN A FATAL ERROR MESSAGE IS GENERATED.

	THIS ROUTINE CREATES AN "ARRAYREF" NODE FOR THIS ARRAY REFERENCE
	AND RETURNS A POINTER TO IT.
********)%
BEGIN
	MAP SYMTABENTRY ARRNAMENTRY;

	REGISTER
		DIMSUBENTRY DIMLSTPTR,	! Subentry for a given dimension
		SSLSTP1;		! Used to walk thru subscripts

	OWN
		PEXPRNODE ARG1NODE,	! ARG1PTR of add or sub ss
		PEXPRNODE ARG2NODE,	! ARG2PTR of add or sub ss
		DIMENTRY ARRDIMENTRY,	! Dimension table entry for this array
		PEXPRNODE ARREFNODE,	! Ptr to array ref node built
		PEXPRNODE DIMFNODE,	! Expression node for the "factor"
		PEXPRNODE SSNODE,	! Ptr to expression node for a subscrpt
					! corresponding to that dimension
		SSCNSTPTR,		! Ptr to constant node with constant
					! part in it
		SSCNSTVAL,		! Constant part of subscript expression
		PEXPRNODE SSVARPTR;	! Expression for runtime address
					! calculation


	ARRDIMENTRY_.ARRNAMENTRY[IDDIM];

     	! Check for wrong number of subscripts
	IF .ARRDIMENTRY[DIMNUM] NEQ (.SSLSTPTR<LEFT>+1)
%4516%	THEN  RETURN FATLERR(.ARRNAMENTRY[IDSYMBOL],.ISN,E27<0,0>);


	%(***IF THE USER SPECIFIED THAT SUBSCRIPT BOUNDS CHECKING WAS TO
		BE PERFORMED ON ALL ARRAYS (BY USING THE "BOUNDS" SWITCH)
		DO NOT EXPAND THE ADDRESS CALCULATION - 
		INSTEAD CALL A FN AT RUN TIME WITH
		ALL THE INDIVIDUAL SUBSCRIPTS**)%
	IF  .FLGREG<BOUNDS> THEN RETURN PROARRXPN(.ARRNAMENTRY,.SSLSTPTR);


	%(***EXPAND ADDRESS CALCULATION. REPLACE THE SUBSCRIPT LIST BY EXPRESSION
		NODE FOR THE SUM OF THE PRODUCTS OF EACH SUBSCRIPT BY A FACTOR
		CORRESPONDING TO THAT DIMENSION OF THE ARRAY. KEEP SUM OF CONSTANT
		TERMS SEPARATE FROM SUM OF VARIABLE TERMS.
	***)%

	%(***INIT SUM OF CONSTANT TERMS TO 0**)%
	SSCNSTVAL_0;

	! Zero pointer to the runtime address calculation
%1766%	SSVARPTR = 0;


	%(***GET PTR TO DIMENSION SUBENTRY FOR 1ST DIMENSION OF THIS ARRAY**)%
	DIMLSTPTR_ARRDIMENTRY[FIRSTDIM];

	%(**GET PTR TO PTR TO NODE FOR 1ST SUBSCRIPT**)%
	SSLSTP1_.SSLSTPTR<RIGHT>;

	DECR CT FROM .SSLSTPTR<LEFT> TO 0
	DO
	BEGIN
		SSNODE_@.SSLSTP1;
		DIMFNODE_.DIMLSTPTR[DIMFACTOR];

		%(****IF THIS SS IS NOT OF VALTYPE INTEGER, CONVERT IT***)%
%2253%		IF .SSNODE[VALTP1] NEQ INTEG1
%2253%		THEN
%2253%			BEGIN
%2253%			IF FLAGANSI THEN WARNERR(.ISN,E260<0,0>); ! Comp flagger
%2253%			SSNODE=CNVNODE(.SSNODE,INTEGER,0) ! Convert to integer
%2253%			END;

		%(**MULTIPLY THE SUBSCRIPT BY A  FACTOR DETERMINED
			BY THE PRECEEDING DIMENSIONS****)%

		%(**THIS FACTOR MAY BE A VARIABLE, IF PRECEEDING DIMENSIONS
			WERE VARIABLES****)%

		! If factor is a variable, generate nodes to multiply ss
		! by this variable and add it into the variable term
		IF .DIMLSTPTR[VARFACTFLG]
		THEN
		BEGIN
			SSNODE_MAKPR1(0,ARITHMETIC,MULOP,INDEX,.SSNODE,.DIMFNODE);
%1766%			IF .SSVARPTR NEQ 0
			THEN	SSVARPTR _ MAKPR1(0,ARITHMETIC,ADDOP,INDEX,.SSVARPTR,.SSNODE)
			ELSE	SSVARPTR _ .SSNODE;
		END
		ELSE

		%(*****IF FACTOR FOR THIS DIMENSION IS A CONSTANT (IE ALL PRECEEDING DIMENSIONS
		WERE OF CONSTANT SIZE)*********)%

		BEGIN
	
			%(***CHECK FOR A SUBSCRIPT OF THE FORM  "X+C" , "X-C", "C+X", "C-X"
				WHERE C IS A CONSTANT.  REMOVE THE CONSTANT PART OF THE
				PRODUCT OF "DIMENSION FACTOR" AND SUBSCRIPT AND 
				ADD IT INTO THE CONSTANT PORTION OF THE ADDRESS******)%
			IF ADDORSUB(SSNODE)
			THEN
			BEGIN
				ARG1NODE_.SSNODE[ARG1PTR];
				ARG2NODE_.SSNODE[ARG2PTR];
	
				IF .ARG2NODE[OPR1] EQL CONSTFL
				THEN
				%(***IF HAVE X+K OR X-K****)%
				BEGIN
					SSCNSTVAL_ (IF SUBORDIV(SSNODE)
						THEN (.SSCNSTVAL - .ARG2NODE[CONST2]*.DIMFNODE[CONST2])
						ELSE (.SSCNSTVAL + .ARG2NODE[CONST2]*.DIMFNODE[CONST2]));
					SSNODE_.ARG1NODE;
				END
				ELSE
				IF .ARG1NODE[OPR1] EQL CONSTFL
				THEN
				%(***IF HAVE K+X OR K-X*****)%
				BEGIN
					SSCNSTVAL_.SSCNSTVAL+.ARG1NODE[CONST2]*.DIMFNODE[CONST2];
					SSNODE_ (IF SUBORDIV(SSNODE)
						THEN
						MAKPR1(0,NEGNOT,NEGOP,INDEX,0,.ARG2NODE)
						ELSE .ARG2NODE);
				END
			END;

			IF .SSNODE[OPR1] EQL CONSTFL
			THEN
	
			%(***IF SS AND FACTOR ARE BOTH CONSTANTS, ADD
				THEIR PRODUCT INTO THE CONSTANT TERM FOR
				THIS ADDRESS CALCULATION
			***)%
			SSCNSTVAL_.SSCNSTVAL+.DIMFNODE[CONST2]*.SSNODE[CONST2]
	
	
			ELSE
			%(**IF SS IS A VARIABLE AND FACTOR IS A CONSTANT, GENERATE
				NODES TO MULTIPLY THEM AND ADD THE PRODUCT
				INTO THE VARIABLE TERM***)%
			BEGIN
				IF  .DIMFNODE[CONST2] NEQ 1
				THEN
				%(****IF FACTOR IS NOT 1, MULTIPLY BY IT***)%
				SSNODE_MAKPR1(0,ARITHMETIC,MULOP,INDEX,.SSNODE,.DIMFNODE);
%1766%				IF .SSVARPTR NEQ 0
				THEN	SSVARPTR _ MAKPR1(0,ARITHMETIC,ADDOP,INDEX,.SSVARPTR,.SSNODE)
				ELSE	SSVARPTR _ .SSNODE
			END;
		END;

		SSLSTP1_.SSLSTP1+1;
		DIMLSTPTR_.DIMLSTPTR+DIMSUBSIZE;

	END;


	%(***ADD IN THE ARRAY OFFSET FOR THIS ARRAY -
		IF THE DIMENSIONS ARE CONSTANT THEN THIS WILL BE A CONSTANT
		AND SHOULD BE ADDED INTO THE CONSTANT TERM.
		IF THE DIMENSIONS ARE VARIABLE, THEN THIS VALUE WILL BE
		COMPUTED UPON ENTERING THE SUBROUTINE AND STORED IN A
		TEMPORARY WHICH SHOULD BE ADDED INTO THE VARIABLE TERM.
	*********)%

	IF .ARRDIMENTRY[ADJDIMFLG]
	THEN
	BEGIN
%1766%		IF .SSVARPTR NEQ 0
		THEN	SSVARPTR _ MAKPR1(0,ARITHMETIC,ADDOP,INDEX,.SSVARPTR,.ARRDIMENTRY[ARAOFFSET])
		ELSE	SSVARPTR _ .ARRDIMENTRY[ARAOFFSET];
	END
	ELSE
	BEGIN
		OWN PEXPRNODE OFFSETNODE;
		OFFSETNODE_.ARRDIMENTRY[ARAOFFSET];
		SSCNSTVAL_.SSCNSTVAL+.OFFSETNODE[CONST2];
	END;


	! If the array  is a  formal (and  the array  is not  adjustably
	! dimensioned - in  which case the  "offset" value includes  the
	! base val), add the base into the variable term.  Don't do this
	! for character arrays -  the base address is  the address of  a
	! descriptor.

	IF  .ARRNAMENTRY[FORMLFLG] AND NOT .ARRDIMENTRY[ADJDIMFLG] 
	THEN
%1250%	IF .ARRNAMENTRY[VALTYPE] NEQ CHARACTER
%1250%	THEN
	BEGIN
		! If already have  a variable  term, add  the base  into
		! that expression
%1766%		IF .SSVARPTR NEQ 0
		THEN	! Ptr to symbol that contains the base address
			SSVARPTR _ MAKPR1(0,ARITHMETIC,ADDOP,INDEX,.SSVARPTR,
				.ARRDIMENTRY[ARADDRVAR])
		ELSE	! If do not yet have a variable term, set the
			! variable term to be the base address
			SSVARPTR _ .ARRDIMENTRY[ARADDRVAR];
	END;


	! If the array is type character, or the constant is too big  to
	! store in the  TARGADDR field, explicitly  add in the  constant
	! part and set SSCNSTVAL to 0.

%1250%	IF .ARRNAMENTRY[VALTYPE] EQL CHARACTER
%1766%		OR NOT STORETARGADDR(.SSCNSTVAL)
	THEN
	BEGIN	! Add in constant part

%1436%		! Flag for character operator used in prog
%1766%		IF .ARRNAMENTRY[VALTYPE] EQL CHARACTER 
%1436%		THEN	CHARUSED = TRUE;


		! Make constant node for constant part 
		SSCNSTPTR _ MAKECNST(INTEGER,0,.SSCNSTVAL);

		! Make an add  node,   adding constant  into address offset
		! expression.
%1766%		IF .SSVARPTR NEQ 0
		THEN	! Already have variable part
			SSVARPTR _ MAKPR1(0,ARITHMETIC,ADDOP,INTEGER,.SSVARPTR,.SSCNSTPTR)
		ELSE	! No variable part, make one
			SSVARPTR _ .SSCNSTPTR;

		! Set constant part to 0, it's been explicitly added in
		SSCNSTVAL _ 0;

	END;	! Add in constant part


	%(****MAKE THE ARRAYREF NODE FOR THIS REFERENCE. ARG1PTR SHOULD PT TO THE
		SYMBOL TABLE ENTRY FOR THE ARRAY NAME; ARG2PTR SHOULD PT TO THE
		ADDRESS CALCULATION (OR BE EQUAL TO 0 IF NO RUNTIME CALCULATION
		IS NEEDED).

	********)%
%2463%	ARREFNODE _ MAKEPR(ARRAYREF,ARREFSMALL,.ARRNAMENTRY[VALTYPE],
%1766%			.ARRNAMENTRY,.SSVARPTR);

	%(***PUT THE CONSTANT TERM INTO THE ARRAYREF NODE (ONLY USE THE LAST 18 BITS.)***)%
	ARREFNODE[TARGET]_.SSCNSTVAL AND #777777;


	%(****RETURN THE SSLST TO FREE STORAGE***)%
	SAVSPACE(.SSLSTPTR<LEFT>,@SSLSTPTR);


	%(***IF SS CALCULATION IS A SINGLE DATA ITEM (OR CONSTANT), SET A2VALFLG ***)%
	SSNODE_.ARREFNODE[ARG2PTR];
	IF .SSNODE[OPRCLS] EQL DATAOPR OR .SSNODE EQL 0
	THEN ARREFNODE[A2VALFLG]_1
	ELSE SSNODE[PARENT]_.ARREFNODE;

	RETURN .ARREFNODE;	! Array ref created

END;	!END OF "ARRXPND"
GLOBAL ROUTINE PROARRXPN(ARRNAMENTRY,SSLSTPTR)=
%(***************************************************************************

Creates an ARRAYREF node for a reference to an element of an array  on
which array bounds checking  is to be  performed.  The expression  for
the address calculation under such an ARRAYREF will be a function call
node for the library function PROAR. with the following parameters:

	Sequence number of statement containg this reference
	Pointer to the dimension block for this array (Created in DEBUG.BLI)
	Pointer to 1st subscript
	Pointer to 2nd subscript
	Etc.

The arguments to this routine are:

ARRNAMENTRY - Pointer to the STE for the array name

SSLSTPTR - Left half contains the number of subscripts minus 1.  Right
half is a pointer to  a list of pointers  to expression nodes for  the
individual subscripts.

***************************************************************************)%
BEGIN
	STRUCTURE PVECTOR[I]=(@.PVECTOR+.I)<0,36>;	!STRUCTURE FOR A PTR TO A VECTOR

	MAP PVECTOR SSLSTPTR;
	MAP BASE ARRNAMENTRY;

	OWN BASE ARRDIMENTRY;		!DIMENSION TABLE ENTRY FOR THIS ARRAY
	REGISTER PEXPRNODE SSNODE;	!EXPRESSION NODE FOR A GIVEN SUBSCRIPT

	REGISTER PEXPRNODE FNCALLNODE;	!FUNCTION CALL NODE FOR THE CALL TO "PROAR."
	REGISTER ARGUMENTLIST ARGLST;	!ARG LIST FOR ARGS TO "PROAR."
	OWN BASE PROARSYM;	!SYMBOL TABLE ENTRY FOR THE FN NAME "PROAR."
	OWN PEXPRNODE ARREFNODE;	!THE ARRAY REF NODE BUILT HERE
%1766%	LOCAL BASE OFFSETNODE;		! Offset calculation
 

	%(***RESET FLAG SO THAT 16 WILL ALWAYS BE SAVED/RESTORED***)%
	FLGREG<BTTMSTFL>_0;

	%(**GET CORE FORTHE ARGUMENT LIST**)%
	NAME<LEFT>_ARGLSTSIZE(.SSLSTPTR<LEFT>+1	!NUMBER OF SUBSCRIPTS
				+2);		! PLUS 2 IS THE NUMBER OF ARGS TO "PROAR."
	ARGLST_CORMAN();


	%(**Get the symbol table entry for the routine name "PROAR."**)%

	NAME_IDTAB;
%4515%	ENTRY[0] = ONEWPTR(SIXBIT'PROAR.');
	PROARSYM_TBLSEARCH();	!MAKE THE SYM TABLE ENTRY IF THERE ISNT ONE
%4524%	IF NOT .FLAG			! if TBLSEARCH made a new entry
%4524%	THEN				! fill in its VALTYPE and stuff
%4524%	BEGIN
		PROARSYM[VALTYPE]_INTEGER;	!FILL IN TYPE FIELD
		PROARSYM[OPERSP]_FNNAME;
%4524%		PROARSYM[IDPSECT] = PSCODE;
%2561%		PROARSYM[IDLIBFNFLG] = 1;	! PROAR. is a library function.

%4524%	END;

	%(**MAKE THE FUNCTION CALL NODE FOR THE CALL TO "PROAR."**)%
	FNCALLNODE_MAKEPR(FNCALL,LIBARY,INTEGER,.PROARSYM,.ARGLST);

	FNCALLNODE[VALTYPE]_INTEGER;

	ARGLST[ARGCOUNT]_.SSLSTPTR<LEFT>+1+2;	!NUMBER OF SUBSCRIPTS PLUS 2

	! 1ST arg is seq number of this stmnt
	ARGLST[1,ARGNPTR]_MAKECNST(INTEGER,0,.ISN);
	ARGLST[1,AVALFLG]_1;
	! Dimension table entry for the array
	ARRDIMENTRY_.ARRNAMENTRY[IDDIM];
	! 2nd arg is the label that  will be on the dimension block  for
	! this array
	ARGLST[2,ARGNPTR]_.ARRDIMENTRY[ARADLBL];
	ARGLST[2,AVALFLG]_1;

	%(**HAVE A PARAMETER FOR EACH OF THE INDIVIDUAL SUBSCRIPTS**)%
	INCR I FROM 0 TO .SSLSTPTR<LEFT>
	DO
	BEGIN
		SSNODE_.SSLSTPTR[.I];	!EXPRESSION NODE FOR THIS SUBSCRIPT

		IF .SSNODE[VALTP1] NEQ INTEG1	!IF SUBSCRIPT IS NOT INTEGER
		THEN
%2253%			BEGIN
%2253%			IF FLAGANSI THEN WARNERR(.ISN,E260<0,0>); ! Comp flagger
%2253%			SSNODE=CNVNODE(.SSNODE,INTEGER,0) ! Convert to integer
%2253%			END;
		ARGLST[.I+3,ARGNPTR]_.SSNODE;

		IF .SSNODE[OPRCLS] EQL DATAOPR	!IF SUBSCRIPT IS A LEAF
		THEN ARGLST[.I+3,AVALFLG]_1	! SET VALFLG IN ARG LIST
		ELSE SSNODE[PARENT]_.FNCALLNODE;	! OTHERWISE SET PARENT FOR THE SS EXPR
	END;

	SAVSPACE(.SSLSTPTR<LEFT>,.SSLSTPTR);	!RETURN THE SS LIST TO FREE STORAGE

%2463%	ARREFNODE_MAKEPR(ARRAYREF,ARREFSMALL,.ARRNAMENTRY[VALTYPE],
		.ARRNAMENTRY,.FNCALLNODE);	!MAKE THE ARRAY REF NODE


	! If array is  not type  CHARACTER and array  is not  adjustably
	! dimensioned, and  constant is  not  too big  to store  in  the
	! TARGADDR field, then add the constant offset in with the  base
	! address.

	OFFSETNODE_.ARRDIMENTRY[ARAOFFSET];

%1250%	IF .ARRNAMENTRY[VALTYPE] NEQ CHARACTER THEN
	IF NOT .ARRDIMENTRY[ADJDIMFLG] 
	THEN	! Check if offset should be stored in TARGADDR

%1766%		IF STORETARGADDR(.OFFSETNODE[CONST2])
		THEN	ARREFNODE[TARGET] = .OFFSETNODE[CONST2] AND #777777
%1766%		ELSE
%1766%		BEGIN	! Make add node adding constant and PROAR. result
%1766%
%1766%			FNCALLNODE[PARENT] = ARREFNODE[ARG2PTR] =
%1766%				MAKPR1(.ARREFNODE,ARITHMETIC,ADDOP,INTEGER,
%1766%				.OFFSETNODE,.FNCALLNODE);
%1766%
%1766%			RETURN .ARREFNODE;
%1766%
%1766%		END;	! Make add node adding constant and PROAR. result

	FNCALLNODE[PARENT]_.ARREFNODE;	!PARENT PTR IN THE FN CALL NODE
					! POINTS TO THE ARRAYREF NODE
	RETURN .ARREFNODE

END;	! of PROARRXPN
%(***OWN VARIABLES USED BY THE DATA-STMNT CHECKING ROUTINES BELOW***)%
OWN OINDEXLIST;	!OWN IN WHICH SAVE PTR TO LIST OF LEGAL INDICES AS RECURSE
			! THRU THE EXPRESSION TREES CHECKING FOR LEGAL SUBSCRIPTS
			! (SINCE FOR EACH CALL TO DATASUBCHK THIS THEN STAYS CONSTANT)
OWN OIXCT;		!OWN IN WHICH SAVE IXCT AS RECURSE
%2271%	OWN CONBOUND;	! False if substring bounds are not constant

GLOBAL ROUTINE DATASUBCHK(DATACALLS,IXCT,INDEXLIST)=
%(***************************************************************************
	THIS ROUTINE CHECKS A LIST OF DATACALLS TO DETERMINE WHETHER THEY
	ARE LEGAL DATA-ITEMS FOR A DATA STATEMENT.
	IT IS CALLED WITH THE ARGS:
		DATACALLS- A LINKED LIST OF DATACALL NODES, DO-STMNT NODES, AND
			CONTINUE STMNT NODES. DATACALL NODES WHICH ARE INSIDE
			OF ANY IMPLIED DO-LOOPS ON THIS LIST WILL BE IGNORED.
		INDEXLIST- A LIST OF PTRS TO THE SYMBOL TABLE ENTRIES FOR ALL
			VARIABLES WHICH ARE DO-INDICES ON IMPLIED DO LOOPS THAT
			CONTAIN THE LIST OF DATACALLS WITHIN THEM
		IXCT- CT OF THE NUMBER OF INDICES ON INDEXLIST
	THIS ROUTINE CHECKS EACH DATACALL NODE ON THE LIST OF DATACALLS WHICH
	IS NOT INSIDE OF ANY DO-LOOPS THAT ARE ON THE LIST. FOR EACH ARRAYREF
	UNDER THESE TOP-LEVEL DATACALLS, IT CHECKS THAT THE ADDRESS CALCULATION
	INCLUDES NO OPERATIONS OTHER THAN ADD,SUB,MUL,DIV,AND POWER AND
	NO TERMS OTHER THAN INTEGER CONSTANTS AND VARIBLES WHICH ARE ON
	THE LIST "INDEXLIST" (IE WHICH ARE INDICES ON LOOPS THAT INCLUDE THESE
	DATACALLS)
	RETURNS TRUE IF THE ABOVE CONDITION IS SATISFIED.
***************************************************************************)%
BEGIN
	OWN BASE CDATAELEM;


	%(***IF SYNTAX DETECTED AN ERROR IN THIS STMNT EARLIER, THEN
		THIS ROUTINE WILL BE CALLED WITH "DATACALLS" EQUAL
		TO  #777777. IF SO, JUST RETURN***)%
	IF .DATACALLS EQL #777777 THEN RETURN FALSE;

	%(***PUT THE 2 ARGS INDEXLIST AND IXCT INTO "OWN" TYPE VARS SO DONT HAVE
		TO PASS THEM AS ARGS OVER AND OVER AS RECURSE (THEY NEVER CHANGE)***)%
	OINDEXLIST_.INDEXLIST;
	OIXCT_.IXCT;
	CDATAELEM_.DATACALLS;		!PTR TO 1ST ELEM ON DATA-ITEM LIST

	%(***GO THRU LIST OF DATA-ITEMS, EXAMINING ALL TOP-LEVEL DATACALLS***)%
	UNTIL .CDATAELEM EQL 0
	DO
	BEGIN
		IF .CDATAELEM[OPRCLS] EQL STATEMENT
		THEN
		BEGIN
			%(***WHEN ENCOUNTER A DO-STMNT, SKIP TO THE CONTINUE THAT
				TERMINATES THE DO***)%
			IF .CDATAELEM[SRCID] EQL DOID
			THEN
			BEGIN
				OWN BASE ENDLAB;
				ENDLAB_.CDATAELEM[DOLBL];
				CDATAELEM_.ENDLAB[SNHDR];
			END;
			%(***IGNORE CONTINUE STMNTS***)%
		END

		ELSE
		IF .CDATAELEM[OPERATOR] EQL DATACLFL
		THEN
		BEGIN
			OWN PEXPRNODE ARGNODE;
			ARGNODE_.CDATAELEM[DCALLELEM];

%1416%			%(***EXAMINE SUBSTRING BOUNDS***)%
%2271%			! If compatibility flagging is being done, check to
%2271%			! see if all substring bounds are constant, and if not
%2271%			! put out a flagger warning.
%1416%			IF .ARGNODE[OPRCLS] EQL SUBSTRING
%1416%			THEN
%1416%			BEGIN
%2271%				CONBOUND=TRUE;	! Becomes false when non-constant bound is found

%1416%				IF NOT LEGLDATASUB(.ARGNODE[ARG1PTR])
%1416%				THEN (FATLERR(.ISN,E173<0,0>); RETURN FALSE);
%1416%				IF NOT LEGLDATASUB(.ARGNODE[ARG2PTR])
%1416%				THEN (FATLERR(.ISN,E173<0,0>); RETURN FALSE);
%2271%				IF NOT .CONBOUND
%2271%				THEN IF FLAGANSI THEN WARNERR(.ISN,E272<0,0>);

%1416%				ARGNODE _ .ARGNODE[ARG4PTR];
%1416%			END;

			%(***WANT TO EXAMINE THE ADDRESS CALC UNDER ANY ARRAYREF***)%
			IF .ARGNODE[OPRCLS] EQL ARRAYREF
			THEN
			BEGIN
				IF NOT LEGLDATASUB(.ARGNODE[ARG2PTR])
				%(***IF SUBSCRIPT CONTAINS VARIABLES NOT
					USED AS LOOP INDICES OR OPERATORS OTHER
					THAN +,-,*,/***)%
				THEN (FATLERR(.ISN,E26<0,0>);RETURN FALSE);
			END;

		END;
	CDATAELEM_.CDATAELEM[CLINK];
	END;

	RETURN TRUE;
END;

GLOBAL ROUTINE LEGLDATASUB(EXPR)=
%(***************************************************************************
	CHECKS WHETHER THE ARG "EXPR" IS A LEGAL SUBSCRIPT EXPRESSION
	FOR A DATACALL UNDER A DATASTATEMENT. THE GLOBAL "OINDEXLIST"
	IS ASSUMED TO HAVE BEEN SET UP TO CONTAIN A PTR TO A LIST OF
	PTRS TO SYMBOL TABLES ENTRIES FOR INDICES OF IMPLIED DO LOOPS THAT INCLUDE THE
	DATACALL NODE IN QUESTION.
	A SUBSCRIPT EXPRESSION IS LEGAL IFF ALL TERMS ARE EITHER INTEGER
	CONSTANTS OR VARIABLES ON "OINDEXLIST", AND ALL OPERATORS ARE
	ADD,SUB,MUL,DIV,OR POWER
***************************************************************************)%
BEGIN
	MAP PEXPRNODE EXPR;

	IF .EXPR EQL 0 THEN RETURN TRUE

	ELSE
	IF .EXPR[OPERATOR] EQL INTCONST
	THEN RETURN TRUE			!INTEGER CONSTANT

	ELSE
	%(***FOR AN INTEGER VARIABLE, DETERMINE WHETHER IT IS ON THE LIST OF LEGAL VARIABLES***)%
	IF .EXPR[OPR1] EQL VARFL
%2271%	THEN
%2271%	BEGIN
%2271%		CONBOUND=FALSE;	! Non-constant
%2271%		RETURN ONLST(.EXPR,.OIXCT,.OINDEXLIST)	
%2271%	END

	ELSE
	%(***FOR A LEGAL ARITHMETIC OP (ADD,SUB,MUL,DIV,OR POWER), DETERMINE THAT BOTH ARGS
		ARE LEGAL EXPRESSIONS***)%
%1416%	IF .EXPR[OPRCLS] EQL ARITHMETIC
	THEN
	BEGIN
		IF NOT LEGLDATASUB(.EXPR[ARG1PTR])
		THEN RETURN FALSE
		ELSE
		RETURN LEGLDATASUB(.EXPR[ARG2PTR])
	END

	ELSE
	%(***FOR OPERATION NEGATE (UNARY MINUS) - THE ARG MUST BE LEGAL***)%
	IF .EXPR [OPR1] EQL NEGFL
	THEN RETURN LEGLDATASUB(.EXPR[ARG2PTR])

	ELSE
	RETURN FALSE
END;

ROUTINE ONLST(VARTOMATCH,LSTLNTH,LISTTOMATCH)=
%(***************************************************************************
	DETERMINE WHETHER "VARTOMATCH" IS AN ELEMENT IN THE VECTOR POINTED TO
	BY "LISTTOMATCH". LSTLNTH IS THE NUMBER OF ELEMENTS ON LISTTOMATCH.
***************************************************************************)%
BEGIN
	%(***DEFINE A STRUCTURE FOR A PTR TO A VECTOR IN WHICH
		ONLY THE RIGHT HALF OF EACH ENTRY SHOULD BE EXAMINED***)%
	STRUCTURE PVECTOR[CT]=
	(@.PVECTOR+.CT)<0,18>;

	MAP PVECTOR LISTTOMATCH;

	INCR I FROM 0 TO (.LSTLNTH-1)
	DO
	BEGIN
		IF .LISTTOMATCH[.I] EQL .VARTOMATCH
		THEN RETURN TRUE
	END;

	%(***IF NEVER FIND IT***)%
	RETURN FALSE;
END;
GLOBAL ROUTINE PROSUB (SSNODE) =	! [1554] New

! Insert call to PROSB. to do substring range checking.  Only do this if
! /DEBUG:BOUNDS.
!
! This routine effectively replaces a substring
!
!	A(I:J)
!
! with
!
!	A(I: PROSB.(A,I,J,ISN,'A') )
! 
! where PROSB. will return J, and also checks that I and J are legal substring
! bounds.  The descriptor for A gives A's length.  The ISN and variable name
! arguments are provided for the error message.

BEGIN
	MAP BASE SSNODE;

	REGISTER BASE A:FNCALLNODE;
	REGISTER ARGUMENTLIST ARGLST;
	LOCAL BASE PROSBSYM;

	! If we're not doing bounds checking, return the node untouched

	IF NOT .FLGREG<BOUNDS> THEN RETURN .SSNODE;

	! Make arg list and FNCALL node 

	NAME<LEFT> = ARGLSTSIZE(5);	! get a block for 5 args
	ARGLST = CORMAN();

	NAME = IDTAB;			! get ID table entry for PROSB.
%4515%	ENTRY = ONEWPTR(SIXBIT 'PROSB.');
	PROSBSYM = TBLSEARCH();
	IF NOT .FLAG			! if TBLSEARCH made a new entry
	THEN				! fill in its VALTYPE and stuff
	BEGIN
		PROSBSYM[VALTYPE] = INTEGER;
		PROSBSYM[OPERSP] = FNNAME;
		PROSBSYM[IDPSECT] = PSCODE;
%2561%		PROSBSYM[IDLIBFNFLG] = 1;	! PROSB. is a library function.

	END;
	
	FNCALLNODE = MAKEPR(FNCALL,LIBARY,INTEGER,.PROSBSYM,.ARGLST);

	! Fill in arg block 

	ARGLST[ARGCOUNT] = 5;		! arg count is 5
%4532%	ARGLST[ARGPARENT] = .FNCALLNODE;
	ARGLST[1,ARGNPTR] = A = COPYEXPR(.SSNODE[ARG4PTR],.FNCALLNODE);
	ARGLST[1,AVALFLG] = (.A[OPRCLS] EQL DATAOPR);

	ARGLST[2,ARGNPTR] = COPYEXPR(.SSNODE[ARG2PTR],.FNCALLNODE);
	ARGLST[2,AVALFLG] = .SSNODE[A2VALFLG];

	ARGLST[3,ARGNPTR] = COPYEXPR(.SSNODE[ARG1PTR],.FNCALLNODE);
	ARGLST[3,AVALFLG] = .SSNODE[A1VALFLG];

	ARGLST[4,ARGNPTR] = MAKECNST(INTEGER,0,.ISN);
	ARGLST[4,AVALFLG] = 1;

%4532%	!The fifth arg is transformed to an address where the long name
%4532%	!is listed when the arg block is output in CGARGS

	IF .A[OPRCLS] EQL ARRAYREF THEN A = .A[ARG1PTR];
	ARGLST[5,ARGNPTR] = MAKECNST(INTEGER,0,.A[IDSYMBOL]);
	ARGLST[5,AVALFLG] = 1;

	! Replace the upper bound expr with the PROSB. call

	SSNODE[ARG1PTR] = .FNCALLNODE;
	SSNODE[A1VALFLG] = 0;
	FNCALLNODE[PARENT] = .SSNODE;

	! Set flag saying ac 16 must be saved

	FLGREG<BTTMSTFL> = 0;

	! Done.  Return altered substring node

	RETURN .SSNODE;

END;	! PROSUB
ROUTINE COPYEXPR (CNODE, PARNODE) =	! [1554] New

! Routine to copy an expression tree

BEGIN
	MAP BASE CNODE;
	REGISTER BASE T;

	IF .CNODE[OPRCLS] EQL DATAOPR THEN RETURN .CNODE;
	IF .CNODE[OPRCLS] EQL LABOP THEN RETURN .CNODE;

	NAME<LEFT> = IF .CNODE[OPRCLS] EQL SUBSTRING THEN EXSIZ+1 ELSE EXSIZ;
	T = CORMAN();

	T[PARENT] = .PARNODE;		! set parent pointer
	T[CW1] = .CNODE[CW1];		! copy [EXPFLAGS] and [OPERATOR]
%1714%	T[CW2] = .CNODE[CW2];		! copy [TARGET]

	IF .CNODE[ARG1PTR] NEQ 0	! copy arg 1
	THEN T[ARG1PTR] = COPYEXPR(.CNODE[ARG1PTR],.T);

	IF .CNODE[OPRCLS] EQL FNCALL	! copy arg 2
	THEN
	BEGIN	! copy arg list
		REGISTER ARGUMENTLIST OARGLST:NARGLST;

		OARGLST = .CNODE[ARG2PTR];
		NAME<LEFT> = ARGLSTSIZE(.OARGLST[ARGCOUNT]);
		NARGLST = CORMAN();
		T[ARG2PTR] = .NARGLST;

		INCR I FROM -ARGHDRSIZ+1 TO 0 DO
		NARGLST[.I,0,FULL] = .OARGLST[.I,0,FULL];

		INCR I FROM 1 TO .OARGLST[ARGCOUNT] DO
		BEGIN
			NARGLST[.I,ARGNPTR] =
				COPYEXPR(.OARGLST[.I,ARGNPTR],.T);
			NARGLST[.I,AVALFLG] = .OARGLST[.I,AVALFLG];
		END;

	END	! copy arg list
	ELSE IF .CNODE[ARG2PTR] NEQ 0	! copy ordinary arg 2
	     THEN T[ARG2PTR] = COPYEXPR(.CNODE[ARG2PTR],.T);

	IF .CNODE[OPRCLS] EQL SUBSTRING	! copy arg 4
	THEN T[ARG4PTR] = COPYEXPR(.CNODE[ARG4PTR],.T);

	RETURN .T;

END;	! COPYEXPR

END ELUDOM