Google
 

Trailing-Edge - PDP-10 Archives - bb-4157j-bm_fortran20_v11_16mt9 - fortran-compiler/ver5.bli
There are 12 other files named ver5.bli in the archive. Click here to see a list.
!COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1976, 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: STAN WHITLOCK/TFV/TJK/AlB/CDM

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


	! REQUIRES FIRST, TABLES, OPTMAC

GLOBAL BIND VER5V = #11^24 + 0^18 + #4504;	! Version Date:	22-Jan-85

%(

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

2	437	QAR771	PASS ORFIXFLG UP TO SUBSUMER IN DOTOFIX, (SJW)
3	505	QAR815	IN DOTORFIX MOVE MODIFIED .R INIT TO BEFORE
			  TOP ONLY IF NOT ALREADY THERE, (SJW)
4	515	QAR815	REMOVE "TEMP [EXPRUSE] = 1" IN DOTORFIX, (SJW)

***** Begin Version 5A *****	 7-Nov-76

5	525	QAR949	DO CORRECT TYPECNV IN DOTOFIX ONLY IF NECESSARY, (SJW)

***** Begin Version 5B *****	 19-Dec-77

6	631	10962	TEACH VER5 HOW TO ZERO DEF POINTS IN IOLISTS, (JNG)

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

7	1245	TFV	3-Aug-81	------
	Fix definition of REGSTUFF.  IDCHOS, IDUSED, IDDEF were moved from
	word 2 to word 8 of symbol table entry.  The left half of word 8
	also contains the PSECT field so we can not just clear the left half.

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

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

2211	TFV	18-Aug-83
	Add INQUIRE  case to  ZSTATEMENT.   Create routines  ZDEFIO  and
	ZDEFOCI to process I/O specifiers.

2212	CDM	30-Aug-83
	Fix for edit 2211.  Check if IOFORM is a half word of -1  rather
	than a full word.

2372	TJK	14-Jun-84
	Add cases in ZDEFPT for SUBSTRING and CONCATENATION.

2427	AlB	17-Jul-84
	REGSTUFF used to be defined in DFCLEANUP to clear some fields in STE
	word 2, and was also defined (differently) in CLEANUP of module GOPT2
	to clear some other fields.  This edit uses IDCLEANA instead of
	REGSTUFF;  IDCLEANA is now defined in FIRST.

	Note that the fields being cleared have been moved out of word 2
	and placed into word 8.

2507	CDM	21-Dec-84
	Move IDDOTF to FIRST.

***** End V10 Development *****
***** End Revision History *****
***** Begin Version 11 *****

4500	MEM	22-Jan-85
	Zero the definition points for the expressions for keys pointed to
	by IOKEY for OPEN statement nodes.

4502	MEM	22-Jan-85
	Modify ZSTATEMENT for DELETE statement.

4503	MEM	22-Jan-85
	Modify ZSTATEMENT for REWRITE statement.

4504	MEM	22-Jan-85
	Modify ZSTATEMENT for UNLOCK statement.

ENDV11

)%

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

FORWARD
%631%	ZIOLIST(1),	!CALLED FROM ZDEFPT AND ZSTATEMENT
%631%	ZDEFPT(1),		!CALLED FROM ZIOLIST
%2211%	ZDEFIO(1),
%2211%	ZDEFOCI(1),
%631%	ZSTATEMENT(1),	!CALLED FROM ZDEFPT
	ZTREE,
	UNBUSY(1),
	DOTORFIX(2),
	DOTOFIX(2),
	DFCLEANUP;
ROUTINE ZIOLIST(LIST)=
BEGIN
	MAP BASE LIST;		![631]

%631%	WHILE .LIST NEQ 0 DO
%631%	BEGIN
%631%		ZDEFPT(.LIST);
%631%		LIST = .LIST[CLINK]
%631%	END
END;	! of ZIOLIST	![631]
ROUTINE ZDEFPT(EXPR)=
BEGIN
	! ZERO DEFINITION POINTS IN EXPRESSION

	MAP PEXPRNODE  EXPR;

	! ZERO DEFPT FOR ARG 1

	MACRO  ZDEFPT1=
		BEGIN
			IF NOT .EXPR[A1VALFLG]
		    	THEN ZDEFPT(.EXPR[ARG1PTR]);

			EXPR[DEFPT1] = 0;
		END$;

	! ZERO DEFPT FOR ARG 2

	MACRO ZDEFPT2=
		BEGIN
			IF NOT .EXPR[A2VALFLG]
			THEN ZDEFPT(.EXPR[ARG2PTR]);

			EXPR[DEFPT2] = 0;
		END$;

	IF .EXPR EQL 0
	THEN RETURN;

	CASE  .EXPR [OPRCLS]  OF SET
