Google
 

Trailing-Edge - PDP-10 Archives - bb-4157j-bm_fortran20_v11_16mt9 - fortran-compiler/doxpn.bli
There are 12 other files named doxpn.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: NORMA ABEL/HPW/JNG/TFV/EGM/CDM/AHM/TJK

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

GLOBAL BIND DOXPNV = #11^24 + 0^18 + #4515;	! Version Date: 20-SEP-85


%(

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

75	-----	-----	FIX ADJGEN TO CORRSPOND TO NEW DIMENSION ENTRY
76	-----	-----	FIX EDIT 75
77	-----	-----	REMOVE CODE THAT KEEPS ARRAY DIMENSIONS ASSOCIATED
			WITH ADJUSTABLE DIMENSIONS ACROSS ENTRIES
78	-----	-----	IN ADJGEN, SET THE "IDLIBFNFLG" IN THE SYMBOL TABLE
			ENTRIES FOR "ADJG." AND "ADJ1." (SO THAT CAN KNOW
			THAT THEY DONT CLOBBER ALL REGS AS OTHER CALLS DO)
79	-----	-----	DO NOT BUILD A REGCONTENTS NODE IN DOXPN
			(CLEVER BUT A BUMMER)

80	-----	-----	CLEAR THE NOALLOC BIT FOR PHASE 1, WHEN GENERATING TEMPORARIES
81	19130	433	IF ALL DO PARAMS KNOWN AT COMPILE TIME AND
			LOOP WILL BE XCT'D NEG OR ZERO TIMES, DO IT ONCE, (JNG)
82	19130	633	FIX 433 TO NOT WIPE OUT A CONSTANT TABLE ENTRY., (JNG)

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

83	761	TFV	1-Mar-80	-----
	Add indices for folding /GFLOATING and remove KA indices

84	772	EGM	5-Jun-80	29516
	Generate fatal error for adjustable dimension variable dimensioned
	after the fact.

88	1143	AHM	13-Nov-81
	More of edit 1136 to make  "data transfer" statements work as well  as
	"device control" statements.  Delete code in IODOXPN that  incremented
	the reference  count  for  labels  used in  END=  and  ERR=  in  "data
	transfer" statements.  BLDKEY now references those labels correctly.

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

85	1204	DCE	25-Nov-80	-----
	Handle F77 DO loops (potential zero trip).  Modify the trip count
	code substantially to separate out F66 and F77.  Use different
	algorithm (F77) for trip count, being careful to preserve correct
	behavior for both F66 and F77.

86	1250	CKS	6-Aug-81
	Modify ADJGEN to call ADJC1. or ADJCG. for character arrays.

87	1413	CDM	4-Nov-81
	Modify ADJGEN to use ARGLSTSIZE when getting core for argument node.

1505	AHM	12-Mar-82
	Have SSIZTMP and INITLTEMP set the psect index of STEs for  DO
	loop temps to  PSDATA and have  ADJGEN set the  ADJxy. STE  to
	PSCODE to relocate those references properly.

1551	AHM	3-Jun-82
	Don't set the psect index of  ADJxy. STEs to PSCODE in  ADJGEN
	since they are only external references.

1670	CKS	10-Nov-82
	Adjustable array dimension bounds can be arbitrary integer expressions,
	not just constants and scalars.  Modify ADJGEN to set AVALFLG correctly
	in the ADJ. arg list.

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

1746	CDM	2-May-83
	Subscript expression nodes for adjustably dimensioned arrays are
	not evaluated for some expressions, so later compiler processing
	finds an expression node  where  it wants a variable.  Create  a
	.Innnn variable to  assign the expression  into, and store  this
	away in the dimension tables.

2002	TJK	23-Sep-83
	Fix evaluation of INT((M2-M1+M3)/M3) in DOXPN for cases in
	which M3 is a constant +1 or -1.  Previously it used
	INT(M2-M1)+1 and 1-INT(M2-M1), which is incorrect when
	-1 < (M2-M1) < 0 (first case) and 0 < (M2-M1) < 1 (second case).
	Changed to INT((M2-M1)+M3) and INT(-((M2-M1)+M3)).

2011	TJK	13-Oct-83
	Have all  non-constant  step  size expressions  be  stored  in
	temporaries.  Previously this was not done for any DATAOPR, so
	if the step size was a variable which changed during execution
	of the loop, the new value  was used for the step (instead  of
	the original value, which is what should be used).

2451	AHM	16-Aug-84
	Modify ADJCALL to only call ADJGEN for arrays that are
	allocated.  This prevents ADJxy.'s arg lists from referencing
	0' and 1'.  ADJx. would Ill Mem Ref when it interpreted byte
	pointers left in 0' by the routine prologue as an address.

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

ENDV11
)%

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

%*****
	TAKE A NUMBER AND MAKE 4 SIXBIT DIGITS OUT OF IT
	USED TO GENERATE TEMPORARY NAMES
*****%

MACRO MAKNAME(NUMB)=
	(.NUMB<9,3>+16)^18 + (.NUMB<6,3>+16)^12 + (.NUMB<3,3>+16)^6
	+ (.NUMB<0,3>+16)$;
FORWARD
!**; [1746] DOXPN, 4056, CDM, 2-May-83
%1746%	DOTIASGN,	! Makes a .Innnn assignment statement for the
%1746%			! expression passed to it.
	INITLTEMP, SSIZTMP;

EXTERNAL
%1746%	CORMAN,		! Core manager
%1746%	BASE CSTMNT,	! Current statement
%4515%	ONEWPTR;	! Returns [1,,pointer] to Sixbit argument
GLOBAL ROUTINE DOXPN(CNODE)=
BEGIN


![761] KARIGB and KGFRL for folding /GFLOATING
%761%	EXTERNAL CORMAN,KARIGB,KARIIB;
	EXTERNAL C1L,C1H,C2L,C2H,TBLSEARCH,CNVNODE;
	EXTERNAL COPRIX,SPKABA,CNSTCM,EXPRTYPER,MAKPR1;
