Google
 

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

!COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION
!AUTHOR: S. MURPHY/HPW/MD/DCE/JNG/TFV

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

GLOBAL BIND P2S2V = 6^24 + 0^18 + 60;	! Version Date:	20-Jul-81

%(

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

47	-----	-----	FOLD EXPONENTIATIONS WHICH
			REQUIRE FEWER THAN 8 MULTIPLIES INTO THE SPECIAL
			OPERATOR EXPCIOP
			ELIMINATE SQROP, CUBOP, P4OP
48	-----	-----	FIX INTEGC AND CREATION OF SPECIAL OP EXPCIOP

49	-----	-----	DO DP EXPONENS TO INTEGER POWERS IN LINE ON KI10
50	-----	-----	MAKE "CNTMPY" A GLOBAL ROUTINE
51	331	17091	FIX TAKNEGARG FOR OPERATOR EXPCIOP
			RAISE TO AN ODD POWER CANNOT ABSORB NEG, (MD)
52	345	17554	ABSORB NEG CORRECTLY FOR EVEN EXPONENTIATION
53	430	18876	ABSORB NEG IN ARITHMETIC IF CORRECTLY, (JNG)

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

54	530	21606	DO NOT ALLOW FSC ON DOUBLE PRECISION NUMBERS, (DCE)
55	553	21826	BE CAREFUL COLLAPSING AN AND NODE WITH TRUE AS ARG,
			(DCE)
56	610	23333	FIX EDIT 52 (MUST TEST OPERCLAS TOO), (DCE)

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

57	761	TFV	1-Mar-80	-----
	Add /GFLOATING constant folding.  Use proprer form of DP when
	checking constants

58	1054	DCE	12-Feb-81	-----
	Fix bug with non-existant parent pointers in comsub node (/OPT)

59	1074	SRM	27-May-81	Fix problem with FOLDLIF ignoring
					A1NOTFLG

60	1102	CKS	18-Jun-81
	Fix NOTOFNEG and NEGOFNOT to handle case where P2SKL1DISP alters
	NEGFLG or NOTFLG.  Eg .not.(-(-(.not x)))

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

)%

![761] KTYPCG for /GFLOATING type conversions
	EXTERNAL
		CANONICALIZE,CGERR,MAKEPR,C1H,C1L,C2H,C2L,COPRIX,CNSTCM,
%[761]%		KBOOLBASE,KTYPCB,KTYPCG,SPKABA,CNSTCMB,TBLSEARCH,
		SKERR;
	FORWARD
		TAKNEGARG(1),SETNEG(2),DNEGCNST(1),NEGOFNOT(1),NOTOFNEG(1), BLCMB(3), 
		ARCMB(4),CMBEQLARGS(1),FOLDLIF(0),FOLDAIF(0);


	EXTERNAL
		P2SKBL,P2SKREL,P2SKFN,P2SKARITH,P2SKLTP,P2SKLARR,
		P2SKNEGNOT;


EXTERNAL NEGFLG,NOTFLG;

EXTERNAL P2SKL1DISP;

EXTERNAL SETPVAL;
EXTERNAL KDNEGB;

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



%(***************************************************************************
	THIS MODULE CONTAINS ROUTINES USED BY PHASE 2 SKELETON.
***************************************************************************)%