!BOOLEAN
	  BEGIN
	    ZDEFPT1;
	    ZDEFPT2;
	  END;
!DATAOPR
	  BEGIN  END;
!REALTIONAL
	  BEGIN
	    ZDEFPT1;
	    ZDEFPT2;
	  END;
!FNCALL
	  BEGIN
	  LOCAL ARGUMENTLIST  AG;
	    AG = .EXPR [ARG2PTR];		! NEVER = 0
	    INCR  I  FROM 1  TO .AG [ARGCOUNT]
	      DO BEGIN
	        IF NOT .AG [.I, AVALFLG]
		  THEN ZDEFPT (.AG [.I, ARGNPTR]);
	      END;
	  END;
!ARITHMETIC
	  BEGIN
	    ZDEFPT1;
	    ZDEFPT2;
	  END;
!TYPECNV
	  BEGIN
	    ZDEFPT2;
	  END;
!ARRAYREF
	  BEGIN
	    EXPR [DEFPT1] = 0;
	    ZDEFPT2;
	  END;
!CMNSUB
	  BEGIN  END;			! NONE GENERATED YET
!NEGNOT
	  BEGIN
	    ZDEFPT2;
	  END;
!SPECOP
	  BEGIN
	    ZDEFPT1;
	  END;
!FIELDREF
	  BEGIN  END;			! UNUSED
!STORECLS
	  BEGIN  END;
!REGCONTENTS
	  BEGIN  END;
!LABOP
	  BEGIN  END;
!STATEMENT
%631%	  BEGIN
%631%	    ZSTATEMENT(.EXPR)	!CAN HAPPEN UNDER IOLISTS
%631%	  END;
!IOLSCLS
%631%	  BEGIN
%631%	    CASE .EXPR[OPERSP] OF
%631%	    SET
%631%	    !DATACALL
%631%	      ZDEFPT(.EXPR[DCALLELEM]);
%631%	    !SLISTCALL
%631%	      BEGIN
%631%		ZDEFPT(.EXPR[SCALLELEM]);
%631%		ZDEFPT(.EXPR[SCALLCT])
%631%	      END;
%631%	    !IOLSTCALL
%631%	      BEGIN
%631%		ZIOLIST(.EXPR[IOLSTPTR]);
%631%		ZIOLIST(.EXPR[IOLCOMNSUB])
%631%	      END;
%631%	    !E1LISTCALL
%631%	      BEGIN
%631%		ZIOLIST(.EXPR[ELSTPTR]);
%631%		ZIOLIST(.EXPR[IOLCOMNSUB])
%631%	      END;
%631%	    !E2LISTCALL
%631%	      BEGIN
%631%		ZIOLIST(.EXPR[ELSTPTR]);
%631%		ZIOLIST(.EXPR[IOLCOMNSUB])
%631%	      END;
%631%	    !ESNGLELEM
%631%	      ZDEFPT(.EXPR[DCALLELEM]);
%631%	    !EDBLELEM
%631%	      ZDEFPT(.EXPR[DCALLELEM])
%631%	    TES
%631%	  END;
!INLINFN
	  BEGIN
	    ZDEFPT1;
	    IF .EXPR [ARG2PTR] NEQ 0		! NO ARG2 ON ABS
	      THEN ZDEFPT2;
	  END;

!SUBSTRING	[2372]
%2372%	BEGIN
%2372%		ZDEFPT1;		! Upper bound
%2372%		ZDEFPT2;		! Lower bound
%2372%		ZDEFPT(.EXPR[ARG4PTR]);	! ARRAYREF or DATAOPR
%2372%		EXPR[DEFPTSS] = 0;	! For SUBSTRING only
%2372%	END;

!CONCATENATION	[2372]
%2372%	BEGIN
%2372%		LOCAL ARGUMENTLIST AG;
%2372%		AG = .EXPR[ARG2PTR];		! Pointer to argument list
%2372%
%2372%		INCR I FROM 2 TO .AG[ARGCOUNT]	! Skip first argument
%2372%		DO
%2372%		BEGIN	! For each argument
%2372%
%2372%			IF NOT .AG[.I,AVALFLG]
%2372%			THEN ZDEFPT(.AG[.I,ARGNPTR]);
%2372%
%2372%		END;	! For each argument
%2372%	END;

	TES;

	RETURN;