%761%	EXTERNAL KDPRL,KGFRL;
	!CREATE DO LOOP CONTROL EXPRESSION
	!CNODE POINTS TO DO STATEMENT ENCODED SOURCE
	MAP BASE CNODE;
	OWN	DOINITL,					!POINTER TO INITIAL VALUE
	DOULIM,						!POINTER TO UPPER LIMIT
	DOSTEPSIZ,					!POINTER TO STEP SIZE;0 IF STEP SIZE IS 1
	DOSYMBOL,					!POINTER TO INDUCTION VARABLE
	DOCESSOR,					!PREDECESSOR OF DO STATEMENT
	OPEXPR,						!TEMPORARY
	PEXPR;						!TEMPORARY
	OWN SSIZMINUSONEFLG;	!SET THIS FLAG IF STEP SIZE IS MINUS ONE
	OWN BASE T;		!TEMPORARY
	MAP PEXPRNODE DOCESSOR;
	MAP PEXPRNODE DOSYMBOL:DOINITL:DOULIM:DOSTEPSIZ:PEXPR:OPEXPR;

	!MACRO WILL MOVE LABEL ON THE DO STATEMENT ITSELF (IF ANY)
	!BACK TO THE STEP SIZE COMPUTATION OR INITIAL VALUE
	!COMPUTATION IF THESE ARE PRESENT
	MACRO ADJLAB=
		IF .CNODE[SRCLBL] NEQ 0 THEN
		BEGIN
			LOCAL BASE TMP;
			OPEXPR[SRCLBL]_.CNODE[SRCLBL];
			CNODE[SRCLBL]_0;
			TMP_.OPEXPR[SRCLBL];
			TMP[SNHDR]_.OPEXPR;
		END$;

	DOSYMBOL_.CNODE[DOSYM];
	!SET SYMBOL TABLE BIT TO INDICATE THIS VARIABLE IS
	!STORED INTO IN CASE IT IS AN ARGUMENT THAT NEEDS
	!STORING BACK
	DOSYMBOL[IDATTRIBUT(STORD)]_1;
	DOINITL_.CNODE[DOM1];
	DOULIM_.CNODE[DOM2];
	DOSTEPSIZ_.CNODE[DOM3];
	DOCESSOR_.CNODE[DOPRED];
	CNODE[NEDSMATRLZ]_1;		!SET BIT OPTIMIZER WILL RESET


	!IF EITHER OF THE LIMITS OR THE STEP SIZE IS A NEGATIVE OF A CONSTANT,
	! FOLD THAT NEGATION HERE SO THAT THE GENERATED CODE FOR
	!       DO 10 I=10,1,-1
	! WILL NOT TREAT THE -1 AS AN ARBITRARY EXPRESSION(SRM-FEB 9,1973)
	IF .DOINITL[OPR1] EQL NEGFL
	THEN
	BEGIN
		T_.DOINITL[ARG2PTR];	!ARG UNDER THE NEG
		IF .T[OPR1] EQL CONSTFL THEN DOINITL_NEGCNST(T);
	END;
	IF .DOULIM[OPR1] EQL NEGFL
	THEN
	BEGIN
		T_.DOULIM[ARG2PTR];	!ARG UNDER THE NEG
		IF .T[OPR1] EQL CONSTFL THEN DOULIM_NEGCNST(T);
	END;
	IF .DOSTEPSIZ[OPR1] EQL NEGFL
	THEN
	BEGIN
		T_.DOSTEPSIZ[ARG2PTR];	!ARG UNDER THE NEG
		IF .T[OPR1] EQL CONSTFL THEN DOSTEPSIZ_NEGCNST(T);
	END;


	!IF EITHER OF THE LIMITS OR THE STEP SIZE HAS A DIFFERENT VAL-TYPE FROM
	! THE INDUCTION VARIABLE, MUST PERFORM TYPE CONVERSION (SRM-OCT 6,1972)
	IF .DOINITL[VALTP2] NEQ .DOSYMBOL[VALTP2] THEN DOINITL_CNVNODE(.DOINITL,.DOSYMBOL[VALTYPE],0);
	IF .DOULIM[VALTP2] NEQ .DOSYMBOL[VALTP2] THEN DOULIM_CNVNODE(.DOULIM,.DOSYMBOL[VALTYPE],0);
	IF .DOSTEPSIZ[VALTP2] NEQ .DOSYMBOL[VALTP2] THEN DOSTEPSIZ_CNVNODE(.DOSTEPSIZ,.DOSYMBOL[VALTYPE],0);




	IF .DOSYMBOL[VALTP1] NEQ INTEG1
	THEN
		 CNODE[REALARITH]_1;


	!LOOK AT THE STEP SIZE


	SSIZMINUSONEFLG_FALSE;		!FLAG FOR STEP SIZE = -1, INIT TO FALSE

	IF .DOSTEPSIZ[OPR1] EQL CONSTFL THEN
	BEGIN
		!CHECK FOR STEP SIZES ONE AND MINUS ONE
		IF .DOSTEPSIZ[VALTYPE] EQL REAL THEN
		BEGIN
			%(***FOR REALS- MUST ROUND FROM 2 WDS OF PREC TO ONE BEFORE
				EXAMINING THE VALUE (KEEP THEM AS UNROUNDED 2 WD VALS
				INSIDE THE COMPILER) ***)%
			C1H_.DOSTEPSIZ[CONST1];	!SET GLOBALS FOR THE ASSEMBLY LANG
			C1L_.DOSTEPSIZ[CONST2];		! THAT ROUNDS THE CONST