GLOBAL ROUTINE TAKNOTARG(PNODE)=
%(***************************************************************************
	THIS ROUTINE RETURNS "TRUE" IFF THE NODE POINTED TO BY PNODE CAN
	ABSORB A "NOT" ON ITS ARGS AS "A1NOTFLG" OR "A2NOTFLG"
***************************************************************************)%
BEGIN
	MAP PEXPRNODE PNODE;

	%(***WHETHER OR NOT A NODE CAN ABSORB A NOT FROM BELOW DEPENDS ON ITS OPRCLS**)%
	RETURN
	(
		CASE .PNODE[OPRCLS] OF SET
		TRUE;			!BOOLEAN NODES ABSORB NOT ON SONS
		FALSE;		!SHOULD NEVER SEE A DATA NODE AS A "PARENT"
		FALSE;		!RELATIONALS CANNOT ABSORB 'NOT' FROM SONS
					! (NOTE HOWEVER THAT THEY DO ABSORB 'NOT' PROPAGATED
					! DOWN FROM ABOVE THEM
		FALSE;		!NOT ON AN ARG TO A FN CALL CANNOT BE ABSORBED
		FALSE;		!ARITHMETIC NODES DO NOT ABSORB NOT
		BEGIN			!TYPE-CONV NODES ABSORB NOT EXCEPT
			IF NOCNV(PNODE)	! FOR THOSE THAT DONT ACTUALLY
			THEN TAKNOTARG(.PNODE[PARENT])
			ELSE TRUE		! GENERATE ANY CODE
		END;
		TRUE;			!ARRAY-REF NODES ABSORB NOT ON THE ADDR CALC
		TRUE;			!COMMON SUBEXPR NODES ABSORB NOT
		TRUE;			!NEG/NOT NODES ABSORN NOT
		TRUE;			!THE SPECIAL-CASE OPERATORS ABSORB NOT
		FALSE;		!FIELD-REF - NOT IN RELEASE 1
		FALSE;		!STORECLS - SHOULD NOT OCCUR IN P2S
		FALSE;		!REGCONTENTS - NOT ABOVE NEG/NOT
		FALSE;		!LABOP
		BEGIN			!STATEMENT - FOR ASSIGNMENT AND LOGICAL IF,
					! PARENT CAN ABSORN NOT, OTHERWISE IT CANT
			IF .PNODE[SRCID] EQL ASGNID OR .PNODE[SRCID] EQL IFLID
			THEN TRUE
			ELSE FALSE
		END;
		FALSE;		!IOLSCLS - CANNOT PROPAGATE
		FALSE;		!INLINFN - CANNOT PROPAGATE FOR ALL OF
					! THEM, SO DONT BOTHER
		TES
	)
END;


GLOBAL ROUTINE TAKNEGARG(PNODE)=
%(***************************************************************************
	THIS ROUTINE RETURNS "TRUE" IFF THE NODE PNODE  CAN ABSORB A
	NEG ON ITS ARG(S) AS "A1NEGFLG" OR "A2NEGFLG".
***************************************************************************)%
BEGIN
	MAP PEXPRNODE PNODE;

	%(***WHETHER OR NOT A NODE CAN ABSORB A NEG FROM BELOW DEPENDS ON ITS OPRCLS***)%
	RETURN
	(
		CASE .PNODE[OPRCLS] OF SET
		FALSE;			!BOOLEANS DO NOT ABSORB NEG
		FALSE;			!DATA ITEM (SHOULD NEVER OCCUR)
		TRUE;			!RELATIONALS DO ABSORB NEG
		FALSE;			!NEG ON ARG TO A FN CALL CANNOT BE ABSORBED
		BEGIN			!ARITH NODES EXCEPT FOR EXPONEN ABSRB NEG
			IF .PNODE[OPERSP] EQL EXPONOP
			THEN FALSE
			ELSE TRUE
		END;
		BEGIN
			IF NOCNV(PNODE)	!FOR TYPE-CNV NODES THAT GENERATE NO CODE
			THEN TAKNEGARG(.PNODE[PARENT])	!WILL HAVE TO PASS THE NEG UP AN
							! ADDITIONAL LEVEL
			ELSE TRUE	!OTHER TYPE-CNV NODES DO ABSORB NEG FROM BELOW
		END;
		TRUE;			!ARRAYREF NODES ABSORB NEG FROM ADDR CALC
		TRUE;			!COMMON SUBEXPR NODES ABSORB NEG
		TRUE;			!NEG/NOT NODES ABSORB NEG
		BEGIN			! SPECOP ABSORB NEG EXCEPT
			IF .PNODE[OPERSP] EQL EXPCIOP	! FOR RAISE
			AND .PNODE[ARG2PTR]	! TO AN ODD POWER
			THEN FALSE
			ELSE TRUE
		END;
		FALSE;			!FIELD-REF - NOT IN RELEASE 1
		FALSE;			!STORECLS NODES DO NOT ABSORB NEG (SHOULD NOT OCCUR IN P2S)
		FALSE;			!REGCONTENTS - NEVER OCCURS ABOVE NEG
		FALSE;			!LABOP - NEVER OCCURS
		BEGIN			!STATEMENT - ASSIGNMENT AND ARITH-IF ABSORB NEG
			IF .PNODE[SRCID] EQL ASGNID
				OR .PNODE[SRCID] EQL IFAID
			THEN TRUE
			ELSE FALSE
		END;
		FALSE;			!IOLSCLS - CANNOT PROPAGATE NEG UP
		FALSE;			!INLINFN - CANNOT ALWAYS PROPAGATE NEG UP- SO
					! DONT BOTHER
		TES      
	)
END;


GLOBAL ROUTINE SETNEG(PNODE,ARG1FLG)=
%(***************************************************************************
	IF THE NODE "PNODE" CANNOT ABSORB A NEGATE FROM ITS ARGS AS A1NEGFLG/A2NEGFLG
	THEN THIS ROUTINE RETURNS FALSE.
	IF "PNODE" CAN ABSORB A NEGATE FROM ITS ARGS, THEN THIS ROUTINE
	COMPLEMENTS EITHER A1NEGFLG (IF "ARG1FLG" IS TRUE) OR A2NEGFLG (IF
	"ARG1FLG" IS FALSE) IN PNODE AND RETURNS TRUE
***************************************************************************)%
BEGIN
	MAP PEXPRNODE PNODE;

	IF TAKNEGARG(.PNODE)
	THEN
	BEGIN
		%(***IF PNODE CAN ABSORB NEG FROM ITS ARGS***)%
		IF .ARG1FLG OR (.PNODE[OPRCLS] EQL STATEMENT AND .PNODE[SRCID] EQL IFAID)
		! ARITHMETIC IF STATEMENT NODES ALWAYS USE THE A1????? FLAGS
		THEN
		BEGIN
			IF .PNODE[A1NOTFLG] THEN RETURN FALSE;
			! SIMPLY ABSORB THE NEG FOR EVEN EXPONENTIATION
			IF .PNODE[OPR1] NEQ EXPCIF THEN
			 PNODE[A1NEGFLG]_NOT .PNODE[A1NEGFLG]
		END
		ELSE
		BEGIN
			IF .PNODE[A2NOTFLG] THEN RETURN FALSE;
			 PNODE[A2NEGFLG]_NOT .PNODE[A2NEGFLG];
		END;

		RETURN TRUE
	END
	ELSE
	RETURN FALSE
END;



GLOBAL ROUTINE DNEGCNST(CNNODE)=
%(***************************************************************************
	ROUTINE TO TAKE THE NEGATIVE OF A DOUBLE-PREC CONSTANT.
	RETURNS  A PTR TO THE CONSTANT TABLE ENTRY FOR THE NEW CONSTANT.
***************************************************************************)%
BEGIN
	MAP PEXPRNODE CNNODE;

	%(***SET UP GLOBALS USED BY THE ASSEMBLY LANG CONSTANT FOLDING
		ROUTINE*****)%
	C1H_.CNNODE[CONST1];
	C1L_.CNNODE[CONST2];
%[761]%	COPRIX_KDNEGB;

	CNSTCM();

	RETURN MAKECNST(.CNNODE[VALTYPE],.C2H,.C2L);
END;


GLOBAL ROUTINE NOTOFNEG(CNODE)=
%(***************************************************************************
	IN PHASE 2 SKELETON WHEN WERE TRYING TO PROPAGATE A NOT DOWN OVER A NEG
	AS IN NOT(-X), CALL THIS ROUTINE
	CALLED WITH THE ARG CNODE A PTR TO THE 'NEG' NODE;
		WITH NOTFLG KNOWN TO BE SET
	IF X IS A CONSTANT, CREATE A NEW CONSTANT FOR NOT(-X)
	OTHERWISE, SINCE CANNOT PROPAGATE NOT ACROSS NEGATE, PROPAGATE
	THE NOT BACK UP AND ATTEMPT TO PROPAGATE THE NEG DOWN.
	IF THE NEG CANNOT BE PROPAGATED DOWN, MUST LEAVE THE NEG NODE IN THE
	TREE (IN ALL OTHER CASES, NEG NODES ARE ELIMINATED
	FROM THE TREE)
***************************************************************************)%
BEGIN
	MAP PEXPRNODE CNODE;
	LOCAL PEXPRNODE ARGNODE;

	ARGNODE_.CNODE[ARG2PTR];

	IF .CNODE[A2VALFLG]
	THEN

	%(****IF THE ARG UNDER CNODE IS A LEAF****)%
	BEGIN

		IF .ARGNODE[OPR1] EQL CONSTFL
		THEN
		%(***IF THE ARG IS A CONSTANT, CAN ELIMINATE BOTH THE NEG AND
			THE NOT - BY CREATING A NEW CONSTANT***)%
		BEGIN
			NOTFLG_FALSE;
			%(***SET THE VAL-FLAG IN THE PARENT OF THE NEG NODE***)%
			SETPVAL(.CNODE);
			RETURN NTNGCNST(ARGNODE);
		END

		ELSE
		%(***IF THE ARG IS A LEAF, BUT NOT A CONSTANT, CANNOT
			PROPAGATE THE NEG DOWN AND HENCE MUST LEAVE THE NEG
			NODE IN THE TREE******)%
		RETURN .CNODE;

	END

	ELSE
	%(***IF THE ARG UNDER THE NEGATE NODE IS NOT A LEAF, ATTEMPT TO PROPAGATE
		THE NEG DOWN OVER IT (BUT DO NOT PROPAGATE THE NOT)***)%
	BEGIN
		NOTFLG_FALSE;
		NEGFLG_NOT .NEGFLG;
		ARGNODE_(.P2SKL1DISP[.ARGNODE[OPRCLS]])(.ARGNODE);
		IF .NEGFLG
		THEN
		%(***IF COULD NOT PROPAGATE THE NEGATE, MUST LEAVE THE NEGATE NODE
			IN THE TREE***)%
		BEGIN
			NEGFLG_FALSE;
			CNODE[ARG2PTR]_.ARGNODE;
%[1102]%		NOTFLG_NOT .NOTFLG;	!PROPAGATE THE NOT BACK UP
			RETURN .CNODE;
		END

		ELSE
		BEGIN
%[1102]%		NOTFLG_NOT .NOTFLG;
			%(***IF ARE REPLACING THE 'NEG' NODE BY A LEAF, SET THE VALFLG
				IN THE PARENT OF THE NEG NODE***)%
			IF .ARGNODE[OPRCLS] EQL DATAOPR OR .ARGNODE[OPRCLS] EQL REGCONTENTS 
			THEN SETPVAL(.CNODE)
			ELSE
			ARGNODE[PARENT]_.CNODE[PARENT];
			RETURN .ARGNODE;
		END;
	END;
END;


GLOBAL ROUTINE NEGOFNOT(CNODE)=
%(***************************************************************************
	IN PHASE 2 SKELETON WHEN WERE TRYING TO PROPAGATE A NEG DOWN OVER A NOT
	AS IN -(NOT X), CALL THIS ROUTINE 
	CALLED WITH THE ARG CNODE A PTR TO THE 'NOT' NODE;
		WITH NEGFLG KNOWN TO BE SET
	IF X IS A CONSTANT, CREATE A NEW CONSTANT FOR-(NOT X)
	OTHERWISE, SINCE CANNOT PROPAGATE NEGATE ACROSS NOT, PROPAGATE
	THE NEG BACK UP AND ATTEMPT TO PROPAGATE THE NOT DOWN.
	IF THE NOT CANNOT BE PROPAGATED DOWN, MUST LEAVE THE NOT NODE IN THE
	TREE (IN ALL OTHER CASES, NOT NODES ARE ELIMINATED
	FROM THE TREE)
***************************************************************************)%
BEGIN
	MAP PEXPRNODE CNODE;
	LOCAL PEXPRNODE ARGNODE;

	ARGNODE_.CNODE[ARG2PTR];

	IF .CNODE[A2VALFLG]
	THEN

	%(****IF THE ARG UNDER CNODE IS A LEAF****)%
	BEGIN

		IF .ARGNODE[OPR1] EQL CONSTFL
		THEN
		%(***IF THE ARG IS A CONSTANT, CAN ELIMINATE BOTH THE NEG AND
			THE NOT - BY CREATING A NEW CONSTANT***)%
		BEGIN
			NEGFLG_FALSE;
			%(***SET THE VAL FLAG IN THE PARENT OF THE "NOT"***)%
			SETPVAL(.CNODE);
			RETURN NGNTCNST(ARGNODE);
		END

		ELSE
		%(***IF THE ARG IS A LEAF, BUT NOT A CONSTANT, CANNOT
			PROPAGATE THE NOT DOWN AND HENCE MUST LEAVE THE NOT
			NODE IN THE TREE******)%
		RETURN .CNODE;

	END

	ELSE
	%(***IF THE ARG UNDER THE NOT IS NOT A LEAF, ATTEMPT TO PROPAGATE
		THE NOT DOWN OVER IT (BUT DO NOT PROPAGATE THE NEGATE)***)%
	BEGIN
		NEGFLG_FALSE;
		NOTFLG_NOT .NOTFLG;
		ARGNODE_(.P2SKL1DISP[.ARGNODE[OPRCLS]])(.ARGNODE);
		IF .NOTFLG
		THEN
		%(***IF COULD NOT PROPAGATE THE NOT, MUST LEAVE THE NOT NODE
			IN THE TREE***)%
		BEGIN
			NOTFLG_FALSE;
			CNODE[ARG2PTR]_.ARGNODE;
%[1102]%		NEGFLG_NOT .NEGFLG;	!PROPAGATE THE NEG BACK UP
			RETURN .CNODE;
		END

		ELSE
		BEGIN
%[1102]%		NEGFLG_NOT .NEGFLG;
			%(***IF THE NOT NODE IS BEING REPLACED BY A LEAF, SET THE VAL-FLAG
				IN THE PARENT****)%
			IF .ARGNODE[OPRCLS] EQL DATAOPR OR .ARGNODE[OPRCLS] EQL REGCONTENTS
			THEN SETPVAL(.CNODE)
			ELSE
			ARGNODE[PARENT]_.CNODE[PARENT];
			RETURN .ARGNODE;
		END;
	END;
END;

GLOBAL ROUTINE BLCMB(CNODE,CNARGNODE,VARGNODE)=
%(***************************************************************************
	ROUTINE TO CHECK FOR
		TRUE AND A = A
		FALSE AND A = FALSE
		TRUE OR A = TRUE
		FALSE OR A = A
		TRUE EQV A = A
		FALSE EQV A = NOT A
		TRUE XOR A = NOT A
		FALSE XOR A = A
	CALLED WITH THE ARGS
		CNODE - THE PARENT NODE TO BE CHECKED
		CNARGNODE - ARG KNOWN TO BE A CONSTANT
		VARGNODE - ARG KNOWN TO BE A VARIABLE
	IF THE VALUE OF CNARGNODE IS TRUE OR FALSE, REPLACES CNODE BY
	THE VALUE INDICATED ABOVE.
***************************************************************************)%
BEGIN
	MAP PEXPRNODE CNODE:CNARGNODE:VARGNODE;
	OWN PEXPRNODE OLDCNODE;

	%(***A CONSTANT MUST HAVE VALTYPE CONTROL,LOGICAL, OR INTEGER TO BE 'TRUE' OR 'FALSE'****)%
	IF .CNARGNODE[VALTP1] NEQ INTEG1
	THEN RETURN .CNODE;

	OLDCNODE_.CNODE;

	IF .CNARGNODE[CONST2] EQL TRUE
	THEN
	%(***IF CONSTANT ARG IS "TRUE"*******)%
	BEGIN

		CASE .CNODE[OPERSP] OF SET

		%(***FOR AND***)%
		CNODE_.VARGNODE;

		%(***FOR OR***)%
		CNODE_.CNARGNODE;

		%(***FOR EQV***)%
		CNODE_.VARGNODE;

		%(***FOR XOR***)%
		%(****TRUE XOR A=NOT A****)%
		%(******(IN ORDER TO PASS A "NOT" BACK UP IN THE TREE WOULD HAVE TO
			FIRST EXAMINE THE OPRCLS OF THE PARENT. SINCE THIS IS A RARE CASE,
			DONT BOTHER)****)%
		BEGIN
		END

		TES;
	END

	ELSE
	IF .CNARGNODE[CONST2] EQL FALSE
	THEN
	%(***IF CONSTANT ARG IS FALSE***)%
	BEGIN
		CASE .CNODE[OPERSP] OF SET

		%(***FOR AND***)%
		CNODE_.CNARGNODE;

		%(***FOR OR*****)%
		CNODE_.VARGNODE;

		%(***FOR EQV****)%
		%(****FALSE EQV A = NOT A****)%
		%(******(IN ORDER TO PASS A "NOT" BACK UP IN THE TREE WOULD HAVE TO
			FIRST EXAMINE THE OPRCLS OF THE PARENT. SINCE THIS IS A RARE CASE,
			DONT BOTHER)****)%
		BEGIN
		END;

		%(***FOR XOR*****)%
		CNODE_.VARGNODE

		TES;

	END;


	%(***IF HAVE REPLACED THE OLD CNODE BY "VARGNODE" AND THERE WAS A "NOTFLG"
		SET IN THE OLD CNODE OVER "VARGNODE", MUST SET THAT FLAG IN THE
		NEW PARENT OF VARGNODE****)%
	IF .CNODE EQL .VARGNODE
	THEN 
	BEGIN		OWN VNOTFLG;

		! IF TYPE CONVERSION NODE IS BEING PROMOTED, WE MUST
		!TAKE INTO CONSIDERATION THE FACT THAT IT MAY HAVE TO
		!GENERATE CODE NOW WHERE IT DIDN'T USED TO...
		IF .CNODE[OPRCLS] EQL TYPECNV THEN CNODE[NOCNVFLG]_0;
		VNOTFLG_(IF .VARGNODE EQL .OLDCNODE[ARG1PTR]
			THEN .OLDCNODE[A1NOTFLG]
			ELSE .OLDCNODE[A2NOTFLG]);
		IF .VNOTFLG
		THEN
		BEGIN
			IF TAKNOTARG(.OLDCNODE[PARENT])	!IF THE NOT CAN BE PROPAGATED
			THEN				! BACK UP TO THE NEW PARENT OF VARGNODE
			NOTFLG_NOT .NOTFLG		! THEN WILL DO SO
			ELSE				!IF CANNOT
			RETURN .OLDCNODE		! THEN GIVE UP ON THIS OPTIM
		END
	END;


	%(***IF HAVE THE OLD CNODE BY A VARIABLE OR CONSTANT, SET THE VALFLG IN ITS
		PARENT.
		IF HAVE REPLACED IT BY AN EXPRESSION, SET THE PARENT PTR OF THE
		EXPRESSION.
	*********)%
	IF .CNODE[OPRCLS] EQL DATAOPR OR .CNODE[OPRCLS] EQL REGCONTENTS
	THEN
	SETPVAL(.OLDCNODE)
	ELSE
	CNODE[PARENT]_.OLDCNODE[PARENT];

	RETURN .CNODE;

END;



GLOBAL ROUTINE ARCMB(CNODE,CNARGNODE,VARGNODE,ARG1CFLG)=
%(****************************************************************************
	THIS ROUTINE IS CALLED DURING PHASE 2 SKEL WHEN ONE OF THE
	ARGS OF AN ARITHMETIC OPERATOR IS A CONSTANT
	IT COLLAPSES
		0 + A = A
		0 - A = -A
		0 * A = 0
		0/A = 0
		A ** 0 = 1 (CANNOT OPTIMIZE 0**A BECAUSE A MIGHT BE 0 AT RUN TIME)
		1 * A = A
		A / 1 = A
		1 ** A  = 1
		A ** 1 = A
	IT ALSO TRANSFORMS MULTIPLICATION AND DIVISION BY A POWER
	OF 2 INTO THE OPERATION "P2MUL" (IE THE MULT/DIV NODE IN
	THE TREE IS CHANGED TO A "P2MUL" NODE); AND MULT BY
	A POWER OF 2 PLUS ONE TO A "P2PL1MUL"

	CALLED WITH THE ARGS
		CNODE - PTR TO THE NODE FOR THE ARITH OPERATION
		CNARGNODE - PTR TO THE CONSTANT ARG
		VARGNODE - PTR TO THE VARIABLE ARG
		ARG1CFLG - FLAG FOR "CONSTANT ARG IS THE 1ST ONE"
***************************************************************************)%
BEGIN
![761] KGFINT for IDINT on /GFLOATING
%[761]%	EXTERNAL KDPINT,KGFINT;		!TO PERFORM IDINT FUNCTION
	LABEL P2OPTIM;
	EXTERNAL PROPNEG;
	OWN PEXPRNODE OLDCNODE;		!KEEP PTR TO THE ORIGINAL NODE WERE CALLED WITH


	MAP PEXPRNODE CNODE:CNARGNODE:VARGNODE;
	OWN NEGVARFLG;				!THIS FLAG IS SET IFF THE NEGFLG
						! FOR THE VARIABLE ARG IS SET IN CNODE
	OWN INTEGFLG;				!THIS FLAG IS SET IF THE VALTP1
						! FIELD OF THE CONSTANT IS "INTEG1"

	OWN KH,KL;				!THE CONSTANT STORED IN "CNARGNODE"
						! FOR KA10 DP AND REAL (WHICH ARE
						! UNROUNDED UNTIL FINAL OUTPUT
						! THESE 2 WDS CONTAIN THE ROUNDED FORM
	OWN ONEFLG:MONEFLG;			!THESE FLAGS ARE SET IFF THE CONSTANT ARG IS 1
						! OR -1 RESPECTIVELY

	BIND F1 =	#201400000000;		!FLOATING POINT 1
	BIND FM1 =	#576400000000;		!FLOATING POINT -1
	MACRO RLP2M =	#000400000000$;		!MASK FOR A (JUSTIFIED) REAL POWER OF 2
	MACRO MANTMSK =	#000777777777$;		!MASK TO GET THE MANTISSA OF A FLOATING PT NUMBER

![761] /GFLOATING constants
%[761]%	BIND G1 =	#200140000000;		!FLOATING POINT 1
%[761]%	BIND GM1 =	#577640000000;		!FLOATING POINT -1
%[761]%	MACRO GFP2M =	#000040000000$;		!MASK FOR A (JUSTIFIED) REAL POWER OF 2
%[761]%	MACRO GMANTMSK =	#000077777777$;		!MASK TO GET THE MANTISSA OF A FLOATING PT NUMBER




	%(***DEFINE MACROS AND ROUTINES TO TEST PROPERTIES OF CONSTANTS ***)%

	%(****TO TEST FOR A CONSTANT EQUAL TO 0***)%
	MACRO ZERCNST=
		.KH EQL 0 AND .KL EQL 0$;

	%(***TO COUNT THE # OF MULTIPLIES REQUIRED TO REACH
	    A SPECIFIED POWER***)%

	GLOBAL ROUTINE CNTMPY(POWER)=
	BEGIN
	LOCAL BASE NUMOP;
	NUMOP_0;
	IF .POWER NEQ 0 THEN
	WHILE .POWER NEQ 1 DO
	BEGIN
		NUMOP_.NUMOP+1+.POWER<0,1>;	!COUNT # OF MULTIPLIES
		POWER_.POWER^(-1)		!SHIFT OUT A POWER
	END;
	RETURN .NUMOP
	END;

	%(****TO TEST FOR A CONSTANT EQUAL TO 1***)%

	ROUTINE ONECNST = 
	BEGIN
		IF .INTEGFLG
		THEN 
		.KL EQL 1
		ELSE
![761] Use right form of constant under /GFLOATING
%[761]%		IF .GFLOAT
%[761]%			THEN .KH EQL G1 AND .KL EQL 0
%[761]%			ELSE .KH EQL F1 AND .KL EQL 0
	END;
	
	%(***TO TEST FOR A CONSTANT EQUAL TO -1*****)%
	ROUTINE MONECNST=
	BEGIN
		IF .INTEGFLG
		THEN 
		.KL EQL -1
		ELSE
![761] Use right form of constant under /GFLOATING
%[761]%		IF .GFLOAT
%[761]%			THEN .KH EQL GM1 AND .KL EQL 0
%[761]%			ELSE .KH EQL FM1 AND .KL EQL 0
	END;



	%(****TO TEST FOR A CONSTANT WHICH IS EQUAL TO AN INTEGER (IE EITHER AN INTEGER OR
		A REAL WHICH IS EQUAL TO AN INTEGER*****)%
	ROUTINE INTEGC=
	BEGIN
		IF .INTEGFLG THEN 1 ELSE
		BEGIN
			LOCAL EXP;
			MACHOP LSHC=#246;
			REGISTER CN[2];
			CN[0]_.KH;
			CN[1]_.KL^1;
![761] Use right form of check for constant under /GFLOATING
%[761]%			IF .GFLOAT
%[761]%			THEN
%[761]%			BEGIN
%[761]%				EXP_.KH<24,11>;		!LOAD EXPONENT
%[761]%				IF .KH LSS 0 THEN EXP_.EXP XOR #3777;	!MAKE POSITIVE
%[761]%				EXP_.EXP - #2000;	!CONVERT TO REAL EXPONENT
%[761]%				IF .EXP LEQ 0 OR .EXP GTR 35 THEN 0 ELSE
%[761]%				BEGIN
%[761]%					LSHC(CN,.EXP+12);
%[761]%					.CN[0] EQL 0 AND .CN[1] EQL 0
%[761]%				END
%[761]%			END
%[761]%			ELSE
%[761]%			BEGIN
%[761]%				EXP_.KH<27,8>;		!LOAD EXPONENT
%[761]%				IF .KH LSS 0 THEN EXP_.EXP XOR #377;	!MAKE POSITIVE
%[761]%				EXP_.EXP - #200;	!CONVERT TO REAL EXPONENT
%[761]%				IF .EXP LEQ 0 OR .EXP GTR 35 THEN 0 ELSE
%[761]%				BEGIN
%[761]%					LSHC(CN,.EXP+9);
%[761]%					.CN[0] EQL 0 AND .CN[1] EQL 0
%[761]%				END
%[761]%			END
		END
	END;


	%(***TO TEST FOR A CONSTANT EQUAL TO A POWER OF 2 (OR MINUS A POWER OF 2)*********)%
	ROUTINE POWEROF2 =
	BEGIN
		IF .INTEGFLG
		THEN
		%(***FOR A POSITIVE INTEGER I - I IS A POWER OF 2 IFF IT HAS NO BITS IN
			COMMON WITH (I-1)****)%
		BEGIN
			REGISTER RT;
			RT_.KL;
			IF .RT LSS 0 THEN RT_-.RT;
			(.RT AND (.RT-1)) EQL 0
		END

		ELSE
		%(***FOR REAL, DOUBLE-PREC, AND COMPLEX - 1ST WD SHOULD
			HAVE MANTISSA=400000000 (KLDP) OR 40000000 (GFLOAT)
			2ND WD SHOULD BE 0*******)%
![761] Use right form of constant under /GFLOATING
%[761]%		IF .GFLOAT
%[761]%		THEN (.KH AND GMANTMSK) EQL GFP2M AND .KL EQL 0
%[761]%		ELSE (.KH AND MANTMSK) EQL RLP2M AND .KL EQL 0
	END;

	%(****TO DETERMINE THE VALUE OF N FOR A CONSTANT KNOWN TO BE EQUAL TO 2**N *****)%
	ROUTINE P2VAL =
	BEGIN
		IF .INTEGFLG
		THEN
		35-FIRSTONE( ABS(.KL))
		ELSE
![761] Use right form of constant under /GFLOATING
%[761]%		IF .GFLOAT
%[761]%		THEN ABS(.KH)^(-24) - #2000 -1	! exponent of the real number
%[761]%						!   minus 1
%[761]%		ELSE ABS(.KH)^(-27) - #200 - 1	!EXPONENT OF THE REAL NUMBER
%[761]%						! MINUS 1
	END;


	%(*****TO TEST FOR A CONSTANT EQUAL TO A POWER OF 2 PLUS 1 (OR MINUS (A POWER OF 2 PLUS 1))***)%
	ROUTINE P2PLUS1=
	BEGIN
		IF .INTEGFLG
		THEN
		%(****FOR A POSITIVE INTEGER I - I-1 IS A POWER OF 2
			IFF I-1 HAS NO BITS IN COMMON WITH I-2****)%
		BEGIN
			REGISTER RT;
			RT_.KL;
			IF .RT LSS 0 THEN RT_-.RT;
			((.RT-1) AND (.RT-2)) EQL 0
		END

		ELSE
		%(****FOR A REAL,DOUBLE-PREC,OR COMPLEX********)%
		BEGIN
			REGISTER RT;
			IF .KL NEQ 0 
			THEN FALSE			!(IGNORE DOUBLE-PREC CASES
							! GREATER THAN 2**27)

			ELSE
			BEGIN
				RT_ABS(.KH) FSBR F1;		!FLOATING PT VAL FOR THIS
									! NUMBER MINUS 1
				 (.RT AND MANTMSK) EQL RLP2M
					AND (.RT GTR 0)
			END
		END
	END;

	%(***TO DETERMINE THE VALUE OF N FOR A CONSTANT KNOWN TO BE 2**N + 1 ******)%
	ROUTINE P2VL1 =
	BEGIN
		REGISTER RT;
		IF .INTEGFLG
		THEN
		35-FIRSTONE( ABS(.KL)- 1)
		ELSE
		BEGIN
			RT_ABS(.KH) FSBR F1;		!MUST SUBTRACT 1 BEFORE LOOK AT EXPONENT
						! IN ORDER TO CORRECTLY HANDLE 1.5,1.25,...
			(.RT)^(-27) - 128 - 1 	!EXPONENT MINUS 1
		END
	END;


	ROUTINE RETURNNEGV(CNODE,VARGNODE)=
	%(**************************************
		ROUTINE TO CAUSE CNODE TO BE REPLACED BY THE NEGATIVE OF
		VARGNODE (WHICH ONE WANTS TO DO FOR:
			(-1)*V
			(-V)**1
			V/(-1)
		FIRST TRIES TO PROPAGATE THE NEG DOWN OVER V. IF IT FAILS
		AT THAT, THEN IF A NEG CAN BE PROPAGATED BACK UP THE TREE
		DOES THAT.
	***************************************)%
	BEGIN
		MAP PEXPRNODE CNODE:VARGNODE;
		EXTERNAL PROPNEG,TAKNEGARG,MAKPR1;

		IF .VARGNODE[OPR1] EQL CONSTFL	!IF THE ARG IS A CONSTANT,
		THEN RETURN NEGCNST(VARGNODE)	! THEN CAN SIMPLY NEGATE IT

		ELSE
		IF PROPNEG(.VARGNODE)	!IF ARE SUCCESSFUL IN PROPAGATING THE NEG
		THEN RETURN .VARGNODE	! OVER THE VARIABLE ARG, CAN JUST RETURN
					! THE VARIABLE ARG
		ELSE
		IF .NOTFLG		!IF THERE IS A NOTFLG BEING PROPAGATED
		THEN RETURN .CNODE	!CANT PROPAGATE ANEG BACK UP

		ELSE
		IF TAKNEGARG(.CNODE[PARENT])	!IF PARENT OF CNODE CAN HAVE A
		THEN				! NEG PROPAGATED INTO IT
		BEGIN
			NEGFLG_NOT .NEGFLG;
			RETURN .VARGNODE
		END
		ELSE
		%(***OTHERWISE, INSERT A NEGATE NODE INTO THE TREE ABOVE VARGNODE***)%
		RETURN MAKPR1(.CNODE[PARENT],NEGNOT,NEGOP,.CNODE[VALTYPE],0,.VARGNODE)
	END;



	%(*********START OF ROUTINE********************************************)%


	OLDCNODE_.CNODE;


	%(***SET A FLAG INDICATING WHETHER THE CONSTANT IS INTEGER OR OCTAL/LOGICAL***)%
	INTEGFLG_(.CNARGNODE[VALTP1] EQL INTEG1);

	%(***SET THE VARIABLES KH AND KL TO THE 2 WDS OF THE CONSTANT WHOSE
		PROPERTIES ARE TO BE EXAMINED. IF ARE COMPILING  ON THE
		KA10, THEN DOUBLE-PREC AND REAL CONSTANTS ARE NOT ROUNDED
		UNTIL THE END OF COMPILATION. HENCE MUST ROUND THEM IN ORDER
		TO TEST THEIR PROPERTIES***)%
		KH_.CNARGNODE[CONST1];
		KL_.CNARGNODE[CONST2];


	%(***SET THE FLAG NEGVARFLG IFF THE NEG FLAG IS SET FOR THE VARIABLE ARG***)%
	NEGVARFLG_ (IF .ARG1CFLG
			THEN .CNODE[A2NEGFLG]
			ELSE .CNODE[A1NEGFLG]);


	
	%(***IF CONSTANT ARG IS 0, COLLAPSE CNODE*****)%
	IF ZERCNST
	THEN
	BEGIN
		CASE .CNODE[OPERSP] OF SET

		%(**********FOR ADD*************)%
		BEGIN
			IF .NEGVARFLG
			THEN
			%(***IF HAVE 0-A,  MUST PERFORM 'NEG' ON A WHEN ELIMINATE CNODE***)%
			BEGIN
				IF .NOTFLG
				THEN
				%(***SINCE CANNOT PROPAGATE NEG UP ACROSS NOT - 
					DONT BOTHER COLLAPSING IF THERE IS 
					AN UNPROPAGATED 'NOT' HERE*******)%
				RETURN .CNODE;

		%(***HAVE ALREADY PERFORMED NEG/NOT PROPAGATION
					ON THE VARIABLE ARG - SO SIMPLY PASS THIS
					NEW 'NEG' BACK UP TO THE PARENT OF CNODE
					IF THE PARENT IS A NODE THAT CAN ABSORB NEG*****)%
				IF .NEGFLG OR TAKNEGARG(.CNODE[PARENT])
				THEN
				NEGFLG_NOT .NEGFLG
				ELSE
				RETURN .CNODE;
			END;

			CNODE_.VARGNODE;
		END;

		%(**********FOR SUBTRACT**********)%
		SKERR();		!SHOULD HAVE REMOVED ALL SUB NODES

		%(********FOR MULTIPLY***********)%
		CNODE_.CNARGNODE;		!0*X=0

		%(********FOR DIVIDE***********)%
		BEGIN
			IF .ARG1CFLG THEN CNODE_.CNARGNODE;	!0/X=0
		END;

		%(***FOR EXPONENTIATION*******)%
		BEGIN
			%(***OPTIMIZE A**0, BUT CANNOT OPTIMIZE 0**A (BECAUSE
				AT RUN TIME A MIGHT BE 0)***)%
			IF NOT .ARG1CFLG
			THEN
			%(****X**0=1*****)%
			CNODE_(IF .CNODE[VALTP1] EQL INTEG1
				THEN MAKECNST(.CNODE[VALTYPE],0,1)
![761] Make right form of constant under /GFLOATING
%[761]%				ELSE IF .GFLOAT
%[761]%					THEN MAKECNST(.CNODE[VALTYPE],G1,0)
%[761]%					ELSE MAKECNST(.CNODE[VALTYPE],F1,0) );
		END;

		TES;
	END


	ELSE



	%(****DETERMINE WHETHER CONSTANT ARG IS ONE OR MINUS ONE***)%
	IF (ONEFLG_ONECNST()) OR (MONEFLG_MONECNST())
	THEN
	BEGIN
		CASE .CNODE[OPERSP] OF SET

		%(***FOR ADD - DO NOTHING***)%
		RETURN .CNODE;

		%(***FOR SUB - DO NOTHING***)%
		RETURN .CNODE;

		%(***FOR MUL - 
			A*1=A
			(-A)*(-1)=A
			(-A)*1=-A
			A*(-1)=-A
		********)%
		BEGIN
			IF .MONEFLG EQL .NEGVARFLG
			THEN
			CNODE_ .VARGNODE
			ELSE
			CNODE_RETURNNEGV(.CNODE,.VARGNODE)
		END;

		%(****FOR DIV - 
			A/1=A
			(-A)/(-1)=A
			(-A)/1=-A
			A/(-1)=-A
		**********)%
		BEGIN
			%(***IF THE 1 IS THE DIVIDEND, CANNOT COLLAPSE***)%
			IF .ARG1CFLG
			THEN RETURN .CNODE;

			IF .MONEFLG EQL .NEGVARFLG
			THEN
			CNODE_ .VARGNODE
			ELSE
			CNODE_RETURNNEGV(.CNODE,.VARGNODE)
		END;

		%(****FOR EXPONENTIATION  -
			A**1=A
			(-A)**1=-A
			A**(-1)=1/A
			(-A)**(-1)=1/(-A)
			1**A=1
			1**(-A)=1
			(-1)**I=TEST FOR I EVEN (IF I IS INTEGER)
		*******)%
		BEGIN
			IF .ARG1CFLG
			THEN
			BEGIN
				IF .MONEFLG
				THEN
				%(***(-1)**A****)%
				RETURN .CNODE
				ELSE
				%(***1**A*******)%
				CNODE_ .CNARGNODE
			END
			ELSE
			IF .MONEFLG
			THEN
			%(***FOR A**(-1) AND (-A)**(-1), TRANSFORM THE EXPONEN NODE TO
				A DIVISION NODE*****)%
			BEGIN
				CNODE[OPR1]_DIVOPF;
				CNODE[ARG2PTR]_.CNODE[ARG1PTR];
				CNODE[A2FLGS]_.CNODE[A1FLGS];
				CNODE[ARG1PTR]_
					(IF .CNODE[VALTP1] EQL INTEG1
					THEN
					MAKECNST(.CNODE[VALTYPE],0,1)
					ELSE
![761] Make right form of constant under /GFLOATING
%[761]%					IF .GFLOAT
%[761]%						THEN MAKECNST(.CNODE[VALTYPE],G1,0)
%[761]%						ELSE MAKECNST(.CNODE[VALTYPE],F1,0) );
				CNODE[A1FLGS]_VLFLSET;		!ONLY THE VAL FLG
			END
			ELSE
			IF .NEGVARFLG
			%(***FOR -A**1 - PROPAGATE NEG BACK UP***)%
			THEN
			CNODE_RETURNNEGV(.CNODE,.VARGNODE)
			ELSE
			%(***FOR A**1 *****)%
			CNODE_ .VARGNODE
		END;

		TES;

	END




	ELSE

	%(*** FOR EXPONENTIATION -
		OPTIMIZE ALL EXPONENTIATIONS WHICH CAN BE
		DONE IN FEWER THAN 8 MULTIPLIES
	********)%
	IF .CNODE[OPERSP] EQL EXPONOP THEN
	BEGIN
		IF (NOT .ARG1CFLG) AND INTEGC()  
			AND NOT (.VARGNODE[VALTYPE] EQL COMPLEX)
		THEN
		BEGIN
			LOCAL INTPOW;
			INTPOW_IF .INTEGFLG THEN .KL ELSE
			BEGIN
				C1H_.CNARGNODE[CONST1];
				C1L_.CNARGNODE[CONST2];
![761] Fold right form of constant under /GFLOATING
%[761]%				IF .GFLOAT
%[761]%					THEN COPRIX_KGFINT
%[761]%					ELSE COPRIX_KDPINT;
				CNSTCM();
				.C2L
			END;
			IF .INTPOW GEQ 0 THEN
			BEGIN
				LOCAL BASE EXPOPS;
				EXPOPS_CNTMPY(.INTPOW);	!COMPUTE # OF OPS
				IF .EXPOPS LEQ 8 THEN
				BEGIN
					CNODE[OPR1]_EXPCIF;
					IF NOT .INTPOW THEN CNODE[A1NEGFLG]_0;
					CNODE[A2FLGS]_0;
					CNODE[ARG2PTR]_.INTPOW
				END
			END
		END
	END



	ELSE

	! DO NOT ALLOW DOUBLE PRECISION ARGS THROUGH HERE, FOR TO DO
	!SO WOULD CAUSE FSC INSTRUCTIONS LATER WHICH ARE BAD CODE!
	IF .CNODE[VALTYPE] NEQ DOUBLPREC THEN

	%(****IF HAVE A MULTIPLICATION OR DIVISION BY A POWER OF 2, REPLACE CNODE
		 BY A "P2MUL" OR "P2DIV"  NODE***)%
	IF  POWEROF2()
	THEN
	BEGIN
		IF .CNODE[OPERSP] EQL MULOP OR (.CNODE[OPERSP] EQL DIVOP AND NOT .ARG1CFLG)
		THEN
P2OPTIM:	BEGIN
			%(***CANNOT OPTIMIZE INTEGER DIVIDE IF DIVIDEND WILL NOT
				FIT IN A HALF-WD****)%
			IF .CNODE[OPERSP] EQL DIVOP
			THEN
			BEGIN
				IF .INTEGFLG AND ABS(.KL) GTR #777777
				THEN LEAVE P2OPTIM;
			END;

			IF NEGATIVC(CNARGNODE)
			THEN
			%(***IF CONSTANT IS MINUS A POWER OF 2***)%
			BEGIN
				%(***TRANSFORM (-C)*A TO C*(-A) IF C IS A POWER OF 2***)%
				IF NOT PROPNEG(.VARGNODE)	!IF CANT PROPAGATE THE
				THEN				! NEG OVER THE VARIABLE ARG
				BEGIN
					%(***SET NEGFLG OVER THE VARIABLE ARG IN THE MULTIPLY NODE**)%
					IF .ARG1CFLG
					THEN CNODE[A2NEGFLG]_NOT .CNODE[A2NEGFLG]
					ELSE CNODE[A1NEGFLG]_NOT .CNODE[A1NEGFLG]
				END;
			END;

			%(***VARIABLE ARG SHOULD BE ARG1 UNDER THIS P2MUL NODE***)%
			IF .ARG1CFLG 
			THEN
			BEGIN
				CNODE[ARG1PTR]_.VARGNODE;
				A2TOA1FLGS(CNODE);		!SET FLAGS FOR  
								! ARG1 TO THOSE FOR ARG2
								!CLEAR FLAGS FOR ARG2
			END;

			%(***SET ARG2PTR FIELD TO THE POWER OF 2***)%
			CNODE[ARG2PTR]_P2VAL();
			CNODE[A2FLGS]_0;


			%(***FOR DIVISION SET OPERATOR FIELD OF CNODE TO "P2DIV'***)%
			IF .CNODE[OPERSP] EQL DIVOP
			THEN
			CNODE[OPR1]_P2DIVOPF
			ELSE
			%(***FOR MULT CHANGE OPERATOR FIELD OF CNODE TO 'P2MUL'***)%
			CNODE[OPR1]_P2MULOPF;

		END;
	END


	ELSE
	%(****IF HAVE MULTIPLICATION BY A POWER OF 2 PLUS 1, REPLACE CNODE BY A 'P2PL1MUL' NODE****)%
	IF .CNODE[OPERSP] EQL MULOP
	THEN
	BEGIN
		IF P2PLUS1()
		THEN
		BEGIN
			IF NEGATIVC(CNARGNODE)
			THEN
			%(***IF CONSTANT IS NEGATIVE, WILL WANT TO TRANSFORM (-C)*A INTO C*(-A)**)%
			BEGIN
				IF NOT PROPNEG(.VARGNODE)	!IF CANT PROPAGATE THE
				THEN				! NEG OVER THE VARIABLE ARG
				BEGIN
					%(***SET NEGFLG OVER THE VARIABLE ARG IN THE MULTIPLY NODE**)%
					IF .ARG1CFLG
					THEN CNODE[A2NEGFLG]_NOT .CNODE[A2NEGFLG]
					ELSE CNODE[A1NEGFLG]_NOT .CNODE[A1NEGFLG]
				END;
			END;

			%(***VARIABLE ARG SHOULD BE 1ST ARG UNDER THE NEW P2PL1MUL NODE***)%
			IF .ARG1CFLG
			THEN
			BEGIN
				CNODE[ARG1PTR]_.VARGNODE;
				A2TOA1FLGS(CNODE);		!SET FLAGS FOR NEW ARG1
								! (FROM FLAGS FOR 'OLD ARG2')
			END;

			%(***SET ARG2PTR FIELD TO THE POWER OF 2***)%
			CNODE[ARG2PTR]_P2VL1();
			CNODE[A2FLGS]_0;

			%(***SET THE OPERATOR FIELD OF CNODE TO P2PL1MUL***)%
			CNODE[OPR1]_P2PL1OPF;
		END;
	END;




	%(****IF HAVE REPLACED THE OLD CNODE BY A LEAF, SET THE VALFLG OF THE PARENT,
		OTHERWISE SET THE PARENT PTR OF THE NEW NODE***)%
	IF .CNODE[OPRCLS] EQL DATAOPR OR .CNODE[OPRCLS] EQL REGCONTENTS
%[1054]%	OR .CNODE[OPRCLS] EQL CMNSUB
	THEN
	SETPVAL(.OLDCNODE)
	ELSE
	CNODE[PARENT]_.OLDCNODE[PARENT];
	RETURN .CNODE;

END;

GLOBAL ROUTINE CMBEQLARGS(CNODE,SKEWFLAG)=
%(***************************************************************************
	ROUTINE TO COLLAPSE AN OPERATION ON EQUAL ARGS.
	COLLAPSES
		A+A=2*A
		A-A=0
		A/A=1
		A/(-A)=-1
		A AND A=A
		A AND (NOT A) = 0
		A OR A=A
		A OR (NOT A) = -1
		A EQV A = TRUE (-1)
		A EQV (NOT A) = FALSE (0)
		A XOR A = FALSE(0)
		A XOR (NOT A) = TRUE (-1)
		A EQ A =TRUE
		A LEQ A = TRUE
		A GEQ A = TRUE
		A NEQ A = FALSE
		A LSS A = FALSE
		A GTR A = FALSE

	CALLED WITH THE ARG CNODE A PTR TO AN EXPRESSION NODE OF OPRCLS
	RELATIONAL, ARITHMETIC, OR BOOLEAN IN WHICH EITHER  ARG1 IS IDENTICAL TO ARG2
	OR ARG1 IS AN EXPRESSION IN WHICH 2ND ARG IS IDENTICAL TO ARG2 AND
	OPERATOR IS IDENTICAL TO OPERATOR ON THE PARENT.
	IF "SKEWFLAG" IS TRUE, THEN THE 2ND CASE APPLIES.
**************************************************************************)%
BEGIN
	MAP PEXPRNODE CNODE;
	OWN PEXPRNODE ARG1NODE:RESNODE;
	OWN A1NEG:A1NOT:T1;
	OWN PEXPRNODE OLDCNODE;		!KEEP ORIG VAL OF CNODE


	BIND	F1 =	#201400000000,			!FLOATING PT 1
		FM1 =	#576400000000;			!FLOATING PT -1
![761] Define /GFLOATING 1.0, -1.0
%[761]%	BIND	G1 =	#200140000000,			!FLOATING PT 1
%[761]%		GM1 =	#577640000000;			!FLOATING PT -1


	OLDCNODE_.CNODE;

	%(****FOR AN ARITHMETIC OPERATOR************)%

	IF .CNODE[OPRCLS] EQL ARITHMETIC
	THEN
	BEGIN
		IF .CNODE[A1NOTFLG] NEQ .CNODE[A2NOTFLG]
		THEN RETURN .CNODE;

		%(***IF ARE LOOKING AT SKEWED ARGS UNDER AN NARY NODE, MUST LOOK AT
			THE FLAGS UNDER ARG1*****)%
		IF .SKEWFLAG
		THEN
		BEGIN
			ARG1NODE_.CNODE[ARG1PTR];
			A1NEG_.CNODE[A1NEGFLG] XOR .ARG1NODE[A2NEGFLG];
		END
		ELSE
		A1NEG_.CNODE[A1NEGFLG];

		%(***COLLAPSE THIS OPERATION IF CAN*****)%
		CASE .CNODE[OPERSP] OF SET

		%(***FOR ADD - IF A1NEGFLG DIFFERS FROM A2NEGFLG THEN
			COLLAPSE TO 0, OTHERWISE TRANSFORM TO P2MUL***)%
		BEGIN
		IF .CNODE[VALTYPE] NEQ DOUBLPREC
		THEN
		BEGIN

			%(***IF THE SIGNS ON THE ARGS TO BE COLLAPSED TOGETHER ARE IDENTICAL,
				THEN TRANSFORM CNODE INTO A P2MUL NODE***)%
			IF .A1NEG EQL .CNODE[A2NEGFLG] 
			THEN
			BEGIN
				CNODE[A2NEGFLG]_0;
				CNODE[ARG2PTR]_1;
				CNODE[OPR1]_P2MULOPF;

				%(***FOR THE SKEW CASE, TRANSFORM (B+A)+A 
					INTO B+(2*A)
					USE THE CORE THAT HELD (B+A) TO HOLD THE NEW + NODE
					USE THE CORE THAT HELD CNODE TO HOLD THE P2MUL NODE
					BECAUSE WE USE THE CORE FROM "CNODE" TO HOLD
					THE NEW "P2MUL" NODE, PARENT PTRS MUST BE RESET****)%
				IF .SKEWFLAG
				THEN
				BEGIN
					CNODE[ARG1PTR]_.ARG1NODE[ARG2PTR];	!PTR TO A
					CNODE[A1VALFLG]_.ARG1NODE[A2VALFLG];
					CNODE[A1NEGFLG]_.A1NEG;
					ARG1NODE[ARG2PTR]_.CNODE;
					ARG1NODE[A2FLGS]_0;
					ARG1NODE[PARENT]_.CNODE[PARENT];
					CNODE[PARENT]_.ARG1NODE;

					%(***HAVE OVERWRITTEN THE CONTENTS OF THE OLD CNODE,
						THEREFORE SHOULD NOT
						USE THE CODE AT THE END OF CMBEQLARGS WHICH
						ASSUMES THIS  NODE TO BE IN ITS ORIG STATE***)%
					RETURN .ARG1NODE;
				END
			END

			%(***IF THE SIGNS OF THE ARGS DIFFER, COLLAPSE THEM TOGETHER TO BE 0***)%
			ELSE
			BEGIN
				%(***IF THE IDENTICAL ARGS ARE SKEWED ON AN NARY NODE, RETURN
					THE 3RD ELEMENT OF THE NARY SUM (EG FOR
					A+B-B RETURN A*****)%
				IF .SKEWFLAG
				THEN
				BEGIN
					IF .ARG1NODE[A1NEGFLG]
					THEN NEGFLG_NOT(.NEGFLG);
					IF .ARG1NODE[A2NOTFLG]
					THEN NOTFLG_NOT(.NOTFLG);
					%(***REPLACE THE NARY NODE CNODE BY THE REMAINING ARG***)%
					CNODE_.ARG1NODE[ARG1PTR];
				END
				ELSE
				%(***REPLACE CNODE BY THE CONSTANT 0***)%
				CNODE_ MAKECNST(.CNODE[VALTYPE],0,0);
			END;
		END
		ELSE RETURN .CNODE
		END;

		%(***SHOULD NEVER SEE A SUBTRACT (ALL SUBTRACTS HAVE BEEN TRANSFORMED
			TO ADD WITH A2NEGFLG)*******)%
		BEGIN
			SKERR();
			RETURN .CNODE;
		END;

		%(***FOR MULTIPLY - DO NOTHING****)%
		RETURN .CNODE;

		%(***FOR DIVISION - IF THE SIGNS OF THE ARGS DIFFER, COLLAPSE THEM
			TOGETHER TO BE -1, IF THEY ARE THE SAME TO BE 1***)%
		BEGIN

			%(***FOR THE SKEW CASE:
				(A/B)/B=A
				(A/-B)/B=-A
			**********)%
			IF .SKEWFLAG
			THEN
			BEGIN
				IF .ARG1NODE[A1NEGFLG]
				THEN NEGFLG_NOT(.NEGFLG);
				IF .ARG1NODE[A1NOTFLG]
				THEN NOTFLG_NOT(.NOTFLG);
				IF .A1NEG NEQ .CNODE[A2NEGFLG]
				THEN NEGFLG_ NOT(.NEGFLG);
				%(***REPLACE THE NARY NODE CNODE BY THE REMAINING ARG***)%
				CNODE_.ARG1NODE[ARG1PTR];
			END

			%(***COLLAPSE B/B=1
					-B/B=-1
				REPLACE THE NODE CNODE BY A CONSTANT NODE - 
				FIXED OR FLOATING ONE OR MINUS ONE
			****)%
			ELSE

			CNODE_
			BEGIN
				IF .A1NEG EQL .CNODE[A2NEGFLG]
				THEN 
				BEGIN
					
					IF .CNODE[VALTP1] EQL INTEG1
					THEN MAKECNST(.CNODE[VALTYPE],0,1)
![761] Make right form of constant under /GFLOATING
%[761]%					ELSE IF .GFLOAT
%[761]%						THEN MAKECNST(.CNODE[VALTYPE],G1,0)
%[761]%						ELSE MAKECNST(.CNODE[VALTYPE],F1,0)
				END
				ELSE
				BEGIN
					IF .CNODE[VALTP1] EQL INTEG1
					THEN MAKECNST(.CNODE[VALTYPE],0,-1)
![761] Make right form of constant under /GFLOATING
%[761]%					ELSE IF .GFLOAT
%[761]%						THEN MAKECNST(.CNODE[VALTYPE],GM1,0)
%[761]%						ELSE MAKECNST(.CNODE[VALTYPE],FM1,0)
				END
			END;
		END;

		%(***FOR EXPONENTIATION - DO NOTHING*****)%
		RETURN .CNODE

		TES;
	END

	ELSE
	IF .CNODE[OPRCLS] EQL BOOLEAN
	THEN
	BEGIN
		IF .CNODE[A1NEGFLG] NEQ .CNODE[A2NEGFLG] THEN RETURN .CNODE;

		ARG1NODE_.CNODE[ARG1PTR];


		%(***IF ARE LOOKING AT A SKEWED NARY CASE, LOOK AT NOT FLAG
			ON THE LEFT SUBNODE RATHER THAN ON THE PARENT***)%
		IF .SKEWFLAG
		THEN
		A1NOT_.ARG1NODE[A2NOTFLG]
		ELSE
		A1NOT_.CNODE[A1NOTFLG];

		CASE .CNODE[OPERSP] OF SET

		%(***FOR AND*****************)%
		BEGIN
			IF .A1NOT NEQ .CNODE[A2NOTFLG]
			THEN CNODE_ MAKECNST(LOGICAL,0,FALSE)
			ELSE
			BEGIN
				IF .CNODE[A1NOTFLG] THEN NOTFLG_ NOT .NOTFLG;
				CNODE_ .ARG1NODE
			END;
		END;

		%(****FOR OR*************************)%
		BEGIN
			IF .A1NOT NEQ .CNODE[A2NOTFLG]
			THEN
			CNODE_ MAKECNST(LOGICAL,0,-1)
			ELSE
			BEGIN
				IF .CNODE[A1NOTFLG] THEN NOTFLG_NOT .NOTFLG;
				CNODE_ .ARG1NODE;
			END
		END;

		%(*****FOR EQV***********************)%
		BEGIN
			%(**DONT BOTHER WITH THE SKEW CASE***)%
			IF .SKEWFLAG
			THEN
			BEGIN
			END
			ELSE
			IF .A1NOT NEQ .CNODE[A2NOTFLG]
			THEN
			CNODE_ MAKECNST(LOGICAL,0,FALSE)
			ELSE
			CNODE_ MAKECNST(LOGICAL,0,-1)
		END;

		%(******FOR XOR**********************)%
		BEGIN
			%(**DONT BOTHER WITH THE SKEW CASE***)%
			IF .SKEWFLAG
			THEN
			BEGIN
			END
			ELSE
			IF .A1NOT NEQ .CNODE[A2NOTFLG]
			THEN
			CNODE_ MAKECNST(LOGICAL,0,-1)
			ELSE
			CNODE_ MAKECNST(LOGICAL,0,FALSE)
		END

		TES;
	END

	ELSE
	IF .CNODE[OPRCLS] EQL RELATIONAL
	THEN
	BEGIN
		%(****DEFINE TABLE OF RESULTS FOR EACH OF THE RELATIONALS***)%
		BIND RELRSLT=PLIT (
			FALSE,				!UNUSED OPERSP
			FALSE,				!FOR L
			TRUE,				!FOR E
			TRUE,				!FOR LE
			FALSE,				!UNUSED OPERSP
			TRUE,				!FOR GE
			FALSE,				!FOR N
			FALSE);				!FOR G
		IF (.CNODE[A1NOTFLG] NEQ .CNODE[A2NOTFLG]) OR 
			(.CNODE[A1NEGFLG] NEQ .CNODE[A2NEGFLG])
		THEN
		RETURN .CNODE;

		CNODE_ MAKECNST(LOGICAL,0,.RELRSLT[.CNODE[OPERSP]]);
	END

	ELSE
	SKERR();


	%(***IF THE NODE TO REPLACE CNODE IS A LEAF, SET THE VALFLG IN THE PARENT OF THE
		OLD CNODE. OTHERWISE SET THE PARENT PTR OF THE NEW CNODE***)%
	IF .CNODE[OPRCLS] EQL DATAOPR OR .CNODE[OPRCLS] EQL REGCONTENTS
	THEN
	SETPVAL(.OLDCNODE)
	ELSE
	CNODE[PARENT] _ .OLDCNODE[PARENT];


	RETURN .CNODE;

END;

GLOBAL ROUTINE FOLDLIF=
%(***************************************************************************
	ROUTINE TO FOLD A LOGICAL IF STATEMENT IN WHICH THE
	CONDITIONAL EXPRESSION IS A CONSTANT.
	IF THE CONSTANT IS 'FALSE', THE IF STMNT BECOMES A CONTINUE.
	IF THE CONSTANT IS 'TRUE', THE IF STMNT BECOMES A CONTINUE AND THE
	SUBSTATEMENT IS LINKED TO IT AS THE NEXT STATEMENT.
	THE GLOBAL "CSTMNT" POINTS TO THE STATEMENT.
***************************************************************************)%
BEGIN
	EXTERNAL DELGOLABS;	!ROUTINE TO DECR REF CTS TO ALL VARS ON A GOTO LIST

	EXTERNAL CSTMNT;
	MAP BASE CSTMNT;
	OWN PEXPRNODE CONDEXPR;
	REGISTER BASE SUBSTMNT;
	REGISTER PEXPRNODE DELLABENT;	!PTR TO STMNT NUMBER TABLE ENTRY FOR A LABEL
					! TO WHICH A REFERENCE IS BEING DELETED
%[1074]%	LOCAL TRUEFLG;		!TRUE iff the condition is TRUE


	CONDEXPR_.CSTMNT[LIFEXPR];

	SUBSTMNT_.CSTMNT[LIFSTATE];

![1074] Make the check on the truth of the conditional look at A1NOTFLG

%[1074]%	TRUEFLG_ NEGATIVC(CONDEXPR);	! If negative, then TRUE else FALSE
%[1074]%	If .CSTMNT[A1NOTFLG]	! If statement was flagged to NOT the conditional
%[1074]%	THEN
%[1074]%	TRUEFLG_ NOT .TRUEFLG;

	%(***CHANGE CSTMNT TO A CONTINUE STATEMENT***)%
	CSTMNT[SRCID]_CONTID;

	%(***IF THE CONDITIONAL EXPRESSION IS TRUE, LINK THE SUBSTATEMENT INTO
		THE PROGRAM AS THE STATEMENT AFTER THE CONTINUE***)%
%[1074]%	IF .TRUEFLG
	THEN
	BEGIN
		SUBSTMNT[SRCLINK]_.CSTMNT[SRCLINK];
		CSTMNT[SRCLINK]_.SUBSTMNT;
	END

	ELSE
	%(***IF THE CONDITIONAL IS FALSE, ARE REMOVING THE SUBSTATEMENT FROM THE PROGRAM -
		IF THE SUBSTATEMENT REFERENCES ANY LABELS, DECR THE REF CTS OF THOSE LABELS**)%
	BEGIN
		SELECT .SUBSTMNT[SRCID] OF NSET
		GOTOID:
		BEGIN
			DELLABENT_.SUBSTMNT[GOTOLBL];	!FOR A GOTO, DECR CT TO THE LABEL
			DELLABENT[SNREFNO]_.DELLABENT[SNREFNO]-1;
		END;

		IFAID:					!FOR AN ARITH IF
		BEGIN				!DECR CTS TO THE 3 LABELS
			DELLABENT_.SUBSTMNT[AIFGTR];
			DELLABENT[SNREFNO]_.DELLABENT[SNREFNO]-1;
			DELLABENT_.SUBSTMNT[AIFLESS];
			DELLABENT[SNREFNO]_.DELLABENT[SNREFNO]-1;
			DELLABENT_.SUBSTMNT[AIFEQL];
			DELLABENT[SNREFNO]_.DELLABENT[SNREFNO]-1;
		END;

		AGOID:					!FOR ASSIGNED GOTO
		BEGIN
			IF .SUBSTMNT[GOTOLIST] NEQ 0	!IF IT HAS A LIST OF LABELS
			THEN DELGOLABS(.SUBSTMNT)	! DECR REFS TO ALL LABELS ON THAT LIST
		END;

		CGOID:					! FOR A COMPUTED GOTO
		DELGOLABS(.SUBSTMNT);		! DECR REFS TO LABELS ON THE LIST

		TESN;
	END;
END;

GLOBAL ROUTINE FOLDAIF=
%(***************************************************************************
	ROUTINE TO FOLD AN ARITHMETIC IF WHEN THE CONDITIONAL EXPRESSION IS A CONSTANT.
	CHANGES THE ARITH IF STMNT TO A GOTO.
***************************************************************************)%
BEGIN
	EXTERNAL CSTMNT;
	MAP BASE CSTMNT;
	OWN PEXPRNODE CONDEXPR;
	OWN TSTVAL;
	REGISTER PEXPRNODE LABDEL1:LABDEL2;	!PTRS TO THE STMNT NUMBER TABLE ENTRIES
					! FOR THE 2 LABELS TO WHICH REFERENCES WILL BE DELETED

	CONDEXPR_.CSTMNT[AIFEXPR];

	%(***MAKE CSTMNT BE A GOTO****)%
	CSTMNT[SRCID]_GOTOID;


	%(***THE SIGN OF A CONSTANT IS DETERMINED BY ITS 2ND WD FOR INTEGER VALUES, 
		BY ITS 1ST WD FOR REAL AND DOUBLE-PRECISION*****)%
	IF .CONDEXPR[VALTP1] EQL INTEG1
	THEN
	TSTVAL_.CONDEXPR[CONST2]
	ELSE
	TSTVAL_.CONDEXPR[CONST1];

	CSTMNT[GOTOLBL]_
	BEGIN
		IF .TSTVAL LSS 0
		THEN
		(LABDEL1_.CSTMNT[AIFGTR]; LABDEL2_.CSTMNT[AIFEQL];.CSTMNT[AIFLESS])
		ELSE
		IF .TSTVAL EQL 0
		THEN
		(LABDEL1_.CSTMNT[AIFGTR]; LABDEL2_.CSTMNT[AIFLESS];.CSTMNT[AIFEQL])
		ELSE
		(LABDEL1_.CSTMNT[AIFEQL]; LABDEL2_.CSTMNT[AIFLESS];.CSTMNT[AIFGTR])
	END;

	%(***DECREMENT THE REFERENCE CTS FOR THE LABELS TO WHICH REFERENCES HAVE BEEN REMOVED**)%
	LABDEL1[SNREFNO]_.LABDEL1[SNREFNO]-1;
	LABDEL2[SNREFNO]_.LABDEL2[SNREFNO]-1;

END;
END
ELUDOM