END;	! of ZDEFPT
ROUTINE ZDEFIO(SRC)=	![2211] New
BEGIN
	!***************************************************************
	! Zero definition points for UNIT, FMT, REC, IOSTAT, and  IOLIST
	! elements.
	!***************************************************************

	MAP BASE SRC;

	REGISTER BASE TMP;

	ZDEFPT(.SRC[IOUNIT]);		! Zero UNIT

	! Zero FMT but ignore list-directed

%2212%	IF (TMP = .SRC[IOFORM]) NEQ #777777 THEN ZDEFPT(.TMP);

	ZDEFPT(.SRC[IORECORD]);		! Zero RECORD
	ZDEFPT(.SRC[IOIOSTAT]);		! Zero IOSTAT

	TMP = .SRC[IOLIST];		! Zero IOLIST
	WHILE .TMP NEQ 0 DO
	BEGIN
		ZDEFPT(.TMP);
		TMP = .TMP[CLINK];
	END
END;	! of ZDEFIO
ROUTINE ZDEFOCI(SRC)=
BEGIN
	!***************************************************************
	! Zero  definition   points  for   OPEN,  CLOSE,   and   INQUIRE
	! specifiers.  elements.
	!***************************************************************

%2211%	! Written by TFV on 18-Aug-83

	MAP BASE SRC;

	REGISTER OPENLIST OPENL;
%4500%	LOCAL OPNKEYLIST KEYL;

	ZDEFPT(.SRC[IOUNIT]);		! Zero UNIT
	ZDEFPT(.SRC[IOFILE]);		! Zero FILE
	ZDEFPT(.SRC[IOIOSTAT]);		! Zero IOSTAT

	OPENL = .SRC[OPLST];

	DECR I FROM .SRC[OPSIZ] - 1 TO 0	! Zero other specifiers
	DO ZDEFPT(.OPENL[.I,ARGNPTR]);

%4500%	IF (KEYL = .SRC[IOKEY]) NEQ 0
%4500%	THEN 
%4500%	BEGIN
%4500%		DECR I FROM .KEYL[NUMKEYS] TO 1
%4500%		DO
%4500%		BEGIN
%4500%			ZDEFPT(.KEYL[.I,KEYLOW]);
%4500%			ZDEFPT(.KEYL[.I,KEYHIGH]);
%4500%		END;
%4500%	END;
END;	! of ZDEFOCI
ROUTINE ZSTATEMENT(SRC)=
BEGIN
	!*********************************************************
	! Zero definition points for expression under a statement.
	!*********************************************************

%2211%	! Rewritten by TFV on 18-Aug-83

	MAP BASE  SRC;
	REGISTER TMP;

	CASE .SRC[SRCID] OF SET

	BEGIN			! ASSIGNMENT
		ZDEFPT(.SRC[RHEXP]);
		ZDEFPT(.SRC[LHEXP]);
	END;			! ASSIGNMENT

	ZDEFPT(.SRC[ASISYM]);	! ASSIGN

	BEGIN			! CALL
		LOCAL ARGUMENTLIST  AG;
		IF (AG = .SRC[CALLIST]) NEQ 0
		THEN DECR I FROM .AG[ARGCOUNT] TO 1 DO
		IF NOT .AG[.I,AVALFLG]
		THEN ZDEFPT(.AG[.I,ARGNPTR]);
	END;			! CALL

	BEGIN END;		! CONTINUE

	BEGIN			! DO
		ZDEFPT(.SRC[DOM1]);		! INITIAL EXPR
		ZDEFPT(.SRC[DOM2]);		! FINAL EXPR
		ZDEFPT(.SRC[DOM3]);		! INCR EXPR
		ZDEFPT(.SRC[DOLPCTL]);		! CONTROL EXPR
	END;			! DO

 	BEGIN END;		! ENTRY
	BEGIN END;		! COMNSUB
	BEGIN END;		! GOTO
	ZDEFPT(.SRC[AGOTOLBL]);	! ASSIGNED GOTO
	ZDEFPT(.SRC[CGOTOLBL]);	! COMPUTED GOTO
	ZDEFPT(.SRC[AIFEXPR]);	! ARITHMETIC IF

	BEGIN			! LOGICAL IF
		ZDEFPT(.SRC[LIFEXPR]);
		ZSTATEMENT(.SRC[LIFSTATE]);
	END;			! LOGICAL IF

	ZDEFPT(.SRC[RETEXPR]);	! RETURN
	BEGIN END;		! STOP
	ZDEFIO(.SRC);		! READ
	ZDEFIO(.SRC);		! WRITE
	ZDEFIO(.SRC);		! DECODE
	ZDEFIO(.SRC);		! ENCODE
	ZDEFIO(.SRC);		! REREAD
	ZDEFIO(.SRC);		! FIND
	ZDEFOCI(.SRC);		! CLOSE