![761] Choose index for folding based on /GFLOATING
%761%			IF .GFLOAT
%761%				THEN COPRIX_KGFRL
%761%				ELSE COPRIX_KDPRL;

			CNSTCM();			!ROUND - LEAVE RESULT IN C2H

			IF .C2H EQL #201400000000 THEN
				CNODE[SSIZONE]_1
			ELSE IF .C2H EQL #576400000000
			THEN
				SSIZMINUSONEFLG_TRUE
		END ELSE
		IF .DOSTEPSIZ[VALTP1] EQL INTEG1 THEN
		BEGIN
			IF .DOSTEPSIZ[CONST2] EQL 1 THEN
				CNODE[SSIZONE]_1
			ELSE IF .DOSTEPSIZ[CONST2] EQL -1 THEN
				SSIZMINUSONEFLG_TRUE
		END
		ELSE
		%(***FOR DOUBLE PRECISION AND COMPLEX - DONT BOTHER OPTIMIZING THE -1 CASE***)%
		BEGIN
			IF .DOSTEPSIZ[CONST1] EQL #201400000000 AND .DOSTEPSIZ[CONST2] EQL 0
			THEN CNODE[SSIZONE]_1
		END;

	END
%2011%	ELSE	! Step size is not a constant
%2011%	BEGIN
%2011%		! Step size must  be stored in  a temporary.  Make  an
%2011%		! assignment statement for it and  put it in front  of
%2011%		! the DO statement.
%2011%
		NAME<LEFT>_ASGNSIZ+SRCSIZ;
		OPEXPR_CORMAN();
		!LINK IT IN
		DOCESSOR[SRCLINK]_.OPEXPR;
		OPEXPR[SRCLINK]_.CNODE;
		!SET VAL FLG IN STATEMENT NODE
		OPEXPR[A1VALFLG]_1;
		OPEXPR[OPRCLS]_STATEMENT;
		OPEXPR[SRCID]_ASGNID;
		OPEXPR[LHEXP]_SSIZTMP(.DOSTEPSIZ[VALTYPE]);
		OPEXPR[RHEXP]_.DOSTEPSIZ;

%2011%		IF .DOSTEPSIZ[OPRCLS] EQL DATAOPR	! Is step a variable?
%2011%		THEN OPEXPR[A2VALFLG] = 1		! Yes, set val flag
%2011%		ELSE DOSTEPSIZ[PARENT] = .OPEXPR;	! No, set parent field

		!FIX FIELDS IN DO STATMENT NODE
		CNODE[DOPRED]_.OPEXPR;
		!FIX LOCALS
		DOCESSOR_.OPEXPR;
		DOSTEPSIZ_.OPEXPR[LHEXP];
		!SET FLAG
		CNODE[SSIZINTMP]_1;
		!MOVE THE LABEL BACK
		ADJLAB;
	END;


		CNODE[DOSSIZE]_.DOSTEPSIZ;
		CNODE[DOCTLVAR]_SSIZTMP(INTEGER);






	PEXPR_0;

	%(***SET "PEXPR" TO POINT TO AN EXPRESSION NODE FOR "M2-M1"
		THIS WILL BE USED IN THE COMPUTATION OF THE LOOP ITERATION CT***)%
	IF .DOULIM[OPR1] EQL CONSTFL AND .DOINITL[OPR1] EQL CONSTFL THEN
	BEGIN
		COPRIX_KKARITHOP(.DOINITL[VALTP1],SUBOP);
		C1H_.DOULIM[CONST1];
		C1L_.DOULIM[CONST2];
		C2H_.DOINITL[CONST1];
		C2L_.DOINITL[CONST2];
		CNSTCM();
		PEXPR_MAKECNST(.DOINITL[VALTYPE],.C2H,.C2L);
	END

	ELSE
	!IF NOT BOTH CONSTANTS, BUILD EXPRESSION
	BEGIN
		!BUILD AN EXPRESSION NODE
		!CHECK THE PROPERTIES OF THE INITIAL VALUE
		!BAD RESULTS (IN CODE) IF IT IS A CONSTANT EXPRESSION
		!AS WE WILL NOT FOLD IT HERE

		!IF INITIAL VAL IS AN EXPRESSION, BUILD AN ASSIGNMENT
		!STMNT TO A TEMPORARY FOR THAT EXPRESSION
		!INSERT THAT ASSIGNMENT STMNT BEFORE THE DO STMNT
		IF .DOINITL[OPRCLS] NEQ DATAOPR THEN
		BEGIN
			CNODE[INITLTMP]_1;	!SET FLAG
			!MAKE AN ASSIGNMENT STATEMENT FOR IT
			!OPEXPR IS USED AS A TEMPORARY
			NAME<LEFT>_ASGNSIZ+SRCSIZ;
			OPEXPR_CORMAN();
			!LINK IT IN FRONT OF THE DO STATEMENT
			DOCESSOR[SRCLINK]_.OPEXPR;
			OPEXPR[SRCLINK]_.CNODE;
			!SET APPROPRIATE FLAGS
			OPEXPR[A1VALFLG]_1;		!THE TEMP
			OPEXPR[OPRCLS]_STATEMENT;
			OPEXPR[SRCID]_ASGNID;
							!GENERATE TEMPORARY
							!FOR INITIAL
							!VALUE
			OPEXPR[LHEXP]_INITLTEMP(.DOINITL[VALTYPE]);
			OPEXPR[RHEXP]_.DOINITL;
			DOINITL[PARENT]_.OPEXPR;
			!RESET DOPRED  IN THE DO STATEMENT
			CNODE[DOPRED]_.OPEXPR;
			!RESET MY LOCALS FOR THE RIGHT THING
			DOINITL_.OPEXPR[LHEXP];
			DOCESSOR_.OPEXPR;
			!MOVE THE LABEL BACK IF THERE IS ONE
			ADJLAB;
		END;


		%(***MAKE EXPRESSION NODE FOR FINAL VALUE(POSSIBLY AN EXPRESSION)
			MINUS INITIAL VALUE (ALWAYS EITHER A DATAOPR OR THE REGCONTENTS
			NODE JUST BUILT) ****)%
		PEXPR_MAKPR1(.CNODE,ARITHMETIC,SUBOP,.DOULIM[VALTYPE],.DOULIM,.DOINITL);

		PEXPR[A2VALFLG]_1;	!ARG2 OF THE SUBTRACT IS EITHER A DATAOPR OR A REGCONTENTS
					! HENCE SHOULD ALWAYS HAVE VALFLG SET ABOVE IT
		OPEXPR_.PEXPR[ARG1PTR];	!IF ARG1 IS A DATAOPR, SET THE VALFLG ABOVE IT

		PEXPR[A1VALFLG]_.OPEXPR[OPRCLS] EQL DATAOPR;
	END;

