Google
 

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

!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1983
!AUTHOR: S. MURPHY/NEA/SJW/TFV/CKS/AHM

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

!	REQUIRES FIRST, TABLES

GLOBAL BIND ARRXPV = 7^24 + 0^18 + #1714;	! Version Date: 11-Jan-83


%(

***** 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 Revision History *****

)%


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,
	ENTRY,
	FATLERR,
	ISN,
	KTYPCB,
	KTYPCG,
	MAKEPR,			!ROUTINE TO BUILD AN EXPRESSION NODE
	MAKPR1,
	NAME,

	SAVSPACE,		!RETURNS CORE TO FREE STORAGE
	TBLSEARCH;

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>
	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 SSLSTP1;
	OWN PEXPRNODE SSNODE;		!PTR TO EXPRESSION NODE FOR A GIVEN SUBSCRIPT
	OWN DIMENTRY ARRDIMENTRY;	!DIMENSION TABLE ENTRY FOR THIS ARRAY
	REGISTER DIMSUBENTRY DIMLSTPTR;	!SUBENTRY FOR A GIVEN DIMENSION
	OWN PEXPRNODE DIMFNODE;		!EXPRESSION NODE FOR THE "FACTOR" CORRES
					! PONDING TO THAT DIMENSION
	OWN SSVARFLG;			!THIS FLAG IS SET IF SOME PART OF
					! THE ADDRESS MUST BE COMPUTED AT RUN TIME
	OWN SSCNSTVAL;			! CONSTANT PART OF SUBSCRIPT EXPRESSION
	OWN SSCNSTPTR;			! PTR TO CONSTANT NODE WITH CONSTANT PART IN IT
	OWN PEXPRNODE SSCONSTPTR:SSVARPTR;
	OWN PEXPRNODE ARREFNODE;	!PTR TO ARRAY REF NODE BUILT
	OWN PEXPRNODE ARG1NODE:ARG2NODE;		!WHEN A SS IS ADD OR SUB THESE
							! PT TO THE 2 ARGS OF THAT OPERATOR


	ARRDIMENTRY_.ARRNAMENTRY[IDDIM];

	IF .ARRDIMENTRY[DIMNUM] NEQ (.SSLSTPTR<LEFT>+1)
	THEN  RETURN FATLERR( ARRNAMENTRY[IDSYMBOL],.ISN,E27<0,0>);
	     	!WRONG NUMBER OF SUBSCRIPTS



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

	%(***INIT FLAG FOR "SOME PART OF THE ADDRESS CALC MUST BE DONE AT RUN TIME" TO FALSE***)%
	SSVARFLG_FALSE;


	%(***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***)%
		IF .SSNODE[VALTP1] NEQ INTEG1 THEN SSNODE_CNVNODE(.SSNODE,INTEGER,0);


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

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

		IF .DIMLSTPTR[VARFACTFLG]
		THEN
		%(**IF FACTOR IS A VARIABLE, GENERATE NODES TO MULTIPLY SS BY THIS VARIABLE
			AND ADD IT INTO THE VARIABLE TERM**)%
		BEGIN
			SSNODE_MAKPR1(0,ARITHMETIC,MULOP,INDEX,.SSNODE,.DIMFNODE);
			IF .SSVARFLG
			THEN
			SSVARPTR_MAKPR1(0,ARITHMETIC,ADDOP,INDEX,.SSVARPTR,.SSNODE)
			ELSE
			BEGIN
				SSVARFLG_TRUE;
				SSVARPTR_.SSNODE;
			END;

		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);
				IF .SSVARFLG
				THEN
				SSVARPTR_MAKPR1(0,ARITHMETIC,ADDOP,INDEX,.SSVARPTR,.SSNODE)
				ELSE
				BEGIN
					SSVARFLG_TRUE;
					SSVARPTR_.SSNODE
				END
			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
		IF .SSVARFLG
		THEN
		SSVARPTR_MAKPR1(0,ARITHMETIC,ADDOP,INDEX,.SSVARPTR,.ARRDIMENTRY[ARAOFFSET])
		ELSE
		BEGIN
			SSVARPTR_.ARRDIMENTRY[ARAOFFSET];
			SSVARFLG_TRUE
		END
	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***)%
		IF .SSVARFLG
		THEN
		SSVARPTR_MAKPR1(0,ARITHMETIC,ADDOP,INDEX,.SSVARPTR,
				.ARRDIMENTRY[ARADDRVAR])	!PTR TO SYMBOL THAT
								! CONTAINS THE BASE ADDRESS
		ELSE
		%(***IF DO NOT YET HAVE A VARIABLE TERM, SET THE VARIABLE TERM
			TO BE THE BASE ADDRESS***)%
		BEGIN
			SSVARPTR_.ARRDIMENTRY[ARADDRVAR];
			SSVARFLG_TRUE
		END;
	END;