%4502%	ZDEFIO(.SRC);		! DELETE
%4503%	ZDEFIO(.SRC);		! REWRITE
	ZDEFIO(.SRC);		! BACKSPACE
	ZDEFIO(.SRC);		! BACKFILE
	ZDEFIO(.SRC);		! REWIND
	ZDEFIO(.SRC);		! SKIPFILE
	ZDEFIO(.SRC);		! SKIPRECORD
	ZDEFIO(.SRC);		! UNLOAD
%4504%	ZDEFIO(.SRC);		! UNLOCK
	ZDEFIO(.SRC);		! ENDFILE
	BEGIN END;		! END
	BEGIN END;		! PAUSE
	ZDEFOCI(.SRC);		! OPEN
	BEGIN END;		! STATEMENT FUNCTION
	BEGIN END;		! FORMAT
	BEGIN END;		! BLTID
	BEGIN END;		! REGMARK
	ZDEFOCI(.SRC);		! INQUIRE

	TES;

	RETURN;

END;	! of ZSTATEMENT
GLOBAL ROUTINE ZTREE=
BEGIN
	! ZERO DEFINITION POINTS IN ENTIRE TREE
	! ZERO OUT ORFIXFLG, OMOVDCNS IN SYMTBL FOR .O VARS

	! CALLED FROM MRP2 IN PHA2


EXTERNAL BASE  SORCPTR;

LOCAL BASE  PTR;
LOCAL BASE  SRC;

	PTR = .SORCPTR <LEFT>;
	WHILE  .PTR NEQ .SORCPTR <RIGHT>
	  DO BEGIN
	    SRC = .PTR;			! GET THIS STATEMENT
	    ZSTATEMENT  (.SRC);		! ZERO IT
	    PTR = .SRC [SRCLINK];	! TO NEXT STATEMENT
	  END;

	DECR  I  FROM SSIZ-1  TO 0
	  DO BEGIN
	    PTR = .SYMTBL [.I];
	    WHILE  .PTR NEQ 0
	      DO BEGIN
		IF .PTR [IDDOTO] EQL SIXBIT ".O"
		  THEN PTR [TARGET] = 0;
		PTR = .PTR [SRCLINK];
	      END;		! OF WHILE
	  END;			! OF DECR

	RETURN;
END;	! of ZTREE

SWITCHES  NOSPEC;

	! UNLINK T FROM BUSY & POSTDOM LISTS

	! CALLED FROM DOTOHASGN IN GCMNSB

	! IF T IS FROM IMPLIED DO (NOW BEING MOVED AS CONSTANT), IT
	!   WON'T BE ON LISTS => IGNORE
GLOBAL ROUTINE UNBUSY(T)=
BEGIN

MAP PHAZ2  T;			! STATEMENT NODE PTR

EXTERNAL  TOP;
MAP PHAZ2  TOP;
REGISTER PHAZ2  P;
LOCAL PHAZ2  OLDP;		! TO FIND END OF POSTDOM LIST

LABEL  L;

	P = .TOP;		! START SEARCH FOR RIGHT BROTHER
L:	WHILE  TRUE
	  DO BEGIN
	    IF .P EQL 0
	      THEN RETURN;	! T NOT ON BUSY LIST
	    IF .P [BUSY] EQL .T
	      THEN BEGIN
		P [BUSY] = .T [BUSY];
		LEAVE L;	! DONE WITH BUSY LIST
	      END;
	    P = .P [BUSY];	! NEXT ELEMENT
	  END;			! OF L:  WHILE  TRUE DO

	OLDP = P = .TOP;	! START SEARCH FOR RIGHT BROTHER
	WHILE  TRUE
	  DO BEGIN
	    IF .P [POSTDOM] EQL .T
	      THEN BEGIN
		P [POSTDOM] = .T [POSTDOM];
		RETURN;		! ALL DONE
	      END;
	    OLDP = .P;		! SAVE THIS ELEMENT
	    P = .P [POSTDOM];	! NEXT ELEMENT
	    IF .P EQL .OLDP
	      THEN RETURN;	! T NOT ON POSTDOM LIST
	  END;			! OF WHILE  TRUE DO