!**;[1204], DOXPN @3455, DCE, 25-Nov-80
!**;[1204], Modify the calculation of the loop control expression to conform
!**;[1204], to the F77 standard.  Preserve the F66 behavior under switch control.

%[1204]%	!NOW MAKE THE LOOP CONTROL EXPRESSION
%[1204]%
%[1204]%	! We have computed the expression M2-M1.  Using this and the stepsize M3,
%[1204]%	! it is time to create the loop control expression.  We try for a
%[1204]%	! constant expression first; if not possible, then build the loop
%[1204]%	! control expression by hand to be: (M2-M1+M3)/M3.  Observe that
%[1204]%	! one tries to be clever with M3 if it is +1 or -1.
%[1204]%
%[1204]%	IF .PEXPR[OPR1] EQL CONSTFL AND .DOSTEPSIZ[OPR1] EQL CONSTFL
%[1204]%	THEN	! Everyting in sight is a constant (wonderful!)
%[1204]%	BEGIN
%2002%			COPRIX_KKARITHOP(.PEXPR[VALTP1],ADDOP);
%2002%			C1H_.PEXPR[CONST1];
%2002%			C1L_.PEXPR[CONST2];
%2002%			C2H_.DOSTEPSIZ[CONST1];
%2002%			C2L_.DOSTEPSIZ[CONST2];
%2002%			CNSTCM();
%2002%			PEXPR_MAKECNST(.PEXPR[VALTYPE],.C2H,.C2L); ! M2-M1+M3
%2002%
%2002%			IF .SSIZMINUSONEFLG THEN
%2002%				PEXPR_NEGCNST(PEXPR)	! -(M2-M1+M3)
%2002%			ELSE IF NOT .CNODE[SSIZONE] THEN
%2002%			BEGIN
%[1204]%			! Now divide by the stepsize M3
%[1204]%
%[1204]%			COPRIX_KKARITHOP(.PEXPR[VALTP1],DIVOP);
%[1204]%			C1H_.PEXPR[CONST1];
%[1204]%			C1L_.PEXPR[CONST2];
%[1204]%			C2H_.DOSTEPSIZ[CONST1];
%[1204]%			C2L_.DOSTEPSIZ[CONST2];
%[1204]%			CNSTCM();
%[1204]%			PEXPR_MAKECNST(.PEXPR[VALTYPE],.C2H,.C2L); ! (M2-M1+M3)/M3
%[1204]%		END;
%[1204]%
%[1204]%		! We are done with computing the loop trip count.  We need
%[1204]%		! to put on the finishing touches - convert to integer type,
%[1204]%		! and check for zero trip cases both F66 and F77.
%[1204]%
%[1204]%		IF .PEXPR[VALTYPE] NEQ INTEGER
%[1204]%			THEN PEXPR_CNVNODE(.PEXPR,INTEGER,0);
%[1204]%
%[1204]%		IF .PEXPR[CONST2] LEQ 0 THEN
%[1204]%			IF F77 THEN
%[1204]%			BEGIN
%[1204]%				PEXPR_MAKECNST(INTEGER,0,0);
%[1204]%				CNODE[MAYBEZTRIP]_1
%[1204]%			END
%[1204]%			ELSE PEXPR_MAKECNST(INTEGER,0,1); ! For F66, 1 trip loop
%[1204]%	END	! Of case where everything is a constant
%[1204]%	ELSE	! Either M2-M1 is non-constant or M3 is non-constant.
%[1204]%		! We need to build an expression (sigh).
%[1204]%	BEGIN
%[1204]%		CNODE[MAYBEZTRIP]_1;
%2002%			PEXPR_MAKPR1(.CNODE,ARITHMETIC,ADDOP,.PEXPR[VALTYPE],
%2002%					.PEXPR,.DOSTEPSIZ); ! M2-M1+M3
%2002%			IF .SSIZMINUSONEFLG THEN
%2002%				PEXPR_MAKPR1(.CNODE,NEGNOT,NEGOP,.PEXPR[VALTYPE]
%2002%						,0,.PEXPR)  ! -(M2-M1+M3)
%2002%			ELSE IF NOT .CNODE[SSIZONE] THEN
%2002%				PEXPR_MAKPR1(.CNODE,ARITHMETIC,DIVOP,.PEXPR[VALTYPE],
%2002%						.PEXPR,.DOSTEPSIZ); ! (M2-M1+M3)/M3
%[1204]%
%[1204]%		IF .PEXPR[VALTYPE] NEQ INTEGER
%[1204]%			THEN PEXPR_CNVNODE(.PEXPR,INTEGER,0);
%[1204]%	END;	! Of case where there is a non-constant



!IF LOOP CAN BE HANDLED WITH AN AOBJN, MAKE LOOP CONTROL CONSTANT
IF .PEXPR[OPR1] EQL CONSTFL		!NUMBER OF ITERATIONS A COMPILE TIME CONSTANT
	 AND NOT .CNODE[REALARITH]	! LOOP INDEX MUST BE INTEGER 
	 AND .CNODE[SSIZONE]		!STEP SIZE MUST BE ONE
	AND .DOINITL[CONST2] LEQ #377777	!LOWER BOUND ON INDEX MUST BE LESS THAN 17 BITS
	AND .DOINITL[CONST2] GEQ 0		! AND MUST BE POSITIVE
	AND .DOULIM[CONST2] LEQ #377777		!UPPER BOUND ON INDEX MUST BE LESS THAN 17 BITS
	AND .DOULIM[CONST2] GEQ 0		! AND MUST BE POSITIVE
