Trailing-Edge
-
PDP-10 Archives
-
FORTRAN-10_Alpha_31-jul-86
-
p2s2.bli
There are 12 other files named p2s2.bli in the archive. Click here to see a list.
!COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1972, 1986
!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: S. MURPHY/HPW/MD/DCE/JNG/TFV/MEM
MODULE P2S2(SREG=#17,VREG=#15,FREG=#16,DREGS=4,RESERVE(0,1,2,3),GLOROUTINES) =
BEGIN
GLOBAL BIND P2S2V = #11^24 + 0^18 + #4517; ! Version Date: 4-Oct-85
%(
***** 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)))
***** Begin Version 6 *****
61 1431 CKS 15-Dec-81
Add substring and concatenation to the CASEs in TAKNEGARG and
TAKNOTARG. The new nodes are analagous to existing nodes:
substring is like subtraction, concatenation is like a function
call.
***** End Revision History *****
***** Begin Version 11 *****
4517 MEM 4-Oct-85
In TAKNOTARG and TAKNEGARG, if we have a 1-char asmnt, return FALSE.
ENDV11
)%
![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;
%4517% REGISTER BASE LHS; !LHS of assignment
%(***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 NON-CHAR ASSIGNMENT AND ARITH-IF,
! PARENT CAN ABSORN NOT, OTHERWISE IT CANT
%4517% IF .PNODE[SRCID] EQL IFLID
%4517% THEN TRUE
%4517% ELSE IF .PNODE[SRCID] EQL ASGNID
%4517% THEN
%4517% BEGIN
%4517% LHS = .PNODE[LHEXP];
%4517% IF .LHS[OPR1] NEQ CHARFNFL !not char asmnt
%4517% THEN TRUE
%4517% ELSE FALSE
%4517% END
%4517% ELSE FALSE
END;
FALSE; !IOLSCLS - CANNOT PROPAGATE
FALSE; !INLINFN - CANNOT PROPAGATE FOR ALL OF
! THEM, SO DONT BOTHER
%1431% FALSE; !SUBSTRING - CANT, LIKE ARITH
%1431% FALSE !CONCATENATION - CANT, LIKE FN CALL
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;
%4517% REGISTER BASE LHS; !LHS of assignment
%(***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
%4517% IF .PNODE[SRCID] EQL IFAID
%4517% THEN TRUE
%4517% ELSE IF .PNODE[SRCID] EQL ASGNID
%4517% THEN
%4517% BEGIN
%4517% LHS = .PNODE[LHEXP];
%4517% IF .LHS[OPR1] NEQ CHARFNFL !not char asmnt
%4517% THEN TRUE
%4517% ELSE FALSE
%4517% END
%4517% ELSE FALSE
END;
FALSE; !IOLSCLS - CANNOT PROPAGATE NEG UP
FALSE; !INLINFN - CANNOT ALWAYS PROPAGATE NEG UP- SO
! DONT BOTHER
%1431% TRUE; !SUBSTRING - YES
%1431% FALSE !CONCATENATION - LIKE FN CALL
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