END;	! of UNBUSY

SWITCHES  NOSPEC;

	! REDUCE .R + X -> .O BECAUSE .R USE COUNT = 1
	! SET & RETURN HASHP [TEMPER] <- .O CREATED
	! NOTE X MUST BE LEAF SINCE MOVCNST HASHED .R + X FOR .O
	!      .R IS ALWAYS OF TYPE INTEGER
	!      X MUST BE SAME TYPE AS .R SINCE TO HASH .R + X, THERE
	!        CAN BE NO TYPECNV NODE IN BETWEEN + & X

	! CALLED FROM MOVCNST IN GCMNSB

	! IF .R IS REDUCED LOOP VAR
	!   THEN .R INIT IS DOM1 => DOM1 <- DOM1 + X
	! 	 BUT DOM1 ALWAYS VAR OR CNST NEVER EXPR =>
	! 	 MAKE .O' <- DOM1 + X STATEMENT BEFORE TOP
	! 	 & DOM1 <- .O'
	!          IF X = .O'' THEN .O' <- DOM1 + .O'' WILL BE AFTER
	!            .O'' <- E
	!          MUST PUT DOM1 + .O'' INTO HASH TBL FOR GLOBDEP
	!        .R INCR IS DOM3
	!        .R -> .O IN DOSYM => .O CANT MOVE OUTSIDE LOOP SO SET
	!          .O DEFPT <- TOP => SET .O HASHP [STPT] <- TOP
	!        MAKE DOM2 <- DOM2 + X FOR COMPLETENESS
	!   ELSE FIND .R <- Y INIT BETWEEN LENTRY & TOP
	!        FIND .R <- .R + Z INCR BETWEEN HERE & LEND (EASIER TO
	!          START AT TOP THAN TO FIND HERE)
	!        MAKE .R <- Y INTO .O <- Y + X
	!        IF X = .O'' THEN MOVE .O <- Y + .O'' TO AFTER .O'' <- E
	!          => MOVE TO BEFORE TOP SINCE FINDTHESPOT PUT .O'' <- E
	!          INTO TREE AFTER ALL OPTIM CREATED STATEMENTS 
	!          INCLUDING .R <- Y
	! 	 DON'T BOTHER MOVING IT IF IT'S ALREADY THERE !
	!          MUST PUT Y + .O'' INTO HASH TBL SO GLOBDEP WILL
	!          COMBINE .O'' BACK IN
	!          Y IS ALWAYS A LEAF (SO Y + .O'' CAN BE HASHED) SINCE
	!          Y IS INIT OF .R WHICH COMES FROM DOM1 WHICH IS
	!          ALWAYS A LEAF
	!        MAKE .R <- .R + Z INTO .O <- .O + Z (CANT ASSUME
	!          .R IS 1ST ARG ON RHS)

	! NOTE: DOPRED NOT CURRENT SO MUST SEARCH FOR STATEMENT BEFORE TOP

	! IF EXPR PUT INTO HASH TBL, MUST SET .O [ORFIXFLG] SO MOVCNST
	!   WILL IGNORE ENTRY & GLOBDEP WILL CALL DOTOFIX TO CLEAN UP
	!   POTENTIAL .O COMBINATION
GLOBAL ROUTINE DOTORFIX(PB,HASHP)=
BEGIN

MAP BASE  PB;			! STRAIGHT EXPR .R + X
MAP BASE  HASHP;		! HASH TABLE ENTRY

EXTERNAL  GETOPTEMP, SKERR, MAKPR1, MAKASGN;
EXTERNAL  HASHIT, TBLSRCH, MAKETRY;
EXTERNAL  TOP, LENTRY, LEND;

MAP PEXPRNODE  TOP, LENTRY, LEND;

