Trailing-Edge
-
PDP-10 Archives
-
bb-4157j-bm_fortran20_v11_16mt9
-
fortran-compiler/p2s1.bli
There are 26 other files named p2s1.bli in the archive. Click here to see a list.
!COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1972, 1987
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
!AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!AUTHOR: S. MURPHY/JNG/DCE/TFV/CDM/RVM/AHM/TJK/MEM
MODULE P2S1(SREG=#17,VREG=#15,FREG=#16,DREGS=4,RESERVE(0,1,2,3),GLOROUTINES) =
BEGIN
GLOBAL BIND P2S1V = #11^24 + 0^18 + #4560; ! Version Date: 22-Dec-86
%(
***** 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 V7 Development *****
2007 CDM 6-Oct-83
Do not make LEN or ICHAR inline functions when the argument is a
dynamic concatenation. Dynamic concatenation requires "marks"
and "unwinds". The existing code to do this requires an
argument list structure, but this is thrown away when the
functions are made inline.
2025 TJK 21-Dec-83
P2SKCONCAT doesn't handle inline functions correctly.
Specifically, it makes a redundant call to P2SILF, and more
importantly it doesn't correctly update the argument count,
which can result in incorrect code. This corrects edit 1655.
2030 TJK 4-Jan-84 20-19858
P2SKARITH doesn't check to see if ARSKOPT returns a constant
with NEGFLG set. This case should be reduced to a new negated
constant with NEGFLG cleared, since some routines which call
P2SKARITH ignore NEGFLG when the returned expression is a
constant.
***** Begin Version 10 *****
2243 CDM 13-Dec-83
Detect AOBJN DO loop register indexes into large arrays (arrays
in .LARG.). This is done in the skeleton optimizer, and will
disable the DO loop from using an AOBJN instruction for the
cases that can be caught this early in compilation. This will
prevent the negative left half of the AOBJN register appearing
to be an invalid section number when indexing into the array
when running in a non-zero section.
2251 CDM 22-Dec-83
Add new global variable BIGCONCAT to declare the size (50,000
for now) of the largest concatenation allowed as fixed (CONCTF)
or known maximum (CONCTM) in length. If the concatenation is
larger than this, then the concatenation will be dynamic
(CONCTV) so that it will use the character stack.
2272 TJK 20-Jan-84
Remove code from P2SKCONCAT which folds top-level
subconcatenation nodes in a concatenation argument list,
modify it and make it into a new routine called P2SKFOLD.
Have P2SKCONCAT call this new routine (P2SKCONCAT is
functionally unchanged). This is so SKCALL can call P2SKFOLD
if the CALL statement is really a character assignment or
character statement function so that subconcatenations can be
folded in these cases.
2304 TJK 8-Feb-84
Add P2SKOVRLP to do compile-time overlap checking for
character assignments. Have SKCALL call this routine if the
CALL statement is really a character assignment.
2307 TJK 13-Feb-84
Have P2SKOVRLP manually set NOALLOC for new symbol table
entries CASNN. and CNCAN., since this isn't automatically done
after phase 1.
2352 CDM 1-May-84
Make intrinsic functions IAND, IOR, and IEOR inline functions. They
are converted to Fortran .AND., .OR., AND .XOR. within the skeleton
optimizer.
Generalize P2SILF a little more for inline folding.
2401 TJK 19-Jun-84
Prevent P2SKSUBSTR from creating .Dnnnn constant substring
descriptors. This causes problems elsewhere, and would be
even worse with the optimizer turned on. They are now created
during the complexity walk. Also, remove a .Dnnnn check from
P2SKOVRLP.
2404 TJK 21-Jun-84
Add call to UNSAFE from P2SKOVRLP, replacing an equivalent
in-line test.
***** End V10 Development *****
2544 MEM 13-Aug-85
When converting subtract node into add node, don't just set it to one,
because it might already be set and need to be cleared.
***** End Revision History *****
***** Begin Version 11 *****
4507 MEM 25-Jul-85
Modified P2SKSUBSTR to change some lower/upper substring nodes to
lower/length substring nodes. If it creates a new lower/length
substring node and it is a substring of an array element (instead of a
substring of a variable) then the array offset will be folded into
the lower bound.
4510 MEM 14-Aug-85
Move code for substring bounds checking from DOTDCHECK back to
P2SKSUBSTR.
4515 CDM 20-Sep-85
Phase I for VMS long symbols. Create routine ONEWPTR for Sixbit
symbols. For now, return what is passed it. For phase II, return
[1,,pointer to symbol].
4517 MEM 17-Sep-85
Add routine SINGLECHARCHK to check if it was passed a 1-char variable
(non-dummy), 1-char substring or 1-char arrayref. If it was then
return true else return false.
Routine P2SKFN now checks to see if we have a character
relational with single character args (by calling SINGLECHARCHK) -
if so then convert this into a control relational with ICHAR nodes
above each of the operands. Set the INCRFLG in the ICHAR nodes
indicating that we will have an incremented bytepointer under it.
If an arrayref or substring is under one of the ICHAR nodes,
increment its offset by one.
Two changes are made to P2SILF. If some silly programmer has a
concatenation under an ICHAR, remove the concatenation and replace it
with the first arg of the concatenation - i.e. (ichar(c1//c2//...//cn)
=> ichar(c1) . If we have an ICHAR over a variable(non-dummy),
arrayref or substring then set the INCRFLG in the ICHAR node and if we
have an arrayref or substring node under it then increment its offset.
4522 MEM 5-Nov-85
Modify SINGLECHARCHK to allow dummys and function calls.
Modify P2SKFN to allow incremented and/or unincremented bytepointers
in inline 1-char relationals.
4527 CDM 1-Jan-86
VMS Long symbols phase II. Convert all internal symbols from
one word of Sixbit to [length,,pointer]. The lengths will be one
(word) until a later edit, which will store and use long symbols.
4555 MEM 4-Dec-86
Move bounds checking code back from P2SKSUBSTR to DOTDCHECK.
4557 MEM 9-Dec-86
Modified P2SKSUBSTR to handle ICHAR over function call.
4560 MEM 22-Dec-85
Remove edit 4555 until its bugs are fixed.
ENDV11
)%
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE OPTMAC.BLI;
SWITCHES LIST;
! Below is for use in making PLM's with RUNOFF
!++
!.LITERAL
!--
!++
!***************************************************************
! 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),
%2272% P2SKFOLD(2),
%1431% P2SKCONCAT(1),
%2304% P2SKOVRLP(0),
%4517% SINGLECHARCHK(1), !Check if we have a single char variable/substring/arrayref/function call
%1431% P2SKSUBSTR(1),
%1567% P2SILF(1);
EXTERNAL
ARCMB,
%2243% ARNOAOBJN, ! Routine to decide if array reference's address
%2243% ! calc should make a innermost DO loop not AOBJN.
%2251% BIGCONCAT, ! Size of the biggest concatenation to allow as
%2251% ! as a "fixed length" or "known maximum length"
%2251% ! concatenation.
BLCMB,
C1H,
C1L,
C2H,
C2L,
CANONICALIZE,
CDONODE,
CGERR, ! Error routine for Internal Compiler Errors
%1567% CHEXLEN, ! Returns length of character expression or LENSTAR
CMBEQLARGS,
%761% CNSTCM,
CNTMPY,
COPRIX,
%4507% COPYEXPR,
%1474% CORMAN, ! Routine to get some space from free memory
%2304% BASE CSTMNT, ! Pointer to current statement
DOWDP,
%761% DNEGCNST,
%4510% E165, ! Substring bound out of range error
%1567% E202, ! CHAR library function error
%1522% FATLERR, ! Error routine
%2243% INNERLOOP, ! Flag indicating that we are within an innermost DO loop.
%761% KARIGB,
%761% KARIIB,
%761% KBOOLBASE,
KDNEGB,
KDPRL,
%1542% KGFOCT,
KGFRL,
KSPECB,
KSPECG,
%761% KTYPCB,
%761% KTYPCG,
%2352% MAKPR1, ! Make an expression node
%1535% MAKLIT, ! Makes literal constant entry
NEGFLG,
NEGOFNOT,
%4517% NEWENTRY, ! Make a new table entry
NOTFLG,
NOTOFNEG,
%4517% ONEPLIT, ! Returns pointer to constant table entry for 1
%4515% ONEWPTR, ! Returns [1,,pointer] to Sixbit argument
SAVSPACE, ! Return free space
SETPIMMED,
SETPVAL,
SKERR,
TAKNEGARG,
TAKNOTARG,
%761% TBLSEARCH,
%2404% UNSAFE, ! Checks if two variables can overlap
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
%4517% ARGUMENTLIST ALST, ! Argument list to an ICHAR function
%4527% BASE FNNAMENTRY; ! Function symble table node
LOCAL
%4527% BASE ARGNODE, !Argument node for spec arg
%4517% BASE NODE:TMP, !Temp
PRVNEGFLG,
PRVNOTFLG,
%4517% CH1FLAG; ! true if all args are 1 char
%4517% CH1FLAG = TRUE; ! Assume all arguments are 1 character
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;
%4517% IF NOT SINGLECHARCHK(.ARGLST[.CT,ARGNPTR]) THEN CH1FLAG = FALSE;
%(***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;
%4517% ! If we have a relational with single character args try to make the
%4517% ! following transformation
%4517%
%4517% ! fncall => control relational
%4517% ! / \ / \
%4517% ! fnname arglist inlinfn inlinfn
%4517% ! Lxx. / \ ICHAR ICHAR
%4517% ! arg1 arg2 / /
%4517% ! arg1 arg2
%4517% !
%4517% ! where if arg1 [or arg2] is a char constant then
%4517% !
%4517% ! inlinfn
%4517% ! ICHAR
%4517% ! / => integer const
%4517% ! char const
%4517%
%4517% IF .CH1FLAG EQL TRUE ! All args are a single character
%4527% THEN IF (SELECT .FNNAMENTRY[ID1ST6CHAR] OF
%4517% NSET
%4517% SIXBIT 'LLT.':(TMP = L; EXITSELECT 1);
%4517% SIXBIT 'LEQ.':(TMP = E; EXITSELECT 1);
%4517% SIXBIT 'LLE.':(TMP = LE; EXITSELECT 1);
%4517% SIXBIT 'LNE.':(TMP = N; EXITSELECT 1);
%4517% SIXBIT 'LGT.':(TMP = G; EXITSELECT 1);
%4517% SIXBIT 'LGE.':(TMP = GE; EXITSELECT 1);
%4517% OTHERWISE: 0;
%4517% TESN)
%4517% THEN
%4517% BEGIN
%4517% INCR CT FROM 1 TO .ARGLST[ARGCOUNT]
%4517% DO
%4517% BEGIN
%4517% ARGNODE = .ARGLST[.CT,ARGNPTR];
%4517%
%4517% ! convert char const to integer constant
%4517% IF .ARGNODE[OPR1] EQL CONSTFL
%4517% THEN ARGLST[.CT,ARGNPTR] = MAKECNST(INTEGER,0,.ARGNODE[LITC2])
%4517%
%4522% ! If we have a non-dummy substring/arrayref then
%4517% ! Change arg2ptr to lower bound instead of lower bound-1 in substrings
%4517% ! Change arg2ptr to array offset instead of array offset-1
%4517% ELSE IF .ARGNODE[OPRCLS] EQL SUBSTRING
%4517% OR .ARGNODE[OPRCLS] EQL ARRAYREF
%4517% THEN
%4517% BEGIN
%4522% IF NOT ISDUMMY(ARGNODE)
%4522% THEN
%4522% BEGIN
%4517% ARGNODE[A2VALFLG] = 0;
%4517% NODE = MAKPR1(.ARGNODE,ARITHMETIC,ADDOP,INTEGER,.ARGNODE[ARG2PTR],.ONEPLIT);
%4517% ARGNODE[ARG2PTR] = NODE = (.P2SKL1DISP[.NODE[OPRCLS]])(.NODE);
%4517% IF .NODE[OPRCLS] EQL DATAOPR
%4517% THEN ARGNODE[A2VALFLG] = 1
%4517% ELSE NODE[PARENT] = .ARGNODE;
%4517% END
%4517% END
%4517% END;
%4517%
%4517%
%4517% !Make an expression node for CONTROL RELATIONAL
%4517%
%4517% ARGNODE = MAKPR1(.CNODE[PARENT],RELATIONAL,.TMP,CONTROL,0,0);
%4517% TMP = .CNODE[PARENT];
%4517% IF .TMP[OPRCLS] EQL FNCALL
%4517% THEN
%4517% BEGIN
%4517% REGISTER I;
%4517% ALST = .TMP[ARG2PTR];
%4517% I=0;
%4517% WHILE .ALST[I=.I+1,ARGNPTR] NEQ .CNODE DO;
%4517% ALST[.I,ARGNPTR] = CNODE = .ARGNODE;
%4517% END
%4517% ELSE
%4517% BEGIN ! TMP is not a fncall
%4517% IF .TMP[ARG1PTR] EQL .CNODE
%4517% THEN TMP[ARG1PTR] = CNODE = .ARGNODE
%4517% ELSE TMP[ARG2PTR] = CNODE = .ARGNODE;
%4517% END;
%4517%
%4517% TMP = .ARGLST[1,ARGNPTR];
%4517% IF .TMP[OPR1] EQL CONSTFL
%4517% THEN ! First arg is a constant
%4517% BEGIN
%4517% CNODE[ARG1PTR] = .TMP;
%4517% CNODE[A1VALFLG] = 1;
%4517% CNODE[A1IMMEDFLG] = 1;
%4517% END
%4517%
%4517% !Make an inlinfn expression node for first arg
%4517%
%4517% ELSE
%4517% BEGIN
%4557% ARGNODE = .TMP[ARG1PTR];
%4557% IF .TMP[OPR1] EQL CHARFNFL !Remove CHAR over FNCALL
%4557% THEN IF .ARGNODE[OPRCLS] EQL FNCALL
%4557% THEN
%4557% BEGIN
%4557% CNODE[ARG1PTR] = .TMP[ARG2PTR]; !ARG TO CHAR FN
%4557% SAVSPACE(EXSIZ-1,.TMP); !Savspace CHAR node
%4557% TMP = .CNODE[ARG1PTR];
%4557% END;
%4557%
%4517% ARGNODE = CNODE[ARG1PTR] = MAKPR1(.CNODE,INLINFN,ICHARFN,INTEGER,.TMP,0);
%4517%
%4522% IF .TMP[OPRCLS] EQL SUBSTRING
%4522% OR .TMP[OPRCLS] EQL ARRAYREF
%4522% OR .TMP[OPR1] EQL VARFL
%4522% THEN IF NOT ISDUMMY(TMP)
%4522% THEN ARGNODE[INCRFLG] = 1; ! INCREMENTED BP
%4517% END;
%4517%
%4517% TMP = .ARGLST[2,ARGNPTR];
%4517% IF .TMP[OPR1] EQL CONSTFL
%4517% THEN
%4517% BEGIN
%4517% CNODE[ARG2PTR] = .TMP;
%4517% CNODE[A2VALFLG] = 1;
%4517% CNODE[A2IMMEDFLG] = 1;
%4517% END
%4517%
%4517% !Make an inlinfn expression node for second arg
%4517%
%4517% ELSE
%4517% BEGIN
%4557% ARGNODE = .TMP[ARG1PTR];
%4557% IF .TMP[OPR1] EQL CHARFNFL !Remove CHAR over FNCALL
%4557% THEN IF .ARGNODE[OPRCLS] EQL FNCALL
%4557% THEN
%4557% BEGIN
%4557% CNODE[ARG2PTR] = .TMP[ARG2PTR]; !ARG TO CHAR FN
%4557% SAVSPACE(EXSIZ-1,.TMP); !Savspace CHAR node
%4557% TMP = .CNODE[ARG2PTR];
%4557% END;
%4557%
%4517% NAME = EXPTAB;
%4517% ARGNODE = CNODE[ARG2PTR] = NEWENTRY(); !Make an expression node
%4517% ARGNODE[PARENT] = .CNODE;
%4517% ARGNODE[VALTYPE] = INTEGER;
%4517% ARGNODE[OPRCLS] = INLINFN;
%4517% ARGNODE[OPERSP] = ICHARFN;
%4517% ARGNODE[ARG1PTR] = .TMP; ! = .ARGLST[2,ARGNPTR];
%4517% ARGNODE[ARG2PTR] = 0;
%4517% IF .TMP[OPRCLS] EQL DATAOPR
%4517% THEN ARGNODE[A1VALFLG] = 1
%4517% ELSE TMP[PARENT] = .ARGNODE;
%4522% IF .TMP[OPRCLS] EQL SUBSTRING
%4522% OR .TMP[OPRCLS] EQL ARRAYREF
%4522% OR .TMP[OPR1] EQL VARFL
%4522% THEN IF NOT ISDUMMY(TMP)
%4522% THEN ARGNODE[INCRFLG] = 1; ! INCREMENTED BP
%4517% END;
%4517%
%4517%
%4517% RETURN P2SKREL(.CNODE);
%4517% 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
%2544% CNODE[A2NEGFLG] = IF .CNODE[A2NEGFLG] THEN 0 ELSE 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***)%
%2030% CNODE = ARSKOPT(.CNODE);
%2030%
%2030% IF .NEGFLG AND .CNODE[OPR1] EQL CONSTFL
%2030% THEN
%2030% BEGIN
%2030% NEGFLG = FALSE;
%2030% CNODE = NEGCNST(CNODE);
%2030% END;
%(***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;
%2030% RETURN .CNODE;
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 has 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
!
! CNODE is the ARRAYREF expression node.
!***********************************************************************
!--
BEGIN
MAP PEXPRNODE CNODE;
LOCAL PEXPRNODE SSNODE,
PRVNEGFLG,
PRVNOTFLG;
DEBGNODETST(CNODE); !FOR DEBUGGING ONLY
SSNODE = .CNODE[ARG2PTR];
%(*****UNLESS THE ADDRESS-CALCULATION IS A LEAF, PERFORM THE
PHASE 2 SKEL OPTIMIZATIONS ON IT****)%
IF NOT .CNODE[A2VALFLG]
THEN
BEGIN
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;
%2243% ! If a numeric array reference is:
%2243% !
%2243% ! o in an innermost DO loop,
%2243% ! o and the array is in PSLARGE,
%2243% ! o and the index variable for the DO is in the address
%2243% ! calculation for the array,
%2243% !
%2243% ! then mark that this should not be an AOBJN loop.
%2243%
%2243% IF .INNERLOOP
%2243% THEN ARNOAOBJN(.CNODE);
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
GLOBAL ROUTINE P2SKFOLD(ARGLIST,PARNODE) = ![2272] New
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine is called to fold top-level subconcatenation
! nodes in a concatenation argument list, i.e., it will replace
! any top-level subconcatenation nodes with their corresponding
! operands.
!
! If there are no top-level subconcatenation nodes, it returns
! ARGLIST (unchanged).
!
! If there are top-level subconcatenation nodes, it allocates
! space for a new argument list, fills it in, and returns it.
! In this case, the parent pointers of all operands of top-level
! subconcatenation nodes are replaced with PARNODE (but only
! when appropriate, i.e., not for symbol table entries). Also,
! the original argument list, and all top-level subconcatenation
! nodes and their argument lists, are deallocated.
!
! Note that this routine only looks down one level, since it is
! assumed that skeleton optimizations have already been
! performed on every operand in the argument list. Also note
! that the first operand in the argument is assumed to be the
! destination for the concatenation, and is left unchanged.
!
! FORMAL PARAMETERS:
!
! ARGLIST points to a concatenation argument list
! PARNODE value to be used as a parent pointer
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NAME set up for call to CORMAN
!
! ROUTINE VALUE:
!
! Pointer to an equivalent concatenation argument list with any
! original top-level concatenation operands folded in at the top
! level.
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
MAP ARGUMENTLIST ARGLIST; ! Pointer to the argument list
REGISTER
PEXPRNODE ARGNODE, ! Pointer to an argument
ARGUMENTLIST NEWARGL; ! Pointer to the new argument
! list used when moving
! concatenation subexpressions
! to top level
LOCAL 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
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
INCR I FROM 2 TO .ARGLIST[ARGCOUNT]
DO
BEGIN ! For each concat operand
ARGNODE = .ARGLIST[.I,ARGNPTR]; ! Pointer to argument
! We've already performed skeleton optimizations for
! each argument. Just count the number of
! concatenation operands.
IF .ARGNODE[OPRCLS] EQL CONCATENATION
THEN
BEGIN
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
ELSE NUMARGS = .NUMARGS + 1; ! Single operand
END; ! For each concat operand
! NUMARGS is now the number of arguments we really want. If
! it's equal to the current argument count, then we didn't
! find any subconcatenation nodes that we want to fold, so
! simply return the original argument list.
IF .NUMARGS EQL .ARGLIST[ARGCOUNT]
THEN RETURN .ARGLIST;
! There are subconcatenations in this argument list. Build a
! new argument list with all concatenation operands at the top
! level.
NAME<LEFT> = ARGLSTSIZE(.NUMARGS); ! Size of new arg list
NEWARGL = CORMAN(); ! Get space for new arg list
! Copy the header words to the new argument list
DECR I FROM ARGHDRSIZ - 1 TO 0
DO (.NEWARGL)[.I] = .(.ARGLIST)[.I];
! Also copy the first argument, which is the destination
NEWARGL[1,ARGFULL] = .ARGLIST[1,ARGFULL];
NEWARGL[ARGCOUNT] = .NUMARGS; ! Fill in the arg count
! Walk down the old argument list copying the arguments into
! the new argument list. Move the arguments of concatenation
! subnodes to the top level. Don't 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
ARGNODE = .ARGLIST[.I,ARGNPTR]; ! Get ptr to this arg
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,
%1641% ! (is not an STE), then change it to
%1641% ! point to the parent of the old arg
%1641% ! list.
%1641%
%1641% IF NOT .NEWARGL[.NEWARGPOS,AVALFLG]
%1641% THEN
%1641% BEGIN
%1641% SUBARG = .NEWARGL[.NEWARGPOS,ARGNPTR];
%1641% SUBARG[PARENT] = .PARNODE;
%1641% END;
! Update position in new arg 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);
RETURN .NEWARGL;
END; ! of P2SKFOLD
ROUTINE P2SKCONCAT(CNODE) =
BEGIN
%1474% ! Written by TFV on 8-Feb-82
![2272] Removed code to fold subconcatenation nodes and put it into
![2272] P2SKFOLD so it can be used elsewhere.
!++
! 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. Otherwise keep it unchanged at CONCTV.
!--
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
LEN, ! Size of the fixed length result
PEXPRNODE SUBARG; ! Pointer to the argument in the
! argument list of a subnode
LEN = 0; ! Initialize length
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];
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];
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];
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% SUBARG = .ARGNODE[ARG2PTR]; ! .Dnnn return value
%1655% LEN = .LEN + .SUBARG[IDCHLEN]; ! Add in length
%1655%
%1655% END; ! INLINFN
BEGIN ! SUBSTRING
%4517% ! Get pointer to upper bound / length 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
%4517% IF .ARGNODE[OPERSP] EQL SUBSTRUP ! upper/lower substring
%4507% THEN LEN = .LEN + .UNODE[CONST2] - .LNODE[CONST2]
%4507% ELSE LEN = .LEN + .UNODE[CONST2];! lower/length substring
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
END; ! SUBSTRING
BEGIN ! CONCATENATION
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
END; ! CONCATENATION
TES;
END; ! Walk down the argument list
! Now try to make this a "fixed length" or "known maximum
! length" concatenation. Leave it "variable length" if it is
! too large, since we'd rather do this on the character stack
! than allocating large amounts of static storage in the
! user's program. Note that LEN will be ill-defined if there
! are any variable-length operands. In this case, ISFIXEDLEN
! and ISMAXLEN will both be false (i.e., the concatenation
! will remain variable-length), so the following test is still
! safe.
%2251% IF .LEN LEQ .BIGCONCAT
%2251% THEN
%2251% BEGIN ! Length small enough to make non-dynamic
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
%2251% END; ! Length small enough to make non-dynamic
%2272% ! Fold top-level concats
%2272%
%2272% CNODE[ARG2PTR] = P2SKFOLD(.ARGLIST,.CNODE);
RETURN .CNODE ! Return the new node
END; ! of P2SKCONCAT
GLOBAL ROUTINE P2SKOVRLP = ![2304] New
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine performs compile-time overlap detection for
! character assignments. The assignment statement is a CALL
! statement pointed to by CSTMNT, and should call either CASNM.
! or CNCAM., which are the routines that perform character
! assignment in its most general case.
!
! This routine tries to determine whether or not overlap is
! possible in the character assignment. If it determines that
! overlap cannot occur, it replaces the call to CASNM. or CNCAM.
! with a call to CASNN. or CNCAN. (these routines assume there's
! no overlap).
!
! As a future development edit, the following optimization may
! be added: If it determines that overlap always occurs, it
! replaces the call to CASNM. or CNCAM. with a call to CASNO.
! or CNCAO. (these routines assume there's overlap).
!
! If it can't make any determination at compile-time, it
! preserves the call to the original routine (CASNM. or CNCAM.).
! These routines make no assumptions about overlap and perform
! run-time tests to determine whether or not overlap occurs.
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! CSTMNT This points to a character assignment
! statement (i.e., a CALL statement to CASNM. or
! CNCAM.)
!
! FLAG Set by TBLSEARCH. True if the symbol table
! entry already existed.
!
! IMPLICIT OUTPUTS:
!
! CSTMNT[CALSYM] This is the name of the routine to be called
! by the CALL statement pointed to by CSTMNT.
!
! ENTRY Set for call to TBLSEARCH. Contains the
! [length,,pointer] to name of the symbol table entry.
!
! NAME Set for call to TBLSEARCH. Indicates which
! table to use.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN
REGISTER
ARGUMENTLIST ARGLIST, ! Pointer to the argument list
BASE SRCNAME, ! Pointer to symbol table entry
! for a source variable
BASE DESTNAME; ! Pointer to symbol table entry
! for destination variable
LOCAL NOOVRLP, ! Flag indicating no overlap
BASE CALLNAME; ! Pointer to symbol table entry
! for name of routine being called
LABEL SRCWALK, ! Labels loop to walk source strings
THISSRC; ! Labels body of loop to walk source
! strings
ARGLIST = .CSTMNT[CALLIST]; ! Get pointer to argument list
DESTNAME = .ARGLIST[1,ARGNPTR]; ! Get pointer to destination
! DESTNAME is either a SUBSTRING, an ARRAYREF, or a variable
IF .DESTNAME[OPRCLS] EQL SUBSTRING ! If DESTNAME is a substring
THEN DESTNAME = .DESTNAME[ARG4PTR]; ! Get full string
! DESTNAME is now either an ARRAYREF or a variable
IF .DESTNAME[OPRCLS] EQL ARRAYREF ! If DESTNAME is an array ref
THEN DESTNAME = .DESTNAME[ARG1PTR]; ! Get ptr to array name
! DESTNAME is now a variable or array name
NOOVRLP = TRUE; ! Initially assume no overlap
SRCWALK:
INCR I FROM 2 TO .ARGLIST[ARGCOUNT]
DO
THISSRC:
BEGIN ! For each source string
SRCNAME = .ARGLIST[.I,ARGNPTR]; ! Get ptr to next src
IF .SRCNAME[OPERATOR] EQL CHARCONST ! If SRCNAME is const
THEN LEAVE THISSRC; ! No overlap
IF .SRCNAME[OPRCLS] NEQ SUBSTRING
THEN IF .SRCNAME[OPRCLS] NEQ ARRAYREF
THEN IF .SRCNAME[OPRCLS] NEQ DATAOPR
THEN LEAVE THISSRC; ! No overlap
! SRCNAME is now either a SUBSTRING, an ARRAYREF, or a variable
IF .SRCNAME[OPRCLS] EQL SUBSTRING ! If substring
THEN SRCNAME = .SRCNAME[ARG4PTR]; ! Get full string
! SRCNAME is now either an ARRAYREF or a variable
IF .SRCNAME[OPRCLS] EQL ARRAYREF ! If an array ref
THEN SRCNAME = .SRCNAME[ARG1PTR]; ! Get ptr to array name
! SRCNAME is now a variable or array name
IF .SRCNAME EQL .DESTNAME ! Check for match
THEN
BEGIN ! Matching source and destination names
!!! This should become more sophisticated someday
!!! Could also check to see if array indices are
!!! different constants
NOOVRLP = FALSE; ! Assume overlap
LEAVE SRCWALK; ! Punt
END ! Matching source and destination names
! Now check for common/equivalence potential overlap.
%2404% ELSE IF UNSAFE(.SRCNAME,.DESTNAME)
THEN
BEGIN ! Potential common/equiv problems
NOOVRLP = FALSE; ! Assume overlap
LEAVE SRCWALK; ! Punt
END; ! Potential common/equiv problems
END; ! For each source string
IF .NOOVRLP
THEN
BEGIN ! No overlap
NAME = IDTAB; ! Look in symbol table
CALLNAME = .CSTMNT[CALSYM]; ! Get routine name
! See if we're calling CASNM. or CNCAM., and set ENTRY
! accordingly.
%4527% IF .CALLNAME[ID1ST6CHAR] EQL SIXBIT 'CASNM.'
THEN ENTRY = SIXBIT 'CASNN.' ! It's CASNM., make it CASNN.
ELSE ENTRY = SIXBIT 'CNCAN.'; ! It's CNCAM., make it CNCAN.
%4515% ENTRY = ONEWPTR(.ENTRY); ! [1,,pointer]
! Get the symbol table entry for the new routine. If
! it's not already there, create it.
CSTMNT[CALSYM] = CALLNAME = TBLSEARCH();
IF NOT .FLAG ! New symbol table entry?
THEN
BEGIN ! New symbol table entry
CALLNAME[OPERSP] = FNNAME; ! Func/subr name
CALLNAME[IDLIBFNFLG] = 1; ! Library func/subr
CALLNAME[IDCLOBB] = 1; ! ACs are clobbered
%2307% ! Have to manually set NOALLOC after phase 1
%2307%
%2307% CALLNAME[IDATTRIBUT(NOALLOC)] = 1;
END; ! New symbol table entry
END; ! No overlap
END; ! of P2SKOVRLP
GLOBAL ROUTINE SINGLECHARCHK(EXP) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Checks if EXP is a one character const, variable, array element,
! substring or function call
!
! FORMAL PARAMETERS:
!
! EXP Expression node
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE:
!
! Return 1 if EXP is a single character substring, array ref,
! variable, const or function call. Otherwise, return 0
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN ! New [4517]
MAP BASE EXP;
REGISTER BASE EXP2;
IF .EXP[VALTYPE] NEQ CHARACTER THEN RETURN FALSE;
IF .EXP[OPR1] EQL SUBSLFL AND .EXP[A1VALFLG]
THEN ! lower/length substring
BEGIN
RETURN .EXP[ARG1PTR] EQL .ONEPLIT ! true if constant 1
END
ELSE IF .EXP[OPRCLS] EQL ARRAYREF
THEN
BEGIN
EXP2 = .EXP[ARG1PTR]; ! EXP2 = variable
RETURN .EXP2[IDCHLEN] EQL 1 ! true if 1 char array element
END
ELSE IF .EXP[OPRCLS] EQL DATAOPR
THEN
BEGIN
IF .EXP[OPERSP] EQL VARIABLE THEN
BEGIN
RETURN .EXP[IDCHLEN] EQL 1 ! true if 1 char
END
ELSE IF .EXP[OPERSP] EQL CONSTANT
THEN
BEGIN
RETURN .EXP[LITLEN] EQL 1 ! true if const 1
END
END
%4522% ELSE IF .EXP[OPRCLS] EQL FNCALL
%4522% THEN
%4522% BEGIN
%4522% EXP2 = .EXP[ARG1PTR]; !Routine name
%4522%
%4522% RETURN .EXP2[IDCHLEN] EQL 1 ! true if 1 char
%4522% END;
RETURN 0
END;
ROUTINE P2SKSUBSTR(CNODE)= ![1431] New
%(**********************************************************************
PHASE 2 SKELETON FOR A SUBSTRING NODE
[4507] 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.
[2401] Note that this latter NYI optimization will probably involve
[2401] the creation of a compile-time constant (.Dnnnn), or partially
[2401] initialized (.Qnnnn) descriptor. If so, or if any new
[2401] aliasing of this type is implemented, it must be done during
[2401] the complexity walk (in DOTDCHECK) to avoid creating bugs.
**********************************************************************)%
BEGIN
MACRO STRIPCONST(BOUND,CONSTSUM,NEGFLG,LOWLEN) = ! [4507] New
!
! FORMAL PARAMETERS:
!
! BOUND lower or upper bound of a substring index
!
! CONSTSUM sum of constants in length of substring
!
! NEGFLG negflg for BOUND ( set if BOUND = k - D)
!
! LOWLEN false if BOUND is not one of the following
! D + k D - k D
! k + D k - D k
! where D is a dataopr and k is a constant
!
BEGIN
MAP BASE BOUND;
LOCAL BASE ARG1:ARG2;
IF .BOUND[OPR1] EQL ADDOPF ! D + k or k + D or D + D2
THEN
BEGIN
ARG1 = .BOUND[ARG1PTR];
ARG2 = .BOUND[ARG2PTR];
IF .ARG1[OPERSP] EQL CONSTANT ! k + D
THEN
BEGIN
IF .BOUND[A1NEGFLG]
THEN CONSTSUM = .CONSTSUM - .ARG1[CONST2]
ELSE CONSTSUM = .CONSTSUM + .ARG1[CONST2];
BOUND = .BOUND[ARG2PTR];
END
ELSE IF .ARG2[OPERSP] EQL CONSTANT! D + k
THEN
BEGIN
IF .BOUND[A2NEGFLG]
THEN CONSTSUM = .CONSTSUM - .ARG2[CONST2]
ELSE CONSTSUM = .CONSTSUM + .ARG2[CONST2];
BOUND = .BOUND[ARG1PTR];
END
ELSE LOWLEN = FALSE; ! D + D2
END
ELSE IF .BOUND[OPERSP] EQL SUBOPF ! D - k or k - D or D - D2
THEN
BEGIN
ARG1 = .BOUND[ARG1PTR];
ARG2 = .BOUND[ARG2PTR];
IF .ARG2[OPERSP] EQL CONSTANT ! D - k
THEN
BEGIN
IF .BOUND[A2NEGFLG]
THEN CONSTSUM = .CONSTSUM + .ARG1[CONST2]
ELSE CONSTSUM = .CONSTSUM - .ARG1[CONST2];
BOUND = .ARG1;
END
ELSE IF .ARG1[OPERSP] EQL CONSTANT! k - D
THEN
BEGIN
IF .BOUND[A1NEGFLG]
THEN CONSTSUM = .CONSTSUM - .ARG1[CONST2]
ELSE CONSTSUM = .CONSTSUM + .ARG1[CONST2];
NEGFLG = 1;
BOUND = .ARG2;
END
ELSE LOWLEN = FALSE; ! D - D2
END
ELSE LOWLEN = FALSE; ! not an addop or subop
END$;
MAP PEXPRNODE CNODE;
REGISTER PEXPRNODE LNODE:UNODE:ANODE;
LOCAL PEXPRNODE DVAR;
LOCAL PRVNEGFLG,PRVNOTFLG;
%1557% LOCAL PEXPRNODE CHLEN;
%4507% LOCAL BASE SUBNODE:LENNODE; ! USED FOR BUILDING SUBSTRING NODE
%4507% LOCAL CONSTSUM,LNEGFLG,UNEGFLG; ! USED FOR BUILDING SUBSTRING NODE
%4507% LOCAL LOWLEN; ! FLAG INDICATING IF THE NEW LENGTH/LOW
! NODE CAN BE BUILT
DEBGNODETST(CNODE); ! For debugging only
%4517% ! If we already have a lower/length form then return
%4517% IF .CNODE[OPERSP] EQL SUBSTRLEN THEN RETURN .CNODE;
! Perform skel optimizations on offspring nodes
%4507% UNODE = .CNODE[ARG1PTR]; ! UNODE points to upper bound or length expr
%4507% LNODE = SUBNODE = .CNODE[ARG2PTR];! LNODE points to lower bound-1 expr
%4507% IF .LNODE[OPR1] NEQ SUBOPF THEN SKERR();
%4507% LNODE = .LNODE[ARG1PTR]; ! LNODE points to lower bound 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
%4507% IF NOT .SUBNODE[A1VALFLG]
%4507% THEN
%4507% BEGIN ! do L node
%4507% PRVNEGFLG = .NEGFLG;
%4507% PRVNOTFLG = .NOTFLG;
%4507% NEGFLG = NOTFLG = FALSE;
%4507% SUBNODE[ARG1PTR] = LNODE = (.P2SKL1DISP[.LNODE[OPRCLS]])(.LNODE);
%4507% SUBNODE[A1NEGFLG] = .NEGFLG;
%4507% SUBNODE[A1NOTFLG] = .NOTFLG;
%4507% NEGFLG = .PRVNEGFLG;
%4507% NOTFLG = .PRVNOTFLG;
%4507% END; ! do L node
%4510%
%4510% ! Get the length of the character variable or array element
%4510% ! we're taking the substring from.
%4510%
%4510% IF .ANODE[OPRCLS] NEQ ARRAYREF
%4510% THEN CHLEN = .ANODE[IDCHLEN] ! ANODE is scalar, get its length
%4510% ELSE
%4510% BEGIN ! ARRAYREF
%4510%
%4510% CHLEN = .ANODE[ARG1PTR]; ! Array name
%4510% CHLEN = .CHLEN[IDCHLEN]; ! Length of array element
%4510%
%4510% END; ! ARRAYREF
%4510%
%4510% IF .LNODE[OPR1] EQL CONSTFL
%4510% THEN IF .LNODE[CONST2] LSS 1 ! Lower bound must be >= 1
%4510% OR ! and < CHLEN
%4510% (.CHLEN NEQ LENSTAR AND .LNODE[CONST2] GTR .CHLEN)
%4510% THEN FATLERR(.ISN,E165<0,0>); ! Give bounds error
%4510%
%4510% IF .UNODE[OPR1] EQL CONSTFL
%4510% THEN
%4510% BEGIN ! Upper bound is constant
%4510%
%4510% IF .UNODE[CONST2] LSS 1 ! Upper bound must be >= 1
%4510% OR ! and <= CHLEN
%4510% (.CHLEN NEQ LENSTAR AND .UNODE[CONST2] GTR .CHLEN)
%4510% THEN FATLERR(.ISN,E165<0,0>); ! Give bounds error
%4510%
%4510%
%4510% IF .LNODE[OPR1] EQL CONSTFL
%4510% THEN
%4510% BEGIN ! Upper and lower bounds are both constant
%4510%
%4510% ! Give a bounds error if the lower bound minus
%4510% ! one is >= the upper bound (i.e., the
%4510% ! user-specified lower bound is > the upper
%4510% ! bound).
%4510%
%4510% IF .LNODE[CONST2] GTR .UNODE[CONST2]
%4510% THEN FATLERR(.ISN,E165<0,0>) ! Give bounds error
%4510% END;
%4510% END;
%4510%
%4507% ! If both the upper and lower bounds are of one of the following forms
%4507% ! then we should make a lower/length substring node
%4507%
%4507% ! D D + k D - k
%4507% ! k k + D k - D
%4507%
%4507% ! where D = a dataopr and k = a constant
%4507%
%4507% LOWLEN = TRUE; ! Assume both indexes are of the appropriate form until
%4507% ! we find otherwise
%4507% LNEGFLG = .SUBNODE[A1NEGFLG];
%4507% UNEGFLG = .CNODE[A1NEGFLG];
%4507%
%4507%
%4507% ! Check if lower bound is of one of the 6 cases and set LOWLEN accordingly
%4507% CONSTSUM = 0;
%4507% IF (.LNODE[OPRCLS] NEQ DATAOPR)
%4507% THEN
%4507% BEGIN
%4507% IF (.LNODE[A1VALFLG]) AND (.LNODE[A2VALFLG])
%4507% THEN STRIPCONST(LNODE,CONSTSUM,LNEGFLG,LOWLEN)
%4507%
%4507% ELSE LOWLEN = FALSE;
%4507% END;
%4507%
%4507% CONSTSUM = 1 - .CONSTSUM; ! length = U - (L-1) = 1-L+U
%4507%
%4507% ! Check if upper bound is of one of the 6 cases and set LOWLEN accordingly
%4507% IF (.UNODE[OPRCLS] NEQ DATAOPR) AND (.LOWLEN EQL TRUE)
%4507% THEN
%4507% BEGIN
%4507% IF (.UNODE[A1VALFLG]) AND (.UNODE[A2VALFLG])
%4507% THEN STRIPCONST(UNODE,CONSTSUM,UNEGFLG,LOWLEN)
%4507% ELSE LOWLEN = FALSE;
%4507% END;
%4507%
%4507% IF .LOWLEN EQL TRUE
%4507% THEN ! Make lower/length substring node
%4507% BEGIN
%4507% CNODE[OPERSP] = SUBSTRLEN;
%4507%
%4507% ! Length node will look like +
%4507% ! / \
%4507% ! - C
%4507% ! / \
%4507% ! U L
%4507% !
%4507% ! where upper bound = U + k
%4507% ! lower bound = L + k2
%4507% ! C = k + k2 + 1
%4507%
%4507%
%4507%
%4507% ! Make UBOUND into length node
%4507%
%4507% LENNODE = MAKPR1(.CNODE,ARITHMETIC,ADDOP,INTEGER,0,MAKECNST(INTEGER,0,.CONSTSUM));
%4507% SUBNODE = MAKPR1(.LENNODE,ARITHMETIC,SUBOP,INTEGER,.UNODE,.LNODE);
%4507%
%4507% SUBNODE[A1NEGFLG] = .UNEGFLG;
%4507% SUBNODE[A2NEGFLG] = .LNEGFLG;
%4507%
%4507% LENNODE[ARG1PTR] = .SUBNODE;
%4507% UNODE = CNODE[ARG1PTR] = .LENNODE;
%4507% CNODE[A1VALFLG] = 0;
%4507%
%4507% IF NOT .CNODE[A1VALFLG]
%4507% THEN
%4507% BEGIN ! do U node
%4507% PRVNEGFLG = .NEGFLG; ! Cannot pass neg/not down over
%4507% PRVNOTFLG = .NOTFLG; ! substring, so stop them here
%4507% NEGFLG = NOTFLG = FALSE; ! and pass them back up to parent.
%4507% CNODE[ARG1PTR] = UNODE = (.P2SKL1DISP[.UNODE[OPRCLS]])(.UNODE);
%4507% CNODE[A1NEGFLG] = .NEGFLG;
%4507% CNODE[A1NOTFLG] = .NOTFLG;
%4507% NEGFLG = .PRVNEGFLG;
%4507% NOTFLG = .PRVNOTFLG;
%4507% END; ! do U node
%4507% END;
%4507%
%4507% LNODE = .CNODE[ARG2PTR];
%4507% IF .LNODE[OPRCLS] EQL DATAOPR
%4507% THEN .CNODE[A2VALFLG] = 1
%4507% ELSE LNODE[PARENT] = .CNODE;
%4507%
%4507% ! If we have a lower/length substring node and ANODE is an arrayref
%4507% ! then add the array offset to the lower bound and set anode to
%4507% ! anode[arg1ptr]
%4507%
%4517% IF .CNODE[OPERSP] EQL SUBSTRLEN AND .ANODE[OPRCLS] EQL ARRAYREF
%4507% THEN
%4507% BEGIN
%4507% CNODE[ARG2PTR] = LNODE = MAKPR1(.CNODE,ARITHMETIC,ADDOP,INTEGER,.LNODE,.ANODE[ARG2PTR]);
%4507% SUBNODE = .ANODE;
%4507% CNODE[ARG4PTR] = ANODE = .ANODE[ARG1PTR];
%4507% SAVSPACE(EXSIZ-1,.SUBNODE) ! savspace arrayref node
%4507% END;
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
%2401% THEN CNODE[ARG4PTR] = (.P2SKL1DISP[.ANODE[OPRCLS]])(.ANODE);
%2401% ! Remove code which creates .Dnnnn variables. This is now
%2401% ! done during the complexity walk, along with bounds checking,
%2401% ! by DOTDCHECK.
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
%4517% BASE NODE:ARG1;
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 this function call into something else now. We may
! be able to fold this into a constant or a node that the compiler
! already recognizes.
IF .FNNAMENTRY[IDFNFOLD]
THEN
BEGIN ! Try to fold into a constant
! Try to optimize library functions based on the function type.
! If we can fold into something better, then return to caller
! and stop processing for an inline function.
%2352% CASE .FNNAMENTRY[IDILFOPERSP] OF SET
%2352%
%2352% BEGIN END; ! ABSFN - Can't fold
%2352% BEGIN END; ! CMPLXFN - Can't fold
%2352% BEGIN END; ! SIGNFN - Can't fold
%2352% BEGIN END; ! DIMFN - Can't fold
%2352% BEGIN END; ! MODFN - Can't fold
%2352% BEGIN END; ! MAXFN - Can't fold
%2352% BEGIN END; ! MINFN - Can't fold
%1535% BEGIN ! CHARFN
%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; ! CHARFN
BEGIN ! LENFN
! 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.
%2007% ! If the argument is a dynamic concatenation,
%2007% ! then don't make this into an inline fn.
%2007% IF .ARGNODE[OPR1] EQL DYNCONCAT THEN RETURN .CNODE;
! 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; ! LENFN
%1535% BEGIN ! ICHARFN
%4517%
%4517% ! ichar(c1) <= ichar(c1//c2//...cn)
%4517%
%4517% IF .ARGNODE[OPRCLS] EQL CONCATENATION
%4517% THEN
%4517% BEGIN
%4517% LOCAL ARGUMENTLIST ALST;
%4517%
%4517% ALST = .ARGNODE[ARG2PTR];
%4517% ! SAVSPACE
%4517% ARGNODE = .ALST[2,ARGNPTR];
%4517% ARGNODE[PARENT] = .CNODE;
%4517% ARGLST[1,ARGNPTR] = .ARGNODE;
%4517% END;
%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
%4517% ELSE IF .ARGNODE[OPR1] EQL VARFL
%4517% THEN
%4517% BEGIN
%4517% IF NOT .ARGNODE[IDATTRIBUT(DUMMY)]
%4517% THEN CNODE[INCRFLG] = 1; !INCREMENTED BP
%4517% END
%4517% ELSE IF .ARGNODE[OPRCLS] EQL SUBSTRING
%4517% THEN
%4517% BEGIN
%4517% LOCAL BASE LEN;
%4517% LEN = .ARGNODE[ARG1PTR];
%4517%
%4517% NODE = .CNODE[ARG4PTR]; !ARRAYREF/VARIABLE
%4517% IF .NODE[OPRCLS] EQL ARRAYREF
%4517% THEN NODE = .NODE[ARG1PTR]; !VARIABLE
%4517% IF NOT .NODE[IDATTRIBUT(DUMMY)]
%4517% THEN ! non-dummy substring
%4517% BEGIN
%4517% CNODE[INCRFLG] = 1; !ALREADY INCREMENTED BP
%4517%
%4517% ! Make all substrings of length 1
%4517% IF .ARGNODE[OPERSP] NEQ SUBSTRLEN
%4517% OR .LEN[OPR1] NEQ CONSTFL OR .LEN[CONST2] NEQ 1
%4517% THEN
%4517% BEGIN
%4517% IF .LEN[OPR1] NEQ CONSTFL AND .LEN[OPR1] NEQ VARFL
%4517% THEN SAVSPACE(EXSIZ-1,.ARGNODE[ARG1PTR]);
%4517%
%4517% IF .LEN NEQ .ONEPLIT
%4517% THEN
%4517% BEGIN
%4517% ARGNODE[ARG1PTR] = .ONEPLIT;
%4517% ARGNODE[A1VALFLG] = 1;
%4517% ARGNODE[A1IMMEDFLG] = 1;
%4517% END;
%4517% END;
%4517%
%4517% ! Change arg2ptr to lower bound instead of
%4517% ! lower bound-1 in all non-dummy substrings
%4517% ARG1 = .ARGNODE[ARG1PTR];
%4517% NODE = .ARGNODE[ARG2PTR];
%4517% ARGNODE[A2VALFLG] = 0;
%4517% ARGNODE[ARG2PTR] = NODE = MAKPR1(.ARGNODE,ARITHMETIC,ADDOP,INTEGER,.NODE,.ONEPLIT);
%4517% ARGNODE[ARG2PTR] = (.P2SKL1DISP[.NODE[OPRCLS]])(.NODE);
%4517% END ! non-dummy substring
%4517% END
%4517%
%4517% ELSE IF .ARGNODE[OPRCLS] EQL ARRAYREF
%4517% THEN
%4517% BEGIN
%4517% NODE = .ARGNODE[ARG1PTR]; !VARIABLE
%4517% IF NOT .NODE[IDATTRIBUT(DUMMY)]
%4517% THEN ! non-dummy arrayref
%4517% BEGIN
%4517% CNODE[INCRFLG] = 1; !ALREADY INCREMENTED BP
%4517%
%4517% ! Change arg2ptr to array offset instead of array
%4517% ! offset-1 in all non-dummy arrayrefs
%4517% NODE = .ARGNODE[ARG2PTR];
%4517% ARGNODE[A2VALFLG] = 0;
%4517% ARGNODE[ARG2PTR] = NODE = MAKPR1(.ARGNODE,ARITHMETIC,ADDOP,INTEGER,.NODE,.ONEPLIT);
%4517% ARGNODE[ARG2PTR] = (.P2SKL1DISP[.NODE[OPRCLS]])(.NODE);
%4517% END ! non-dummy arrayref
%4517% END
%1535%
%1535% END; ! ICHARFN
%2352% BEGIN ! IORFN
%2352%
%2352% ! Convert this to be a simple Fortran OR. Setup arg1,
%2352% ! arg2, then skeleton optimize this new node.
%2352%
%2352% CNODE[OPR1] = OROPFL;
%2352%
%2352% CNODE[ARG1PTR] = .ARGLST[1,ARGNPTR];
%2352% CNODE[A1VALFLG] = .ARGLST[1,AVALFLG];
%2352%
%2352% CNODE[ARG2PTR] = .ARGLST[2,ARGNPTR];
%2352% CNODE[A2VALFLG] = .ARGLST[2,AVALFLG];
%2352%
%2352% RETURN (.P2SKL1DISP[.CNODE[OPRCLS]])(.CNODE);
%2352%
%2352% END; ! IORFN
%2352% BEGIN ! IAND
%2352%
%2352% ! Convert this to be a simple Fortran AND. Setup arg1,
%2352% ! arg2, then skeleton optimize this new node.
%2352%
%2352% CNODE[OPR1] = ANDOPFL;
%2352%
%2352% CNODE[ARG1PTR] = .ARGLST[1,ARGNPTR];
%2352% CNODE[A1VALFLG] = .ARGLST[1,AVALFLG];
%2352%
%2352% CNODE[ARG2PTR] = .ARGLST[2,ARGNPTR];
%2352% CNODE[A2VALFLG] = .ARGLST[2,AVALFLG];
%2352%
%2352% RETURN (.P2SKL1DISP[.CNODE[OPRCLS]])(.CNODE);
%2352%
%2352% END; ! IANDFN
%2352% BEGIN CGERR() END; ! ISHFTFN - ** not yet implimented
%2352% BEGIN CGERR() END; ! ISHFTCFN - ** not yet implimented
%2352% BEGIN CGERR() END; ! IBITSFN - ** not yet implimented
%2352% BEGIN CGERR() END; ! NOTFN - ** not yet implimented
%2352% BEGIN ! IEORFN
%2352%
%2352% ! Convert this to be a simple Fortran XOR. Setup arg1,
%2352% ! arg2, then skeleton optimize this new node.
%2352%
%2352% CNODE[OPR1] = XOROPFL;
%2352%
%2352% CNODE[ARG1PTR] = .ARGLST[1,ARGNPTR];
%2352% CNODE[A1VALFLG] = .ARGLST[1,AVALFLG];
%2352%
%2352% CNODE[ARG2PTR] = .ARGLST[2,ARGNPTR];
%2352% CNODE[A2VALFLG] = .ARGLST[2,AVALFLG];
%2352%
%2352% RETURN (.P2SKL1DISP[.CNODE[OPRCLS]])(.CNODE);
%2352%
%2352% END; ! IEORFN
%2352% BEGIN CGERR() END; ! BTESTFN - ** not yet implimented
%2352% BEGIN CGERR() END; ! IBSETFN - ** not yet implimented
%2352% BEGIN CGERR() END; ! IBCLRFN - ** not yet implimented
%2352%
%2352% TES; ! End of CASE
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
! Below is for use in making PLM's with RUNOFF
!++
!.END LITERAL
!--
END
ELUDOM