Trailing-Edge
-
PDP-10 Archives
-
BB-4157F-BM_1983
-
fortran/compiler/p2s1.bli
There are 26 other files named p2s1.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) DIGITAL EQUIPMENT CORPORATION 1972, 1983
!AUTHOR: S. MURPHY/JNG/DCE/TFV/CDM/RVM/AHM
MODULE P2S1(SREG=#17,VREG=#15,FREG=#16,DREGS=4,RESERVE(0,1,2,3),GLOROUTINES) =
BEGIN
GLOBAL BIND P2S1V = 7^24 + 0^18 + #1706; ! Version Date: 22-Dec-82
%(
***** Begin Revision History *****
57 ----- ----- DO NOT CHECK FOR EXPONEN INVOLVING A LOOP
INDEX UNTIL AFTER IN LINE EXPONENS HAVE BEEN
DETECTED (SO THAT I**2 DOESNT CAUSE THE LP INDEX
TO BE MATERIALIZED)
58 ----- ----- FIX TYPO IN "P2SKFN". WHEN REMOVE A NEG FROM
UNDER AN IN-LINE FN, WHEN
GETTING PTR TO NODE TO SET PARENT PTR, SHOULD
LOOK AT "CNODE[ARG1PTR]", (NOT ARGNODE[ARG1PTR])
59 ----- ----- IN "ARSKOPT", USE "KEXPIX" TO FOLD EXPONEN OF CONSTS
(RATHER THAN SQROP,CUBOP,P4OP)
60 434 19211 CHECK IF FN PARAM IS DO LOOP INDEX AFTER CONST
FOLDING IN CASE I+0 TYPE CONSTRUCTION., (JNG)
61 445 19632 REDUCE CHANCE OF STACK OVERFLOW BY CUTTING
DOWN NUMBER OF LOCALS FOR P2SKARITH, (DCE)
62 671 NVT WHEN SWAPPING ARGS, SWAP DEF PTS TOO, (DCE)
***** Begin Version 6 *****
63 761 TFV 1-Mar-80 -----
Remove KA10FLG and use /GFLOATING when rounding DP to SP
64 1031 TFV 25-Nov-80 ------
When folding relationals, chose low or high word of each constant
based on VALTP1 since octals are not converted to real under GFLOATING
***** Begin Version 7 *****
65 1264 CDM 25-Sept-81
Add code to P2SKFN to check if function is a type conversion NOP
and if so to remove the node.
66 1273 CDM 15-Oct-81
Change P2SKFN to not change functions into inline for octal
arguments (problem with /OPT otherwise).
67 1431 CKS 4-Dec-81
Add P2SKSUBSTR to do skeleton optimizations for substring nodes. Also
add a temporary null routine to optimize concatenation.
68 1452 CKS 4-Jan-82
Do not optimize A(1:2) to a .D variable if A is a formal variable.
1474 TFV 15-Mar-82
Write P2SKCONC to perform the skeleton optimization for
concatenation. It walks down the argument list of the
concatenation performing skeleton optimizations on the
sub-expressions. If all the lengths are fixed, the
concatenation node is changed to an OPERSP of CONCTF, the
ARG1PTR field is also filled in with a constant table entry for
the length of the concatenation in characters. If the
concatenation has a known maximum length, the OPERSP field is
changed to CONCTM. It also folds all the concatenations into
one concatenation node.
1522 TFV 29-Mar-82
Change P2SKSUBSTRING to give the substring bound out of range
error for upper bound less than lower bound, and for lower bound
less than 1.
1535 CDM 17-May-82
Optimize CHAR(constant) and ICHAR(constant) to be constants.
1542 RVM 25-May-82
Convert REAL constants (stored in double precision) back to
single precision before folding LOGICAL expressions. Under
/GFLOATING, REAL numbers do not have the same bit pattern
at compile-time that they have at execution time, so the
conversion must be done for the results gotten at compile-
time to agree with those gotten at run-time.
1557 CKS 14-Jun-82
Detect substrings with constant bounds which have upper bound
greater than string length.
1567 CDM 24-Jun-82
Massive restructuring for inline functions and creation of new
routine P2SILF. Addition of code to fold CHAR, ICHAR, and LEN
to constants.
1641 AHM 10-Oct-82
When P2SKCONCAT sees the expression A//(B//C)//D, it will
change it into A//B//C//D. Make it also change the parent
pointers for B and C to point to the new concat node if they
have parent pointers.
1655 CDM 25-Oct-82
Allow character inline functions for arguments to concatenation.
1706 TFV 22-Dec-82
Fix P2SKSUBSTRING for substring assignments to character
function values.
***** End Revision History *****
)%
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE OPTMAC.BLI;
SWITCHES LIST;
!***************************************************************
! Initial pass of phase 2 skeleton. This pass over an
! expression tree performs the following:
!
! 1. Eliminates neg and not nodes, forcing them down to
! the bottom if possible. In doing this the following
! globals are used:
!
! NEGFLG - If this flag is true when the routine
! is called for a given node, a neg is to
! be forced down from above. This flag
! is returned true if the parent above
! this node must handle negation for this
! node.
!
! NOTFLG - Like negflg except indicating that a
! not is to be forced down (or back up).
!
! 2. Eliminates the subtract operator, changing it to add
! and propagating the neg down over the 2nd arg
!
! 3. Checks for any operations which are performed on
! constants and may be performed at compile time.
! Performs such operations and replaces their entries
! in the expression tree by the resultant constant.
! Creates constant table entries for these new
! constants.
!
! 4. Detects multiplication or division by a constant
! power of 2 and changes the node to p2mul. Detects
! multiplication by a power of 2 plus 1.
!
! 5. Detects exponentiation to a small constant integer
! power.
!
! 6. N-ary nodes are put into canonical order.
!
! This pass is performed before common subexpression
! elimination. It is performed before phase 2 when phase 2 is
! present. It has a routine corresponding to each operator
! class. To process a given node, it dispatches to the routine
! corresponding to its operator class, via the dispatch table
! "P2SKL1DISP".
!
! These routines are called with the argument CNODE - a pointer
! to the node in the tree to be processed. They each return a
! pointer to the node to replace CNODE (this will be CNODE
! itself unless constant elimination or neg/not propogation has
! been performed).
!***************************************************************
FORWARD
P2SKBL(1),
BLSKOPT(1),
P2SKIGNORE(1),
P2SKREL(1),
RELSKOPT(1),
P2SKFN(1),
P2SKARITH(1),
ARSKOPT(1),
P2SKLTP(1),
P2SKLARR(1),
P2SKNEGNOT(1),
%1431% P2SKCONCAT(1),
%1431% P2SKSUBSTR(1),
%1567% P2SILF(1);
EXTERNAL
ARCMB,
BLCMB,
C1H,
C1L,
C2H,
C2L,
CANONICALIZE,
CDONODE,
COPRIX,
%1474% CORMAN, ! Routine to get some space from free memory
CGERR, ! Error routine for Internal Compiler Errors
CMBEQLARGS,
%761% CNSTCM,
CNTMPY,
DOWDP, ! Global used in determining whether a do-loop
! index should live in a reg
%761% DNEGCNST,
%1522% E165, ! Substring bound out of range error
%1567% E202, ! CHAR library function error
%1522% FATLERR, ! Error routine
%761% KARIGB,
%761% KARIIB,
%761% KBOOLBASE,
KDNEGB,
KDPRL,
%1542% KGFOCT,
KGFRL,
KSPECB,
KSPECG,
%761% KTYPCB,
%761% KTYPCG,
MAKEPR,
%1535% MAKLIT, ! Makes literal constant entry
NEGFLG,
NEGOFNOT,
NEWDVAR, ! Makes new .Dnnn variable
NOTFLG,
NOTOFNEG,
SAVSPACE, ! Return free space
%1567% CHEXLEN, ! Returns length of character expression or LENSTAR
SETPIMMED,
SETPVAL,
SKERR,
TAKNEGARG,
TAKNOTARG,
%761% TBLSEARCH,
USERFNFLG; ! Flag indicating that this statement had a call
! to a user function.
!***************************************************************
! Define the dispatch table for phase 2 skeleton - have a
! routine for each operator class
!***************************************************************
BIND DUMDUM = UPLIT(
P2SKL1DISP GLOBALLY NAMES
P2SKBL,
P2SKIGNORE, ! Should get here very rarely (valflg is
! usually set and checked)
P2SKREL,
P2SKFN,
P2SKARITH,
P2SKLTP,
P2SKLARR,
P2SKIGNORE, ! Common sub expression
P2SKNEGNOT, ! Neg/not
P2SKIGNORE, ! Special ops (p2mul, etc.)
P2SKIGNORE, ! Fieldref
P2SKIGNORE, ! Storecls
P2SKIGNORE, ! Regcontents
P2SKIGNORE, ! Label
P2SKIGNORE, ! Statement
P2SKIGNORE, ! Iolscls
P2SKIGNORE, ! In-line-fn (since these are inserted
! in p2s, should not encounter them)
%1431% P2SKSUBSTR, ! Substring
%1431% P2SKCONCAT); ! Concatenation
GLOBAL ROUTINE P2SKBL(CNODE)=
BEGIN
!***************************************************************
! Initial pass of phase 2 skeleton for a boolean
!***************************************************************
MAP PEXPRNODE CNODE;
LOCAL
PEXPRNODE ARG1NODE,
PEXPRNODE ARG2NODE,
PRVNEGFLG,
ARGNOTFLG;
DEBGNODETST(CNODE); ! For debugging only
ARG1NODE = .CNODE[ARG1PTR];
ARG2NODE = .CNODE[ARG2PTR];
!***************************************************************
! For neg/not elimination. Cannot force a neg down across this
! node. Force down a not by:
! not(a and b)=(not a) or (not b)
! not(a or b)=(not a) and (not b)
! not(a xor b)=a eqv b
! not(a eqv b)=a xor b
!***************************************************************
PRVNEGFLG = .NEGFLG;
ARGNOTFLG = .NOTFLG;
IF.NOTFLG
THEN
BEGIN
! Set opersp to OR from AND, AND from OR, EQV from XOR,
! XOR from eqv
CNODE[BOPRFLG] = NOT.CNODE[BOPRFLG];
IF .CNODE[BOOLCLS] NEQ ANDORCLS
THEN ARGNOTFLG = FALSE;
END;
! Process 1st arg
! If arg is a leaf, do not walk down there
IF .CNODE[A1VALFLG]
THEN
BEGIN
IF .ARGNOTFLG THEN CNODE[A1NOTFLG] = 1;
END
ELSE
BEGIN
NEGFLG = FALSE;
NOTFLG = .ARGNOTFLG;
ARG1NODE = (.P2SKL1DISP[.ARG1NODE[OPRCLS]])(.ARG1NODE);
! If neg or not was propagated up from arg1, set the
! flags in CNODE
CNODE[A1NEGFLG] = .NEGFLG<0,1>;
CNODE[A1NOTFLG] = .NOTFLG<0,1>;
END;
! If arg1 is a constant (or was collapsed into into a constant
! by the walk over it) and a1notflg is set, perform the 'not'
! operation
IF .ARG1NODE[OPR1] EQL CONSTFL
THEN
BEGIN
IF .CNODE[A1NOTFLG]
THEN
BEGIN
ARG1NODE = NOTCNST(ARG1NODE);
CNODE[A1NOTFLG] = 0;
END
END;
CNODE[ARG1PTR]_.ARG1NODE;
! Process 2nd arg
! If arg is a leaf, do not walk down there
IF .CNODE[A2VALFLG]
THEN
BEGIN
IF .ARGNOTFLG THEN CNODE[A2NOTFLG] = 1;
END
ELSE
BEGIN ! For arg2 not a leaf (or common subexpr)
NEGFLG = FALSE;
NOTFLG = .ARGNOTFLG;
ARG2NODE = (.P2SKL1DISP[.ARG2NODE[OPRCLS]])(.ARG2NODE);
CNODE[A2NEGFLG] = .NEGFLG<0,1>;
CNODE[A2NOTFLG] = .NOTFLG<0,1>;
END;
! If arg2 is a constant (or was collapsed into one), perform the
! 'not' operation on it if necessary
IF .ARG2NODE[OPR1] EQL CONSTFL
THEN
BEGIN
IF .CNODE[A2NOTFLG]
THEN
BEGIN
ARG2NODE = NOTCNST(ARG2NODE);
CNODE[A2NOTFLG] = 0;
END;
END;
CNODE[ARG2PTR] = .ARG2NODE;
NEGFLG = .PRVNEGFLG;
NOTFLG = FALSE;
! Check for operations on constants and operations on 2
! identical args, fold if can
RETURN BLSKOPT(.CNODE);
END; ! of P2SKBL
GLOBAL ROUTINE BLSKOPT(CNODE)=
BEGIN
!***************************************************************
! Routine to check whether a boolean operation has arguments
! which are either constant or identical to each other and hence
! can be folded. CNODE is a pointer to the boolean node to be
! examined. If CNODE can be folded, this routine returns a
! pointer to the node which will replace CNODE in the expression
! tree. Otherwise it returns a pointer to cnode.
!***************************************************************
REGISTER
PEXPRNODE ARG1NODE,
PEXPRNODE ARG2NODE,
%1542% C1,
%1542% C2;
MAP PEXPRNODE CNODE;
ARG1NODE = .CNODE[ARG1PTR];
ARG2NODE = .CNODE[ARG2PTR];
! Check for arg1 and arg2 both constants and if so compute the
! value corresponding to CNODE and replace CNODE by a constant
! table entry for that value.
IF .ARG1NODE[OPR1] EQL CONSTFL
THEN
BEGIN
IF.ARG2NODE[OPR1] EQL CONSTFL
THEN
BEGIN
! Globals used by the assembly language routine
! that performs the operations are COPRIX, C1L,
! C2L. Set C1L and C2L to the single words to
! be operated on
%1542% C1 = IF .ARG1NODE[VALTYPE] EQL REAL AND .GFLOAT
%1542% THEN
%1542% BEGIN
%1542% C1H = .ARG1NODE[CONST1];
%1542% C1L = .ARG1NODE[CONST2];
%1542% COPRIX = KGFOCT;
%1542% CNSTCM();
%1542% .C2L
%1542% END
ELSE IF .ARG1NODE[VALTP1] EQL INTEG1
THEN .ARG1NODE[CONST2]
ELSE .ARG1NODE[CONST1];
%1542% C2 = IF .ARG2NODE[VALTYPE] EQL REAL AND .GFLOAT
%1542% THEN
%1542% BEGIN
%1542% C1H = .ARG2NODE[CONST1];
%1542% C1L = .ARG2NODE[CONST2];
%1542% COPRIX = KGFOCT;
%1542% CNSTCM();
%1542% .C2L
%1542% END
ELSE IF .ARG2NODE[VALTP1] EQL INTEG1
THEN .ARG2NODE[CONST2]
ELSE .ARG2NODE[CONST1];
%1542% C1L = .C1;
%1542% C2L = .C2;
COPRIX = .CNODE[OPERSP] + KBOOLBASE;
! Find the result of this operation on these 2
! constants
CNSTCM();
! Set valflg in parent of CNODE
SETPVAL(.CNODE);
! Replace CNODE by a new constant node
CNODE = MAKECNST(LOGICAL,0,.C2L);
END
ELSE
!**************************************
! Check for:
! A AND TRUE = A
! A AND FALSE = FALSE
! A OR TRUE = TRUE
! A OR FALSE = A
! A EQV TRUE = A
! A XOR TRUE = NOT A
! A EQV FALSE = NOT A
! A XOR FALSE = A
! and do the replacement
!**************************************
CNODE = BLCMB(.CNODE,.ARG1NODE,.ARG2NODE);
END
ELSE ! Do the same replacement for arg2
IF .ARG2NODE[OPR1] EQL CONSTFL
THEN CNODE = BLCMB(.CNODE,.ARG2NODE,.ARG1NODE)
ELSE
!**************************************
! Check for:
! A AND A =A
! A AND (NOT A) = FALSE
! A OR A = A
! A OR (NOT A) = TRUE
! A EQV A = TRUE
! A EQV (NOT A) = FALSE
! A XOR A = FALSE
! A XOR (NOT A) = TRUE
! and do the replacement
!**************************************
IF .CNODE[ARG1PTR] EQL .CNODE[ARG2PTR]
THEN CNODE = CMBEQLARGS(.CNODE,FALSE);
RETURN CANONICALIZE(.CNODE);
END; ! of BLSKOPT
GLOBAL ROUTINE P2SKIGNORE(CNODE)=
BEGIN
!***************************************************************
! Phase 2 skeleton routine for a data item (constant or
! variable). This routine is also used for regcontents nodes,
! labels, etc. In general, do not walk down to a data node
! because the valflg in the parent is set, and always check the
! flag before walking down to a son. This is here to keep the
! compiler from dying in those rare cases where the valflg was
! left unset (it is used for elements on iolists where there is
! no valflg).
!***************************************************************
RETURN .CNODE
END; ! of P2SKIGNORE
GLOBAL ROUTINE P2SKREL(CNODE)=
BEGIN
!***************************************************************
! Initial pass of phase 2 skeleton for a relational
!***************************************************************
MAP PEXPRNODE CNODE;
LOCAL
PEXPRNODE ARG1NODE,
PEXPRNODE ARG2NODE,
PRVNEGFLG;
DEBGNODETST(CNODE); ! For debugging only
ARG1NODE = .CNODE[ARG1PTR];
ARG2NODE = .CNODE[ARG2PTR];
! For neg/not elimination - can force down a not by changing the
! sense of the relational. Cannot force down a neg.
IF .NOTFLG THEN CNODE[OPERSP] = CMREL(.CNODE[OPERSP]);
PRVNEGFLG = .NEGFLG;
! Process first argument. Do not walk down to arg if it is a
! leaf or common subexpr.
IF NOT .CNODE[A1VALFLG]
THEN
BEGIN
NEGFLG = FALSE;
NOTFLG = FALSE;
CNODE[ARG1PTR] = (.P2SKL1DISP[.ARG1NODE[OPRCLS]])(.ARG1NODE);
CNODE[A1NEGFLG] = .NEGFLG<0,1>;
CNODE[A1NOTFLG] = .NOTFLG<0,1>;
END;
! Process second argument. Do not walk down to arg if it is a
! leaf or common subexpr.
IF NOT .CNODE[A2VALFLG]
THEN
BEGIN
NEGFLG = FALSE;
NOTFLG = FALSE;
CNODE[ARG2PTR] = (.P2SKL1DISP[.ARG2NODE[OPRCLS]])(.ARG2NODE);
CNODE[A2NEGFLG] = .NEGFLG<0,1>;
CNODE[A2NOTFLG] = .NOTFLG<0,1>;
END;
! Set negflg and notflg to the values to be passed back up to
! parent
NOTFLG = FALSE;
NEGFLG = .PRVNEGFLG;
! Check for operations on constants and operations on identical
! args that can be folded
RETURN RELSKOPT(.CNODE);
END; ! of P2SKREL
GLOBAL ROUTINE RELSKOPT(CNODE)=
BEGIN
!***************************************************************
! Routine to check a relational node for arguments equal to
! constants, or to eachother, and to fold such a node if it is
! possible to do so. The argument CNODE points to the
! relational node to be examined. If the node can be folded
! then a pointer to the new node to replace it in the tree is
! returned. Otherwise a pointer to CNODE is returned.
!***************************************************************
OWN
PEXPRNODE ARG1NODE,
PEXPRNODE ARG2NODE;
MAP PEXPRNODE CNODE;
ARG1NODE = .CNODE[ARG1PTR];
ARG2NODE = .CNODE[ARG2PTR];
!***************************************************************
! If arg1 is equal to arg2 -
! substitute TRUE for a eq a, a le a, a ge a
! substitute FALSE for a lt a, a gt a, a ne a
!***************************************************************
IF .CNODE[ARG1PTR] EQL .CNODE[ARG2PTR]
THEN RETURN CMBEQLARGS(.CNODE,FALSE);
!***************************************************************
! Check for both args negated.
! Transform:
! -a lt -b = a gt b
! -a leq -b = a geq b
! -a eq -b = a eq b
! -a gt -b = a lt b
! -a geq -b = a leq b
! -a neq -b = a neq b
!***************************************************************
IF .CNODE[A1NEGFLG] AND .CNODE[A2NEGFLG]
THEN
BEGIN
CNODE[A1NEGFLG] = 0;
CNODE[A2NEGFLG] = 0;
IF NOT EQREL(.CNODE[OPERSP])
THEN CNODE[OPERSP] = REVREL(.CNODE[OPERSP]);
END;
! If the operands are both constants, evaluate the relational
! and replace it in the tree by either TRUE or FALSE. If one of
! the arguments is a constant, let that argument be the 2nd
! argument.
IF .ARG1NODE[OPR1] EQL CONSTFL
AND .ARG1NODE[VALTYPE] NEQ DOUBLOCT
THEN
BEGIN
!!!!!!?????????!!!!!!!!
%(****FEB 23,1972 - THE FOLLOWING BLOCK WAS INSERTED TO
PREVENT A BLISS BUG THAT DELETED CODE . THIS BLOCK FORCES
BLISS TO USE 2 TEMP REGS***)%
BEGIN
OWN T,T1,T2,T3;
T = 1; T1 = 2; T2 = 3; T3 = 4;
END;
IF .ARG2NODE[OPR1] EQL CONSTFL
AND .ARG2NODE[VALTYPE] NEQ DOUBLOCT
THEN
BEGIN
OWN
KN,
K1H, ! Hi word of const1 after the round
K1L, ! Low word of const1 after the round
K2H, ! Hi word of const2 after the round
K2L; ! Low word of const2 after the round
! For real variables and double precision
! variables, must round before compare
%761% IF .ARG1NODE[VALTYPE] EQL REAL
THEN
BEGIN
! Set up the globals for constant folding
C1H = .ARG1NODE[CONST1];
C1L = .ARG1NODE[CONST2];
! To round double precision to real
%761% IF .GFLOAT
%761% THEN COPRIX = KGFRL
%761% ELSE COPRIX = KDPRL;
! Do the rounding, leave result in C2H,
! C2L
CNSTCM();
K1H = .C2H;
K1L = .C2L
END
ELSE
BEGIN
! If rounding is not needed
K1H = .ARG1NODE[CONST1];
K1L = .ARG1NODE[CONST2];
END;
%761% IF .ARG2NODE[VALTYPE] EQL REAL
THEN
BEGIN
! Set up the globals for constant folding
C1H = .ARG2NODE[CONST1];
C1L = .ARG2NODE[CONST2];
! To round double precision to real
%761% IF .GFLOAT
%761% THEN COPRIX = KGFRL
%761% ELSE COPRIX = KDPRL;
! Do the rounding, leave result in C2H,
! C2L
CNSTCM();
K2H = .C2H;
K2L = .C2L
END
ELSE
BEGIN
! If rounding is not needed
K2H = .ARG2NODE[CONST1];
K2L = .ARG2NODE[CONST2];
END;
KN =
BEGIN
IF .ARG1NODE[DBLFLG]
THEN
%(***IF MUST COMPARE 2-WD VAL****)%
BEGIN
CASE .CNODE[OPERSP] OF SET
%(***UNUSED OPERSP CODE - SHOULD NEVER GET HERE***)%
BEGIN
SKERR();
FALSE
END;
%(** LT **)%
(.K1H LSS .K2H)
OR (.K1H EQL .K2H AND .K1L LSS .K2L);
%(** EQ **)%
(.K1H EQL .K2H) AND (.K1L EQL .K2L);
%(** LE **)%
(.K1H LSS .K2H)
OR (.K1H EQL .K2H AND .K1L LEQ .K2L);
%(**UNUSED CODE SHOULD NEVER GET HERE**)%
BEGIN
SKERR();
FALSE
END;
%(** GE **)%
(.K1H GTR .K2H)
OR (.K1H EQL .K2H AND .K1L GEQ .K2L);
%(** NE**)%
(.K1H NEQ .K2H) OR (.K1L NEQ .K2L);
%(** GT **)%
(.K1H GTR .K2H)
OR (.K1H EQL .K2H AND .K1L GTR .K2L);
TES
END
ELSE
%(***IF MUST COMPARE SINGLE-WD VALS***)%
BEGIN
OWN C1,C2;
%(***SET C1 AND C2 TO THE VALS TO BE COMPARED***)%
![1031] Use low or high word of each constant based on VALTP1
![1031] since octals are not converted to reals under GFLOATING
%[1031]% IF .ARG1NODE[VALTP1] EQL INTEG1
%[1031]% THEN C1 = .K1L
%[1031]% ELSE C1 = .K1H;
%[1031]% IF .ARG2NODE[VALTP1] EQL INTEG1
%[1031]% THEN C2 = .K2L
%[1031]% ELSE C2 = .K2H;
CASE .CNODE[OPERSP] OF SET
%(***UNUSED OPERSP CODE - SHOULD BEVER GET HERE***)%
BEGIN
SKERR();
FALSE
END;
%(***LT****)%
.C1 LSS .C2;
%(***EQ****)%
.C1 EQL .C2;
%(***LE****)%
.C1 LEQ .C2;
%(***UNUSED OPERSP CODE - SHOULD NEVER GET HERE***)%
BEGIN
SKERR();
FALSE
END;
%(***GE***)%
.C1 GEQ .C2;
%(***NE***)%
.C1 NEQ .C2;
%(***GT***)%
.C1 GTR .C2
TES
END
END;
%(***SET THE VALFLG IN THE PARENT OF CNODE***)%
SETPVAL(.CNODE);
%(***RETURN THE CONSTANT TABLE ENTRY FOR THE VAL OF THIS RELATIONAL***)%
RETURN MAKECNST(LOGICAL,0,
BEGIN
IF .KN THEN TRUE ELSE FALSE
END);
END
%(***IF ARG1 IS A CONSTANT AND ARG2 IS NOT; SWAP THE 2
ARGS ***)%
ELSE
BEGIN
IF NOT EQREL(.CNODE[OPERSP])
THEN
CNODE[OPERSP] = REVREL(.CNODE[OPERSP]);
SWAPARGS(CNODE);
![671] WHEN WE SWAP THE ARGUMENTS, BE SURE TO SWAP THE DEF PTS TOO
%[671]% IF .FLGREG<OPTIMIZE> THEN
%[671]% BEGIN
%[671]% ARG1NODE = .CNODE[DEFPT2];
%[671]% CNODE[DEFPT2] = .CNODE[DEFPT1];
%[671]% CNODE[DEFPT1] = .ARG1NODE
%[671]% END;
ARG1NODE = .CNODE[ARG1PTR];
ARG2NODE = .CNODE[ARG2PTR];
END;
END;
%(*****IF ONE OF THE ARGS IS ZERO AND THE OTHER IS A SUM, TRANSFORM:
(A+B).REL.0=A.REL.-B
*********)%
IF ( NOT .CNODE[A1VALFLG]) AND (.ARG2NODE[OPR1] EQL CONSTFL)
THEN
BEGIN
IF (.ARG2NODE[CONST1] EQL 0) AND (.ARG2NODE[CONST2] EQL 0) AND (.ARG1NODE[OPR1] EQL ADDOPF)
AND NOT .CNODE[A1NOTFLG]
THEN
BEGIN
%(****MAKE ARG1 UNDER CNODE BE ARG1 UNDER THE SUM, MAKE ARG2 BE
ARG2 UNDER THE SUM WITH THE SIGN REVERSED****)%
CNODE[ARG1PTR] = .ARG1NODE[ARG1PTR];
CNODE[A1FLGS] = .ARG1NODE[A1FLGS];
CNODE[ARG2PTR] = .ARG1NODE[ARG2PTR];
CNODE[A2FLGS] = .ARG1NODE[A2FLGS];
CNODE[A2NEGFLG] = NOT .CNODE[A2NEGFLG];
%(***CORRECT PARENT PTRS IN THE 2 SUBNODES WHICH WERE MOVED***)%
ARG1NODE = .CNODE[ARG1PTR];
ARG2NODE = .CNODE[ARG2PTR];
IF .ARG1NODE[OPRCLS] EQL DATAOPR
THEN
CNODE[A1VALFLG] = 1
ELSE
ARG1NODE[PARENT] = .CNODE;
IF .ARG2NODE[OPRCLS] EQL DATAOPR
THEN
CNODE[A2VALFLG] = 1
ELSE
ARG2NODE[PARENT] = .CNODE;
END;
END;
RETURN .CNODE;
END; ! of RELSKOPT
GLOBAL ROUTINE P2SKFN(CNODE)=
%(*************************************************************************
Initial pass of phase 2 skeleton for a function call. Cannot force
neg or not down across a fn call.
*************************************************************************)%
BEGIN
MAP OBJECTCODE DOWDP;
MAP PEXPRNODE CDONODE;
MAP OBJECTCODE USERFNFLG;
MAP PEXPRNODE CNODE;
%1567% REGISTER
ARGUMENTLIST ARGLST, ! Argument list to function
PEXPRNODE FNNAMENTRY; ! Function symble table node
LOCAL
PEXPRNODE ARGNODE, !Argument node for spec arg
PRVNEGFLG,
PRVNOTFLG;
DEBGNODETST(CNODE); !FOR DEBUGGING ONLY
FNNAMENTRY = .CNODE[ARG1PTR];
ARGLST = .CNODE[ARG2PTR];
! If this fn is not a library fn, set a global indicating that
! this stmnt includes a call to a user fn
IF .CNODE[OPERSP] NEQ LIBARY THEN USERFNFLG = TRUE;
%(***IF THIS FN IS A STMNT FN AND THIS REFERENCE IS INSIDE A DO LOOP
THEN THE INDEX OF THAT LOOP MUST BE MATERIALIZED (SINCE THE
STMNT FN CAN REFERENCE THE VAR)***)%
IF .FNNAMENTRY[IDATTRIBUT(SFN)] THEN DOWDP[DOMTRLZIX] = 1;
%(***PERFORM PHASE 2 SKEL OPTIMS ON ALL ARGS***)%
IF .CNODE[ARG2PTR] NEQ 0
THEN
BEGIN
PRVNEGFLG = .NEGFLG;
PRVNOTFLG = .NOTFLG;
%(*** PROCESS ALL ARGUMENTS ***)%
INCR CT FROM 1 TO .ARGLST[ARGCOUNT]
DO
BEGIN
ARGNODE = .ARGLST[.CT,ARGNPTR];
IF NOT .ARGLST[.CT,AVALFLG]
THEN
%(***UNLESS THIS ARG IS A LEAF OR A COMMON SUBEXPR, PROCESS IT***)%
BEGIN
NEGFLG = FALSE;
NOTFLG = FALSE;
ARGLST[.CT,ARGNPTR] = (.P2SKL1DISP[.ARGNODE[OPRCLS]])(.ARGNODE);
END;
%(***CHECK WHETHER THIS ARG IS THE INDEX OF A DO LOOP THAT
INCLUDES THIS STMNT. IF SO, WILL NOT BE ABLE TO
HAVE THAT LOOP INDEX LIVE IN A REGISTER***)%
IF .ARGLST[.CT,ARGNPTR] EQL .DOWDP[DOINDUC]
THEN DOWDP[DOMTRLZIX] = 1;
END;
%(***RESTORE NEGFLG AND NOTFLG TO THE VALS THAT THEY HAD WHEN ENTERED***)%
NEGFLG = .PRVNEGFLG;
NOTFLG = .PRVNOTFLG;
END;
! Check for whether this fn should be expanded in line. If so,
! transform this FNCALL node into an "in-line-fn" node or a
! type-conversion node. Function won't be made inline if it has
! octal arguments.
IF .FNNAMENTRY[IDINLINFLG]
%1567% THEN RETURN P2SILF(.CNODE);
RETURN .CNODE;
END; ! of P2SKFN
GLOBAL ROUTINE P2SKARITH(CNODE)=
%(***
INITIAL PASS OF PHASE 2 SKELETON FOR AN ARITHMETIC NODE
***)%
BEGIN
MAP OBJECTCODE DOWDP;
LOCAL PEXPRNODE ARG1NODE;
LOCAL PEXPRNODE ARG2NODE;
LOCAL V;
MAP PEXPRNODE CNODE;
! MAKE 4 BOOLEAN LOCALS LIVE INSIDE V
!SO THAT RECURSIVE CALLS ARE LESS LIKELY TO
!OVERFLOW OUR STACK! THE BOOLEANS ARE DEFINED BELOW
MACRO PARNEG=35,1$,
PARNOT=34,1$,
ARG1NEG=33,1$,
ARG2NEG=32,1$;
DEBGNODETST(CNODE); !FOR DEBUGGING ONLY
ARG1NODE = .CNODE[ARG1PTR];
ARG2NODE = .CNODE[ARG2PTR];
%(***FORCE DOWN A NEGATIVE BY:
-(A+B)=-A-B
-(A-B)=-A+B
-(A*B)=(-A)*B
-(A/B)=(-A)/B
***)%
IF .NEGFLG
THEN
BEGIN
CASE .CNODE[OPERSP] OF SET
%(*** FOR ADD ***)%
BEGIN
V<ARG1NEG> = TRUE;
V<ARG2NEG> = TRUE;
V<PARNEG> = FALSE;
END;
%(*** FOR SUB ***)%
BEGIN
CNODE[OPERSP] = ADDOP;
V<ARG1NEG> = TRUE;
V<ARG2NEG> = FALSE;
V<PARNEG> = FALSE;
END;
%(*** FOR MUL ***)%
BEGIN
V<ARG1NEG> = TRUE;
V<ARG2NEG> = FALSE;
V<PARNEG> = FALSE;
END;
%(*** FOR DIV ***)%
BEGIN
V<ARG1NEG> = TRUE;
V<ARG2NEG> = FALSE;
V<PARNEG> = FALSE;
END;
%(*** FOR EXPONENTIATION ***)%
%(*** CANNOT FORCE NEG DOWN ***)%
BEGIN
V<ARG1NEG> = FALSE;
V<ARG2NEG> = FALSE;
V<PARNEG> = TRUE;
END
TES
END
ELSE
BEGIN
V<ARG1NEG> = FALSE;
V<PARNEG> = FALSE;
IF .CNODE[OPERSP] EQL SUBOP
THEN
BEGIN
CNODE[OPERSP] = ADDOP;
V<ARG2NEG> = TRUE;
END
ELSE
V<ARG2NEG> = FALSE;
END;
%(*** CANNOT FORCE DOWN A NOT ***)%
V<PARNOT> = .NOTFLG;
%(********* PROCESS FIRST ARG **********)%
%(****DO NOT WALK DOWN TO A NODE WHICH IS A LEAF OR COMMON SUBEXPR***)%
IF .CNODE[A1VALFLG]
THEN
BEGIN
IF .V<ARG1NEG>
THEN CNODE[A1NEGFLG] = 1;
END
ELSE
%(***IF ARG IS NOT A LEAF OR COMMON SUBEXPR***)%
BEGIN
NOTFLG = FALSE;
NEGFLG = IF .V<ARG1NEG> THEN TRUE ELSE FALSE;
ARG1NODE = (.P2SKL1DISP[.ARG1NODE[OPRCLS]])(.ARG1NODE);
CNODE[A1NEGFLG] = .NEGFLG<0,1>;
CNODE[A1NOTFLG] = .NOTFLG<0,1>;
END;
%(***IF ARG IS A CONSTANT (OR WAS COLLAPSED INTO ONE), PERFORM NEG
ON IT AT COMPILE TIME*****)%
IF .ARG1NODE[OPR1] EQL CONSTFL
THEN
BEGIN
IF .CNODE[A1NEGFLG]
THEN
BEGIN
ARG1NODE = NEGCNST(ARG1NODE);
CNODE[A1NEGFLG] = 0;
END;
END;
CNODE[ARG1PTR] = .ARG1NODE;
%(********* PROCESS SECOND ARG ********)%
IF .CNODE[A2VALFLG]
THEN
BEGIN
IF .V<ARG2NEG>
THEN
CNODE[A2NEGFLG] = 1;
END
ELSE
BEGIN
NEGFLG = IF .V<ARG2NEG> THEN TRUE ELSE FALSE;
NOTFLG = FALSE;
ARG2NODE = (.P2SKL1DISP[.ARG2NODE[OPRCLS]])(.ARG2NODE);
CNODE[A2NEGFLG] = .NEGFLG<0,1>;
CNODE[A2NOTFLG] = .NOTFLG<0,1>;
END;
%(***IF ARG IS A CONSTANT (OR WAS COLLAPSED INTO ONE), PERFORM NEG
ON IT AT COMPILE TIME*****)%
IF .ARG2NODE[OPR1] EQL CONSTFL
THEN
BEGIN
IF .CNODE[A2NEGFLG]
THEN
BEGIN
ARG2NODE = NEGCNST(ARG2NODE);
CNODE[A2NEGFLG] = 0;
END;
END;
CNODE[ARG2PTR] = .ARG2NODE;
%(*** CHECK FOR
(-A)*(-B)=A*B
(-A)/(-B)=A/B
***)%
IF .CNODE[A1NEGFLG] AND .CNODE[A2NEGFLG]
THEN
BEGIN
IF .CNODE[OPERSP] EQL MULOP
OR .CNODE[OPERSP] EQL DIVOP
THEN
BEGIN
CNODE[A1NEGFLG] = 0;
CNODE[A2NEGFLG] = 0;
END;
END;
NEGFLG = IF .V<PARNEG> THEN TRUE ELSE FALSE;
NOTFLG = IF .V<PARNOT> THEN TRUE ELSE FALSE;
%(****CHECK FOR CONSTANT OPERATIONS AND OPERATIONS ON IDEXTICAL ARGS THAT CAN BE FOLDED***)%
V = ARSKOPT(.CNODE);
%(***IF EITHER ARG OF AN EXPONENTIATION IS THE INDEX OF A DO LOOP THAT
INCLUDES THAT EXPONENTIATION, CANNOT HAVE THAT LOOP INDEX LIVE IN A REG***)%
IF .CNODE[OPR1] EQL EXPONOPF
THEN
BEGIN
IF .CNODE[ARG1PTR] EQL .DOWDP[DOINDUC] OR
(.CNODE[ARG2PTR] EQL .DOWDP[DOINDUC])
THEN
DOWDP[DOISUBS] = 0
END;
RETURN .V;
END; ! of P2SKARITH
GLOBAL ROUTINE ARSKOPT(CNODE)=
%(***************************************************************************
FOR AN ARITHMETIC NODE, CHECK FOR OPERATIONS ON CONSTANTS AND ON IDENTICAL ARGS THAT CAN BE FOLDED.
CALLED WITH THE ARG CNODE POINTING TO AN ARITHMETIC EXPRESSION NODE.
***************************************************************************)%
BEGIN
MAP PEXPRNODE CNODE;
OWN PEXPRNODE ARG1NODE:ARG2NODE;
LABEL FOLDCNST;
ARG1NODE = .CNODE[ARG1PTR];
ARG2NODE = .CNODE[ARG2PTR];
%(***
CHECK FOR BOTH OPERANDS CONSTANTS. IF SO, PERFORM THE
OPERATION AT COMPILE TIME - CREATE A CONSTANT TABLE ENTRY
FOR THE NEW CONSTANT WHICH IS THE RESULTS
***)%
IF .ARG1NODE[OPR1] EQL CONSTFL AND .ARG2NODE[OPR1] EQL CONSTFL
%(***DO NOT FOLD OPERATIONS INVOLVING DOUBLE OCTALS SINCE HAVE COMPLICATIONS
DUE TO KEEPING ALL DOUBLE-PRECISION IN KI10 FORMAT UNTIL THE END***)%
AND .ARG1NODE[VALTYPE] NEQ DOUBLOCT AND .ARG2NODE[VALTYPE] NEQ DOUBLOCT
THEN
FOLDCNST: BEGIN
%(***DO NOT FOLD COMPLEX MULTIPLY AND DIVIDE,*****)%
IF .CNODE[VALTYPE] EQL COMPLEX AND MULORDIV(CNODE)
THEN
LEAVE FOLDCNST;
%(***GLOBALS USED BY THE ASSEMBLY LANGUAGE ROUTINE THAT
PERFORMS THE OPERATIONS ARE
COPRIX, C1H, C1L, C2H, C2L***)%
%(***FOLD CONSTANTS RAISED TO INTEGER POWERS ONLY IF THEY USE 8 OR LESS MULTIPLIES***)%
IF .CNODE[OPERSP] EQL EXPONOP
THEN
BEGIN
%(***DO NOT FOLD DOUBLE-PREC EXPONENTIATION AT COMPILE TIME***)%
IF .CNODE[DBLFLG]
THEN LEAVE FOLDCNST
ELSE
BEGIN
IF .ARG2NODE[VALTP1] EQL INTEG1
AND CNTMPY(.ARG2NODE[CONST2]) LEQ 8 !LESS THAN 8 MULTIPLIES
THEN
COPRIX = KEXPIX(.CNODE[VALTP1])
ELSE LEAVE FOLDCNST
END
END
ELSE
COPRIX = KARITHOPIX(CNODE);
%(***PICK UP ARG1 AND ARG2. WHEN HAVE PROPAGATED CONSTANTS, WILL HAVE TO
WORRY ABOUT NEGFLGS***)%
C1H = .ARG1NODE[CONST1];
C1L = .ARG1NODE[CONST2];
C2H = .ARG2NODE[CONST1];
C2L = .ARG2NODE[CONST2];
%(***COMBINE THE CONSTANTS LEAVING THE RESULTS IN C2H AND C2L***)%
CNSTCM();
%(***SET THE VALFLG IN THE PARENT OF CNODE****)%
SETPVAL(.CNODE);
CNODE = MAKECNST(.CNODE[VALTYPE], .C2H, .C2L);
END;
IF .CNODE[OPRCLS] NEQ DATAOPR !IF DID NOT SUCCEED IN FOLDING THIS NODE ALREADY
THEN
BEGIN
%(****
CHECK FOR ONE OF THE ARGUMENTS A CONSTANT
IF SO, GO ATTEMPT TO MAKE THE
VARIOUS OPTOMIZATIONS THAT CAN BE MADE ON OPS BETWEEN
A VARIABLE(OR EXPRESSION) AND A CONSTANT.
THESE INCLUDE RECOGNIZING CONSTANTS AS BEING
1. ZERO
2. ONE
3. MINUS ONE
4. POWERS OF 2
5. POWER OF 2 PLUS ONE
*******)%
IF .ARG1NODE[OPR1] EQL CONSTFL
THEN
CNODE = ARCMB(.CNODE,.ARG1NODE,.ARG2NODE,TRUE)
ELSE
IF .ARG2NODE[OPR1] EQL CONSTFL
THEN
CNODE = ARCMB(.CNODE,.ARG2NODE,.ARG1NODE,FALSE)
%(********
CHECK FOR:
A+A=2*A
A-A=0
A/A=1
A/-A=-1
***********)%
ELSE
IF (.CNODE[ARG1PTR] EQL .CNODE[ARG2PTR])
THEN
CNODE = CMBEQLARGS(.CNODE,FALSE);
END;
%(****CANONICALIZE CNODE AND RETURN THE RESULT*****)%
RETURN CANONICALIZE(.CNODE);
END; ! of ARSKOPT
GLOBAL ROUTINE P2SKLTP(CNODE)=
%(********
INITIAL PASS OF PHASE 2 SKELETON FOR A TYPE-CONVERSION
NODE.
********)%
BEGIN
LOCAL PEXPRNODE ARGNODE;
LOCAL SAVENOTFLG;
MAP PEXPRNODE CNODE;
DEBGNODETST(CNODE); !FOR DEBUGGING ONLY
ARGNODE = .CNODE[ARG2PTR];
IF NOT .CNODE[A2VALFLG]
THEN
%(**PROCESS THE ARGUMENT UNDER THIS NODE.
SIMPLY PASS NEG ON DOWN.
**)%
BEGIN
IF NOT NOCNV(CNODE) !IF THIS IS A TYPE-CNV THAT DOES GENERATE CODE
THEN
BEGIN
SAVENOTFLG = .NOTFLG; !CANNOT PASS A "NOT" DOWN OVER A TYPE CNV
NOTFLG = FALSE;
END;
ARGNODE = (.P2SKL1DISP[.ARGNODE[OPRCLS]])(.ARGNODE); !PROCESS ARG UNDER TPCNV
%(***EXCEPT FOR DUMMY TYPE CONVERSION NODES, CANNOT PASS "NOT"
UP THROUGH THE TYPE CONVERSION***)%
IF NOT NOCNV(CNODE)
THEN
BEGIN
CNODE[A2NOTFLG] = .NOTFLG<0,1>;
NOTFLG = .SAVENOTFLG;
END;
%(***IF HAVE A NEG PASSED UP TO THIS NODE, MUST CHECK WHETHER IT CAN
BE PASSED UP TO THE PARENT OF THIS NODE***)%
IF .NEGFLG AND NOT TAKNEGARG(.CNODE[PARENT])
THEN
%(***IF CANNOT PASS THE NEG BACK UP, PUT IT INTO THE TPCNV NODE***)%
BEGIN
CNODE[A2NEGFLG] = 1;
NEGFLG = FALSE;
END;
END;
%(***PERFORM TYPE-CONVERSION ON A CONSTANT****)%
IF .ARGNODE[OPR1] EQL CONSTFL
THEN
BEGIN
C1H = .ARGNODE[CONST1];
C1L = .ARGNODE[CONST2];
IF .CNODE[A2NOTFLG] !IF MUST TAKE THE "NOT" OF THE ARG
THEN
BEGIN
C1H = NOT .C1H;
C1L = NOT .C1L;
END;
IF .CNODE[A2NEGFLG] !IF MUST TAKE THE NEG OF THE ARG
THEN
BEGIN
IF .ARGNODE[VALTYPE] EQL DOUBLPREC OR .ARGNODE[VALTYPE] EQL REAL
THEN
%(***FOR DOUBLE PREC (AND REAL) MUST USE ASSEMBLY LANG ROUTINE
TO TAKE NEG***)%
BEGIN
%761% COPRIX = KDNEGB;
CNSTCM();
C1H = .C2H;
C1L = .C2L;
END
ELSE
BEGIN
C1H = -.C1H;
C1L = -.C1L;
END
END;
COPRIX = KTPCNVIX(CNODE);
CNSTCM();
%(***SET THE VALFLG IN THE PARENT OF CNODE***)%
SETPVAL(.CNODE);
RETURN MAKECNST(.CNODE[VALTYPE],.C2H,.C2L);
END;
CNODE[ARG2PTR] = .ARGNODE;
RETURN .CNODE;
END; ! of P2SKLTP
GLOBAL ROUTINE P2SKLARR(CNODE)=
%(********
INITIAL PASS OF PHASE 2 SKELETON FOR AN ARRAY REFERENCE.
THE EXPRESSION NODE FOR THE ARRAYREF IS ASSUMED TO HAVE THE
FOLLOWING 2 ARGS:
ARG1PTR - PTR TO THE SYMBOL TABLE ENTRY FOR THE ARRAY NAME
ARG2PTR - PTR TO AN EXPRESSION NODE FOR THE ADDRESS CALCULATION
********)%
BEGIN
MAP PEXPRNODE CNODE;
LOCAL PEXPRNODE SSNODE;
LOCAL PRVNEGFLG,PRVNOTFLG;
DEBGNODETST(CNODE); !FOR DEBUGGING ONLY
%(*****UNLESS THE ADDRESS-CALCULATION IS A LEAF, PERFORM THE
PHASE 2 SKEL OPTIMIZATIONS ON IT****)%
IF NOT .CNODE[A2VALFLG]
THEN
BEGIN
SSNODE = .CNODE[ARG2PTR];
PRVNEGFLG = .NEGFLG;
PRVNOTFLG = .NOTFLG;
NEGFLG = FALSE;
NOTFLG = FALSE;
CNODE[ARG2PTR] = (.P2SKL1DISP[.SSNODE[OPRCLS]])(.SSNODE);
CNODE[A2NEGFLG] = .NEGFLG<0,1>;
CNODE[A2NOTFLG] = .NOTFLG<0,1>;
NEGFLG = .PRVNEGFLG; !CANNOT PASS NEG/NOT DOWN OVER AN
! ARRAYREF NODE; HENCE IF WERE TRYING TO DO SO,
! PASS THEM BACK UP TO PARENT
NOTFLG = .PRVNOTFLG;
END;
RETURN .CNODE;
END; ! of P2SKLARR
GLOBAL ROUTINE P2SKNEGNOT(CNODE)=
%(***************************************************************************
INITIAL PASS OF PHASE 2 SKEL FOR A NEG OR NOT NODE
TRANSFORMS:
-(-X)=X
NOT(NOT X)=X
PERFORMS NEG/NOT ON A CONSTANT
PASSES NEG AND NOT ON DOWN TO BOTTOMMOST NODES
IN MANY CASES
WHEN A NEG/NOT CANNOT BE PASSED DOWN ANY FURTHER, THE PARENT
NODE HAS A FLAG SET INDICATING "NEGATE(OR COMPLEMENT) THE
FIRST (OR 2ND) ARG";
THE NEGATE/NOT NODE IS REMOVED FROM THE TREE.
A NEGATE CANNOT BE PASSED DOWN FROM ABOVE OVER A NOT. IF THIS
SITUATION ARISES (EG -(NOT X)), THE NEG WILL BE PASSED BACK UP
WHEN THE NOT IS ENCOUNTERED AND IF THE NOT CANNOT BE PROPAGATED DOWN
THE NOT NODE MUST BE LEFT IN THE TREE.
SIMILARLY, A NOT CANNOT BE PROPAGATED OVER A NEGATE.
WHEN A NEGATE OR NOT CANNOT BE PROPAGATED DOWNWARD, THEN
DEPENDING ON WHAT THE PARENT NODE OVER THE NEG/NOT NODE IS, THE NEG OR
NOT MAY IN SOME CASES BE PROPAGATED BACK UPWARD.
***************************************************************************)%
BEGIN
MAP PEXPRNODE CNODE;
LOCAL PEXPRNODE ARGNODE;
OWN PEXPRNODE PARNODE; !PTR TO PARENT NODE
%(***DEFINE MACRO TO REMOVE THE NEG/NOT NODE FROM THE TREE***)%
MACRO REMOVE=
BEGIN
%(***IF ARG IS A LEAF, SET VALFLG IN PARENT OF CNODE***)%
IF .ARGNODE[OPRCLS] EQL DATAOPR
OR .ARGNODE[OPRCLS] EQL REGCONTENTS
THEN
BEGIN
SETPVAL(.CNODE);
%(***IF THE IMMEDIATE-FLAG WAS SET IN THE NEG/NOT NODE, SET IT
IN THE PARENT OF THE NEG/NOT NODE***)%
IF .CNODE[A2IMMEDFLG]
THEN SETPIMMED(.CNODE);
END
%(***OTHERWISE SET PARENT PTR OF THE ELEMENT BELOW CNODE
AND IF HAVE A PARENFLG ON CNODE, PUT IT ON THE ELEMENT BELOW**)%
ELSE
BEGIN
ARGNODE[PARENT] = .CNODE[PARENT];
IF .CNODE[PARENFLG] THEN ARGNODE[PARENFLG] = 1;
END;
RETURN .ARGNODE;
END$;
%(***DEFINE A MACRO TO LEAVE A NEG NODE IN THE TREE, AND RETURN WITH NEGFLG=FALSE***)%
MACRO LEAVENEG=
BEGIN
NEGFLG = FALSE;
CNODE[OPERSP] = NEGOP; !THIS NODE MAY HAVE ORIGINALLY BEEN A NOT.
! EG .NOT.(.NOT.(-X))
RETURN .CNODE;
END$;
%(***DEFINE A MACRO TO LEAVE A NOT NODE IN THE TREE, AND RETURN WITH NOTFLG=FALSE***)%
MACRO LEAVENOT=
BEGIN
NOTFLG = FALSE;
CNODE[OPERSP] = NOTOP; !THIS NODE MAY HAVE ORIGINALLY BEE A NEG.
! EG -(-(.NOT.X))
RETURN .CNODE;
END$;
DEBGNODETST(CNODE); !FOR DEBUGGING ONLY
ARGNODE = .CNODE[ARG2PTR];
IF .CNODE[OPERSP] EQL NEGOP
THEN
%(***IF CNODE IS A 'NEG' NODE (UNARY MINUS)***)%
BEGIN
%(***IF WERE TRYING TO PROPAGATE A 'NOT' FROM ABOVE
CANNOT PROPAGATE IT ACROSS A NEG NODE***)%
IF .NOTFLG
THEN
RETURN NOTOFNEG(.CNODE);
NEGFLG = NOT .NEGFLG;
END
ELSE
IF .CNODE[OPERSP] EQL NOTOP
THEN
%(***IF CNODE IS A 'NOT' NODE***)%
BEGIN
IF .NEGFLG
THEN
%(***IF WERE TRYING TO PROPAGATE A 'NEG' FROM ABOVE,
CANNOT PROPAGATE IT ACROSS A 'NOT' NODE***)%
RETURN NEGOFNOT(.CNODE);
NOTFLG = NOT .NOTFLG;
END;
IF .CNODE[A2VALFLG]
THEN
%(***IF THE ARGUMENT UNDER CNODE IS A LEAF***)%
BEGIN
%(****IF THE ARG IS A CONSTANT, CREATE A NEW CONSTANT TABLE ENTRY***)%
IF .ARGNODE[OPR1] EQL CONSTFL
THEN
BEGIN
IF .NEGFLG
THEN
%(****FOR NEG***)%
BEGIN
NEGFLG = FALSE;
%(***SET THE VALFLG IN THE PARENT OF THE NEG***)%
SETPVAL(.CNODE);
RETURN NEGCNST(ARGNODE);
END;
IF .NOTFLG
THEN
%(****FOR NOT***)%
BEGIN
NOTFLG = FALSE;
%(***SET THE VALFLG IN THE PARENT OF THE NOT***)%
SETPVAL(.CNODE);
RETURN NOTCNST(ARGNODE);
END;
END;
END
ELSE
%(***IF ARG IS NOT A LEAF, TRY TO PROPAGATE NEG AND NOT OVER IT***********)%
BEGIN
ARGNODE = (.P2SKL1DISP[.ARGNODE[OPRCLS]])(.ARGNODE);
CNODE[ARG2PTR] = .ARGNODE;
END;
%(****IF ARE LEFT WITH A NEG OR NOT THAT COULD NOT BE PROPAGATED DOWN, DECIDE
WHETHER OR NOT TO COLLAPSE IT UP INTO THE PARENT ON THE BASIS
OF THE OPERATOR CLASS OF THE PARENT
*******)%
IF .NEGFLG
THEN
BEGIN
IF TAKNEGARG(.CNODE[PARENT])
THEN
REMOVE
ELSE
LEAVENEG;
END
ELSE
%(***IF HAVE A NOT THAT WERE UNABLE TO PROPAGATE DOWN***)%
IF .NOTFLG
THEN
BEGIN
IF TAKNOTARG(.CNODE[PARENT]) !IF THE NOT CAN BE ABSORBED BY THE PARENT
THEN REMOVE ! REMOVE THE NOT NODE AND PROPAGATE
! THE NOT UP TO THE PARENT
ELSE LEAVENOT; !OTHERWISE LEAVE THE NOT NODE
END
%(***IF THE NEG OR NOT WAS ABSORBED BELOW THIS NODE, CAN REMOVE THE NEG/NOT NODE
FROM THE TREE****)%
ELSE
REMOVE;
END; ! of P2SKNEGNOT
ROUTINE P2SKCONCAT(CNODE) =
BEGIN
%1474% ! Written by TFV on 8-Feb-82
! Perform skeleton optimizations on CONCATENATION nodes. Walk
! down the argument list performing optimizations on the
! arguments (except for the first which is the descriptor for
! the result). If the lengths are fixed, change the OPERSP to
! CONCTF. If the maximum length of the result is known, change
! the OPERSP to CONCTM.
MAP BASE CNODE;
REGISTER
ARGUMENTLIST ARGLIST, ! Pointer to the argument list
PEXPRNODE ARGNODE; ! Pointer to an argument
LOCAL
PEXPRNODE ANODE, ! Pointer to an arrayref node
! under a substring node
PEXPRNODE LNODE, ! Lower bound of a substring node
PEXPRNODE UNODE, ! Upper bound of a substring node
ISFIXEDLEN, ! Flag for this concatenation
! has a fixed length
ISMAXLEN, ! Flag for this concatenation
! has a known maximum length
HASSUBCONC, ! Flag for this node has
! concatenations as subnodes
LEN, ! Size of the fixed length result
NUMARGS, ! Number of arguments for the
! folded concatenation.
ARGUMENTLIST DOWNARGL, ! Pointer to the argument list of
! a subnode
PEXPRNODE SUBARG, ! Pointer to the argument in the
! argument list of a subnode
ARGUMENTLIST NEWARGL, ! Pointer to the new argument
! list used when moving
! concatenation subexpressions
! to top level
NEWARGPOS; ! Pointer to the next position
! to fill in the new argument
! list
NUMARGS = 1; ! One argument is needed for the
! result of the concatenation
LEN = 0; ! Initialize length
HASSUBCONC = FALSE; ! Assume no concatenations below
! this node
ISFIXEDLEN = TRUE; ! Assume this is a fixed length
! concatenation
ISMAXLEN = TRUE; ! Assume this is a concatenation
! with a known maximum length
ARGLIST = .CNODE[ARG2PTR]; ! Get a pointer to the argument list
INCR I FROM 2 TO .ARGLIST[ARGCOUNT]
DO
BEGIN ! Walk down the argument list
! Walk down the arguments from the second onward. Do
! the skeleton optimization for each sub-expression.
! The length of each legal argument MUST be added into
! LEN so that we can assign the length of the concat
! needed.
ARGNODE = .ARGLIST[.I, ARGNPTR]; ! Pointer to the
! argument
! If this argument is not a DATAOPR, walk down it
! performing further skeleton optimizations.
IF NOT .ARGLIST[.I, AVALFLG]
THEN ARGLIST[.I, ARGNPTR] = ARGNODE =
(.P2SKL1DISP[.ARGNODE[OPRCLS]])(.ARGNODE);
! Now process this argument based on OPRCLS.
CASE .ARGNODE[OPRCLS] OF SET
CGERR(); ! BOOLEAN - error
BEGIN ! DATAOPR
! The argument either was a DATAOPR or it became
! one through folding.
ARGLIST[.I, AVALFLG] = 1; ! Set flag bit
! If this is a fixed length result, update the
! length. Otherwise reset the fixed length and
! maximum length flags.
IF .ARGNODE[OPERATOR] NEQ CHARCONST
THEN
BEGIN ! Variable
IF .ARGNODE[IDCHLEN] EQL LENSTAR
THEN
BEGIN
ISFIXEDLEN = FALSE;
ISMAXLEN = FALSE;
END
ELSE LEN = .LEN + .ARGNODE[IDCHLEN];
END ! Variable
ELSE ! Constant
LEN = .LEN + .ARGNODE[LITLEN];
! Update the argument count
NUMARGS = .NUMARGS + 1;
END; ! DATOPR
CGERR(); ! RELATIONAL - error
BEGIN ! FNCALL
! Look at the symbol table entry for the
! function name to get the length of the result.
! It can not have length *.
SUBARG = .ARGNODE[ARG1PTR];
LEN = .LEN + .SUBARG[IDCHLEN];
! Update the argument count
NUMARGS = .NUMARGS + 1;
END; ! FNCALL
CGERR(); ! ARITHMETIC - error
CGERR(); ! TYPCNV - error
BEGIN ! ARRAYREF
! Get the pointer to the array name
SUBARG = .ARGNODE[ARG1PTR];
! If this is a fixed length array, get the
! length of an element from the array name
! symbol table entry. Otherwise reset the fixed
! length and maximum length flags.
IF .SUBARG[IDCHLEN] EQL LENSTAR
THEN
BEGIN
ISFIXEDLEN = FALSE;
ISMAXLEN = FALSE;
END
ELSE LEN = .LEN + .SUBARG[IDCHLEN];
! Update the argument count
NUMARGS = .NUMARGS + 1;
END; ! ARRAYREF
CGERR(); ! CMNSUB - character common subs are not
! supported in this release.
CGERR(); ! NEGNOT - error
CGERR(); ! SPECOP - error
CGERR(); ! FIELDREF - error
CGERR(); ! STORECLS - error
CGERR(); ! REGCONTENTS - error
CGERR(); ! LABOP - error
CGERR(); ! STATEMENT - error
CGERR(); ! IOLSCLS - error
%1655% BEGIN ! INLINFN
%1655%
%1655% ! Add in the length of the inline function to
%1655% ! the concat node. Do this before calling
%1655% ! P2SILF, since it could come back as a
%1655% ! constant, and we don't want to bother what it
%1655% ! gets optimized into to get the length.
%1655%
%1655% SUBARG = .ARGNODE[ARG2PTR]; ! .Dnnn return value
%1655% LEN = .LEN + .SUBARG[IDCHLEN]; ! Add in length
%1655%
%1655% ARGLIST[.I,ARGNPTR] = P2SILF(.ARGNODE); ! Optimize
%1655%
%1655% END; ! INLINFN
BEGIN ! SUBSTRING
!!! Will need more code to support the A(I:I+3)
!!! case. This is also a fixed length
!!! concatenation.
! Get pointer to upper bound expression
UNODE = .ARGNODE[ARG1PTR];
! Get pointer to lower bound expression
LNODE = .ARGNODE[ARG2PTR];
! Get pointer to ARRAYREF or DATAOPR node
ANODE = .ARGNODE[ARG4PTR];
! If both substring bounds are constants, this
! is a fixed length concatenation. Otherwise if
! the DATAOPR or ARRAYREF subnode is not length
! * it is a known maximum length.
IF .LNODE[OPR1] EQL CONSTFL AND
.UNODE[OPR1] EQL CONSTFL
THEN
BEGIN ! Fixed length result
LEN = .LEN + .UNODE[CONST2] - .LNODE[CONST2];
END ! Fixed length result
ELSE
BEGIN ! Maximum or dynamic length result
! Reset the fixed length flag
ISFIXEDLEN = FALSE;
! If this is an ARRAYREF, get the symbol
! table entry for the identifier under
! it.
IF .ANODE[OPRCLS] EQL ARRAYREF
THEN ANODE = .ANODE[ARG1PTR];
IF .ANODE[IDCHLEN] EQL LENSTAR
THEN
BEGIN ! Dynamic length
ISMAXLEN = FALSE;
END ! Dynamic length
ELSE LEN = .LEN + .ANODE[IDCHLEN];
END; ! Maximum or dynamic length result
! Update the argument count
NUMARGS = .NUMARGS + 1;
END; ! SUBSTRING
BEGIN ! CONCATENATION
! Set the flag for there are concatenations
! under this node.
HASSUBCONC = TRUE;
IF .ARGNODE[OPERSP] EQL CONCTF
THEN
BEGIN ! Fixed length concatenation
! This is a fixed length concatenation
! as a sub-expression. Get the length
! of the result of the subnode
! concatenation. It is a constant table
! entry pointed to by ARG1PTR.
SUBARG = .ARGNODE[ARG1PTR];
LEN = .LEN + .SUBARG[CONST2];
END ! Fixed length concatenation
ELSE IF .ARGNODE[OPERSP] EQL CONCTM
THEN
BEGIN ! Known maximum length
! Reset the fixed length flag
ISFIXEDLEN = FALSE;
! This is a maximum length concatenation
! as a sub-expression. Get the length
! of the result of the subnode
! concatenation. It is a constant table
! entry pointed to by ARG1PTR.
SUBARG = .ARGNODE[ARG1PTR];
LEN = .LEN + .SUBARG[CONST2];
END ! Known maximum length
ELSE
BEGIN ! Dynamic length
! Reset the fixed length and maximum
! length flags
ISFIXEDLEN = FALSE;
ISMAXLEN = FALSE;
END; ! Dynamic length
! Get a pointer to the argument list of the
! subnode.
DOWNARGL = .ARGNODE[ARG2PTR];
! Update the count of the actual number of
! concatenation arguments. The first argument
! is ignored since it is the result for the
! concatenation subnode.
NUMARGS = .NUMARGS + .DOWNARGL[ARGCOUNT] - 1;
END; ! CONCATENATION
TES;
END; ! Walk down the argument list
IF .ISFIXEDLEN
THEN
BEGIN ! Fixed length result
CNODE[OPERSP] = CONCTF;
! Fill in ARG1PTR with a pointer to the constant table
! entry for the length.
CNODE[ARG1PTR] = MAKECNST(INTEGER, 0, .LEN);
END ! Fixed length result
ELSE IF .ISMAXLEN
THEN
BEGIN ! Known maximum length
CNODE[OPERSP] = CONCTM;
! Fill in ARG1PTR with a pointer to the constant table
! entry for the maximum length of the result.
CNODE[ARG1PTR] = MAKECNST(INTEGER, 0, .LEN);
END; ! Known maximum length
IF .HASSUBCONC
THEN
BEGIN ! Concatenations under this node
! There are concatenations under this node, build a new
! node with all the concatenations at top level.
! Compute the size needed for the new argument block
NAME<LEFT> = ARGLSTSIZE(.NUMARGS);
NEWARGL = CORMAN(); ! Get space for the new argument
! block.
! Copy the header words to the new argument list
DECR I FROM ARGHDRSIZ - 1 TO 0
DO (.NEWARGL)[.I] = .(.ARGLIST)[.I];
! Fill in the argument count
NEWARGL[ARGCOUNT] = .NUMARGS;
! Walk down the old argument list copying the arguments
! into the new argument list. Move the arguments of
! concatenation subnodes to the top level. Do not copy
! the first arguments of concatenations since these are
! the decriptors for the result.
NEWARGPOS = 2; ! Start filling the new argument
! block at the second argument
! position
INCR I FROM 2 TO .ARGLIST[ARGCOUNT]
DO
BEGIN ! Walk the old argument list
! Get the pointer to the next argument
ARGNODE = .ARGLIST[.I, ARGNPTR];
IF .ARGNODE[OPRCLS] EQL CONCATENATION
THEN
BEGIN ! Concatenation subexpression
! Get the pointer to the argument list
! of the concatenation subnode
DOWNARGL = .ARGNODE[ARG2PTR];
INCR J FROM 2 TO .DOWNARGL[ARGCOUNT]
DO
BEGIN ! Copy arguments to top level
NEWARGL[.NEWARGPOS, ARGFULL] = .DOWNARGL[.J, ARGFULL];
%1641% ! If this arg has a parent pointer, (is
%1641% ! not an STE), then change it to point
%1641% ! to the upper concatenation node.
%1641% IF NOT .NEWARGL[.NEWARGPOS,AVALFLG]
%1641% THEN
%1641% BEGIN
%1641% SUBARG = .NEWARGL[.NEWARGPOS,ARGNPTR];
%1641% SUBARG[PARENT] = .CNODE
%1641% END;
! Update position in new
! argument list
NEWARGPOS = .NEWARGPOS + 1;
END; ! Copy arguments to top level
! Free the space for the argument list
! of the concatenation subnode
SAVSPACE(ARGLSTSIZE(.DOWNARGL[ARGCOUNT]) - 1, .DOWNARGL);
! Free the space for the concatenation
! subnode
SAVSPACE(EXSIZ - 1, .ARGNODE)
END ! Concatenation subexpression
ELSE
BEGIN ! Not Concatenation
! Just copy this argument to the new
! argument list
NEWARGL[.NEWARGPOS, ARGFULL] = .ARGLIST[.I, ARGFULL];
! Update position in new argument list
NEWARGPOS = .NEWARGPOS + 1;
END; ! Not Concatenation
END; ! Walk the old argument list
! Free the space for the old argument list
SAVSPACE(ARGLSTSIZE(.ARGLIST[ARGCOUNT]) - 1, .ARGLIST);
! Link in the new argument list
CNODE[ARG2PTR] = .NEWARGL;
END; ! Concatenations under this node
RETURN .CNODE ! Return the new node
END; ! of P2SKCONCAT
ROUTINE P2SKSUBSTR(CNODE)= ![1431] New
%(**********************************************************************
PHASE 2 SKELETON FOR A SUBSTRING NODE
TRANSFORMS SUBSTRINGS WITH CONSTANT BOUNDS INTO .D VARIABLES
NYI TRANSFORMS NODES TO LOWER/LENGTH FORM INSTEAD OF LOWER/UPPER FORM
NYI IMPROVES NODES WITH CONSTANT LOWER BOUNDS THAT .NE. 1 TO ONES
(LENGTH FORM?) WITH LOWER BOUND .EQ. 1.
**********************************************************************)%
BEGIN
MAP PEXPRNODE CNODE;
REGISTER PEXPRNODE LNODE:UNODE:ANODE;
LOCAL PEXPRNODE DVAR;
LOCAL PRVNEGFLG,PRVNOTFLG;
%1557% LOCAL PEXPRNODE CHLEN;
DEBGNODETST(CNODE); ! For debugging only
! Perform skel optimizations on offspring nodes
UNODE = .CNODE[ARG1PTR]; ! UNODE points to upper bound expr
LNODE = .CNODE[ARG2PTR]; ! LNODE points to lower bound-1 expr
ANODE = .CNODE[ARG4PTR]; ! ANODE points to ARRAYREF or DATAOPR
IF NOT .CNODE[A1VALFLG]
THEN
BEGIN ! do U node
PRVNEGFLG = .NEGFLG; ! Cannot pass neg/not down over
PRVNOTFLG = .NOTFLG; ! substring, so stop them here
NEGFLG = NOTFLG = FALSE; ! and pass them back up to parent.
CNODE[ARG1PTR] = UNODE = (.P2SKL1DISP[.UNODE[OPRCLS]])(.UNODE);
CNODE[A1NEGFLG] = .NEGFLG;
CNODE[A1NOTFLG] = .NOTFLG;
NEGFLG = .PRVNEGFLG;
NOTFLG = .PRVNOTFLG;
END; ! do U node
IF NOT .CNODE[A2VALFLG]
THEN
BEGIN ! do L node
PRVNEGFLG = .NEGFLG;
PRVNOTFLG = .NOTFLG;
NEGFLG = NOTFLG = FALSE;
CNODE[ARG2PTR] = LNODE = (.P2SKL1DISP[.LNODE[OPRCLS]])(.LNODE);
CNODE[A2NEGFLG] = .NEGFLG;
CNODE[A2NOTFLG] = .NOTFLG;
NEGFLG = .PRVNEGFLG;
NOTFLG = .PRVNOTFLG;
END; ! do L node
IF .ANODE[OPRCLS] EQL ARRAYREF
THEN
CNODE[ARG4PTR] = ANODE = (.P2SKL1DISP[.ANODE[OPRCLS]])(.ANODE);
%1557% ! Get length of variable we're taking substring of
%1557% IF .ANODE[OPRCLS] NEQ ARRAYREF
%1557% THEN CHLEN = .ANODE[IDCHLEN]
%1557% ELSE (CHLEN = .ANODE[ARG1PTR]; CHLEN = .CHLEN[IDCHLEN]);
%1557% ! If bounds are constant, check that they're in range
%1522% IF .LNODE[OPR1] EQL CONSTFL ! If lower bound is constant
%1522% THEN IF .LNODE[CONST2] LSS 0 ! it must be at least 1
%1522% THEN FATLERR(.ISN,E165<0,0>); ! "Substring bound out of range"
%1557% IF .UNODE[OPR1] EQL CONSTFL ! If upper bound is constant
%1557% THEN IF .UNODE[CONST2] GTR .CHLEN ! it must be less than string length
%1557% THEN IF .CHLEN NEQ LENSTAR ! (if length is known)
%1557% THEN FATLERR(.ISN,E165<0,0>); ! "Substring bound out of range"
! Turn reference into a .D variable if both bounds are constant and
! if the base variable is a simple (non-formal) scalar.
%1452% IF .ANODE[OPR1] EQL VARFL
%1706% THEN IF NOT .ANODE[IDATTRIBUT(DUMMY)]
%1706% THEN
BEGIN ! Scalar
! If the substring has constants for both bounds, we can
! replace the substring with a .D variable (whose descriptor
! is calculated at compile time).
IF .LNODE[OPR1] EQL CONSTFL
THEN
BEGIN ! Lower bound constant
IF .UNODE[OPR1] EQL CONSTFL
THEN
BEGIN ! Lower and upper bound both constant
! Substitute a 2-word .D variable for the
! substring reference. Get the .D variable's
! address from the base variable's address;
! calculate its length and byte offset now.
DVAR = NEWDVAR(1);
DVAR[IDADDR] = .CNODE[ARG4PTR];
DVAR[IDCHLEN] = .UNODE[CONST2] - .LNODE[CONST2];
%1522% ! Give substring bound out of range
%1522% ! error if upper bound is less than
%1522% ! lower bound.
%1522% IF .DVAR[IDCHLEN] LEQ 0
%1522% THEN FATLERR(.ISN,E165<0,0>);
DVAR[IDBPOFFSET] = .LNODE[CONST2];
RETURN .DVAR;
END; ! Lower and upper bound both constant
END; ! Lower bound constant
END; ! Scalar
RETURN .CNODE;
END; ! of P2SKSUBSTR
GLOBAL ROUTINE P2SILF(CNODE)=
BEGIN
! Try to change a function call into an inline function or type
! conversion node. It may be instead optimized into a constant, or it
! may be decided to keep the original function call.
! Returns: CNODE
! [1567] New with code moved from P2SKFN
MAP BASE CNODE; ! Function call node to look at
REGISTER
ARGUMENTLIST ARGLST, ! Argument list
BASE ARGNODE; ! Argument node
LOCAL BASE FNNAMENTRY, ! Function symbol table entry
ARGLEN, ! Length of a char arg
ARGPOS, ! Position of arg in arg list
BASE OLDCNODE; ! Node to be removed
ARGLST = .CNODE[ARG2PTR];
FNNAMENTRY = .CNODE[ARG1PTR];
! "In release 1, we don't expand anything with more than 2 args
! inline" Don't make this inline.
IF .ARGLST[ARGCOUNT] GTR 2 THEN RETURN .CNODE;
! Character fn's arg is the 2nd in the arg list.
IF .CNODE[VALTYPE] EQL CHARACTER
THEN ARGNODE = .ARGLST[2,ARGNPTR]
ELSE ARGNODE = .ARGLST[1,ARGNPTR];
! If possible, fold these calls into constants now.
IF .FNNAMENTRY[IDFNFOLD]
THEN
BEGIN
%1535% ! Try to optimize library functions
%1535%
%1535% ! If CHAR or ICHAR with a constant argument, we want to
%1535% ! optimize this, returning the value we would have had
%1535% ! to calculate at run-time.
%1535%
%1535% IF .FNNAMENTRY[IDINLINOPR] EQL ICHARFNOP
%1535% THEN
%1535% BEGIN ! ICHAR
%1535%
%1535% IF .ARGNODE[OPR1] EQL CONSTFL
%1535% THEN
BEGIN
SETPVAL(.CNODE); ! Set parent
SAVSPACE(EXSIZ-1,.CNODE);
%1535% RETURN MAKECNST(INTEGER, 0, .ARGNODE[LITC2]);
%1535% END;
%1535%
%1535% END ! ICHAR
%1535%
%1535% ELSE
%1535% IF .FNNAMENTRY[IDINLINOPR] EQL CHARFNOP
%1535% THEN
%1535% BEGIN ! CHAR
%1535%
%1535% IF .ARGNODE[OPR1] EQL CONSTFL
%1535% THEN
%1535% BEGIN ! Make a character constant
%1535%
SAVSPACE(EXSIZ-1,.CNODE); ! Freespace
! Make a literal constant
%1535% CNODE = MAKLIT(1);
%1535% CNODE[LIT1] = ASCII' ';
%1535% CNODE[LITC2] = .ARGNODE[CONST2]; ! Const value
%1535%
%1535% ! If out of bounds, give a warning.
%1535% IF .ARGNODE[CONST2] LSS 0 OR
%1535% .ARGNODE[CONST2] GTR #177
%1535% THEN FATLERR(.ISN,E202<0,0>);
%1535%
! .Dnnn is not used, don't allocate it.
ARGNODE = .ARGLST[1,ARGNPTR];
ARGNODE[IDATTRIBUT(NOALLOC)] = 1;
SETPVAL(.CNODE); ! Set parent
%1535% RETURN .CNODE;
%1535%
%1535% END; ! Make a character constant
%1535% END ! CHAR
ELSE
IF .FNNAMENTRY[IDINLINOPR] EQL LENFNOP
THEN
BEGIN ! LEN
! If we can find out the length of the character
! argument at compile-time, then remove the
! function call and make this a constant node.
! Make sure we don't have an array ref since we
! could have a function call under this node and
! not know it yet. (If there is a fn call, it
! must be done)
IF .ARGNODE[OPRCLS] NEQ ARRAYREF
THEN
BEGIN
ARGLEN = CHEXLEN(.ARGNODE); ! Len of arg
IF .ARGLEN NEQ LENSTAR ! Len known?
THEN
BEGIN
SETPVAL(.CNODE); ! Set parent
SAVSPACE(EXSIZ-1,.CNODE); ! Freespace
RETURN MAKECNST(INTEGER, 0, .ARGLEN);
END;
END;
END; ! LEN
END; ! Try to fold into a constant
! Make into either a Type convert or an In line function node
IF .FNNAMENTRY[IDILFOPRCLS] EQL TYPECNV
THEN
BEGIN ! Type conversion
CNODE[OPERATOR] = .FNNAMENTRY[IDINLINOPR];
%(***For a type-conversion node, the single arg is arg2***)%
CNODE[ARG2PTR] = .ARGNODE;
IF .ARGLST[1,AVALFLG] THEN CNODE[A2VALFLG] = 1;
%1264% ! If a type conversion NOP (the from and to values are
%1264% ! the same), then remove the node, and replace the type
%1264% ! conversion node with the argument.
%1264%
%1264% IF .CNODE[VALTP2] EQL .CNODE[OPERSP]
%1264% THEN
%1264% BEGIN ! Remove type-convert
%1264%
%1264% OLDCNODE = .CNODE; ! Node to remove
%1264%
%1264% ! Make new node from argument for function
%1264% CNODE = .CNODE[ARG2PTR];
%1264%
%1264% ! Set up parent depending on whether new node is
%1264% ! leaf
%1264%
%1264% IF .CNODE[OPRCLS] EQL DATAOPR
%1264% OR .CNODE[OPRCLS] EQL REGCONTENTS
%1264% OR .CNODE[OPRCLS] EQL CMNSUB
%1264% THEN SETPVAL(.OLDCNODE) % Leaf %
%1264% ELSE CNODE[PARENT] = .OLDCNODE[PARENT];
%1264%
! Free up the space
SAVSPACE(EXSIZ-1,.OLDCNODE);
RETURN .CNODE;
%1264% END; ! Remove type-convert
END ! Type convert
ELSE
BEGIN ! In-line
! If either argument is octal, then we shouldn't make
! this into an inline function. Return the node passed.
INCR CNT FROM 1 TO .ARGLST[ARGCOUNT]
DO
BEGIN
ARGNODE = .ARGLST[.CNT,ARGNPTR];
%1273% IF (.ARGNODE[VALTYPE] EQL OCTAL)
%1273% OR (.ARGNODE[VALTYPE] EQL DOUBLOCT)
THEN RETURN .CNODE; ! Don't make inline
END;
! Change opr fields to be inline
CNODE[OPERATOR] = .FNNAMENTRY[IDINLINOPR];
! Inline's argument position in the arglist depends on
! whether the function is character.
IF .CNODE[VALTYPE] EQL CHARACTER
THEN ARGPOS = 2
ELSE ARGPOS = 1;
! Set up arg1 and whether it is a leaf
CNODE[ARG1PTR] = .ARGLST[.ARGPOS,ARGNPTR];
CNODE[A1VALFLG] = .ARGLST[.ARGPOS,AVALFLG];
IF .ARGLST[ARGCOUNT] EQL 2
THEN
BEGIN ! 2 arguments
! If a character function, a .Dnnn variable is
! needed for the return value. Save the one
! originally generated for the function's return
! value, before the arglist is returned to free
! space.
IF .CNODE[VALTYPE] EQL CHARACTER
THEN ARGPOS = 1
ELSE ARGPOS = 2;
CNODE[ARG2PTR] = .ARGLST[.ARGPOS,ARGNPTR];
CNODE[A2VALFLG] = .ARGLST[.ARGPOS,AVALFLG];
END
ELSE
BEGIN ! One argument
CNODE[ARG2PTR] = 0;
END;
END; ! In-line
%(***If arg1 under this node has a neg node as its top node,
fold it out***)%
ARGNODE = .CNODE[ARG1PTR];
IF .ARGNODE[OPR1] EQL NEGFL
THEN
BEGIN
CNODE[A1NEGFLG] = 1;
CNODE[ARG1PTR] = .ARGNODE[ARG2PTR];
IF .ARGNODE[A2VALFLG]
THEN CNODE[A1VALFLG] = 1
ELSE
BEGIN
OWN PEXPRNODE ARG1NODE;
ARG1NODE = .CNODE[ARG1PTR];
ARG1NODE[PARENT] = .CNODE;
END;
%(***Return the space for the neg to free storage***)%
SAVSPACE(EXSIZ-1,.ARGNODE);
END;
! Return the core that was used for the arg list to free
! storage. Return # of wds-1.
SAVSPACE(.ARGLST[ARGCOUNT]+ARGHDRSIZ-1,.ARGLST);
RETURN .CNODE;
END; ! of P2SILF
END
ELUDOM