MACRO	FIXDOTO (O) =
	  BEGIN
	    HASHIT (.O [IDOPTIM], STGHT);	! HASH Y + .O''
	    PHI = TBLSRCH ();			! LOOK IT UP
	    IF .FLAG
	      THEN SKERR ();			! ALREADY EXISTS
	    PHI = MAKETRY (.PHI, .O [IDOPTIM], STGHT);	! INTO HASH TBL
	    PHI [TEMPER] = .O;			! SINCE .O <- Y + .O''
	    PHI [STPT] = .LENTRY;		! WHERE TO MOVE
	  END$;

LOCAL BASE  DOTR;		! .R SYMTAB ENTRY
LOCAL PEXPRNODE  RINIT;		! .R INITIALIZATION
LOCAL PEXPRNODE  RINITP;	! PRED OF RINIT
LOCAL PEXPRNODE  RINCR;		! .R INCREMENT
LOCAL BASE  DOTO;		! .O CREATED
LOCAL BASE  DOTO2;		! IF X = .O''
LOCAL BASE  TEMP;
LOCAL BASE  PHI;

LABEL  LTOP, LINIT, LINCR, LT1;

	DOTR = .PB [ARG1PTR];		! CAN ASSUME .R IS 1ST ARG

	DOTO = GETOPTEMP (INTEGER);	! CREATE .O

	IF .TOP [DOSYM] EQL .DOTR
	  THEN BEGIN			! .R IS REDUCED LOOP VAR
	    TOP [DOSYM] = .DOTO;
	    HASHP [STPT] = .TOP;	! CANT MOVE THIS .O OUTSIDE LOOP
	    TEMP = MAKPR1 (0, ARITHMETIC, ADDOP, INTEGER,
			   .TOP [DOM1], .PB [ARG2PTR]);
	    TEMP [A2FLGS] = .PB [A2FLGS];
	    TEMP [A1NEGFLG] = .TOP [INITLNEG];
	    TOP [INITLNEG] = 0;
	    TOP [DOM1] = GETOPTEMP (INTEGER);		! .O'

	    RINIT = .LENTRY;		! FIND STATEMENT BEFORE TOP
LTOP:	    WHILE  TRUE
	      DO BEGIN
		IF .RINIT EQL 0
		  THEN SKERR ();	! MISSED TOP
		IF .RINIT [SRCLINK] EQL .TOP
		  THEN LEAVE LTOP;
		RINIT = .RINIT [SRCLINK];
	      END;			! OF LTOP:  WHILE  TRUE DO

	    RINIT [SRCLINK] = MAKASGN (.TOP [DOM1], .TEMP);
	    RINIT = .RINIT [SRCLINK];	! NEW STATEMENT IS IN TREE
	    RINIT [SRCLINK] = .TOP;	! LINK TO REST OF TREE
	    TEMP [PARENT] = .RINIT;	! FIX DOM1 + X EXPR PARENT

	    TOP [DOM2] = MAKPR1 (.TOP, ARITHMETIC, ADDOP, INTEGER,
				 .TOP [DOM2], .PB [ARG2PTR]);	! COMPLETENESS
	    TOP [INITLTMP] = 1;		! DOM1 COMES FROM EXPR
	    DOTO [IDOPTIM] = .TOP [DOM1];

	    DOTO2 = .TOP [DOM1];
	    DOTO2 [IDOPTIM] = .TEMP;
	    TEMP = .PB [ARG2PTR];
	    IF .TEMP [IDDOTO] EQL SIXBIT ".O"
	      THEN BEGIN
		FIXDOTO (DOTO2);
		DOTO2 [ORFIXFLG] = 1;		! HASHED BY DOTORFIX
	!****	TEMP [EXPRUSE] = 1;		! THIS 1 USEAGE
	      END;
	  END

	  ELSE BEGIN
	    RINIT = .LENTRY;
	    RINITP = .RINIT;
LINIT:	    WHILE  TRUE				! FIND .R <- Y INIT
	      DO BEGIN
	        IF .RINIT EQL .TOP
	          THEN SKERR ();		! .R INIT NOT FOUND
	        IF .RINIT [LHEXP] EQL .DOTR
	          THEN LEAVE LINIT;		! FOUND
		RINITP = .RINIT;		! NEXT PREDECESSOR
	        RINIT = .RINIT [SRCLINK];	! NEXT STATEMENT
	      END;			! OF LINIT:  WHILE  TRUE DO

	    RINCR = .TOP;