% [1250] (*** IF THE ARRAY IS TYPE CHARACTER, EXPLICITLY ADD IN THE CONSTANT
              PART AND SET SSCNSTVAL TO 0. ***)%

	IF .ARRNAMENTRY[VALTYPE] EQL CHARACTER
	THEN
	BEGIN		! [1250] CHARACTER ARRAY REF 

%1436%		CHARUSED = TRUE;	! Flag for character operator used
%1436%					! in prog

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

		! Put explicit add of constant part into expression
		IF .SSVARFLG
		THEN			! Already have variable part
		SSVARPTR _ MAKPR1(0,ARITHMETIC,ADDOP,INTEGER,.SSVARPTR,.SSCNSTPTR)
		ELSE
		BEGIN			! No variable part, make one
			SSVARPTR _ .SSCNSTPTR;
			SSVARFLG _ TRUE;
		END;

		SSCNSTVAL _ 0;		! Set constant part to 0, it's been
					! explicitly added in
	END;		! [1250] CHARACTER ARRAY REF



	%(****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).

	********)%
	ARREFNODE_ MAKEPR(ARRAYREF,0,.ARRNAMENTRY[VALTYPE],.ARRNAMENTRY,
			(IF .SSVARFLG THEN .SSVARPTR ELSE 0) );

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

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
 

	%(***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;
%1503%	ENTRY[0]_SIXBIT'PROAR.';
	PROARSYM_TBLSEARCH();	!MAKE THE SYM TABLE ENTRY IF THERE ISNT ONE
	PROARSYM[VALTYPE]_INTEGER;	!FILL IN TYPE FIELD
	PROARSYM[OPERSP]_FNNAME;

	%(**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
	ARGLST[1,ARGNPTR]_MAKECNST(INTEGER,0,.ISN);	!1ST ARG IS SEQ NUMBER OF THIS STMNT
	ARGLST[1,AVALFLG]_1;
	ARRDIMENTRY_.ARRNAMENTRY[IDDIM];	!DIMENSION TABLE ENTRY FOR THE ARRAY
	ARGLST[2,ARGNPTR]_.ARRDIMENTRY[ARADLBL];	!2ND ARG IS THE LABEL THAT WILL BE ON
					! THE DIMENSION BLOCK FOR THIS ARRAY
	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
		SSNODE_CNVNODE(.SSNODE,INTEGER,0);	! CONVERT IT

		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

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

%1250%	IF .ARRNAMENTRY[VALTYPE] NEQ CHARACTER !IF ARRAY IS NOT TYPE CHARACTER
%1250%	THEN
	IF NOT .ARRDIMENTRY[ADJDIMFLG]	!IF THIS ARRAY IS NOT ADJUSTABLY DIMENSIONED,
	THEN				! THEN ADD THE CONSTANT OFFSET IN WITH
	BEGIN				! THE BASE ADDRESS
		OWN BASE OFFSETNODE;
		OFFSETNODE_.ARRDIMENTRY[ARAOFFSET];
		ARREFNODE[TARGET]_.OFFSETNODE[CONST2] AND #777777
	END;

	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


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***)%
%1416%			IF .ARGNODE[OPRCLS] EQL SUBSTRING
%1416%			THEN
%1416%			BEGIN
%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);
%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
	THEN RETURN ONLST(.EXPR,.OIXCT,.OINDEXLIST)	


	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.
	ENTRY = 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;
	END;
	
	FNCALLNODE = MAKEPR(FNCALL,LIBARY,INTEGER,.PROSBSYM,.ARGLST);

	! Fill in arg block 

	ARGLST[ARGCOUNT] = 5;		! arg count is 5

	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;

	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