Google
 

Trailing-Edge - PDP-10 Archives - bb-4157h-bm_fortran20_v10_16mt9 - fortran-compiler/util.bli
There are 13 other files named util.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.

!AUTHORS: NORMA ABEL AND SARA MURPHY/HPW/DCE/SJW/EGM/TFV/CDM/TJK/MEM/AHM

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

GLOBAL BIND UTILV = #10^24 + 0^18 + #2425;	! Version Date:	15-Jul-84

%(

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

72	-----	-----	ADD ROUTINE TRANSMOGRIFY TO RENAME SYMBOLS
73	-----	-----	FIX CONTVAR TO CORRCTLTY HANDLE IOLISTS
74	-----	-----	FIX DOVARSUBSTITUTE TO SET ASGN4USED ON DO LOOP
			INDEX
75	-----	-----	 ADD ROUTINES ALODIMCONSTS,ALDIM1 TO ALLOCATE CORE
			FOR CONSTANTS USED IN SPECIFYING DIMENSION TABLE
			INFORMATION (ROUTINES ARE CALLED WHEN DIMENSION
			INFO WILL BE OUTPUT FOR DEBUGGING PURPOSES
76	-----	----- FIX BUG IN ALDIM1
77	-----	-----	TAKE AWAY ROUTINES USED ONLY IN ALLOCATION
78	-----	-----	FIX 77 BY PUTTING LASTONE BACK IN
79	-----	-----	MAKE IOSUBSTITUTE HANDLE E1 AND E2 LISTS
80	-----	-----	FIX DOVARSUBSTITUTE NOT TO CLOBBER DOIREG
81	-----	-----	CONTFN DOES NOT IGNORE ARG2 OF AN ARRAYREF
			IF IT IS ZERO
82	-----	-----	MOVE LOWLIM TO GLOBAL
83	-----	-----	FIX UNFLDO TO SET SSIZONE. FIX DOVARSUBS
			TO SET INITLIMMED FLAG
84	-----	-----	FOR PROPAGATING .O VARS AND .R AND .S VARS
			MAKE DOVARSUBSTITUTE LOOK AT DOCTLVAR
85	447	19547	DO NOT PROPAGATE NEGS ONTO CERTAIN NODES
			LIKE: I+A(I) WHICH ARE SPECIAL, (DCE)
86	463	19989	IF SUBSTITUTING A REGCONTENTS NODE POINTING TO
			AN AOBJN DO INDEX INTO THE INITIAL VALUE OR
			INCREMENT OF AN IMPLIED DO, SET IMMEDIATE FLAGS
			SO CODE GENERATION WILL ONLY PICK UP RH OF AC., (JNG)

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

87	617	QA2121	ONLY TRY TO SUBSTITUTE THE SUBSCRIPT OF AN
			  ARRAYREF IF IT ISN'T A CONSTANT, (SJW)

***** Begin version 5B *****

88	754	29120	MAKE CONTVAR WALK COMMON SUB EXPRESSION NODES, (EGM)

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

89	1006	TFV	1-Jul-80	------
	Move KISNGL from CGEXPR.BLI and OUTMOD.BLI to this module.
	Make it a global routine.  Note that UTIL is loaded in
	every phase that CGEXPR or OUTMOD is.

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

1167	TFV	11-Jan-83	20-18247
	Fix CONTVAR code for E1/E2LISTCALLs and make it handle arrayrefs
	properly.

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

90	1210	DCE	6-Apr-81	-----
	For ELISTs, do regsubstitution into the assignment statements which
	set up final loop values.

91	1406	TFV	27-Oct-81	------
	Write   NEWDVAR   to   create   a   .Dnnnn   variable   for    a
	compile-time-constant character descriptor.  The entries are all
	linked together.  They have an  OPRCLS of DATAOPR and an  OPERSP
	of VARIABLE.  Either one word  (byte pointer only) or two  words
	(byte pointer  and  length)  are generated  based  on  the  flag
	IDGENLENFLG.  One word .Dnnnn variables are used for  SUBSTRINGs
	with constant lower bounds and non-constant upper bounds.

92	1431	CKS	15-Dec-81
	Add cases for substring and concatenation nodes to the tree walkers
	in LEAFSUBSTITUTE, CONTVAR, and CONTFN.

93	1440	SRM	16-Dec-81
	Fixed the CASE stmt in CONTFN to contain missing cases for:
	FIELDREF, STORECLS, REGCONTENTS, LABOP, STATEMENT, IOLSCLS

94	1406	CDM	18-Dec-81
	Moved routine NEWDVAR to SRCA.

1535	CDM	17-May-82
	Moved MAKLIT to here.
	Then moved it to SRCA!!

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

1730	CKS	21-Feb-83
	Have MISCIO walk the format statement pointer IOFORM so that
	references to DO induction variables get substituted.

1734	TFV	24-Mar-83
	Fix edit 1730.  MISCIO should only walk IOFORM if it exists  and
	is not list directed (i.e. -1).  Only do IOUNIT and IORECORD  if
	they exist too.

1742	TFV	14-Apr-83
	Fix I/O deficiencies.  MISCIO  should look at IOUNIT,  IORECORD,
	IOSTAT, IOFILE,  and the  IOLIST  for registers  to  substitute.
	MISCOCI does the  same for  OPEN/CLOSE/INQUIRE arguments.   Also
	cleanup IOSUBSTITUTE.

1761	BCM	13-Jun-83	20-19276
	Check for  DIALOG/READONLY  without args  when  stepping  thru
	specifier list.

2057	MEM	11-Jun-84
	Add missing case to LEAFSUBSTITUTE so that argument lists  for
	concatenation nodes are walked.  LOKCALST is used to walk  the
	argument list.  A parameter was added to LOKCALST to  indicate
	that the argument list is  from a concatenation node and  that
	the first argument should be skipped.


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

2206	TFV	27-Jun-83
	Fix MISCOCI to handle FILE= for OPEN/CLOSE/INQUIRE.

2333	TJK	30-Mar-84
	Fix some bugs in  SETPVAL and SETPIMMED.  Specifically,  check
	for a  zero parent  pointer, check  for IOLSCLS  nodes,  don't
	assume that ARG2  matches if  ARG1 doesn't,  and in  SETPIMMED
	change a compare of an OPERSP  with FNCALL to a compare of  an
	OPRCLS with FNCALL.

2404	TJK	21-Jun-84
	Add missing  cases to  CONTVAR and  CONTFN for  CONCATENATION.
	Improve a  few things.   Change meaning  of CONTVAR  slightly,
	making it more  powerful and correcting  bugs in its  callers.
	Add UNSAFE,  a  routine  which  tests  for  potential  storage
	overlap.  Add call to UNSAFE from CONTVAR.  Also change CONTFN
	to only return TRUE for user functions.

2425	AHM	15-Jul-84
	Correct a typo in edit 2404 that TJK told us about during EAS
	and RBP's wedding reception.  The CONCATENATION arm of
	CONTVAR's case referred to VAR[ARG2PTR] instead of
	CNODE[ARG2PTR] when fetching the arglist.

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

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

)%

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

FORWARD
	TRANSMOGRIFY(2),
	PROPNEG(1),
	NODERR,
	SETPVAL(1),
	SETPIMMED(1),
	LOOKANYWAY(1),
	LOKA1(1),
	LOKA2(1),
	LEAFSUBSTITUTE(1),
	SWAPEM(1),
	MISCIO(1),
	MISCOCI(1),
	DOVARSUBSTITUTE(1),
	IOSUBSTITUTE(1),
%2404%	UNSAFE(2),		! Checks if two variables can overlap
	CONTVAR(2),
	CONTFN(1),
	UNFLDO(1),
	ARGCONE(1),
	LASTONE(1),
	KISNGL(2);
	
EXTERNAL
%1006%	C1H,		! Argument to CNSTCM
%1006%	C1L,		! Argument to CNSTCM
%1006%	C2H,		! Argument to CNSTCM
%1006%	C2L,		! Argument to CNSTCM
	CDONODE,
	CGERR,		! Error routine
	CHOSEN,
%1006%	CNSTCM,		! Constant combine routine
%1006%	COPRIX,		! Argument to CNSTCM
%1274%	CORMAN,		! Core manager routine
	CSTMNT,		! Current statement being processed
	DOWDP,
	ENTRY,		!SYMBOL NAME FOR TABLE ROUTINES
	GLOBREG,
	ITMCT,
%1006%	KGFRL,
%1006%	KDPRL,
	LOKCALST,
	LOWLIM,		!GLOBAL REGISTER ALLOCATOR COUNTS FROM
			!	ZERO TO ITMCT.
			!OTHER USES COUNT FROM 1 TO ITMCT
	NEWENTRY,	!Makes new entry for symbol table
	NAME,		!SYMBOL TYPE FOR TABLE ROUTINES <GLOBAL>
			! (used by CORMAN for size of entry)
	QQ,
	REPLACARG,
	SKERR,		!STATEMENT ERROR
	SPECCASE,
	SYMTBL,		!THE SYMBOL TABLE
	THASH,		!COMPUTE HASH TABLE INDEX <SRCA>
	TOP;
GLOBAL ROUTINE TRANSMOGRIFY(WHERE,NEWNAME)=
%(**********************************************************************

	ROUTINE TO RENAME A SYMBOL

	CALLED WITH A POINTER TO THE SYMBOL TABLE ENTRY IN
	WHERE AND THE NEW SYMBOL NAME IN NEWNAME

	DELINKS THE SYMBOL AND REHASHES IT

**********************************************************************)%
BEGIN
MAP BASE WHERE:NEWNAME;


LOCAL BASE OLDBASE:NEWBASE;

	NAME_IDTAB;		!SET SYMBOL TABLE ACCESS
	ENTRY_.WHERE[IDSYMBOL];	!COMPUTE HASH INDEX FOR OLD ENTRY
	OLDBASE_THASH();	!VIA THASH
	ENTRY_.NEWNAME;		!COMPUTE HASH INDEX FOR NEW ENTRY
	NEWBASE_THASH();	!VIA THASH

	OLDBASE_SYMTBL[.OLDBASE]<0,0>;	!POINT TO SYMBOL TABLE
	NEWBASE_SYMTBL[.NEWBASE]<0,0>;	!POINT TO SYMBOL TABLE

					!FIND HASH ENTRY IN FRONT
					!OF SYMBOL
	WHILE .OLDBASE[IDLINK] NEQ .WHERE DO
	BEGIN
		IF (OLDBASE_.OLDBASE[IDLINK]) EQL 0 THEN SKERR()
	END;

	OLDBASE[IDLINK]_.WHERE[IDLINK];	!LINK SYMBOL OUT OF TABLE

	WHERE[IDSYMBOL]_.NEWNAME;	!RENAME SYMBOL AND
	WHERE[IDLINK]_.NEWBASE[IDLINK];	!LINK IT INTO
	NEWBASE[IDLINK]_.WHERE		!THE SYMBOL TABLE

END;
GLOBAL ROUTINE PROPNEG(CNODE)=
%(***************************************************************************
	PROPAGATE A NEGATIVE OVER THE NODE "CNODE" IF IT IS POSSIBLE TO DO SO.
	THIS ROUTINE ALLOWS FOR NEGFLAGS SET IN THE NODE CNODE.
	IT RETURNS TRUE IF IT WAS ABLE TO PROPAGATE THE NEG, FALSE IF NOT.
***************************************************************************)%
BEGIN
	REGISTER OPERIX;			!FOR ARITHMETIC OPERATORS, THE OPERSP
						! FIELD IS USED AS AN INDEX TO SPECIFY ACTION
						! TO BE TAKEN
	MAP PEXPRNODE CNODE;


	%(***THE FOLLOWING TABLES ARE USED IF CNODE IS AN ARITHMETIC OPERATION****)%

	%(*****TABLE OF WHETHER TO NEGATE ARG1*****)%
	BIND A1NEGTBL=PLIT (
		TRUE,		!FOR ADD, DO
		TRUE,		!FOR SUB, DO
		TRUE,		!FOR MUL, DO
		TRUE,		!FOR DIV, DO
		FALSE);		!FOR EXPONEN, DO NOT

	%(***TABLE OF WHETHER TO NEGATE ARG2***)%
	BIND A2NEGTBL=PLIT (
		TRUE,		!FOR ADD DO
		TRUE,		!FOR SUB DO
		FALSE,		!FOR MUL DO NOT
		FALSE,		!FOR DIV DO NOT
		FALSE );		!FOR EXPONEN, DO NOT

	%(***TABLE OF WHETHER  THE NEGATE WAS SUCCESSFULLY PROPAGATED***)%
	BIND PROPSUCCESS=PLIT (
		TRUE,		!CAN PROPAGATE FOR ADD
		TRUE,		!CAN FOR SUB
		TRUE,		!CAN FOR MUL
		TRUE,		!CAN FOR DIV
		FALSE );		!CAN NOT PROPAGATE NEG ACROSS EXPONEN




	%(***IF ANY "NOT" FLAGS ARE SET IN CNODE, DONT BOTHER***)%
	IF .CNODE[A1NOTFLG] OR .CNODE[A2NOTFLG]
	THEN RETURN FALSE;

	%(****IF CNODE IS AN ARITHMETIC EXPRESSION********)%

	IF .CNODE[OPRCLS] EQL ARITHMETIC
	THEN
	BEGIN
		%(***ALL DECISIONS WILL BE MADE ON THE BASIS OF THE SPECIFIC OPERATOR***)%
		OPERIX_.CNODE[OPERSP];

		%(***PROCESS 1ST ARG UNDER CNODE***)%
		IF .CNODE[A1NEGFLG]
		THEN
		CNODE[A1NEGFLG]_NOT .A1NEGTBL[.OPERIX]		!2 NEGS CANCEL
		ELSE
		IF .CNODE[A1VALFLG]
		THEN
		BEGIN

			!BE CAREFUL HERE, FOR WE CANNOT PROPAGATE DOWN
			! A NEGATIVE ONTO A NODE WHERE THE A1SAMEFLG
			! IS SET AND WHERE ARG1 IS A VARIABLE LIVING
			! IN A REGISTER - ARG2 COULD BE TAKING ADVANTAGE
			! OF THE SAME REGISTER AS IN THE CASE:
			! K2=-JC*(K+NP(K)) WHICH LOSES OUT IN FORTG
			IF .CNODE[A1SAMEFLG] THEN
				IF NOT .CNODE[A1IMMEDFLG]
					THEN RETURN FALSE;
			CNODE[A1NEGFLG]_.A1NEGTBL[.OPERIX];		!CANNOT PROP OVER A VAR
			IF .CNODE[A1NEGFLG] AND.CNODE[A1IMMEDFLG] AND .CNODE[A1SAMEFLG]	!IF ARG1 IS AN IMMED CONST WHOSE
							! VAL WASLEFT IN A REG FROM A PREV STMNT, NO LONGER
							! WANT TOUSE IT FROM THAT REG
			THEN CNODE[A1SAMEFLG]_0;
		END
		ELSE
		IF .A1NEGTBL[.OPERIX]
		THEN
		BEGIN
			IF NOT PROPNEG(.CNODE[ARG1PTR])
			THEN
			CNODE[A1NEGFLG]_1;			!IF CANNOT PROP NEG OVER ARG1
		END;

		%(***PROCESS 2ND ARG UNDER CNODE***)%
		IF .CNODE[A2NEGFLG]
		THEN
		CNODE[A2NEGFLG]_NOT .A2NEGTBL[.OPERIX]		!2 NEGS CANCEL
		ELSE
		IF .CNODE[A2VALFLG]
		THEN
		CNODE[A2NEGFLG]_.A2NEGTBL[.OPERIX]		!CANNOT PROP OVER A VAR
		ELSE
		IF .A2NEGTBL[.OPERIX]
		THEN
		BEGIN
			IF NOT PROPNEG(.CNODE[ARG2PTR])
			THEN
			CNODE[A2NEGFLG]_1;			!IF CANNOT PROP NEG OVER ARG2
		END;

		%(***RETURN TRUE IF SUCESSFULLY PROPAGATED NEGATE ONTO CNODE***)%
		RETURN .PROPSUCCESS[.OPERIX];

	END


	ELSE
	%(*****IF CNODE IS A TYPE-CONVERSION NODE FOR WHICH CODE MUST BE GENERATED
		(TO BE DIFFERENTIATED FROM TYPE CONVERSION NODES THAT
		ARE PRESENT ONLY TO KEEP TRACK OF VALTYPES)***)%
	IF .CNODE[OPRCLS] EQL TYPECNV AND (NOT NOCNV(CNODE))
	THEN
	BEGIN
		%(***IF THE VAL TO BE CONVERTED ALREADY HAD A NEG, THE 2 CANCEL***)%
		IF .CNODE[A2NEGFLG]
		THEN
		CNODE[A2NEGFLG]_0
		ELSE
		%(***CANNOT PROPAGATE A NEG DOWN ANY FURTHER ONTO A VAR***)%
		IF .CNODE[A2VALFLG]
		THEN
		CNODE[A2NEGFLG]_1
		ELSE
		IF NOT PROPNEG(.CNODE[ARG2PTR])
		THEN
		%(***IF WERE UNABLE TO PROPAGATE THE NEG OVER THE SUBNODE UNDER CNODE***)%
		CNODE[A2NEGFLG]_1;

		%(***CAN ALWAYS SUCCESSFULLY PROPAGATE A NEG ONTO A TYPE-CONVERSION***)%
		RETURN TRUE;
	END

	%(***CANNOT SUCCESSFULLY PROPAGATE A NEG OVER ANYTHING OTHER THAN ARITH OR TYPECNV - 
		(NOTE THAT ANY NEGATE NODES WOULD HAVE BEEN REMOVED AT PHASE 2 SKEL)***)%
	ELSE
	RETURN FALSE
END;
GLOBAL ROUTINE NODERR=
BEGIN
	SKERR();
END;
GLOBAL ROUTINE SETPVAL(CNODE)=
%(****************************************************
	ROUTINE SETS VAL FLAGS IN THE PARENT OF CNODE.
	CNODE IS THE OLD NODE THAT IS BEING		[2333]
	*FOLDED*.
	IT IS CALLED ONLY WHEN IT IS KNOWN THAT
	CNODE IS BEING FOLDED INTO A DATAOPR.		[2333]
*****************************************************)%
BEGIN
	LOCAL ANODE; MAP PEXPRNODE ANODE;
	MAP PEXPRNODE CNODE;

%2333%	IF (ANODE = .CNODE[PARENT]) EQL 0	! Is there a parent?
%2333%	THEN RETURN;				! No, don't bother

	IF .ANODE[OPRCLS] EQL STATEMENT THEN
	!PARENT POINTS BACK AT THE STATEMENT
	BEGIN
		IF .ANODE[SRCID] EQL ASGNID THEN
		!ASSIGNMENT STATEMENT IS ONLY ONE WITH VAL FLGS
		BEGIN
			IF .CNODE EQL .ANODE[RHEXP] THEN
				ANODE[A2VALFLG]_1
			ELSE
				ANODE[A1VALFLG]_1;
		END ELSE
		IF .ANODE[SRCID] EQL IFAID THEN
			ANODE[A1VALFLG]_1
		ELSE
		IF .ANODE[SRCID] EQL IFLID THEN
			ANODE[A1VALFLG]_1;
	END ELSE
	!IT MUST BE AN EXPRESSION

	%(***IF PARENT IS A FN CALL NODE, MUST SET VAL FLAG IN THE ARG-LIST***)%
	IF .ANODE[OPRCLS] EQL FNCALL
	THEN
	BEGIN
		OWN ARGUMENTLIST ARGLST;
		ARGLST_.ANODE[ARG2PTR];
		INCR CT FROM 1 TO .ARGLST[ARGCOUNT]
		DO
		BEGIN
			IF .ARGLST[.CT,ARGNPTR] EQL .CNODE
			THEN ARGLST[.CT,AVALFLG]_1
		END;
	END

%2333%	ELSE IF .ANODE[OPRCLS] NEQ IOLSCLS	! No flags for IOLSCLS nodes
%2333%	THEN
%2333%	BEGIN	! Parent has flags
%2333%
%2333%		IF .CNODE EQL .ANODE[ARG1PTR]
%2333%		THEN ANODE[A1VALFLG] = 1
%2333%		ELSE IF .CNODE EQL .ANODE[ARG2PTR]
%2333%		THEN ANODE[A2VALFLG] = 1;
%2333%
%2333%	END;	! Parent has flags

END;	! of SETPVAL
GLOBAL ROUTINE SETPIMMED(CNODE)=
%(****************************************************
	ROUTINE SETS IMMED FLAGS IN THE PARENT OF CNODE.
	CNODE IS THE OLD NODE THAT IS BEING		[2333]
	*FOLDED*.
	IT IS CALLED ONLY WHEN IT IS KNOWN THAT
	CNODE IS BEING FOLDED INTO A DATAOPR.		[2333]
*****************************************************)%
BEGIN
	LOCAL ANODE; MAP PEXPRNODE ANODE;
	MAP PEXPRNODE CNODE;

%2333%	IF (ANODE = .CNODE[PARENT]) EQL 0	! Is there a parent?
%2333%	THEN RETURN;				! No, don't bother

	IF .ANODE[OPRCLS] EQL STATEMENT THEN
	!PARENT POINTS BACK AT THE STATEMENT
	BEGIN
		IF .ANODE[SRCID] EQL ASGNID THEN
		!ASSIGNMENT STATEMENT IS ONLY ONE WITH IMMED FLGS
		BEGIN
			IF .CNODE EQL .ANODE[RHEXP] THEN
				ANODE[A2IMMEDFLG]_1
			ELSE
				ANODE[A1IMMEDFLG]_1;
		END ELSE
		IF .ANODE[SRCID] EQL IFAID THEN
			ANODE[A1IMMEDFLG]_1
		ELSE
		IF .ANODE[SRCID] EQL IFLID THEN
			ANODE[A1IMMEDFLG]_1;
	END
	!IT MUST BE AN EXPRESSION

	%(***IF PARENT IS A FNCALL NODE, DO NOT SET IMMEDFLGS***)%

%2333%	ELSE IF .ANODE[OPRCLS] NEQ FNCALL	! No flags for FNCALL nodes
%2333%	THEN IF .ANODE[OPRCLS] NEQ IOLSCLS	! No flags for IOLSCLS nodes
%2333%	THEN
%2333%	BEGIN	! Parent has flags
%2333%
%2333%		IF .CNODE EQL .ANODE[ARG1PTR]
%2333%		THEN ANODE[A1IMMEDFLG] = 1
%2333%		ELSE IF .CNODE EQL .ANODE[ARG2PTR]
%2333%		THEN ANODE[A2IMMEDFLG] = 1;
%2333%
%2333%	END;	! Parent has flags

END;	! of SETPIMMED
	!***************************************************************
	! Routines to perform leaf substitution used in three places:
	!	1. statement functions to  substitute the  variables for
	!	   the formals.
	!	2. global register allocation to  substitute regcontents
	!	   nodes for variables.
	!	3. loop optimization in phase 2  skeleton to  substitute
	!	   regcontents nodes for the induction variable
	!
	! SPECCASE unifies these three uses.  It is set to:
	!	0  for statement functions
	!	1  for global register allocation case
	!	2  for phase 2 skeleton loop optimization case
	!
	! QQ is used as a flag both in the phase 2 skeleton case and the
	! global  optimizer.  For  global  opt,  it  prompts   restoring
	! globally  assigned  quantities  to  registers;  for  phase   2
	! skeleton it causes the substitution to terminate.

	ROUTINE LOOKANYWAY(EXPR)=
	BEGIN
		!FOR THE GLOBAL REGISTER ALLOCATOR ONLY.
		!WE HAVE WALKED DOWN ONTO A DATA ITEM,
		!BECAUSE IT IS A PART OF A STATEMENT, NOT
		!AN EXPRESSION.


		DECR I FROM .ITMCT TO .LOWLIM DO
			IF .EXPR EQL .GLOBREG[.I]<RIGHT> THEN
				REPLACARG(.CSTMNT,.GLOBREG[.I]<RIGHT>,
						.CHOSEN[.I]);
	END;
	ROUTINE LOKA1(EXPR)=
	BEGIN
		MAP BASE TOP;
		MAP PEXPRNODE EXPR;
		IF .EXPR[A1VALFLG] THEN
		BEGIN
			DECR I FROM .ITMCT TO .LOWLIM DO
			BEGIN
				IF .EXPR[ARG1PTR] EQL .GLOBREG[.I]<RIGHT> THEN
				BEGIN
					EXPR[ARG1PTR]_.CHOSEN[.I];
					!FOR DO LOOPS ONLY
					!PHASE 2 SKELETON WITH
					!AOBJN TYPE ENDER WORD
					IF .SPECCASE EQL 2 THEN
						EXPR[A1IMMEDFLG]_1
					ELSE
					!GLOBAL ALLOCATION CASE
					IF .SPECCASE EQL 1 THEN
					BEGIN
						IF .GLOBREG[.I]<RIGHT> EQL
						.TOP[DOSYM] AND
						.TOP[FLCWD] THEN
						EXPR[A1IMMEDFLG]_1;
						IF NOT .GLOBREG[.I]<ASGND4USED> THEN
						GLOBREG[.I]<USED4ASGND>_1;
						RETURN;
					END;
				END;
			END;
		END ELSE LEAFSUBSTITUTE(.EXPR[ARG1PTR]);
	END;


	ROUTINE LOKA2(EXPR)=
	BEGIN
		MAP PEXPRNODE EXPR;
		MAP BASE TOP;
		IF .EXPR[A2VALFLG] THEN
		BEGIN
			DECR I FROM .ITMCT TO .LOWLIM DO
			IF .EXPR[ARG2PTR] EQL .GLOBREG[.I]<RIGHT> THEN
			BEGIN
				EXPR[ARG2PTR]_.CHOSEN[.I];
				!FOR DO LOOPS ONLY
				!PHASE 2 SKELETON WITH AOBJN DO
				!LOOP CONTROL WORD
				IF .SPECCASE EQL 2 THEN
					EXPR[A2IMMEDFLG]_1
				ELSE
				!GLOBAL ALLOCATION
				IF .SPECCASE EQL 1 THEN
				BEGIN
					IF .TOP[DOSYM] EQL .GLOBREG[.I]<RIGHT>
						AND .TOP[FLCWD] THEN
					EXPR[A2IMMEDFLG]_1;
					IF NOT .GLOBREG[.I]<ASGND4USED> THEN
					GLOBREG[.I]<USED4ASGND>_1;
					RETURN;
				END;
			END;
		END ELSE LEAFSUBSTITUTE(.EXPR[ARG2PTR]);
	END;
GLOBAL ROUTINE LEAFSUBSTITUTE(EXPR)=
BEGIN
	!PERFORM LEAF SUBSTITUTION OF ANY REFERENCES TO GLOBREG (A VECTOR LIST)
	!WITHIN EXPR. WITH THE CORRESPONDING ELEMENT IN THE VECTOR CHOSEN
	MAP PEXPRNODE EXPR;
	!CHOSEN & GLOBREG ARE USED BY OPTIMIZER ALGORITHMS. THEY ARE GLOBAL
	!AND ARE USED HERE (THOUGH INAPPROPRIATELY NAMED) AS A
	!SPACE SAVING DEVICE.
	!THIS ROUTINE IS ALSO USED TO SUBSTITUTE THE REGCONTENTS NODE
	!FOR THE DO INDUCTION VARIABLE ON INNER-MOST DO LOOPS.
	!QQ IS USED AS A FLAG IN THIS CONTEXT TO NOTE WHEN A FUNCTION
	!CALL HAS BEEN PROCESSED TO TERMINATE THE SUBSTITUTION.
	!NOTE THAT THE EXECUTION MAY DIFFER FROM THE OLD COMPILER
	!SINCE THE REMAINDER OF THE STATEMENT IN WHICH THE FUNCTION
	!REFERENCE EXISTS WILL STILL HAVE THE SUBSTITUTION. THIS
	!IS CONSISTENT WITH THE DEFINITION OF FORTRAN, HOWEVER.


IF .SPECCASE EQL 1 THEN		!GLOBAL REGISTER ALLOCATOR
	LOWLIM_0
ELSE
	LOWLIM_1;

CASE .EXPR[OPRCLS] OF SET
!BOOLEAN
BEGIN
	LOKA1(.EXPR);
	LOKA2(.EXPR);
END;

!DATAOPR
BEGIN
		LOOKANYWAY(.EXPR);
END;

!RELATIONAL
BEGIN
	LOKA1(.EXPR);
	LOKA2(.EXPR);
END;

!FNCALL
BEGIN
	LOCAL ARGUMENTLIST AG;
	AG_.EXPR[ARG2PTR];
	INCR I FROM .LOWLIM TO .ITMCT DO

%2057%	LOKCALST(.AG,.AG[ARGCOUNT],.GLOBREG[.I]<RIGHT>,.CHOSEN[.I],FALSE);
END;

!ARITHMETIC
BEGIN
	LOKA1(.EXPR);
	LOKA2(.EXPR);
END;

!TYPCNV
	LOKA2(.EXPR);

!ARRAYREF
	!IF SUBSCRIPT IS CONSTANT, ARG2PTR = 0 AND CAN'T SUBSTITUTE
	IF .EXPR [ARG2PTR] NEQ 0
	  THEN LOKA2 (.EXPR);

!CMNSUB
LOKA2(.EXPR);

!NEGNOT
LOKA2(.EXPR);

!SPECOP
LOKA1(.EXPR);

!FIELDREF
	BEGIN END;	!RELEASE GTR 1
!STORECLS
	BEGIN END;	!SHOULD NEVER SEE
!REGCONTENTS
	BEGIN END;	!DO NOTHING
!LABOP
	BEGIN END;	!SHOULD NEVER SEE
!STATEMENT
	BEGIN END;	!SHOULD NEVER SEE
!IOLCLS
	BEGIN END;	!HANDLED BY IOSUBSTITUTE
!INLINFN
	BEGIN
		LOKA1(.EXPR);
		IF .EXPR[ARG2PTR] NEQ 0 THEN
		LOKA2(.EXPR);
	END;
!SUBSTRING
%1431%	BEGIN				
%1431%		REGISTER BASE A4;
%1431%		LOKA1(.EXPR);
%1431%		LOKA2(.EXPR);
%1431%		A4 _ .EXPR[ARG4PTR];
%1431%		IF .A4[OPRCLS] EQL ARRAYREF
%1431%		THEN IF .A4[ARG2PTR] NEQ 0
%1431%		     THEN LOKA2(.A4);
%1431%	END;
!CONCATENATION
%1431%	BEGIN
%2057%		LOCAL ARGUMENTLIST AG;
%2057%		AG = .EXPR[ARG2PTR];
%2057%		INCR I FROM .LOWLIM TO .ITMCT
%2057%		DO LOKCALST(.AG,.AG[ARGCOUNT],.GLOBREG[.I]<RIGHT>,.CHOSEN[.I],
%2057%			TRUE);
	END
TES;
END;
GLOBAL ROUTINE SWAPEM(VAR)=
BEGIN
	!LOOK THROUGH GLOBREG FOR VAR. IF
	!THERE RETURN CHOSEN ELSE JUST BACK WHAT YOU GOT


	INCR I FROM .LOWLIM TO .ITMCT DO
		IF .VAR EQL .GLOBREG[.I]<RIGHT> THEN
		BEGIN
			IF .SPECCASE EQL 1 THEN
				IF NOT .GLOBREG[.I]<ASGND4USED> THEN
					GLOBREG[.I]<USED4ASGND>_1;

			RETURN (.CHOSEN[.I]);
		END;

	.VAR
END;
GLOBAL ROUTINE MISCIO(STMT)=
BEGIN
	!***************************************************************
	! Check I/O  keywords  and  IOLIST  elements  for  registers  to
	! substitute.  The usual scheme applies.  GLOBREG points to  the
	! variable;  CHOSEN  points  to  the  regcontents  node.   ITMCT
	! contains the number of items in the lists GLOBREG and  CHOSEN.
	! SPECCASE is a flag which says count from 0 (global  allocator)
	! or count from 1 (statement functions, local allocator).
	!***************************************************************

	MAP BASE STMT;
	REGISTER BASE TMP;

	LOWLIM_(IF .SPECCASE EQL 1 THEN 0 ELSE 1);

%1734%	! Check IOUNIT if specified

%1734%	IF (TMP = .STMT[IOUNIT]) NEQ 0
%1734%	THEN IF .TMP[OPRCLS] EQL DATAOPR
%2404%	THEN STMT[IOUNIT] = SWAPEM(.TMP)
%2404%	ELSE LEAFSUBSTITUTE(.TMP);

%1734%	! Check IOFORM if specified and not list directed (i.e. -1)

%1734%	IF (TMP = .STMT[IOFORM]) NEQ 0
%1734%	THEN IF .TMP NEQ #777777	! don't do it for list directed
%1734%	THEN IF .TMP[OPRCLS] EQL DATAOPR
%2404%	THEN STMT[IOFORM] = SWAPEM(.TMP)
%2404%	ELSE LEAFSUBSTITUTE(.TMP);

%1734%	! Check IORECORD if specified

%1734%	IF (TMP = .STMT[IORECORD]) NEQ 0
%1734%	THEN IF .TMP[OPRCLS] EQL DATAOPR
%1734%	THEN STMT[IORECORD] = SWAPEM(.TMP)
%1734%	ELSE LEAFSUBSTITUTE(.TMP);

%1742%	! Check IOIOSTAT if specified

%1742%	IF (TMP = .STMT[IOIOSTAT]) NEQ 0
%1742%	THEN IF .TMP[OPRCLS] EQL DATAOPR
%1742%	THEN STMT[IOIOSTAT] = SWAPEM(.TMP)
%1742%	ELSE LEAFSUBSTITUTE(.TMP);

%1742%	! Check IOLIST elements if specified

%1742%	TMP = .STMT[IOLIST];
%1742%	WHILE .TMP NEQ 0 DO
%1742%	BEGIN
%1742%		IOSUBSTITUTE(.TMP);
%1742%		TMP = .TMP[SRCLINK];
%1742%	END;
END;	! of MISCIO
GLOBAL ROUTINE MISCOCI(STMT)=
BEGIN
	!***************************************************************
	! Check OPEN/CLOSE/INQUIRE keywords for registers to substitute.
	! The usual  scheme applies.   GLOBREG points  to the  variable;
	! CHOSEN points  to the  regcontents node.   ITMCT contains  the
	! number of items in the lists GLOBREG and CHOSEN.  SPECCASE  is
	! a flag which  says count  from 0 (global  allocator) or  count
	! from 1 (statement functions, local allocator).
	!***************************************************************

%1742%	! Written by TFV, on 14-Apr-83

	MAP BASE STMT;

	REGISTER
		BASE TMP,
		OPENLIST OPENL;

	LOWLIM = (IF .SPECCASE EQL 1 THEN 0 ELSE 1);

	! Check IOUNIT if specified

	IF (TMP = .STMT[IOUNIT]) NEQ 0
	THEN IF .TMP[OPRCLS] EQL DATAOPR
	THEN STMT[IOUNIT] = SWAPEM(.TMP)
	ELSE LEAFSUBSTITUTE(.TMP);


%2206%	! Check IOFILE if specified

%2206%	IF (TMP = .STMT[IOFILE]) NEQ 0
%2206%	THEN IF .TMP[OPRCLS] EQL DATAOPR
%2206%	THEN STMT[IOFILE] = SWAPEM(.TMP)
%2206%	ELSE LEAFSUBSTITUTE(.TMP);

	! Check IOIOSTAT if specified

	IF (TMP = .STMT[IOIOSTAT]) NEQ 0
	THEN IF .TMP[OPRCLS] EQL DATAOPR
	THEN STMT[IOIOSTAT] = SWAPEM(.TMP)
	ELSE LEAFSUBSTITUTE(.TMP);

	! Check aother argument list elements

	OPENL = .STMT[OPLST];
	DECR I FROM .STMT[OPSIZ] - 1 TO 0 DO
	BEGIN
		TMP = .OPENL[.I,OPENLPTR];
%1761%		! add check for 0 pointer
%1761%		IF .TMP NEQ 0
%1761%		THEN
%1761%		BEGIN
			IF .TMP[OPRCLS] EQL DATAOPR
			THEN OPENL[.I,OPENLPTR] = SWAPEM(.TMP)
			ELSE LEAFSUBSTITUTE(.TMP);
%1761%		END;
	END;
END;	! of MISCOCI
GLOBAL ROUTINE DOVARSUBSTITUTE(CLSTCALL)=
BEGIN
	!TO PERFORM REGISTER SUBSTITUTIONS ON ALL FIELDS OF
	!A DO STATEMENT. USED BY IOSUBSTITUTE AND THE GLOBAL
	!REGISTER ALLOCATOR

	MAP BASE CLSTCALL:CDONODE;
	LOCAL BASE P:AOBDOSYM;
	LOWLIM_(IF .SPECCASE EQL 1 THEN 0 ELSE 1);

			P_.CLSTCALL[DOLPCTL];
			IF .P[OPRCLS] NEQ DATAOPR THEN
				LEAFSUBSTITUTE(.P)
			ELSE
				CLSTCALL[DOLPCTL]_SWAPEM(.P);

		%(***NOW TO SUBSTITUTE FOR THE INITIAL VALUE AND STEP
			SIZE FIELDS OF THE DO. IF WE ARE SUBSTITUTING
			A REGCONTENTS NODE THAT POINTS TO THE DO INDEX
			OF THE NEXT OUTER DO, AND THAT DO IS CONTROLLED
			WITH AN AOBJN, THEN MUST MAKE SURE TO SET THE
			APPROPRIATE IMMEDIATE FLAGS IN THIS DO, SO THAT
			CODE GENERATION WILL ONLY PICK UP THE RIGHT HALF
			OF THE AC***)%

		%(***FIRST, SET UP A TEMP THAT CONTAINS A POINTER TO
			THE OUTER DO'S INDEX VAR IF THE OUTER DO IS AN
			AOBJN DO, BUT IS 0 OTHERWISE***)%

		AOBDOSYM _ (IF .CDONODE[FLCWD] THEN .CDONODE[DOSYM]
							ELSE 0);

		P _ SWAPEM(.CLSTCALL[DOM1]);	!CHECK INITIAL VALUE

		IF .CLSTCALL[DOM1] NEQ .P	!IF REGCONTENTS FOUND
		THEN
		BEGIN
			IF .AOBDOSYM EQL .CLSTCALL[DOM1] THEN
				CLSTCALL[INITLIMMED]_1;
			CLSTCALL[DOM1]_.P;
		END;

		P _ SWAPEM(.CLSTCALL[DOSSIZE]);	!CHECK STEP SIZE

		IF .CLSTCALL[DOSSIZE] NEQ .P	!IF DOING SUBSTITUTION
		THEN
		BEGIN
			IF .AOBDOSYM EQL .CLSTCALL[DOSSIZE] THEN
				CLSTCALL[SSIZIMMED]_1;
			CLSTCALL[DOSSIZE]_.P;
		END;

		!IF WE ARE PROPAGATING (OR SUBSUMING) THEN
		!WE COULD ALSO CARE ABOUNT THE DO LOOP CONTROL VARIALE
		!ITSELF

		CLSTCALL[DOCTLVAR]_SWAPEM(.CLSTCALL[DOCTLVAR]);


	!TO TAKE CARE OF GLOBALLY ALLOCATED IMPLIED DOS
	IF .SPECCASE EQL 1 THEN
	BEGIN
		INCR I FROM .LOWLIM TO .ITMCT DO
		BEGIN
			IF .CLSTCALL[DOSYM] EQL .GLOBREG[.I]<RIGHT> THEN
			BEGIN
				P_.CHOSEN[.I];
				CLSTCALL[DOIREG]_.P[TARGTAC];
				CLSTCALL[IXGALLOCFLG]_1;
				IF .CLSTCALL[FLCWD] THEN
				BEGIN
					UNFLDO(.CLSTCALL);
					CLSTCALL[INITLIMMED]_1;
				END;
				IF NOT .GLOBREG[.I]<USED4ASGND> THEN
					GLOBREG[.I]<ASGND4USED>_1;
			END;
		END;
	END;
END;
GLOBAL ROUTINE IOSUBSTITUTE(CLSTCALL)=
BEGIN
	!***************************************************************
	! Substitute a regcontents node into an I/O statement IOLIST
	!***************************************************************

	MAP BASE CLSTCALL;
	MAP BASE TOP:CDONODE:CSTMNT;
	MAP OBJECTCODE DOWDP;
	LOCAL BASE P:TMP;

	!LOCAL ROUTINES TO HELP SHORTEN CODE

	ROUTINE IOCS(CSLST)=
	BEGIN
		!DO THE THING FOR ANY COMMON SUBS

		MAP BASE CSLST;

		WHILE .CSLST NEQ 0 DO
		BEGIN
			IF .CSLST[A2VALFLG] THEN
				CSLST[ARG2PTR]_SWAPEM(.CSLST[ARG2PTR])
			ELSE
				LEAFSUBSTITUTE(.CSLST[ARG2PTR]);

			CSLST_.CSLST[CLINK];
		END;
	END;

	ROUTINE E1ORE2(NOD)=
	BEGIN
		!DO COMMON PROCESSING FOR E1 OR E2 LISTS
		MAP BASE NOD;
		LOCAL BASE TMP:P;
		TMP_.NOD[ELSTPTR];
		WHILE .TMP NEQ 0 DO
		BEGIN
			P_.TMP[E2ARREFPTR];
			IF .P[OPRCLS] EQL DATAOPR THEN
				TMP[E2ARREFPTR]_SWAPEM(.P)
			ELSE
				LEAFSUBSTITUTE(.P);

			P_.TMP[E2INCR];
			IF .P NEQ 0 THEN
				IF .P[OPRCLS] EQL DATAOPR THEN
					TMP[E2INCR]_SWAPEM(.P)
				ELSE
					LEAFSUBSTITUTE(.P);

			TMP_.TMP[CLINK];
		END;

		TMP_.NOD[ECNTPTR];
		IF .TMP[OPRCLS] EQL DATAOPR THEN
			NOD[ECNTPTR]_SWAPEM(.TMP)
		ELSE
			LEAFSUBSTITUTE(.TMP);

%1742%		! Do the substitution on the increment for an E1LIST
%1742%		TMP_.NOD[E1INCR];
%1742%		IF .TMP NEQ 0
%1742%		THEN IF .TMP[OPRCLS] EQL DATAOPR
%1742%		THEN NOD[E1INCR]_SWAPEM(.TMP)
%1742%		ELSE LEAFSUBSTITUTE(.TMP);

%1742%		! Substitute into assignment statement(s) for final loop value(s)
%1742%		TMP_.CSTMNT;		! Save CSTMNT
%1742%		CSTMNT_.NOD[ELPFVLCHAIN];	! Get chain of assignments

%1742%		WHILE .CSTMNT NEQ 0 DO
%1742%		BEGIN	! Walk down chain of assignments
%1742%			LEAFSUBSTITUTE(.CSTMNT[LHEXP]);	! Do assignment substitution
%1742%			LEAFSUBSTITUTE(.CSTMNT[RHEXP]);
%1742%			CSTMNT_.CSTMNT[CLINK]
%1742%		END;	! Walk down chain of assignments
%1742%		CSTMNT_.TMP;		! Restore CSTMNT

%1742%	END;	! of E1ORE2

	LOWLIM_(IF .SPECCASE EQL 1 THEN 0 ELSE 1);

	IF .CLSTCALL[OPRCLS] EQL STATEMENT
	THEN
	BEGIN

		!WE ARE INTERESTED ONLY IF IT IS A DO
		IF .CLSTCALL[SRCID] EQL DOID THEN
		BEGIN
			DOVARSUBSTITUTE(.CLSTCALL);
		END ELSE
		!IT COULD BE AN ASSIGNMENT
		!THE CHEAPEST WAY (CODE SIZE) IS TO SAVE
		!CSTMNT AWAY, POINT IT AT THIS ASSIGNEMNT AND
		!LET LOOKANYWAY AND REPLACARG TAKE CARE OF THE
		!SUBSTITUTION
		IF .CLSTCALL[SRCID] EQL ASGNID THEN
		BEGIN
			TMP_.CSTMNT;
			CSTMNT_.CLSTCALL;
			LEAFSUBSTITUTE(.CSTMNT[LHEXP]);
			LEAFSUBSTITUTE(.CSTMNT[RHEXP]);
			CSTMNT_.TMP;
		END ELSE
		!ITS A CONTINUE STATEMENT
		RETURN
	END ELSE
	CASE .CLSTCALL[OPERSP] OF SET
	!DATACALL
	BEGIN
		P_.CLSTCALL[DCALLELEM];
		IF .P[OPRCLS] NEQ DATAOPR THEN
			LEAFSUBSTITUTE(.P)
		ELSE
			CLSTCALL[DCALLELEM]_SWAPEM(.P);
	END;
	!SLISTCALL
	BEGIN END;
	!IOLSTCALL
	BEGIN
		!LOOK THROUGH THE COMMON SUB-EXPRESSIONS
		!THEY WILL ONLY BE THERE IN THE GLOBAL
		!REGISTER ALLOCATION CASE WITH LOCAL CMNSUBS
		!ON THE I/O LISTS
		IOCS(.CLSTCALL[SRCCOMNSUB]);
		!NOW LOOK AT LIST ITSELF

		P_.CLSTCALL[IOLSTPTR];
		WHILE .P NEQ 0 DO
		BEGIN
			IOSUBSTITUTE(.P);
			P_.P[CLINK];
		END;
	END;

	!E1LISTCALL
	BEGIN
		IOCS(.CLSTCALL[SRCCOMNSUB]);
		E1ORE2(.CLSTCALL);
	END;
	!E2LISTCALL
	BEGIN
		IOCS(.CLSTCALL[SRCCOMNSUB]);
		E1ORE2(.CLSTCALL);
	END;

	TES;
END;	! of IOSUBSTITUTE
GLOBAL ROUTINE UNSAFE(VAR1,VAR2) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	This routine is passed two expression pointers, VAR1 and VAR2.
!	If either one of them isn't a non-constant DATAOPR, it returns
!	FALSE.  Otherwise they're both  non-constant DATAOPRs, and  it
!	returns TRUE if there's any possibility that they may  overlap
!	in memory.  If there isn't, it returns FALSE.
!
!	Note that it  is left to  the caller to  extract the names  of
!	L-values (i.e., things  which may  be stored  into).  This  is
!	mainly to avoid  having to repeatedly  look for SUBSTRING  and
!	ARRAYREF names, and because currently this is already done  by
!	the callers  of this  routine.  However,  it could  safely  be
!	added if this routine is later needed in other situations.
!
!	The main purpose of this routine is to provide a common  place
!	for making common/equivalence checks.  This checking could  be
!	made more sophisticated someday.
!
! FORMAL PARAMETERS:
!
!	VAR1		Pointer to first variable
!	VAR2		Pointer to second variable
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	TRUE if VAR1 and VAR2 are both non-constant DATAOPRs which may
!	potentially overlap.  FALSE otherwise.
!
! SIDE EFFECTS:
!
!	None
!
!--


![2404] New
BEGIN
	MAP BASE VAR1;
	MAP BASE VAR2;

	! If they're not both non-constant DATAOPRs, fall through  and
	! return FALSE.  It is left to the caller to extract the names
	! of L-values (i.e., things which may be stored into).

	IF .VAR1[OPRCLS] EQL DATAOPR
	THEN IF .VAR1[OPERSP] NEQ CONSTANT
	THEN IF .VAR2[OPRCLS] EQL DATAOPR
	THEN IF .VAR2[OPERSP] NEQ CONSTANT
	THEN
	BEGIN	! VAR1 and VAR2 both non-constant DATAOPRs

		IF .VAR1 EQL .VAR2 THEN RETURN TRUE;	! Check obvious case

		! Now check for common/equivalence potential  overlap.
		! Be overly  cautious  to  avoid  dependency  on  when
		! common/equivalence processing is  done.  This  could
		! be made more sophisticated someday.

		IF .VAR1[IDATTRIBUT(INCOM)]
			OR .VAR1[IDATTRIBUT(INEQV)]
		THEN IF .VAR2[IDATTRIBUT(INCOM)]
			OR .VAR2[IDATTRIBUT(INEQV)]
		THEN IF .VAR1[IDATTRIBUT(INEQV)]
			OR .VAR2[IDATTRIBUT(INEQV)]
		THEN RETURN TRUE;			! Assume the worst

	END;	! VAR1 and VAR2 both non-constant DATAOPRs

	RETURN FALSE;		! Safe to assume no overlap
END;
GLOBAL ROUTINE CONTVAR(CNODE,VAR)=
%(***************************************************************************
![2404] The interpretation of this  routine has changed somewhat.   It
![2404] should now be  thought of as  "The value of  CNODE may  change
![2404] when VAR becomes redefined".  VAR is expected to be an L-value
![2404] (i.e., something which may  be stored into).  Specifically,  a
![2404] SUBSTRING,  ARRAYREF,  non-constant  DATAOPR,  or  REGCONTENTS
![2404] node.   If  VAR  isn't  one   of  these,  it  returns   FALSE.
![2404] Otherwise, for SUBSTRING and  ARRAYREF nodes, it extracts  the
![2404] name so  that  VAR  is  either a  non-constant  DATAOPR  or  a
![2404] REGCONTENTS node.  It then recursively looks for a  dependency
![2404] on VAR  in CNODE.   This includes  common/equivalence  checks,
![2404] made through a call to UNSAFE.
![2404]
![2404] This routine is  mostly called to  check for I/O  dependencies
![2404] and to look for  optimizer-created temporaries.  Note that  at
![2404] the  moment  REGCONTENTS  nodes  don't  seem  to  be  possible
![2404] arguments for VAR.   However, it has  always worked and  still
![2404] does for that case, although no common/equivalence checking is
![2404] done for REGCONTENTS nodes.
***************************************************************************)%
BEGIN
	LOCAL PEXPRNODE ARGNODE;
	MAP PEXPRNODE CNODE;
	LOCAL ARGUMENTLIST ARGLST;

%1167%	MAP BASE VAR;

	%(***DEFINE MACRO TO CHECK BINARY NODES*****)%
	MACRO BINARYCHK=
%2404%		(IF CONTVAR(.CNODE[ARG1PTR],.VAR)
%2404%		THEN TRUE
%2404%		ELSE CONTVAR(.CNODE[ARG2PTR],.VAR))$;

	DEBGNODETST(CNODE);	!FOR DEBUGGING ONLY, CHECK THAT CNODE IS NOT 0

%2404%	! If VAR is a  SUBSTRING, use the full  string.  This will  be
%2404%	! either a DATAOPR or an  ARRAYREF.  The latter are caught  by
%2404%	! the check following this one.
%2404%
%2404%	IF .VAR[OPRCLS] EQL SUBSTRING
%2404%	THEN VAR = .VAR[ARG4PTR];

%1167%	! If VAR is an ARRAYREF, use the array name

%1167%	IF .VAR[OPRCLS] EQL ARRAYREF
%1167%	THEN VAR = .VAR[ARG1PTR];

%2404%	! Make sure VAR is an L-value (i.e., make sure it can
%2404%	! be stored into).
%2404%
%2404%	IF .VAR[OPRCLS] NEQ DATAOPR
%2404%	THEN IF .VAR[OPRCLS] NEQ REGCONTENTS
%2404%	THEN RETURN FALSE;

%2404%	! Constants are always safe
%2404%
%2404%	IF .VAR[OPR1] EQL CONSTFL
%2404%	THEN RETURN FALSE;

%2404%	! VAR is now either a non-constant DATAOPR or a REGCONTENTS node.

	CASE .CNODE[OPRCLS] OF SET

	%(***FOR CNODE A BOOLEAN***)%
	RETURN BINARYCHK;

	%(***FOR DATA ITEM********)%
%2404%	RETURN UNSAFE(.CNODE,.VAR);	! Consider common/equivalence

	%(***FOR RELATIONAL***)%
	RETURN BINARYCHK;

	%(***FUNCTION CALL***)%
	BEGIN
		%(***SEARCH THE ARG LIST***)%
		IF (ARGLST_.CNODE[ARG2PTR]) NEQ 0
		THEN
		BEGIN
			INCR CT FROM 1 TO .ARGLST[ARGCOUNT]
			DO 
			BEGIN
				IF CONTVAR(.ARGLST[.CT,ARGNPTR],.VAR) THEN RETURN TRUE;
			END;
		END;
%2404%		RETURN FALSE;
	END;

	%(***FOR AN ARITHMETIC****)%
	RETURN BINARYCHK;

	%(***FOR A TYPECNV***)%
	RETURN CONTVAR(.CNODE[ARG2PTR],.VAR);

	%(***FOR AN ARRAYREF***)%
	BEGIN
		IF .CNODE[ARG2PTR] EQL 0 THEN RETURN (.CNODE[ARG1PTR] EQL .VAR)
		ELSE RETURN BINARYCHK
	END;

	%(***FOR A CMNSUB******)%
%[754]%	RETURN CONTVAR(.CNODE[ARG2PTR],.VAR);

	%(***FOR NEG/NOT***)%
	RETURN CONTVAR(.CNODE[ARG2PTR],.VAR);

	%(***FOR SPECIAL OPERATORS***)%
	RETURN CONTVAR(.CNODE[ARG1PTR],.VAR);


	%(***FOR  FIELD-REF - NOT IN RELEASE 1***)%
	CGERR();

	%(***FOR STORECLS***)%
	RETURN CONTVAR(.CNODE[ARG2PTR],.VAR);

	%(***FOR REGCONTENTS - VAR MAY BE THIS REGCONTENTS NODE***)%
	RETURN (.CNODE EQL .VAR);

	%(***FOR LABEL***)%
	RETURN FALSE;

	%(***SHOULD NOT ENCOUNTER A STATEMENT***)%
	CGERR();

	%(***FOR AN IOLIST-CLASS NODE ***)%
	CASE .CNODE[OPERSP] OF SET

	!DATACALL
		RETURN(CONTVAR(.CNODE[DCALLELEM],.VAR));

	!SLISTCALL
		RETURN(CONTVAR(.CNODE[SCALLELEM],.VAR) OR
			CONTVAR(.CNODE[SCALLCT],.VAR));

	!IOLSTCALL
	BEGIN
		QQ_0;
		ARGNODE_.CNODE[IOLSTPTR];

		WHILE .ARGNODE NEQ 0 DO
		BEGIN
			QQ_.QQ OR CONTVAR(.ARGNODE[DCALLELEM],.VAR);
			ARGNODE_.ARGNODE[CLINK];
		END;

		RETURN(.QQ);
	END;

	!E1LISTCALL
	BEGIN
		QQ_0;
		ARGNODE_.CNODE[ELSTPTR];

%1167%		WHILE .ARGNODE NEQ 0 DO
%1167%		BEGIN
%1167%			QQ = .QQ OR CONTVAR(.ARGNODE[E2ARREFPTR],.VAR);
%1167%			ARGNODE = .ARGNODE[CLINK];
%1167%		END;

		RETURN(.QQ OR CONTVAR(.CNODE[ECNTPTR],.VAR) OR
%1167%			CONTVAR(.CNODE[E1INCR],.VAR));
	END;

	!E2LISTCALL
	BEGIN
		QQ_0;
		ARGNODE_.CNODE[ELSTPTR];
		WHILE .ARGNODE NEQ 0 DO
		BEGIN
%1167%			QQ = .QQ OR CONTVAR(.ARGNODE[E2INCR],.VAR) OR
			   CONTVAR(.ARGNODE[E2ARREFPTR],.VAR);
			ARGNODE_.ARGNODE[CLINK];
		END;
		RETURN(.QQ OR CONTVAR(.CNODE[ECNTPTR],.VAR));
	END;

	TES;

	%(***FOR AN IN-LINE FN***)%
	BEGIN
		IF .CNODE[ARG2PTR] EQL 0
		THEN RETURN (CONTVAR(.CNODE[ARG1PTR],.VAR))
		ELSE RETURN BINARYCHK
	END;

%1431%	%(***FOR SUBSTRING***)%
%1431%	BEGIN
%1431%		IF CONTVAR(.CNODE[ARG1PTR],.VAR) THEN RETURN TRUE;
%1431%		IF CONTVAR(.CNODE[ARG2PTR],.VAR) THEN RETURN TRUE;
%1431%		IF CONTVAR(.CNODE[ARG4PTR],.VAR) THEN RETURN TRUE;
%1431%		RETURN FALSE;
%1431%	END;

%2404%	%(***FOR CONCATENATION***)%
%2404%	BEGIN
%2425%		ARGLST = .CNODE[ARG2PTR];
%2404%
%2404%		INCR CT FROM 2 TO .ARGLST[ARGCOUNT]	! Skip first arg
%2404%		DO IF CONTVAR(.ARGLST[.CT,ARGNPTR],.VAR)
%2404%		THEN RETURN TRUE;			! Found it
%2404%
%2404%		RETURN FALSE;				! Didn't find it
%2404%	END;

	TES;
END;
GLOBAL ROUTINE CONTFN(CNODE)=
%(***************************************************************************
![2404] This routine now returns  TRUE only if  CNODE contains a  user
![2404] function, i.e.,  it doesn't  return  TRUE merely  for  library
![2404] functions, since they don't have side effects.
***************************************************************************)%
BEGIN
%1440%	ROUTINE FNINLIST( ARGNODE ) =
%1440%	! Routine walks a linked list of nodes checking for function calls
%1440%	BEGIN	! FNINLIST
%1440%
%1440%		MAP PEXPRNODE ARGNODE;
%1440%		WHILE .ARGNODE NEQ 0 DO
%1440%		BEGIN
%2404%			IF CONTFN(.ARGNODE) THEN RETURN TRUE;
%2404%			ARGNODE = .ARGNODE[CLINK];
%1440%		END;
%2404%		RETURN FALSE;
%1440%	END;	! of FNINLIST

	MAP PEXPRNODE CNODE;

	%(***DEFINE MACRO TO CHECK FOR EITHER SUBNODE OF A BINARY NODE***)%
	MACRO BINARYCHK=
%2404%		(IF CONTFN(.CNODE[ARG1PTR])
%2404%		THEN TRUE
%2404%		ELSE CONTFN(.CNODE[ARG2PTR]))$;

	CASE .CNODE[OPRCLS] OF SET

	%(**FOR A BOOLEAN***)%
	RETURN BINARYCHK;

	%(***FOR A DATA ITEM***)%
	RETURN FALSE;

	%(***FOR A RELATIONAL***)%
	RETURN BINARYCHK;

	%(***FOR A FN CALL***)%
%2404%	IF .CNODE[OPERSP] NEQ LIBARY
%2404%	THEN RETURN TRUE
%2404%	ELSE
%2404%	BEGIN	! library
%2404%
%2404%		LOCAL ARGUMENTLIST AG;
%2404%		IF (AG = .CNODE[ARG2PTR]) NEQ 0
%2404%		THEN
%2404%		BEGIN	! It has an argument list
%2404%
%2404%			INCR I FROM 1 TO .AG[ARGCOUNT]
%2404%			DO IF CONTFN(.AG[.I,ARGNPTR])
%2404%			THEN RETURN TRUE;			! Found one
%2404%
%2404%		END;	! It has an argument list
%2404%
%2404%		RETURN FALSE;		! No non-LIBRARY functions
%2404%
%2404%	END;	! library

	%(***FOR AN ARITHMETIC***)%
	RETURN BINARYCHK;

	%(***FOR A TYPE CNV***)%
	RETURN CONTFN(.CNODE[ARG2PTR]);

	%(***FOR AN ARRAYREF***)%
	RETURN
	BEGIN
		IF .CNODE[ARG2PTR] NEQ 0 THEN CONTFN(.CNODE[ARG2PTR])
		ELSE 0
	END;

	%(***FOR A CMNSUB***)%
	RETURN FALSE;

	%(***FOR A NEG/NOT***)%
	RETURN CONTFN(.CNODE[ARG2PTR]);

	%(***FOR A SPECOP (P2MUL OR P2DIV) ***)%
	RETURN CONTFN(.CNODE[ARG1PTR]);

%1440%	%(***FOR FIELDREF - NOT SUPPORTED***)%
%1440%	CGERR();
%1440%
%1440%	%(***FOR STORECLS***)%
%1440%	RETURN CONTFN(.CNODE[ARG2PTR]);
%1440%
%1440%	%(***FOR REGCONTENTS***)%
%1440%	RETURN FALSE;
%1440%
%1440%	%(***FOR LABEL***)%
%1440%	RETURN FALSE;
%1440%
%1440%	%(***SHOULD NEVER BE CALLED FOR A STATEMENT***)%
%1440%	CGERR();
%1440%
%1440%	%(***FOR AN IOLIST-CLASS NODE***)%
%1440%	BEGIN	! IOLIST-class nodes
%1440%		CASE .CNODE[OPERSP] OF SET
%1440%
%1440%		!DATACALL
%1440%		RETURN CONTFN( .CNODE[ DCALLELEM ] );
%1440%		
%1440%		!SLISTCALL
%1440%		RETURN ( CONTFN( .CNODE[ SCALLELEM ] ) OR
%1440%			CONTFN( .CNODE[ SCALLCT ] ) );
%1440%
%1440%		!IOLSTCALL
%1440%		! Search the linked list of IOLSCLS nodes under this node
%1440%		RETURN FNINLIST(  .CNODE[IOLSTPTR] );
%1440%
%1440%		!E1LISTCALL
%1440%		! Search the linked list of array ref nodes
%1440%		RETURN FNINLIST ( .CNODE[ELSTPTR] );
%1440%
%1440%		!E2LISTCALL
%1440%		BEGIN	! E2LISTCALL
%1440%			REGISTER FNFOUND;
%1440%			REGISTER PEXPRNODE ARGNODE;
%1440%
%1440%			! Search the linked list of nodes that point
%1440%			!  to arrayrefs and counts. Only need to look
%1440%			!  at the ARRAYREFs.
%1440%			FNFOUND = FALSE;
%1440%			ARGNODE = .CNODE[ELSTPTR];
%1440%			WHILE .ARGNODE NEQ 0 DO
%1440%			BEGIN
%1440%				FNFOUND =.FNFOUND OR
%1440%					  CONTFN(.ARGNODE[E2ARREFPTR] );
%1440%				ARGNODE = .ARGNODE[ CLINK ];
%1440%			END;
%1440%			RETURN .FNFOUND;
%1440%		END;	! E2LISTCALL
%1440%
%1440%		TES;
%1440%	END;	!IOLIST-class nodes

%1431%	%(***FOR AN INLINE FN***)%
%1431%	BEGIN
%1431%		IF CONTFN(.CNODE[ARG1PTR]) THEN RETURN TRUE;
%1431%		IF .CNODE[ARG2PTR] NEQ 0
%1431%		THEN RETURN CONTFN(.CNODE[ARG2PTR])
%1431%		ELSE RETURN FALSE;
%1431%	END;

%1431%	%(***FOR SUBSTRING***)%
%1431%	BEGIN
%1431%		IF CONTFN(.CNODE[ARG1PTR]) THEN RETURN TRUE;
%1431%		IF CONTFN(.CNODE[ARG2PTR]) THEN RETURN TRUE;
%1431%		IF CONTFN(.CNODE[ARG4PTR]) THEN RETURN TRUE;
%1431%		RETURN FALSE;
%1431%	END;

%2404%	%(***FOR CONCATENATION***)%
%2404%	BEGIN
%2404%		! CONCATENATION  nodes  do   not  count  as   function
%2404%		! references for the purposes  of this routine,  which
%2404%		! is concerned with possible side effects of  function
%2404%		! references.    These   aren't    a   problem    with
%2404%		! CONCATENATION nodes.
%2404%
%2404%		LOCAL ARGUMENTLIST AG;
%2404%		AG = .CNODE[ARG2PTR];
%2404%
%2404%		INCR I FROM 2 TO .AG[ARGCOUNT]		! Skip first arg
%2404%		DO IF CONTFN(.AG[.I,ARGNPTR])
%2404%		THEN RETURN TRUE;			! Found one
%2404%
%2404%		RETURN FALSE;				! Didn't find any
%2404%	END;

	TES;
END;
GLOBAL ROUTINE UNFLDO(DONODE)=
%(***************************************************************************
	ROUTINE TO CHANGE A DO-LOOP NODE FROM AN AOBJN LOOP TO A NON-AOBJN LOOP.
	THIS ROUTINE CAN ONLY BE CALLED AFTER THE DO-LOOP HAS BEEN EXPANDED BY
	THE SEMANTICS ROUTINE "DOXPN", AND BEFORE REGISTER ALLOCATION HAS BEEN
	PERFORMED FOR THE LOOP (BEFORE THE "COMPLEXITY" PASS.
	IT IS CALLED
		1. IN PHASE 1, WHEN THE LOOP INDEX IS FOUND TO BE REASSIGNED INSIDE THE LOOP
		2. IN PHASE 2 SKELETON, FOR AOBJN LOOPS IN WHICH THE CTL VAL
			IS TO LIVE IN A REGISTER, BUT IS THEN USED IN CONTEXTS THAT
			REQUIRE A WHOLE WORD VALUE (IOLISTS, COMPUTED GOTO)
***************************************************************************)%
BEGIN
	MAP PEXPRNODE DONODE;
	OWN PEXPRNODE CTLCONST;

	IF NOT .DONODE[FLCWD] THEN RETURN;	!IF THIS LOOP ISNT AOBJN, RETURN

	%(***THE CONTROL CONSTANT MUST BE SET TO THE LEFT HALF OF THE AOBJN CONST***)%
	CTLCONST_.DONODE[DOLPCTL];
	DONODE[DOLPCTL]_MAKECNST(INTEGER,0,
				-(ARITHSHIFT(.CTLCONST[CONST2],-18)) );
	DONODE[CTLNEG]_1;
	DONODE[CTLIMMED]_1;
	DONODE[SSIZONE]_1;

	DONODE[FLCWD]_0;
END;
GLOBAL ROUTINE ARGCONE(FNNODE)=
BEGIN
	!EXAMINE THE FUNCTION CALL NODE FNNODE. IF IT IS A 
	!REFERENCE TO A LIBRARY FUNCTION OF 1 ARGUMENT RETURN
	!TRUE ELSE RETURN FALSE.
	!USED IN DEFPT AND COMSUB

	MAP BASE FNNODE;
	REGISTER ARGUMENTLIST AG;

	IF .FNNODE[OPERSP] EQL LIBARY THEN
	BEGIN
		AG_.FNNODE[ARG2PTR];
		IF .AG[ARGCOUNT] EQL 1 THEN
			RETURN(.AG[1,AVALFLG]);
	END;
END;
GLOBAL ROUTINE LASTONE(WD)=
	BEGIN
		!EXAMINE CLOBBREGS TO DETERMINE WHICH REGS NEED TO
		!BE SAVED. FIND THE POSITION OF THE TRAILING ONE.
		!EXAMPLE:
		!	LET USE USE A SIX BIT VALUE OF WD OF 111011.
		!	BITCT INITIALLY BECOMES 3 (BITS NUMBER FROM
		!	LEFT TO RIGHT STARTING AT ZERO.
		!	IN THE UNTIL LOOP, THE FIRST VALUE OF
		!	T1 IS 100000. BITCT THEN BECOMES 4.
		!	THE LOOP TERMINATED SINCE WD^4 = 0. 4
		!	IS THE VALUE RETURNED.
		OWN T1,BITCT,OBIT;
		IF .WD EQL -1 THEN RETURN 13;
		!WD WILL REALLY NEVER BE -1 SINCE A MAX OF
		!13 BITS CAN BE SET IN IT FOR REGS 2-15.
		IF .WD EQL 0 THEN RETURN -1;
		BITCT_FIRSTONE(NOT .WD);
		UNTIL (T1_.WD^.BITCT) EQL 0 DO
		BEGIN
			OBIT_.BITCT;
			BITCT_FIRSTONE(NOT .T1) + .BITCT;
			IF .OBIT EQL .BITCT THEN
				BITCT_.BITCT+1;
		END;
		.BITCT-1
	END;
GLOBAL ROUTINE  KISNGL(X,Y)=
![1006] ROUTINE TO ROUND UP SINGLE PRECISION FROM DOUBLE PRECISION
%[1006]%	BEGIN
%[1006]%		!X IS THE HIGH ORDER KI-10 CNSTANT, Y IS LOW ORDER WORD
%[1006]%		! Use CNSTCM for folding based on /GFLOATING
%[1006]%		C1H_.X;
%[1006]%		C1L_.Y;
%[1006]%		IF .GFLOAT
%[1006]%			THEN COPRIX_KGFRL
%[1006]%			ELSE COPRIX_KDPRL;
%[1006]%		CNSTCM();
%[1006]%		.C2H	! IS RETURNED
%[1006]%	END;

END
ELUDOM