LINCR:	    WHILE  TRUE				! FIND .R <- .R + Z INCR
	      DO BEGIN
	        IF .RINCR EQL .LEND
	          THEN SKERR ();		! .R INCR NOT FOUND
	        IF .RINCR [LHEXP] EQL .DOTR
	          THEN LEAVE LINCR;		! FOUND
	        RINCR = .RINCR [SRCLINK];	! NEXT STATEMENT
	      END;			! OF LINCR:  WHILE  TRUE DO

	    RINIT [LHEXP] = .DOTO;
	    TEMP = MAKPR1 (.RINIT, ARITHMETIC, ADDOP, INTEGER,
			   .RINIT [RHEXP], .PB [ARG2PTR]);
	    TEMP [A2FLGS] = .PB [A2FLGS];
	    RINIT [RHEXP] = .TEMP;
	    DOTO [IDOPTIM] = .TEMP;
	    TEMP [A1FLGS] = .RINIT [A2FLGS];	! MOVE Y FLAGS DOWN
	    CLRA2FLGS (RINIT);

	    TEMP = .PB [ARG2PTR];
	    IF .TEMP [IDDOTO] EQL SIXBIT ".O"
	      THEN BEGIN
	        !DON'T BOTHER MOVING .R INIT IF IT'S ALREADY IN CORRECT PLACE
		IF .RINIT [SRCLINK] NEQ .TOP
		THEN BEGIN
		TEMP = .RINIT;
LT1:		WHILE  TRUE		! FIND STATEMENT BEFORE TOP
		  DO BEGIN
		    IF .TEMP EQL 0
		      THEN SKERR ();
		    IF .TEMP [SRCLINK] EQL .TOP
		      THEN LEAVE LT1;
		    TEMP = .TEMP [SRCLINK];
		  END;			! OF LT1:  WHILE  TRUE DO

		RINITP [SRCLINK] = .RINIT [SRCLINK];	! UNLINK RINIT
		TEMP [SRCLINK] = .RINIT;		! LINK BACK IN
		RINIT [SRCLINK] = .TOP;			! REST OF TREE
		END;

		FIXDOTO (DOTO);
	      END;

	    RINCR [LHEXP] = .DOTO;
	    TEMP = .RINCR [RHEXP];
	    IF .TEMP [ARG1PTR] EQL .DOTR
	      THEN TEMP [ARG1PTR] = .DOTO	! WAS .R + Z
	      ELSE TEMP [ARG2PTR] = .DOTO;	! WAS Z + .R
	  END;					! OF IF

	HASHP [TEMPER] = .DOTO;
	HASHP [MOVDCNS] = 0;		! .O ISNT CONSTANT IN LOOP NOW
	DOTO [ORFIXFLG] = 1;			! HASHED BY DOTORFIX
	DOTR [IDATTRIBUT (NOALLOC)] = 1;	! DONT ALLOCATE THIS .R

	RETURN .DOTO;

END;	! of DOTORFIX


SWITCHES  NOSPEC;

	! IF SUBSUMING .O WHICH CAME FROM .R, FIND .O INCR (=.O + Z) &
	!   CHANGE TO NEW .O
	! IGNORE IF .O BEING SUBSUMED IS DOM1
	! IF SUBSUMEE IS DIFFERENT TYPE THAN SUBSUMER, MUST BUILD TYPECNV
	!   NODE ABOVE .O INCR EXPR (=Z) TO MAKE SUBSUMER GET CORRECT INCR
	!   EXPR (EXCEPT INTEGER <-> INDEX IS NOT NECESSARY) SO USE VALTP2
	!   TO CHECK 1ST 3 BITS OF VALTYPE: MUST CONVERT IF NEQ


	! CALLED FROM GLOBDEP IN GCMNSB
GLOBAL ROUTINE DOTOFIX(T,PAE)=
BEGIN

MAP BASE  T;			! OLD .O TO BE REPLACED
MAP BASE  PAE;			! NEW .O <- EXPR (OLD .O) STATEMENT

EXTERNAL  SKERR, MAKPR1;
EXTERNAL  TOP, LEND;

MAP PEXPRNODE  TOP, LEND;