THEN
BEGIN
	PEXPR_MAKECNST(INTEGER,0,-.PEXPR[CONST2]^18+.DOINITL[CONST2]);
	CNODE[SSIZONE]_0;		!RESET ALL OTHER FLAGS
	CNODE[FLCWD]_1;
END ELSE
	!SET SOME OTHER FLAGS DESCRIBING THE CONTROL WORD (IF ITS CONSTANT)
	IF .PEXPR[OPR1] EQL CONSTFL THEN
	BEGIN
		%(***IF THE NUMBER OF TIMES THAT THE LOOP IS TO BE EXECUTED IS A POS
			NUMBER THAT CAN BE USED IMMEDIATE MODE, DO SO. FOR A NEG
			ITERATION COUNT, DONT BOTHER. (NOTE THAT CAN COUNT ON THE CT BEING 
			AN INTEGER***)%
		IF .PEXPR[CONST2] LEQ #777777
		THEN
			CNODE[CTLIMMED]_1;
		CNODE[CTLNEG]_1;
	END ELSE
		IF .PEXPR[OPRCLS] EQL DATAOPR THEN
			CNODE[CTLNEG]_1
		ELSE
	!INSERT THE NEGATE NODE NEEDED
	PEXPR_MAKPR1(.CNODE,NEGNOT,NEGOP,INTEGER,0,.PEXPR);




CNODE[DOLPCTL]_.PEXPR;
CNODE[DOM1]_.DOINITL;		!INITIAL VALUE FOR LOOP INDEX
END;

EXTERNAL
	SSIZTC,			!COUNTER FOR STEP SIZE TEMPS
				!GENERATED FOR DO LOOPS
	INTLTC;			!COUNTER FOR TEMPS GENERATED
				!FOR DO LOOP INITIAL VALUES
%*****
	NOTE THAT THE NAMES WILL NOT BE UNIQUE OR VALID IF THERE
	ARE MORE THAN 9999 FOR EACH
*****%
GLOBAL ROUTINE SSIZTMP(SSIZ)=
BEGIN
EXTERNAL TBLSEARCH;

! Create a step size temporary for DO loops

REGISTER BASE STPTMP;

	NAME_IDTAB;
%4515%	ENTRY[0] = ONEWPTR(SIXBIT'.S'+MAKNAME(SSIZTC));
	SSIZTC_.SSIZTC+1;
	STPTMP_TBLSEARCH();		! Look up the name
	STPTMP[VALTYPE]_.SSIZ;		! Set the value type of the variable
	STPTMP[IDATTRIBUT(NOALLOC)]_0;	! Clear NOALLOC bit for phase 1
%1505%	STPTMP[IDPSECT] = PSDATA;	! Put it in .DATA.
	RETURN .STPTMP
END;
GLOBAL ROUTINE INITLTEMP(IVAL)=
BEGIN
EXTERNAL TBLSEARCH;

! Make an initial value temporary

REGISTER BASE ITLTMP;

	NAME = IDTAB;
%4515%	ENTRY[0] = ONEWPTR(SIXBIT'.I'+MAKNAME(INTLTC));
	INTLTC = .INTLTC+1;
	ITLTMP = TBLSEARCH();
	ITLTMP[VALTYPE] = .IVAL;	! IVAL is the initial value type
	ITLTMP[IDATTRIBUT(NOALLOC)] = 0;	! Clear NOALLOC bit for phase 1
%1505%	ITLTMP[IDPSECT] = PSDATA;	! Put it in .DATA.
	RETURN .ITLTMP
END;
GLOBAL ROUTINE IODOXPN(IOSTMNT)=
%(***************************************************************************
	ROUTINE TO WALK THRU AN IOLIST AND PERFORM DOXPN ON ALL IMPLICIT
	DO STMNT NODES. SETS THE "DOPRED" FIELD OF EACH DO STMNT NODE
	BEFORE CALLING DOXPN.
	CALLED WITH A PTR TO THE IO STMNT FOR WHICH THE IOLIST IS TO BE
	PROCESSED.
***************************************************************************)%
BEGIN
	EXTERNAL CORMAN;
	MAP BASE IOSTMNT;
	OWN PEXPRNODE IOLPTR;
	OWN PEXPRNODE PRVELEM;	!PTR TO THE ELEMENT IN THE IOLIST PRECEEDING
					! THE ELEMENT POINTED TO BY IOLPTR


![1143]	The following  code used  to  increment the  reference counts  of  the
![1143]	labels used after ERR=  or END= in  "data transfer" statments  because
![1143]	the labels were lexically  parsed as integer  constants and never  had
![1143]	their counts bumped by one.  Edit 760 made the front end routines  for
![1143]	"data transfer" and "device control" statements use the routine LABREF
![1143]	which incremented  the count  correctly.  Unfortunately,  IODOXPN  was
![1143]	still  incrementing  the  counts,  so   code  written  for  edit   760
![1143]	decremented the counts to even things  out.  This made the counts  for
![1143]	labels referenced  by "device  control" statements  incorrect  because
![1143]	they don't  go  through  here,  so edit  1136  removed  the  decrement
![1143]	inserted in edit 760.  At this  point, labels used by "data  transfer"
![1143]	statements were wrong because they were still being incremented  here.
![1143]	So the final solution is to get rid of this code entirely.

![1143]	!PHASE ONE IS NOT COUNTING END=,ERR= LABEL REFERENCES
![1143]	!SO WE WILL COUNT THEM NOW
![1143]	IF (IOLPTR_.IOSTMNT[IOEND]) NEQ 0 THEN
![1143]		IOLPTR[SNREFNO]_.IOLPTR[SNREFNO]+1;
![1143]
![1143]	IF (IOLPTR_.IOSTMNT[IOERR]) NEQ 0 THEN
![1143]		IOLPTR[SNREFNO]_.IOLPTR[SNREFNO]+1;

	IF (IOLPTR_.IOSTMNT[IOLIST]) EQL 0
	THEN RETURN;		!IF STMNT HAS NO IOLIST

	%(***IF THE FIRST ELEMENT IN THE IOLIST IS A DO-STMNT, INSERT A 
		CONTINUE STMNT IN FRONT OF IT FOR THE "DOPRED" FIELD
		OF THE DO STMNT TO POINT BACK TO***)%
	IF .IOLPTR[OPERATOR] EQL DOSTATEMENT
	THEN
	BEGIN
		NAME_CONTDATA;
		PRVELEM_CORMAN();
		PRVELEM[OPERATOR]_CONTSTATEMENT;
		PRVELEM[CLINK]_.IOLPTR;
		IOSTMNT[IOLIST]_.PRVELEM;
	END;


	%(***WALK THRU SUCCESSIVE ELEMS OF THE IOLIST. SET THE "DOPRED" FIELD
		OF EACH DO-STMNT NODE TO PT TO THE NODE PRECEEDING IT. CALL
		DOXPN FOR EACH DO STMNT NODE***)%
	%(** IF HAVE AN EXPRESSION NODE UNDER A DATACALL, FILL
		IN THE PARENT POINTER)%
	UNTIL .IOLPTR EQL 0
	DO
	BEGIN
		IF .IOLPTR[OPERATOR] EQL DOSTATEMENT
		THEN
		BEGIN
			IOLPTR[DOPRED]_.PRVELEM;
			DOXPN(.IOLPTR);
		END
		ELSE
		IF .IOLPTR[OPERATOR] EQL DATACLFL
		THEN
		BEGIN
			OWN PEXPRNODE T;
			T _ .IOLPTR[DCALLELEM];

			IF .T NEQ 0		!IF THERE WAS AN ERROR FOUND WHEN
						! PROCESSING THIS DATA ELEMNT (EG
						! AN ILLEGAL ARRAYREF)
			THEN
			BEGIN
				IF .T[OPRCLS] NEQ DATAOPR
				THEN
				T[PARENT] _ .IOLPTR
			END;
		END;

		%(***GO ON TO THE NEXT ELEMENT***)%
		PRVELEM_.IOLPTR;
		IOLPTR_.IOLPTR[CLINK];
	END;
END;
FORWARD ALLONES;
ROUTINE ADJGEN(DTABB,ARY)=
BEGIN
	!GENERATE ACTUAL FN(CALL STATEMENT)
	!NODE FOR CALL TO RUN-TIME
	!ROUTINES FOR ADJUSTABLE DIMENSIONS

	LABEL ARGDO;
%1413%	LOCAL ARGNUM;		!Number of arguments for call to ADJ*
	OWN BASE CALNODE;
	EXTERNAL BASE CSTMNT,CORMAN,ONEPLIT;
	EXTERNAL TBLSEARCH;
	MAP BASE DTABB: ARY;
	OWN BASE G:ROUT:DNUM:J;
	OWN DIMSUBENTRY DSUBETRY;
	OWN ARGUMENTLIST CLNODLST;

	BTTMSTFNFLG_FALSE;	!IF INSERT A CALL TO ADJUST, THIS ROUTINE IS NO LONGER "BOTTOMMOST"

	NAME<LEFT>_CALLSIZ+SRCSIZ;
	CALNODE_CORMAN();
	CALNODE[SRCLINK]_.CSTMNT[SRCLINK];
	CSTMNT[SRCLINK]_.CALNODE;
	CALNODE[OPRCLS]_STATEMENT;
	CALNODE[SRCID]_CALLID;
	G_ALLONES(.DTABB);

	!THE SPECIAL PURPOSE ROUTINE FOR ALL LOWER BOUND OF
	!ONE WILL BE CALLED ONLY IF IT IS ALSO TRUE THAT
	!ALL DIMENSIONS ARE ADJUSTABLE. WE NOW DETERMINE THAT FACT
	!BY SEEING IF THE SECOND ONE IS ADJUSTABLE. THE
	!FIRST ONE ALWAYS HAS A FACTOR OF ONE .

%[1250]	***** REMOVE, SEE WHAT BREAKS *****
	IF .DTABB[DIMNUM] GTR 1 THEN
	BEGIN
		DSUBETRY_DTABB[FIRSTDIM]+DIMSUBSIZE;	!SECOND ONE
		IF NOT .DSUBETRY[VARFACTFLG] THEN G_0;
	END;
[1250]%

%1250%	IF .ARY[VALTYPE] NEQ CHARACTER
%1250%	THEN
		IF .G
		THEN ENTRY _ SIXBIT'ADJ1. '
		ELSE ENTRY _ SIXBIT'ADJG. '
%1250%	ELSE
%1250%		IF .G
%1250%		THEN ENTRY _ SIXBIT'ADJC1.'
%1250%		ELSE ENTRY _ SIXBIT'ADJCG.';

%4515%	ENTRY = ONEWPTR(.ENTRY);	! [count,,pointer]

	NAME_IDTAB;
	ROUT_TBLSEARCH();
	!FILL IN THE POINTER TO THE FUNCTION NAME
	CALNODE[CALSYM]_.ROUT;
	IF NOT .FLAG		! If we have just created a new STE
	THEN
	BEGIN
		ROUT[OPERSP]_FNNAME;
		ROUT[IDLIBFNFLG]_1
	END;
	DNUM_.DTABB[DIMNUM];

	!COMPOSE THE ARGUMENT LIST FOR A CALL TO
	!ADJ1.OR ADJG.
%1250%	!OR ADJC1. OR ADJCG.

	!First get the core for the list
%1413%	ARGNUM _ (3-.G)*(.DNUM)+4;	!Number of arguments
%1413%	NAME<LEFT> _ ARGLSTSIZE(.ARGNUM);

	!FOR EACH DIMENSION
	!ONE WORD FOR U(I)			!MAYBE ONE FDR L(I)
	!ONE WORD FOR MULT(I)
	!=(2 OR 3)*DNUM
	!+
	!ONE WORD FOR OFFSET
	!+
	!ONE WORD FOR NUMBER OF DIMENSIONS
	!+
	!WORD THAT CONTAINS NUMBER OF PARAMETERS
	!+
	!ZERO HEADER WORD (FILLED IN IN CODE
	!GENERATION WITH LABEL FOR GENERATED
	!ARG LIST)
	!+
	!WORD FOR ARRAY SIZE
	!+
	!WORD FOR BASE ADDRESS OF ARRAY

	CLNODLST _ CALNODE[CALLIST] _ CORMAN();
	!FILL IN ARG LIST
	!First the number of arguments

%1413%	CLNODLST[ARGCOUNT] _ .ARGNUM;

	!NOW FILL IN THE ARGUMENT LIST.
	!J POINTS TO ARG ENTRY WHILE THE INCR LOOP
	!GOES THROUGH ALL DIMENSIONS
	!THE FIRST ARGUMENT WE WILL FIRST FILL IN IS UB(1)
	!WHUCH IS THE FOURTH ARGUMENT,THUS J=4.
	!THEN MULT(2) WHICH IS THE DIMFACTOR FROM THE
	!DIMENSION SUBENTRY AFTER THE ONE CONTAINING UB(1).
	J_6;
	DSUBETRY_DTABB[FIRSTDIM];
	!IN ORDER FOR THE LOOP TO OPERATE CORRECTLY, WE ARE
	!NOT DOING WHAT IT APPEARS WE ARE DOING. WE WILL
	!FILL IN MULT(1), UB(1),.....MULT(N),UB(N) AND
	!THEN SINCE MULT(1) IS SPECIAL REALLY FILL IT IT LATER
	!ROUT WILL BE USED AS A TEMP TO
	!HELP US SAVE THE RIGHT THING TO PUT INTO MULT(1)
	!LATER.
	!A DOUBLE PRECISION OR COMPLEX ARRAY STARTS OUT AT TWO
%1250%	!A CHARACTER ARRAY USES A .I TEMP FOR MULT(1).  IT'S FILLED IN
%1250%	!AT RUNTIME BY ADJC.
%1250%	IF .ARY[VALTYPE] EQL CHARACTER
%1250%	THEN ROUT _ .DSUBETRY[DIMFACTOR]
	ELSE IF .ARY[DBLFLG] 
	     THEN ROUT_MAKECNST(INTEGER,0,2)
	     ELSE ROUT_.ONEPLIT;

	ARGDO:
	INCR I FROM 1 TO .DNUM DO
	BEGIN
			!HOLE FOR PARTIALLY CONSTANT ONES
%1670%			LOCAL PEXPRNODE E;
!**; [1746] ADJGEN, 4697, CDM, 2-May-83
%1746%			E = .DSUBETRY[DIMUB];		! upper bound dismens
%1746%			CLNODLST[.J,AVALFLG] = 1;
%1746%			! Either assign  dimension  espression,  or  the
%1746%			! .Innnn that expression is assigned into.
%1670%			IF .E[OPRCLS] EQL DATAOPR
%1746%			THEN	CLNODLST[.J,ARGNPTR] = .E	! Expr given
%1746%			ELSE	CLNODLST[.J,ARGNPTR] =		! make .Innnn
%1746%					DSUBETRY[DIMUB] = DOTIASGN(.E);
			IF NOT .G THEN
			BEGIN
			!ALL LOWER BOUNDS ARE NOT 1
				J_.J+1;
!**; [1746] ADJGEN, 4705, CDM, 2-May-83
%1746%				E = .DSUBETRY[DIMLB];	! Lower bound dimens
%1746%				CLNODLST[.J,AVALFLG] = 1;
%1746%				! Either assign dimension espression, or the
%1746%				! .Innnn that expression is assigned into.
%1670%				IF .E[OPRCLS] EQL DATAOPR
%1746%				THEN	CLNODLST[.J,ARGNPTR] = .E  ! As is
%1746%				ELSE	CLNODLST[.J,ARGNPTR] =     ! .Innnn
%1746%						DSUBETRY[DIMLB] =
%1746%						DOTIASGN(.E);
			END;
			!DONT PUT OUT FACTOR FOR LAST ONE
			IF .I EQL .DNUM THEN LEAVE ARGDO;
			DSUBETRY_.DSUBETRY+DIMSUBSIZE;
			J_.J+1;
			CLNODLST[.J,ARGNPTR]_.DSUBETRY[DIMFACTOR];
			CLNODLST[.J,AVALFLG]_1;
			J_.J+1;
	END;							!INCR LOOP

	!FILL IN ARGUMENT 1, THE NUMBER
	!OF DIMENSIONS
	
	CLNODLST[1,ARGNPTR]_MAKECNST(INTEGER,0,.DNUM);
	CLNODLST[1,AVALFLG]_1;
	!FILL IN ARRAY SIZE
	CLNODLST[2,ARGNPTR]_.DTABB[ARASIZ];
	CLNODLST[2,AVALFLG]_1;
	!FILL IN ARGUMENT 2, BASE ADDRESS OF ARRAY
	CLNODLST[3,ARGNPTR]_.ARY;
	CLNODLST[3,AVALFLG]_1;
	!FILL IN ARGUMENT 4, THE ARRAY OFFSET
	CLNODLST[4,ARGNPTR]_.DTABB[ARAOFFSET];
	CLNODLST[4,AVALFLG]_1;
	!FILL IN MULT(1)
	CLNODLST[5,ARGNPTR]_.ROUT;
	CLNODLST[5,AVALFLG]_1;

END;	! of ADJGEN
!**; [1746], add routine after ADJGEN, 4737, CDM, 2-May-83
ROUTINE DOTIASGN(EXPR)=	![1746] NEW
BEGIN
	! Make an assignment statement
	! 	.Innnn = expr
	! Inserts created assignment node after CSTMNT.

	! Returns: symbol table entry for .Innnn created.

	REGISTER
		BASE ASGN,	! Assignment statement created
		BASE DOTI;	! .Innnn variable

	MAP	BASE EXPR;	! Expression assigned to .Innnn


	NAME<LEFT> = ASGNSIZ + SRCSIZ;
	ASGN = CORMAN();	! Get node for assignment

	EXPR[PARENT] = .ASGN;	! Parent pointer of expression

	ASGN[OPRS] = ASGNOS;	! Operator fields
	ASGN[LHEXP] = DOTI = INITLTEMP(.EXPR[VALTYPE]);	! LH expression (.I)
	ASGN[RHEXP] = .EXPR;	! RH expression (expression in stmnt)
	ASGN[A1VALFLG] = 1;	! LH expression is a leaf.

	ASGN[SRCLINK] = .CSTMNT[SRCLINK];	! Link into statements
	CSTMNT[SRCLINK] = .ASGN;

	RETURN .DOTI;		! Return .Innnn variable of the statement

END;	! of DOTIASGN
ROUTINE ALLONES(DTABB)=

BEGIN
	!LOOK THROUGH DIMENSION TABLE ENTRY
	!TO SEE IF ALL LOWER BOUNDS ARE 1.
	!RETURN 1 (TRUE) IF THEY ARE AND
	!0 (FALSE) IF NOT
	EXTERNAL ONEPLIT;
	OWN DNUM,DSUBETRY;
	MAP PEXPRNODE DTABB;
	MAP DIMSUBENTRY DSUBETRY;
	DNUM_.DTABB[DIMNUM];
	DSUBETRY_DTABB[FIRSTDIM];			!POINT TO FIRST SUBENTRY
	INCR I FROM 1 TO .DNUM DO
	BEGIN
		IF .DSUBETRY[DIMLB] NEQ .ONEPLIT
		THEN
		RETURN(0)
		ELSE
		DSUBETRY_.DSUBETRY+DIMSUBSIZE;
	END;
	RETURN 1
END;
GLOBAL ROUTINE ADJCALL=
BEGIN
	!INSERT CALL STATEMENT NODES FOR ADJUSTABLY DIMENSIONED
	!ARRAYS TO CALL THE OBJECT TIME ROUTINES
	!ADJ1. OR ADJG. TO COMPUTE FACTORS AND OFFSET
	EXTERNAL CSTMNT,CHOSEN,ENTRY,NAME,CORMAN;
	EXTERNAL VERYFRST,QQ;
	OWN DTABB,CLST,CALNODE,CLNODLST,G,CLSTARG;
	MAP ARGUMENTLIST CLNODLST:CLST;
	MAP BASE CSTMNT:DTABB:CLSTARG;
%772%	EXTERNAL FATLERR,E126;
%772%	OWN DIMSUBENTRY DSUBETRY;
%772%	MAP BASE G;	! SYMBOL TEMP FOR ADJCAL

	VERYFRST_0;
	CSTMNT_.SORCPTR<LEFT>;
	WHILE .CSTMNT NEQ 0 DO
	BEGIN
		!IF ITS AN ENTRY
		IF .CSTMNT[SRCID] EQL ENTRID THEN
		!IF THERE ARE PARAMETERS
		IF .CSTMNT[CALLIST] NEQ 0 THEN
		BEGIN
			CLST_.CSTMNT[CALLIST];
			INCR I FROM 1 TO .CLST[ARGCOUNT] DO
			BEGIN
				CLSTARG_.CLST[.I,ARGNPTR];
				!IF AN ARRAY LOOK TO SEE
				!IF IT IS ADJUSTABLE

				IF .CLSTARG[OPR1] EQL
				OPR1C(DATAOPR,FORMLARRAY)
				THEN
				BEGIN
					DTABB_.CLSTARG[IDDIM];
					!LOOK TO SEE IF IT IS
					!ADJUSTABLY DIMENSIONED
![772] If this is indeed a variable DIMENSIONed array, generate the
![772] run-time call, and check the dimension information one last
![772] time to catch the case where a variable dimension subscript
![772] variable has later been DIMENSIONed itself.
%772%					IF .DTABB[ADJDIMFLG]
%772%					THEN
%772%					BEGIN
%2451%						IF NOT .CLSTARG[IDATTRIBUT(NOALLOC)]
%2451%						THEN ADJGEN(.DTABB,.CLSTARG);

%772%						DSUBETRY_DTABB[FIRSTDIM]<0,0>;
%772%						INCR J FROM 1 TO .DTABB[DIMNUM] DO
%772%						BEGIN
%772%							G_.DSUBETRY[DIMLB];
%772%							IF .DSUBETRY[VARLBFLG] AND
%772%							   .G[IDDIM] NEQ 0
%772%							THEN
%772%								FATLERR(.G[IDSYMBOL],0,E126<0,0>);
%772%							G_.DSUBETRY[DIMUB];
%772%							IF .DSUBETRY[VARUBFLG] AND
%772%							   .G[IDDIM] NEQ 0
%772%							THEN
%772%								FATLERR(.G[IDSYMBOL],0,E126<0,0>);
%772%							DSUBETRY_.DSUBETRY+DIMSUBSIZE;
%772%						END;
%772%					END;
				END;
			END;
		END;
		CSTMNT_.CSTMNT[SRCLINK];
	END;
END;