LOCAL BASE  P;			! TO MARCH DOWN TREE
LOCAL BASE  TEMP;
LOCAL BASE  NEWO;		! NEW .O (THE SUBSUMER)
LOCAL BASE  T1;

	IF .TOP [DOSYM] EQL .T
	  THEN RETURN;

	P = .PAE;		! START TREE SEARCH
	WHILE  TRUE
	  DO BEGIN
	    IF .P EQL .LEND
	      THEN SKERR ();	! .O INCR NOT FOUND
	    IF .P [LHEXP] EQL .T
	      THEN BEGIN	! FOUND OLD .O (ONLY ONE)
		NEWO = .PAE [LHEXP];
		!MARK SUBSUMING .O AS COMING FROM .R
		NEWO [ORFIXFLG] = 1;		! PASS FLAG UP TO SUBSUMER
		P [LHEXP] = .NEWO;
		TEMP = .P [RHEXP];
		IF .TEMP [ARG1PTR] EQL .T
		  THEN TEMP [ARG1PTR] = .NEWO		! WAS .O + Z
		  ELSE BEGIN
		    TEMP [ARG2PTR] = .NEWO;		! WAS Z + .O
		    SWAPARGS (TEMP);			! MAKE IT .O + Z
		    T1 = .TEMP [DEFPT1];
		    TEMP [DEFPT1] = .TEMP [DEFPT2];
		    TEMP [DEFPT2] = .T1;
		  END;
		!  DO TYPE CONVERSION ONLY IF NECESSARY AND DON'T CLOBBER "PARENT"
		IF .T [VALTP2] NEQ .NEWO [VALTP2]	! CONVERSION NECESSARY ?
		  THEN BEGIN
		    TEMP [VALTYPE] = .NEWO [VALTYPE];
		    T1 = MAKPR1 (.TEMP, TYPECNV, .T [VALTYPE],
		                 .NEWO [VALTYPE], 0,
		                 .TEMP [ARG2PTR]);
		    TEMP [ARG2PTR] = .T1;
		    T1 [A2FLGS] = .TEMP [A2FLGS];	! MOVE FLAGS DOWN
		    CLRA2FLGS (TEMP);
		  END;
		RETURN;
	      END;
	    P = .P [SRCLINK];
	  END;			! OF WHILE  TRUE DO
END;	! of DOTOFIX


SWITCHES NOSPEC;

	! GO THRU SYMBOL TABLE AND ZERO FIELDS USED BY THE OPTIMIZER
	!   EXCEPT FOR THE .O FIELDS
	! CALLED FROM PROPAGATE IN PNROPT (USED TO USE CLEANUP IN GOPT2)

	! .O EXPRUSE FIELD ZEROED IN GLOBDE & ORFIXFLG
	!   & OMOVDCNS FLAGS ZEROED BY ZTREE
GLOBAL ROUTINE DFCLEANUP=
BEGIN

!%1245%	Redefine REGSTUFF, IDCHOS, IDUSED, and IDDEF were moved from word 2 to
!%1245%	word 8.  The left half also contains the PSECT info so we can not clear the half word.

	INCR  I  FROM 0  TO SSIZ-1
	  DO BEGIN

	  REGISTER BASE  T;

	    T = .SYMTBL [.I];
	    WHILE  .T NEQ 0
	      DO BEGIN

	! 	KLUDGE BECAUSE OF STATEMENT FUNCTION OPTIMIZATIONS

		IF .T [IDDOTF] NEQ SIXBIT ".F"
		  THEN BEGIN
		    IF .T [IDDOTF] NEQ SIXBIT ".O"
%2427%		      THEN T [IDCLEANA] = 0;

	! 	    IF THIS IS A FORMAL ARRAY THE PSEUDO ENTRY
	! 	      MUST ALSO BE ZERO IF NOT ADJUSTABLY DIMENSIONED

		    IF .T [OPERSP] EQL FORMLARRAY
		      THEN BEGIN

		    REGISTER BASE  ET;

			ET = .T [IDDIM];
			IF NOT .ET [ADJDIMFLG]
			  THEN BEGIN
			    ET = .ET [ARADDRVAR];

	! 		    THIS PSEUDO ENTRY IS POINTED TO BY THE
	! 		      ARADDRVAR FIELD OF THE DIM TABLE ENTRY

%2427%			    ET [IDCLEANA] = 0;
			  END;
		      END;	! SPECIAL STUFF FOR FORMAL ARRAYS
		  END;		! SFN KLUDGE
		T = .T [CLINK];
	      END;		! WHILE .T NEQ 0
	  END;			! INCR I

END;	! of DFCLEANUP

END
ELUDOM