Trailing-Edge
-
PDP-10 Archives
-
bb-4157j-bm_fortran20_v11_16mt9
-
fortran-compiler/util.bli
There are 13 other files named util.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.
!AUTHORS: NORMA ABEL AND SARA MURPHY/HPW/DCE/SJW/EGM/TFV/CDM/TJK/MEM/AHM
MODULE UTIL(RESERVE(0,1,2,3),SREG=#17,VREG=#15,FREG=#16,DREGS=4,GLOROUTINES)=
BEGIN
GLOBAL BIND UTILV = #11^24 + 0^18 + #4527; ! Version Date: 1-Jan-85
%(
***** Begin Revision History *****
72 ----- ----- ADD ROUTINE TRANSMOGRIFY TO RENAME SYMBOLS
73 ----- ----- FIX CONTVAR TO CORRCTLTY HANDLE IOLISTS
74 ----- ----- FIX DOVARSUBSTITUTE TO SET ASGN4USED ON DO LOOP
INDEX
75 ----- ----- ADD ROUTINES ALODIMCONSTS,ALDIM1 TO ALLOCATE CORE
FOR CONSTANTS USED IN SPECIFYING DIMENSION TABLE
INFORMATION (ROUTINES ARE CALLED WHEN DIMENSION
INFO WILL BE OUTPUT FOR DEBUGGING PURPOSES
76 ----- ----- FIX BUG IN ALDIM1
77 ----- ----- TAKE AWAY ROUTINES USED ONLY IN ALLOCATION
78 ----- ----- FIX 77 BY PUTTING LASTONE BACK IN
79 ----- ----- MAKE IOSUBSTITUTE HANDLE E1 AND E2 LISTS
80 ----- ----- FIX DOVARSUBSTITUTE NOT TO CLOBBER DOIREG
81 ----- ----- CONTFN DOES NOT IGNORE ARG2 OF AN ARRAYREF
IF IT IS ZERO
82 ----- ----- MOVE LOWLIM TO GLOBAL
83 ----- ----- FIX UNFLDO TO SET SSIZONE. FIX DOVARSUBS
TO SET INITLIMMED FLAG
84 ----- ----- FOR PROPAGATING .O VARS AND .R AND .S VARS
MAKE DOVARSUBSTITUTE LOOK AT DOCTLVAR
85 447 19547 DO NOT PROPAGATE NEGS ONTO CERTAIN NODES
LIKE: I+A(I) WHICH ARE SPECIAL, (DCE)
86 463 19989 IF SUBSTITUTING A REGCONTENTS NODE POINTING TO
AN AOBJN DO INDEX INTO THE INITIAL VALUE OR
INCREMENT OF AN IMPLIED DO, SET IMMEDIATE FLAGS
SO CODE GENERATION WILL ONLY PICK UP RH OF AC., (JNG)
***** Begin Version 5A *****
87 617 QA2121 ONLY TRY TO SUBSTITUTE THE SUBSCRIPT OF AN
ARRAYREF IF IT ISN'T A CONSTANT, (SJW)
***** Begin version 5B *****
88 754 29120 MAKE CONTVAR WALK COMMON SUB EXPRESSION NODES, (EGM)
***** Begin Version 6 *****
89 1006 TFV 1-Jul-80 ------
Move KISNGL from CGEXPR.BLI and OUTMOD.BLI to this module.
Make it a global routine. Note that UTIL is loaded in
every phase that CGEXPR or OUTMOD is.
***** Begin Version 6A *****
1167 TFV 11-Jan-83 20-18247
Fix CONTVAR code for E1/E2LISTCALLs and make it handle arrayrefs
properly.
***** Begin Version 7 *****
90 1210 DCE 6-Apr-81 -----
For ELISTs, do regsubstitution into the assignment statements which
set up final loop values.
91 1406 TFV 27-Oct-81 ------
Write NEWDVAR to create a .Dnnnn variable for a
compile-time-constant character descriptor. The entries are all
linked together. They have an OPRCLS of DATAOPR and an OPERSP
of VARIABLE. Either one word (byte pointer only) or two words
(byte pointer and length) are generated based on the flag
IDGENLENFLG. One word .Dnnnn variables are used for SUBSTRINGs
with constant lower bounds and non-constant upper bounds.
92 1431 CKS 15-Dec-81
Add cases for substring and concatenation nodes to the tree walkers
in LEAFSUBSTITUTE, CONTVAR, and CONTFN.
93 1440 SRM 16-Dec-81
Fixed the CASE stmt in CONTFN to contain missing cases for:
FIELDREF, STORECLS, REGCONTENTS, LABOP, STATEMENT, IOLSCLS
94 1406 CDM 18-Dec-81
Moved routine NEWDVAR to SRCA.
1535 CDM 17-May-82
Moved MAKLIT to here.
Then moved it to SRCA!!
***** End V7 Development *****
1730 CKS 21-Feb-83
Have MISCIO walk the format statement pointer IOFORM so that
references to DO induction variables get substituted.
1734 TFV 24-Mar-83
Fix edit 1730. MISCIO should only walk IOFORM if it exists and
is not list directed (i.e. -1). Only do IOUNIT and IORECORD if
they exist too.
1742 TFV 14-Apr-83
Fix I/O deficiencies. MISCIO should look at IOUNIT, IORECORD,
IOSTAT, IOFILE, and the IOLIST for registers to substitute.
MISCOCI does the same for OPEN/CLOSE/INQUIRE arguments. Also
cleanup IOSUBSTITUTE.
1761 BCM 13-Jun-83 20-19276
Check for DIALOG/READONLY without args when stepping thru
specifier list.
2057 MEM 11-Jun-84
Add missing case to LEAFSUBSTITUTE so that argument lists for
concatenation nodes are walked. LOKCALST is used to walk the
argument list. A parameter was added to LOKCALST to indicate
that the argument list is from a concatenation node and that
the first argument should be skipped.
***** End Revision History *****
***** Begin Version 10 *****
2206 TFV 27-Jun-83
Fix MISCOCI to handle FILE= for OPEN/CLOSE/INQUIRE.
2333 TJK 30-Mar-84
Fix some bugs in SETPVAL and SETPIMMED. Specifically, check
for a zero parent pointer, check for IOLSCLS nodes, don't
assume that ARG2 matches if ARG1 doesn't, and in SETPIMMED
change a compare of an OPERSP with FNCALL to a compare of an
OPRCLS with FNCALL.
2404 TJK 21-Jun-84
Add missing cases to CONTVAR and CONTFN for CONCATENATION.
Improve a few things. Change meaning of CONTVAR slightly,
making it more powerful and correcting bugs in its callers.
Add UNSAFE, a routine which tests for potential storage
overlap. Add call to UNSAFE from CONTVAR. Also change CONTFN
to only return TRUE for user functions.
2425 AHM 15-Jul-84
Correct a typo in edit 2404 that TJK told us about during EAS
and RBP's wedding reception. The CONCATENATION arm of
CONTVAR's case referred to VAR[ARG2PTR] instead of
CNODE[ARG2PTR] when fetching the arglist.
***** End V10 Development *****
***** End Revision History *****
***** Begin Version 11 *****
4500 MEM 22-Jan-85
Check expressions for lower and upper bounds of keys pointed to by
IOKEY for registers to substitute in OPEN statements.
4501 MEM 22-Jan-85
Check IOKEY expression for registers to substitute in READ statements.
4505 MEM 2-Apr-85
Rip out substituting lower and upper bounds of keys with registers
because forots can't deal with registers in a secondary arg block.
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.
ENDV11
)%
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;
FORWARD
TRANSMOGRIFY(2),
PROPNEG(1),
NODERR,
SETPVAL(1),
SETPIMMED(1),
LOOKANYWAY(1),
LOKA1(1),
LOKA2(1),
LEAFSUBSTITUTE(1),
SWAPEM(1),
MISCIO(1),
MISCOCI(1),
DOVARSUBSTITUTE(1),
IOSUBSTITUTE(1),
%2404% UNSAFE(2), ! Checks if two variables can overlap
CONTVAR(2),
CONTFN(1),
UNFLDO(1),
ARGCONE(1),
LASTONE(1),
KISNGL(2);
EXTERNAL
%1006% C1H, ! Argument to CNSTCM
%1006% C1L, ! Argument to CNSTCM
%1006% C2H, ! Argument to CNSTCM
%1006% C2L, ! Argument to CNSTCM
CDONODE,
CGERR, ! Error routine
CHOSEN,
%1006% CNSTCM, ! Constant combine routine
%1006% COPRIX, ! Argument to CNSTCM
%1274% CORMAN, ! Core manager routine
%4527% CPYSYM, ! Copies [length,,pointer] to permanent location
CSTMNT, ! Current statement being processed
DOWDP,
ENTRY, !SYMBOL NAME FOR TABLE ROUTINES
GLOBREG,
ITMCT,
%1006% KGFRL,
%1006% KDPRL,
LOKCALST,
LOWLIM, !GLOBAL REGISTER ALLOCATOR COUNTS FROM
! ZERO TO ITMCT.
!OTHER USES COUNT FROM 1 TO ITMCT
NEWENTRY, !Makes new entry for symbol table
NAME, !SYMBOL TYPE FOR TABLE ROUTINES <GLOBAL>
! (used by CORMAN for size of entry)
QQ,
REPLACARG,
SKERR, !STATEMENT ERROR
SPECCASE,
SYMTBL, !THE SYMBOL TABLE
THASH, !COMPUTE HASH TABLE INDEX <SRCA>
TOP;
GLOBAL ROUTINE TRANSMOGRIFY(WHERE,NEWNAME)=
%(**********************************************************************
ROUTINE TO RENAME A SYMBOL
CALLED WITH A POINTER TO THE SYMBOL TABLE ENTRY IN
WHERE AND THE NEW SYMBOL NAME IN NEWNAME
DELINKS THE SYMBOL AND REHASHES IT
**********************************************************************)%
BEGIN
MAP BASE WHERE:NEWNAME;
LOCAL BASE OLDBASE:NEWBASE;
NAME_IDTAB; !SET SYMBOL TABLE ACCESS
ENTRY_.WHERE[IDSYMBOL]; !COMPUTE HASH INDEX FOR OLD ENTRY
OLDBASE_THASH(); !VIA THASH
ENTRY = .NEWNAME; !COMPUTE HASH INDEX FOR NEW ENTRY
NEWBASE_THASH(); !VIA THASH
OLDBASE_SYMTBL[.OLDBASE]<0,0>; !POINT TO SYMBOL TABLE
NEWBASE_SYMTBL[.NEWBASE]<0,0>; !POINT TO SYMBOL TABLE
!FIND HASH ENTRY IN FRONT
!OF SYMBOL
WHILE .OLDBASE[IDLINK] NEQ .WHERE DO
BEGIN
IF (OLDBASE_.OLDBASE[IDLINK]) EQL 0 THEN SKERR()
END;
OLDBASE[IDLINK]_.WHERE[IDLINK]; !LINK SYMBOL OUT OF TABLE
%4527% WHERE[IDSYMBOL] = CPYSYM(.NEWNAME); !RENAME SYMBOL AND
WHERE[IDLINK]_.NEWBASE[IDLINK]; !LINK IT INTO
NEWBASE[IDLINK]_.WHERE !THE SYMBOL TABLE
END; ! of TRANSMOGRIFY
GLOBAL ROUTINE PROPNEG(CNODE)=
%(***************************************************************************
PROPAGATE A NEGATIVE OVER THE NODE "CNODE" IF IT IS POSSIBLE TO DO SO.
THIS ROUTINE ALLOWS FOR NEGFLAGS SET IN THE NODE CNODE.
IT RETURNS TRUE IF IT WAS ABLE TO PROPAGATE THE NEG, FALSE IF NOT.
***************************************************************************)%
BEGIN
REGISTER OPERIX; !FOR ARITHMETIC OPERATORS, THE OPERSP
! FIELD IS USED AS AN INDEX TO SPECIFY ACTION
! TO BE TAKEN
MAP PEXPRNODE CNODE;
%(***THE FOLLOWING TABLES ARE USED IF CNODE IS AN ARITHMETIC OPERATION****)%
%(*****TABLE OF WHETHER TO NEGATE ARG1*****)%
BIND A1NEGTBL=PLIT (
TRUE, !FOR ADD, DO
TRUE, !FOR SUB, DO
TRUE, !FOR MUL, DO
TRUE, !FOR DIV, DO
FALSE); !FOR EXPONEN, DO NOT
%(***TABLE OF WHETHER TO NEGATE ARG2***)%
BIND A2NEGTBL=PLIT (
TRUE, !FOR ADD DO
TRUE, !FOR SUB DO
FALSE, !FOR MUL DO NOT
FALSE, !FOR DIV DO NOT
FALSE ); !FOR EXPONEN, DO NOT
%(***TABLE OF WHETHER THE NEGATE WAS SUCCESSFULLY PROPAGATED***)%
BIND PROPSUCCESS=PLIT (
TRUE, !CAN PROPAGATE FOR ADD
TRUE, !CAN FOR SUB
TRUE, !CAN FOR MUL
TRUE, !CAN FOR DIV
FALSE ); !CAN NOT PROPAGATE NEG ACROSS EXPONEN
%(***IF ANY "NOT" FLAGS ARE SET IN CNODE, DONT BOTHER***)%
IF .CNODE[A1NOTFLG] OR .CNODE[A2NOTFLG]
THEN RETURN FALSE;
%(****IF CNODE IS AN ARITHMETIC EXPRESSION********)%
IF .CNODE[OPRCLS] EQL ARITHMETIC
THEN
BEGIN
%(***ALL DECISIONS WILL BE MADE ON THE BASIS OF THE SPECIFIC OPERATOR***)%
OPERIX_.CNODE[OPERSP];
%(***PROCESS 1ST ARG UNDER CNODE***)%
IF .CNODE[A1NEGFLG]
THEN
CNODE[A1NEGFLG]_NOT .A1NEGTBL[.OPERIX] !2 NEGS CANCEL
ELSE
IF .CNODE[A1VALFLG]
THEN
BEGIN
!BE CAREFUL HERE, FOR WE CANNOT PROPAGATE DOWN
! A NEGATIVE ONTO A NODE WHERE THE A1SAMEFLG
! IS SET AND WHERE ARG1 IS A VARIABLE LIVING
! IN A REGISTER - ARG2 COULD BE TAKING ADVANTAGE
! OF THE SAME REGISTER AS IN THE CASE:
! K2=-JC*(K+NP(K)) WHICH LOSES OUT IN FORTG
IF .CNODE[A1SAMEFLG] THEN
IF NOT .CNODE[A1IMMEDFLG]
THEN RETURN FALSE;
CNODE[A1NEGFLG]_.A1NEGTBL[.OPERIX]; !CANNOT PROP OVER A VAR
IF .CNODE[A1NEGFLG] AND.CNODE[A1IMMEDFLG] AND .CNODE[A1SAMEFLG] !IF ARG1 IS AN IMMED CONST WHOSE
! VAL WASLEFT IN A REG FROM A PREV STMNT, NO LONGER
! WANT TOUSE IT FROM THAT REG
THEN CNODE[A1SAMEFLG]_0;
END
ELSE
IF .A1NEGTBL[.OPERIX]
THEN
BEGIN
IF NOT PROPNEG(.CNODE[ARG1PTR])
THEN
CNODE[A1NEGFLG]_1; !IF CANNOT PROP NEG OVER ARG1
END;
%(***PROCESS 2ND ARG UNDER CNODE***)%
IF .CNODE[A2NEGFLG]
THEN
CNODE[A2NEGFLG]_NOT .A2NEGTBL[.OPERIX] !2 NEGS CANCEL
ELSE
IF .CNODE[A2VALFLG]
THEN
CNODE[A2NEGFLG]_.A2NEGTBL[.OPERIX] !CANNOT PROP OVER A VAR
ELSE
IF .A2NEGTBL[.OPERIX]
THEN
BEGIN
IF NOT PROPNEG(.CNODE[ARG2PTR])
THEN
CNODE[A2NEGFLG]_1; !IF CANNOT PROP NEG OVER ARG2
END;
%(***RETURN TRUE IF SUCESSFULLY PROPAGATED NEGATE ONTO CNODE***)%
RETURN .PROPSUCCESS[.OPERIX];
END
ELSE
%(*****IF CNODE IS A TYPE-CONVERSION NODE FOR WHICH CODE MUST BE GENERATED
(TO BE DIFFERENTIATED FROM TYPE CONVERSION NODES THAT
ARE PRESENT ONLY TO KEEP TRACK OF VALTYPES)***)%
IF .CNODE[OPRCLS] EQL TYPECNV AND (NOT NOCNV(CNODE))
THEN
BEGIN
%(***IF THE VAL TO BE CONVERTED ALREADY HAD A NEG, THE 2 CANCEL***)%
IF .CNODE[A2NEGFLG]
THEN
CNODE[A2NEGFLG]_0
ELSE
%(***CANNOT PROPAGATE A NEG DOWN ANY FURTHER ONTO A VAR***)%
IF .CNODE[A2VALFLG]
THEN
CNODE[A2NEGFLG]_1
ELSE
IF NOT PROPNEG(.CNODE[ARG2PTR])
THEN
%(***IF WERE UNABLE TO PROPAGATE THE NEG OVER THE SUBNODE UNDER CNODE***)%
CNODE[A2NEGFLG]_1;
%(***CAN ALWAYS SUCCESSFULLY PROPAGATE A NEG ONTO A TYPE-CONVERSION***)%
RETURN TRUE;
END
%(***CANNOT SUCCESSFULLY PROPAGATE A NEG OVER ANYTHING OTHER THAN ARITH OR TYPECNV -
(NOTE THAT ANY NEGATE NODES WOULD HAVE BEEN REMOVED AT PHASE 2 SKEL)***)%
ELSE
RETURN FALSE
END;
GLOBAL ROUTINE NODERR=
BEGIN
SKERR();
END;
GLOBAL ROUTINE SETPVAL(CNODE)=
%(****************************************************
ROUTINE SETS VAL FLAGS IN THE PARENT OF CNODE.
CNODE IS THE OLD NODE THAT IS BEING [2333]
*FOLDED*.
IT IS CALLED ONLY WHEN IT IS KNOWN THAT
CNODE IS BEING FOLDED INTO A DATAOPR. [2333]
*****************************************************)%
BEGIN
LOCAL ANODE; MAP PEXPRNODE ANODE;
MAP PEXPRNODE CNODE;
%2333% IF (ANODE = .CNODE[PARENT]) EQL 0 ! Is there a parent?
%2333% THEN RETURN; ! No, don't bother
IF .ANODE[OPRCLS] EQL STATEMENT THEN
!PARENT POINTS BACK AT THE STATEMENT
BEGIN
IF .ANODE[SRCID] EQL ASGNID THEN
!ASSIGNMENT STATEMENT IS ONLY ONE WITH VAL FLGS
BEGIN
IF .CNODE EQL .ANODE[RHEXP] THEN
ANODE[A2VALFLG]_1
ELSE
ANODE[A1VALFLG]_1;
END ELSE
IF .ANODE[SRCID] EQL IFAID THEN
ANODE[A1VALFLG]_1
ELSE
IF .ANODE[SRCID] EQL IFLID THEN
ANODE[A1VALFLG]_1;
END ELSE
!IT MUST BE AN EXPRESSION
%(***IF PARENT IS A FN CALL NODE, MUST SET VAL FLAG IN THE ARG-LIST***)%
IF .ANODE[OPRCLS] EQL FNCALL
THEN
BEGIN
OWN ARGUMENTLIST ARGLST;
ARGLST_.ANODE[ARG2PTR];
INCR CT FROM 1 TO .ARGLST[ARGCOUNT]
DO
BEGIN
IF .ARGLST[.CT,ARGNPTR] EQL .CNODE
THEN ARGLST[.CT,AVALFLG]_1
END;
END
%2333% ELSE IF .ANODE[OPRCLS] NEQ IOLSCLS ! No flags for IOLSCLS nodes
%2333% THEN
%2333% BEGIN ! Parent has flags
%2333%
%2333% IF .CNODE EQL .ANODE[ARG1PTR]
%2333% THEN ANODE[A1VALFLG] = 1
%2333% ELSE IF .CNODE EQL .ANODE[ARG2PTR]
%2333% THEN ANODE[A2VALFLG] = 1;
%2333%
%2333% END; ! Parent has flags
END; ! of SETPVAL
GLOBAL ROUTINE SETPIMMED(CNODE)=
%(****************************************************
ROUTINE SETS IMMED FLAGS IN THE PARENT OF CNODE.
CNODE IS THE OLD NODE THAT IS BEING [2333]
*FOLDED*.
IT IS CALLED ONLY WHEN IT IS KNOWN THAT
CNODE IS BEING FOLDED INTO A DATAOPR. [2333]
*****************************************************)%
BEGIN
LOCAL ANODE; MAP PEXPRNODE ANODE;
MAP PEXPRNODE CNODE;
%2333% IF (ANODE = .CNODE[PARENT]) EQL 0 ! Is there a parent?
%2333% THEN RETURN; ! No, don't bother
IF .ANODE[OPRCLS] EQL STATEMENT THEN
!PARENT POINTS BACK AT THE STATEMENT
BEGIN
IF .ANODE[SRCID] EQL ASGNID THEN
!ASSIGNMENT STATEMENT IS ONLY ONE WITH IMMED FLGS
BEGIN
IF .CNODE EQL .ANODE[RHEXP] THEN
ANODE[A2IMMEDFLG]_1
ELSE
ANODE[A1IMMEDFLG]_1;
END ELSE
IF .ANODE[SRCID] EQL IFAID THEN
ANODE[A1IMMEDFLG]_1
ELSE
IF .ANODE[SRCID] EQL IFLID THEN
ANODE[A1IMMEDFLG]_1;
END
!IT MUST BE AN EXPRESSION
%(***IF PARENT IS A FNCALL NODE, DO NOT SET IMMEDFLGS***)%
%2333% ELSE IF .ANODE[OPRCLS] NEQ FNCALL ! No flags for FNCALL nodes
%2333% THEN IF .ANODE[OPRCLS] NEQ IOLSCLS ! No flags for IOLSCLS nodes
%2333% THEN
%2333% BEGIN ! Parent has flags
%2333%
%2333% IF .CNODE EQL .ANODE[ARG1PTR]
%2333% THEN ANODE[A1IMMEDFLG] = 1
%2333% ELSE IF .CNODE EQL .ANODE[ARG2PTR]
%2333% THEN ANODE[A2IMMEDFLG] = 1;
%2333%
%2333% END; ! Parent has flags
END; ! of SETPIMMED
!***************************************************************
! Routines to perform leaf substitution used in three places:
! 1. statement functions to substitute the variables for
! the formals.
! 2. global register allocation to substitute regcontents
! nodes for variables.
! 3. loop optimization in phase 2 skeleton to substitute
! regcontents nodes for the induction variable
!
! SPECCASE unifies these three uses. It is set to:
! 0 for statement functions
! 1 for global register allocation case
! 2 for phase 2 skeleton loop optimization case
!
! QQ is used as a flag both in the phase 2 skeleton case and the
! global optimizer. For global opt, it prompts restoring
! globally assigned quantities to registers; for phase 2
! skeleton it causes the substitution to terminate.
ROUTINE LOOKANYWAY(EXPR)=
BEGIN
!FOR THE GLOBAL REGISTER ALLOCATOR ONLY.
!WE HAVE WALKED DOWN ONTO A DATA ITEM,
!BECAUSE IT IS A PART OF A STATEMENT, NOT
!AN EXPRESSION.
DECR I FROM .ITMCT TO .LOWLIM DO
IF .EXPR EQL .GLOBREG[.I]<RIGHT> THEN
REPLACARG(.CSTMNT,.GLOBREG[.I]<RIGHT>,
.CHOSEN[.I]);
END;
ROUTINE LOKA1(EXPR)=
BEGIN
MAP BASE TOP;
MAP PEXPRNODE EXPR;
IF .EXPR[A1VALFLG] THEN
BEGIN
DECR I FROM .ITMCT TO .LOWLIM DO
BEGIN
IF .EXPR[ARG1PTR] EQL .GLOBREG[.I]<RIGHT> THEN
BEGIN
EXPR[ARG1PTR]_.CHOSEN[.I];
!FOR DO LOOPS ONLY
!PHASE 2 SKELETON WITH
!AOBJN TYPE ENDER WORD
IF .SPECCASE EQL 2 THEN
EXPR[A1IMMEDFLG]_1
ELSE
!GLOBAL ALLOCATION CASE
IF .SPECCASE EQL 1 THEN
BEGIN
IF .GLOBREG[.I]<RIGHT> EQL
.TOP[DOSYM] AND
.TOP[FLCWD] THEN
EXPR[A1IMMEDFLG]_1;
IF NOT .GLOBREG[.I]<ASGND4USED> THEN
GLOBREG[.I]<USED4ASGND>_1;
RETURN;
END;
END;
END;
END ELSE LEAFSUBSTITUTE(.EXPR[ARG1PTR]);
END;
ROUTINE LOKA2(EXPR)=
BEGIN
MAP PEXPRNODE EXPR;
MAP BASE TOP;
IF .EXPR[A2VALFLG] THEN
BEGIN
DECR I FROM .ITMCT TO .LOWLIM DO
IF .EXPR[ARG2PTR] EQL .GLOBREG[.I]<RIGHT> THEN
BEGIN
EXPR[ARG2PTR]_.CHOSEN[.I];
!FOR DO LOOPS ONLY
!PHASE 2 SKELETON WITH AOBJN DO
!LOOP CONTROL WORD
IF .SPECCASE EQL 2 THEN
EXPR[A2IMMEDFLG]_1
ELSE
!GLOBAL ALLOCATION
IF .SPECCASE EQL 1 THEN
BEGIN
IF .TOP[DOSYM] EQL .GLOBREG[.I]<RIGHT>
AND .TOP[FLCWD] THEN
EXPR[A2IMMEDFLG]_1;
IF NOT .GLOBREG[.I]<ASGND4USED> THEN
GLOBREG[.I]<USED4ASGND>_1;
RETURN;
END;
END;
END ELSE LEAFSUBSTITUTE(.EXPR[ARG2PTR]);
END;
GLOBAL ROUTINE LEAFSUBSTITUTE(EXPR)=
BEGIN
!PERFORM LEAF SUBSTITUTION OF ANY REFERENCES TO GLOBREG (A VECTOR LIST)
!WITHIN EXPR. WITH THE CORRESPONDING ELEMENT IN THE VECTOR CHOSEN
MAP PEXPRNODE EXPR;
!CHOSEN & GLOBREG ARE USED BY OPTIMIZER ALGORITHMS. THEY ARE GLOBAL
!AND ARE USED HERE (THOUGH INAPPROPRIATELY NAMED) AS A
!SPACE SAVING DEVICE.
!THIS ROUTINE IS ALSO USED TO SUBSTITUTE THE REGCONTENTS NODE
!FOR THE DO INDUCTION VARIABLE ON INNER-MOST DO LOOPS.
!QQ IS USED AS A FLAG IN THIS CONTEXT TO NOTE WHEN A FUNCTION
!CALL HAS BEEN PROCESSED TO TERMINATE THE SUBSTITUTION.
!NOTE THAT THE EXECUTION MAY DIFFER FROM THE OLD COMPILER
!SINCE THE REMAINDER OF THE STATEMENT IN WHICH THE FUNCTION
!REFERENCE EXISTS WILL STILL HAVE THE SUBSTITUTION. THIS
!IS CONSISTENT WITH THE DEFINITION OF FORTRAN, HOWEVER.
IF .SPECCASE EQL 1 THEN !GLOBAL REGISTER ALLOCATOR
LOWLIM_0
ELSE
LOWLIM_1;
CASE .EXPR[OPRCLS] OF SET
!BOOLEAN
BEGIN
LOKA1(.EXPR);
LOKA2(.EXPR);
END;
!DATAOPR
BEGIN
LOOKANYWAY(.EXPR);
END;
!RELATIONAL
BEGIN
LOKA1(.EXPR);
LOKA2(.EXPR);
END;
!FNCALL
BEGIN
LOCAL ARGUMENTLIST AG;
AG_.EXPR[ARG2PTR];
INCR I FROM .LOWLIM TO .ITMCT DO
%2057% LOKCALST(.AG,.AG[ARGCOUNT],.GLOBREG[.I]<RIGHT>,.CHOSEN[.I],FALSE);
END;
!ARITHMETIC
BEGIN
LOKA1(.EXPR);
LOKA2(.EXPR);
END;
!TYPCNV
LOKA2(.EXPR);
!ARRAYREF
!IF SUBSCRIPT IS CONSTANT, ARG2PTR = 0 AND CAN'T SUBSTITUTE
IF .EXPR [ARG2PTR] NEQ 0
THEN LOKA2 (.EXPR);
!CMNSUB
LOKA2(.EXPR);
!NEGNOT
LOKA2(.EXPR);
!SPECOP
LOKA1(.EXPR);
!FIELDREF
BEGIN END; !RELEASE GTR 1
!STORECLS
BEGIN END; !SHOULD NEVER SEE
!REGCONTENTS
BEGIN END; !DO NOTHING
!LABOP
BEGIN END; !SHOULD NEVER SEE
!STATEMENT
BEGIN END; !SHOULD NEVER SEE
!IOLCLS
BEGIN END; !HANDLED BY IOSUBSTITUTE
!INLINFN
BEGIN
LOKA1(.EXPR);
IF .EXPR[ARG2PTR] NEQ 0 THEN
LOKA2(.EXPR);
END;
!SUBSTRING
%1431% BEGIN
%1431% REGISTER BASE A4;
%1431% LOKA1(.EXPR);
%1431% LOKA2(.EXPR);
%1431% A4 _ .EXPR[ARG4PTR];
%1431% IF .A4[OPRCLS] EQL ARRAYREF
%1431% THEN IF .A4[ARG2PTR] NEQ 0
%1431% THEN LOKA2(.A4);
%1431% END;
!CONCATENATION
%1431% BEGIN
%2057% LOCAL ARGUMENTLIST AG;
%2057% AG = .EXPR[ARG2PTR];
%2057% INCR I FROM .LOWLIM TO .ITMCT
%2057% DO LOKCALST(.AG,.AG[ARGCOUNT],.GLOBREG[.I]<RIGHT>,.CHOSEN[.I],
%2057% TRUE);
END
TES;
END;
GLOBAL ROUTINE SWAPEM(VAR)=
BEGIN
!LOOK THROUGH GLOBREG FOR VAR. IF
!THERE RETURN CHOSEN ELSE JUST BACK WHAT YOU GOT
INCR I FROM .LOWLIM TO .ITMCT DO
IF .VAR EQL .GLOBREG[.I]<RIGHT> THEN
BEGIN
IF .SPECCASE EQL 1 THEN
IF NOT .GLOBREG[.I]<ASGND4USED> THEN
GLOBREG[.I]<USED4ASGND>_1;
RETURN (.CHOSEN[.I]);
END;
.VAR
END;
GLOBAL ROUTINE MISCIO(STMT)=
BEGIN
!***************************************************************
! Check I/O keywords and IOLIST elements for registers to
! substitute. The usual scheme applies. GLOBREG points to the
! variable; CHOSEN points to the regcontents node. ITMCT
! contains the number of items in the lists GLOBREG and CHOSEN.
! SPECCASE is a flag which says count from 0 (global allocator)
! or count from 1 (statement functions, local allocator).
!***************************************************************
MAP BASE STMT;
REGISTER BASE TMP;
LOWLIM_(IF .SPECCASE EQL 1 THEN 0 ELSE 1);
%1734% ! Check IOUNIT if specified
%1734% IF (TMP = .STMT[IOUNIT]) NEQ 0
%1734% THEN IF .TMP[OPRCLS] EQL DATAOPR
%2404% THEN STMT[IOUNIT] = SWAPEM(.TMP)
%2404% ELSE LEAFSUBSTITUTE(.TMP);
%1734% ! Check IOFORM if specified and not list directed (i.e. -1)
%1734% IF (TMP = .STMT[IOFORM]) NEQ 0
%1734% THEN IF .TMP NEQ #777777 ! don't do it for list directed
%1734% THEN IF .TMP[OPRCLS] EQL DATAOPR
%2404% THEN STMT[IOFORM] = SWAPEM(.TMP)
%2404% ELSE LEAFSUBSTITUTE(.TMP);
%1734% ! Check IORECORD if specified
%1734% IF (TMP = .STMT[IORECORD]) NEQ 0
%1734% THEN IF .TMP[OPRCLS] EQL DATAOPR
%1734% THEN STMT[IORECORD] = SWAPEM(.TMP)
%1734% ELSE LEAFSUBSTITUTE(.TMP);
%1742% ! Check IOIOSTAT if specified
%1742% IF (TMP = .STMT[IOIOSTAT]) NEQ 0
%1742% THEN IF .TMP[OPRCLS] EQL DATAOPR
%1742% THEN STMT[IOIOSTAT] = SWAPEM(.TMP)
%1742% ELSE LEAFSUBSTITUTE(.TMP);
%1742% ! Check IOLIST elements if specified
%1742% TMP = .STMT[IOLIST];
%1742% WHILE .TMP NEQ 0 DO
%1742% BEGIN
%1742% IOSUBSTITUTE(.TMP);
%1742% TMP = .TMP[SRCLINK];
%1742% END;
%4501% ! Check IOKEY if specified
%4501%
%4540% IF .STMT[SRCID] EQL READID
%4540% THEN IF (TMP = .STMT[IOKEY]) NEQ 0
%4501% THEN IF .TMP[OPRCLS] EQL DATAOPR
%4501% THEN STMT[IOKEY] = SWAPEM(.TMP)
%4501% ELSE LEAFSUBSTITUTE(.TMP);
END; ! of MISCIO
GLOBAL ROUTINE MISCOCI(STMT)=
BEGIN
!***************************************************************
! Check OPEN/CLOSE/INQUIRE keywords for registers to substitute.
! The usual scheme applies. GLOBREG points to the variable;
! CHOSEN points to the regcontents node. ITMCT contains the
! number of items in the lists GLOBREG and CHOSEN. SPECCASE is
! a flag which says count from 0 (global allocator) or count
! from 1 (statement functions, local allocator).
!***************************************************************
%1742% ! Written by TFV, on 14-Apr-83
MAP BASE STMT;
REGISTER
BASE TMP,
OPENLIST OPENL;
LOWLIM = (IF .SPECCASE EQL 1 THEN 0 ELSE 1);
! Check IOUNIT if specified
IF (TMP = .STMT[IOUNIT]) NEQ 0
THEN IF .TMP[OPRCLS] EQL DATAOPR
THEN STMT[IOUNIT] = SWAPEM(.TMP)
ELSE LEAFSUBSTITUTE(.TMP);
%2206% ! Check IOFILE if specified
%2206% IF (TMP = .STMT[IOFILE]) NEQ 0
%2206% THEN IF .TMP[OPRCLS] EQL DATAOPR
%2206% THEN STMT[IOFILE] = SWAPEM(.TMP)
%2206% ELSE LEAFSUBSTITUTE(.TMP);
! Check IOIOSTAT if specified
IF (TMP = .STMT[IOIOSTAT]) NEQ 0
THEN IF .TMP[OPRCLS] EQL DATAOPR
THEN STMT[IOIOSTAT] = SWAPEM(.TMP)
ELSE LEAFSUBSTITUTE(.TMP);
! Check another argument list elements
OPENL = .STMT[OPLST];
DECR I FROM .STMT[OPSIZ] - 1 TO 0 DO
BEGIN
TMP = .OPENL[.I,OPENLPTR];
%1761% ! add check for 0 pointer
%1761% IF .TMP NEQ 0
%1761% THEN
%1761% BEGIN
IF .TMP[OPRCLS] EQL DATAOPR
THEN OPENL[.I,OPENLPTR] = SWAPEM(.TMP)
ELSE LEAFSUBSTITUTE(.TMP);
%1761% END;
END;
END; ! of MISCOCI
GLOBAL ROUTINE DOVARSUBSTITUTE(CLSTCALL)=
BEGIN
!TO PERFORM REGISTER SUBSTITUTIONS ON ALL FIELDS OF
!A DO STATEMENT. USED BY IOSUBSTITUTE AND THE GLOBAL
!REGISTER ALLOCATOR
MAP BASE CLSTCALL:CDONODE;
LOCAL BASE P:AOBDOSYM;
LOWLIM_(IF .SPECCASE EQL 1 THEN 0 ELSE 1);
P_.CLSTCALL[DOLPCTL];
IF .P[OPRCLS] NEQ DATAOPR THEN
LEAFSUBSTITUTE(.P)
ELSE
CLSTCALL[DOLPCTL]_SWAPEM(.P);
%(***NOW TO SUBSTITUTE FOR THE INITIAL VALUE AND STEP
SIZE FIELDS OF THE DO. IF WE ARE SUBSTITUTING
A REGCONTENTS NODE THAT POINTS TO THE DO INDEX
OF THE NEXT OUTER DO, AND THAT DO IS CONTROLLED
WITH AN AOBJN, THEN MUST MAKE SURE TO SET THE
APPROPRIATE IMMEDIATE FLAGS IN THIS DO, SO THAT
CODE GENERATION WILL ONLY PICK UP THE RIGHT HALF
OF THE AC***)%
%(***FIRST, SET UP A TEMP THAT CONTAINS A POINTER TO
THE OUTER DO'S INDEX VAR IF THE OUTER DO IS AN
AOBJN DO, BUT IS 0 OTHERWISE***)%
AOBDOSYM _ (IF .CDONODE[FLCWD] THEN .CDONODE[DOSYM]
ELSE 0);
P _ SWAPEM(.CLSTCALL[DOM1]); !CHECK INITIAL VALUE
IF .CLSTCALL[DOM1] NEQ .P !IF REGCONTENTS FOUND
THEN
BEGIN
IF .AOBDOSYM EQL .CLSTCALL[DOM1] THEN
CLSTCALL[INITLIMMED]_1;
CLSTCALL[DOM1]_.P;
END;
P _ SWAPEM(.CLSTCALL[DOSSIZE]); !CHECK STEP SIZE
IF .CLSTCALL[DOSSIZE] NEQ .P !IF DOING SUBSTITUTION
THEN
BEGIN
IF .AOBDOSYM EQL .CLSTCALL[DOSSIZE] THEN
CLSTCALL[SSIZIMMED]_1;
CLSTCALL[DOSSIZE]_.P;
END;
!IF WE ARE PROPAGATING (OR SUBSUMING) THEN
!WE COULD ALSO CARE ABOUNT THE DO LOOP CONTROL VARIALE
!ITSELF
CLSTCALL[DOCTLVAR]_SWAPEM(.CLSTCALL[DOCTLVAR]);
!TO TAKE CARE OF GLOBALLY ALLOCATED IMPLIED DOS
IF .SPECCASE EQL 1 THEN
BEGIN
INCR I FROM .LOWLIM TO .ITMCT DO
BEGIN
IF .CLSTCALL[DOSYM] EQL .GLOBREG[.I]<RIGHT> THEN
BEGIN
P_.CHOSEN[.I];
CLSTCALL[DOIREG]_.P[TARGTAC];
CLSTCALL[IXGALLOCFLG]_1;
IF .CLSTCALL[FLCWD] THEN
BEGIN
UNFLDO(.CLSTCALL);
CLSTCALL[INITLIMMED]_1;
END;
IF NOT .GLOBREG[.I]<USED4ASGND> THEN
GLOBREG[.I]<ASGND4USED>_1;
END;
END;
END;
END;
GLOBAL ROUTINE IOSUBSTITUTE(CLSTCALL)=
BEGIN
!***************************************************************
! Substitute a regcontents node into an I/O statement IOLIST
!***************************************************************
MAP BASE CLSTCALL;
MAP BASE TOP:CDONODE:CSTMNT;
MAP OBJECTCODE DOWDP;
LOCAL BASE P:TMP;
!LOCAL ROUTINES TO HELP SHORTEN CODE
ROUTINE IOCS(CSLST)=
BEGIN
!DO THE THING FOR ANY COMMON SUBS
MAP BASE CSLST;
WHILE .CSLST NEQ 0 DO
BEGIN
IF .CSLST[A2VALFLG] THEN
CSLST[ARG2PTR]_SWAPEM(.CSLST[ARG2PTR])
ELSE
LEAFSUBSTITUTE(.CSLST[ARG2PTR]);
CSLST_.CSLST[CLINK];
END;
END;
ROUTINE E1ORE2(NOD)=
BEGIN
!DO COMMON PROCESSING FOR E1 OR E2 LISTS
MAP BASE NOD;
LOCAL BASE TMP:P;
TMP_.NOD[ELSTPTR];
WHILE .TMP NEQ 0 DO
BEGIN
P_.TMP[E2ARREFPTR];
IF .P[OPRCLS] EQL DATAOPR THEN
TMP[E2ARREFPTR]_SWAPEM(.P)
ELSE
LEAFSUBSTITUTE(.P);
P_.TMP[E2INCR];
IF .P NEQ 0 THEN
IF .P[OPRCLS] EQL DATAOPR THEN
TMP[E2INCR]_SWAPEM(.P)
ELSE
LEAFSUBSTITUTE(.P);
TMP_.TMP[CLINK];
END;
TMP_.NOD[ECNTPTR];
IF .TMP[OPRCLS] EQL DATAOPR THEN
NOD[ECNTPTR]_SWAPEM(.TMP)
ELSE
LEAFSUBSTITUTE(.TMP);
%1742% ! Do the substitution on the increment for an E1LIST
%1742% TMP_.NOD[E1INCR];
%1742% IF .TMP NEQ 0
%1742% THEN IF .TMP[OPRCLS] EQL DATAOPR
%1742% THEN NOD[E1INCR]_SWAPEM(.TMP)
%1742% ELSE LEAFSUBSTITUTE(.TMP);
%1742% ! Substitute into assignment statement(s) for final loop value(s)
%1742% TMP_.CSTMNT; ! Save CSTMNT
%1742% CSTMNT_.NOD[ELPFVLCHAIN]; ! Get chain of assignments
%1742% WHILE .CSTMNT NEQ 0 DO
%1742% BEGIN ! Walk down chain of assignments
%1742% LEAFSUBSTITUTE(.CSTMNT[LHEXP]); ! Do assignment substitution
%1742% LEAFSUBSTITUTE(.CSTMNT[RHEXP]);
%1742% CSTMNT_.CSTMNT[CLINK]
%1742% END; ! Walk down chain of assignments
%1742% CSTMNT_.TMP; ! Restore CSTMNT
%1742% END; ! of E1ORE2
LOWLIM_(IF .SPECCASE EQL 1 THEN 0 ELSE 1);
IF .CLSTCALL[OPRCLS] EQL STATEMENT
THEN
BEGIN
!WE ARE INTERESTED ONLY IF IT IS A DO
IF .CLSTCALL[SRCID] EQL DOID THEN
BEGIN
DOVARSUBSTITUTE(.CLSTCALL);
END ELSE
!IT COULD BE AN ASSIGNMENT
!THE CHEAPEST WAY (CODE SIZE) IS TO SAVE
!CSTMNT AWAY, POINT IT AT THIS ASSIGNEMNT AND
!LET LOOKANYWAY AND REPLACARG TAKE CARE OF THE
!SUBSTITUTION
IF .CLSTCALL[SRCID] EQL ASGNID THEN
BEGIN
TMP_.CSTMNT;
CSTMNT_.CLSTCALL;
LEAFSUBSTITUTE(.CSTMNT[LHEXP]);
LEAFSUBSTITUTE(.CSTMNT[RHEXP]);
CSTMNT_.TMP;
END ELSE
!ITS A CONTINUE STATEMENT
RETURN
END ELSE
CASE .CLSTCALL[OPERSP] OF SET
!DATACALL
BEGIN
P_.CLSTCALL[DCALLELEM];
IF .P[OPRCLS] NEQ DATAOPR THEN
LEAFSUBSTITUTE(.P)
ELSE
CLSTCALL[DCALLELEM]_SWAPEM(.P);
END;
!SLISTCALL
BEGIN END;
!IOLSTCALL
BEGIN
!LOOK THROUGH THE COMMON SUB-EXPRESSIONS
!THEY WILL ONLY BE THERE IN THE GLOBAL
!REGISTER ALLOCATION CASE WITH LOCAL CMNSUBS
!ON THE I/O LISTS
IOCS(.CLSTCALL[SRCCOMNSUB]);
!NOW LOOK AT LIST ITSELF
P_.CLSTCALL[IOLSTPTR];
WHILE .P NEQ 0 DO
BEGIN
IOSUBSTITUTE(.P);
P_.P[CLINK];
END;
END;
!E1LISTCALL
BEGIN
IOCS(.CLSTCALL[SRCCOMNSUB]);
E1ORE2(.CLSTCALL);
END;
!E2LISTCALL
BEGIN
IOCS(.CLSTCALL[SRCCOMNSUB]);
E1ORE2(.CLSTCALL);
END;
TES;
END; ! of IOSUBSTITUTE
GLOBAL ROUTINE UNSAFE(VAR1,VAR2) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine is passed two expression pointers, VAR1 and VAR2.
! If either one of them isn't a non-constant DATAOPR, it returns
! FALSE. Otherwise they're both non-constant DATAOPRs, and it
! returns TRUE if there's any possibility that they may overlap
! in memory. If there isn't, it returns FALSE.
!
! Note that it is left to the caller to extract the names of
! L-values (i.e., things which may be stored into). This is
! mainly to avoid having to repeatedly look for SUBSTRING and
! ARRAYREF names, and because currently this is already done by
! the callers of this routine. However, it could safely be
! added if this routine is later needed in other situations.
!
! The main purpose of this routine is to provide a common place
! for making common/equivalence checks. This checking could be
! made more sophisticated someday.
!
! FORMAL PARAMETERS:
!
! VAR1 Pointer to first variable
! VAR2 Pointer to second variable
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE:
!
! TRUE if VAR1 and VAR2 are both non-constant DATAOPRs which may
! potentially overlap. FALSE otherwise.
!
! SIDE EFFECTS:
!
! None
!
!--
![2404] New
BEGIN
MAP BASE VAR1;
MAP BASE VAR2;
! If they're not both non-constant DATAOPRs, fall through and
! return FALSE. It is left to the caller to extract the names
! of L-values (i.e., things which may be stored into).
IF .VAR1[OPRCLS] EQL DATAOPR
THEN IF .VAR1[OPERSP] NEQ CONSTANT
THEN IF .VAR2[OPRCLS] EQL DATAOPR
THEN IF .VAR2[OPERSP] NEQ CONSTANT
THEN
BEGIN ! VAR1 and VAR2 both non-constant DATAOPRs
IF .VAR1 EQL .VAR2 THEN RETURN TRUE; ! Check obvious case
! Now check for common/equivalence potential overlap.
! Be overly cautious to avoid dependency on when
! common/equivalence processing is done. This could
! be made more sophisticated someday.
IF .VAR1[IDATTRIBUT(INCOM)]
OR .VAR1[IDATTRIBUT(INEQV)]
THEN IF .VAR2[IDATTRIBUT(INCOM)]
OR .VAR2[IDATTRIBUT(INEQV)]
THEN IF .VAR1[IDATTRIBUT(INEQV)]
OR .VAR2[IDATTRIBUT(INEQV)]
THEN RETURN TRUE; ! Assume the worst
END; ! VAR1 and VAR2 both non-constant DATAOPRs
RETURN FALSE; ! Safe to assume no overlap
END;
GLOBAL ROUTINE CONTVAR(CNODE,VAR)=
%(***************************************************************************
![2404] The interpretation of this routine has changed somewhat. It
![2404] should now be thought of as "The value of CNODE may change
![2404] when VAR becomes redefined". VAR is expected to be an L-value
![2404] (i.e., something which may be stored into). Specifically, a
![2404] SUBSTRING, ARRAYREF, non-constant DATAOPR, or REGCONTENTS
![2404] node. If VAR isn't one of these, it returns FALSE.
![2404] Otherwise, for SUBSTRING and ARRAYREF nodes, it extracts the
![2404] name so that VAR is either a non-constant DATAOPR or a
![2404] REGCONTENTS node. It then recursively looks for a dependency
![2404] on VAR in CNODE. This includes common/equivalence checks,
![2404] made through a call to UNSAFE.
![2404]
![2404] This routine is mostly called to check for I/O dependencies
![2404] and to look for optimizer-created temporaries. Note that at
![2404] the moment REGCONTENTS nodes don't seem to be possible
![2404] arguments for VAR. However, it has always worked and still
![2404] does for that case, although no common/equivalence checking is
![2404] done for REGCONTENTS nodes.
***************************************************************************)%
BEGIN
LOCAL PEXPRNODE ARGNODE;
MAP PEXPRNODE CNODE;
LOCAL ARGUMENTLIST ARGLST;
%1167% MAP BASE VAR;
%(***DEFINE MACRO TO CHECK BINARY NODES*****)%
MACRO BINARYCHK=
%2404% (IF CONTVAR(.CNODE[ARG1PTR],.VAR)
%2404% THEN TRUE
%2404% ELSE CONTVAR(.CNODE[ARG2PTR],.VAR))$;
DEBGNODETST(CNODE); !FOR DEBUGGING ONLY, CHECK THAT CNODE IS NOT 0
%2404% ! If VAR is a SUBSTRING, use the full string. This will be
%2404% ! either a DATAOPR or an ARRAYREF. The latter are caught by
%2404% ! the check following this one.
%2404%
%2404% IF .VAR[OPRCLS] EQL SUBSTRING
%2404% THEN VAR = .VAR[ARG4PTR];
%1167% ! If VAR is an ARRAYREF, use the array name
%1167% IF .VAR[OPRCLS] EQL ARRAYREF
%1167% THEN VAR = .VAR[ARG1PTR];
%2404% ! Make sure VAR is an L-value (i.e., make sure it can
%2404% ! be stored into).
%2404%
%2404% IF .VAR[OPRCLS] NEQ DATAOPR
%2404% THEN IF .VAR[OPRCLS] NEQ REGCONTENTS
%2404% THEN RETURN FALSE;
%2404% ! Constants are always safe
%2404%
%2404% IF .VAR[OPR1] EQL CONSTFL
%2404% THEN RETURN FALSE;
%2404% ! VAR is now either a non-constant DATAOPR or a REGCONTENTS node.
CASE .CNODE[OPRCLS] OF SET
%(***FOR CNODE A BOOLEAN***)%
RETURN BINARYCHK;
%(***FOR DATA ITEM********)%
%2404% RETURN UNSAFE(.CNODE,.VAR); ! Consider common/equivalence
%(***FOR RELATIONAL***)%
RETURN BINARYCHK;
%(***FUNCTION CALL***)%
BEGIN
%(***SEARCH THE ARG LIST***)%
IF (ARGLST_.CNODE[ARG2PTR]) NEQ 0
THEN
BEGIN
INCR CT FROM 1 TO .ARGLST[ARGCOUNT]
DO
BEGIN
IF CONTVAR(.ARGLST[.CT,ARGNPTR],.VAR) THEN RETURN TRUE;
END;
END;
%2404% RETURN FALSE;
END;
%(***FOR AN ARITHMETIC****)%
RETURN BINARYCHK;
%(***FOR A TYPECNV***)%
RETURN CONTVAR(.CNODE[ARG2PTR],.VAR);
%(***FOR AN ARRAYREF***)%
BEGIN
IF .CNODE[ARG2PTR] EQL 0 THEN RETURN (.CNODE[ARG1PTR] EQL .VAR)
ELSE RETURN BINARYCHK
END;
%(***FOR A CMNSUB******)%
%[754]% RETURN CONTVAR(.CNODE[ARG2PTR],.VAR);
%(***FOR NEG/NOT***)%
RETURN CONTVAR(.CNODE[ARG2PTR],.VAR);
%(***FOR SPECIAL OPERATORS***)%
RETURN CONTVAR(.CNODE[ARG1PTR],.VAR);
%(***FOR FIELD-REF - NOT IN RELEASE 1***)%
CGERR();
%(***FOR STORECLS***)%
RETURN CONTVAR(.CNODE[ARG2PTR],.VAR);
%(***FOR REGCONTENTS - VAR MAY BE THIS REGCONTENTS NODE***)%
RETURN (.CNODE EQL .VAR);
%(***FOR LABEL***)%
RETURN FALSE;
%(***SHOULD NOT ENCOUNTER A STATEMENT***)%
CGERR();
%(***FOR AN IOLIST-CLASS NODE ***)%
CASE .CNODE[OPERSP] OF SET
!DATACALL
RETURN(CONTVAR(.CNODE[DCALLELEM],.VAR));
!SLISTCALL
RETURN(CONTVAR(.CNODE[SCALLELEM],.VAR) OR
CONTVAR(.CNODE[SCALLCT],.VAR));
!IOLSTCALL
BEGIN
QQ_0;
ARGNODE_.CNODE[IOLSTPTR];
WHILE .ARGNODE NEQ 0 DO
BEGIN
QQ_.QQ OR CONTVAR(.ARGNODE[DCALLELEM],.VAR);
ARGNODE_.ARGNODE[CLINK];
END;
RETURN(.QQ);
END;
!E1LISTCALL
BEGIN
QQ_0;
ARGNODE_.CNODE[ELSTPTR];
%1167% WHILE .ARGNODE NEQ 0 DO
%1167% BEGIN
%1167% QQ = .QQ OR CONTVAR(.ARGNODE[E2ARREFPTR],.VAR);
%1167% ARGNODE = .ARGNODE[CLINK];
%1167% END;
RETURN(.QQ OR CONTVAR(.CNODE[ECNTPTR],.VAR) OR
%1167% CONTVAR(.CNODE[E1INCR],.VAR));
END;
!E2LISTCALL
BEGIN
QQ_0;
ARGNODE_.CNODE[ELSTPTR];
WHILE .ARGNODE NEQ 0 DO
BEGIN
%1167% QQ = .QQ OR CONTVAR(.ARGNODE[E2INCR],.VAR) OR
CONTVAR(.ARGNODE[E2ARREFPTR],.VAR);
ARGNODE_.ARGNODE[CLINK];
END;
RETURN(.QQ OR CONTVAR(.CNODE[ECNTPTR],.VAR));
END;
TES;
%(***FOR AN IN-LINE FN***)%
BEGIN
IF .CNODE[ARG2PTR] EQL 0
THEN RETURN (CONTVAR(.CNODE[ARG1PTR],.VAR))
ELSE RETURN BINARYCHK
END;
%1431% %(***FOR SUBSTRING***)%
%1431% BEGIN
%1431% IF CONTVAR(.CNODE[ARG1PTR],.VAR) THEN RETURN TRUE;
%1431% IF CONTVAR(.CNODE[ARG2PTR],.VAR) THEN RETURN TRUE;
%1431% IF CONTVAR(.CNODE[ARG4PTR],.VAR) THEN RETURN TRUE;
%1431% RETURN FALSE;
%1431% END;
%2404% %(***FOR CONCATENATION***)%
%2404% BEGIN
%2425% ARGLST = .CNODE[ARG2PTR];
%2404%
%2404% INCR CT FROM 2 TO .ARGLST[ARGCOUNT] ! Skip first arg
%2404% DO IF CONTVAR(.ARGLST[.CT,ARGNPTR],.VAR)
%2404% THEN RETURN TRUE; ! Found it
%2404%
%2404% RETURN FALSE; ! Didn't find it
%2404% END;
TES;
END;
GLOBAL ROUTINE CONTFN(CNODE)=
%(***************************************************************************
![2404] This routine now returns TRUE only if CNODE contains a user
![2404] function, i.e., it doesn't return TRUE merely for library
![2404] functions, since they don't have side effects.
***************************************************************************)%
BEGIN
%1440% ROUTINE FNINLIST( ARGNODE ) =
%1440% ! Routine walks a linked list of nodes checking for function calls
%1440% BEGIN ! FNINLIST
%1440%
%1440% MAP PEXPRNODE ARGNODE;
%1440% WHILE .ARGNODE NEQ 0 DO
%1440% BEGIN
%2404% IF CONTFN(.ARGNODE) THEN RETURN TRUE;
%2404% ARGNODE = .ARGNODE[CLINK];
%1440% END;
%2404% RETURN FALSE;
%1440% END; ! of FNINLIST
MAP PEXPRNODE CNODE;
%(***DEFINE MACRO TO CHECK FOR EITHER SUBNODE OF A BINARY NODE***)%
MACRO BINARYCHK=
%2404% (IF CONTFN(.CNODE[ARG1PTR])
%2404% THEN TRUE
%2404% ELSE CONTFN(.CNODE[ARG2PTR]))$;
CASE .CNODE[OPRCLS] OF SET
%(**FOR A BOOLEAN***)%
RETURN BINARYCHK;
%(***FOR A DATA ITEM***)%
RETURN FALSE;
%(***FOR A RELATIONAL***)%
RETURN BINARYCHK;
%(***FOR A FN CALL***)%
%2404% IF .CNODE[OPERSP] NEQ LIBARY
%2404% THEN RETURN TRUE
%2404% ELSE
%2404% BEGIN ! library
%2404%
%2404% LOCAL ARGUMENTLIST AG;
%2404% IF (AG = .CNODE[ARG2PTR]) NEQ 0
%2404% THEN
%2404% BEGIN ! It has an argument list
%2404%
%2404% INCR I FROM 1 TO .AG[ARGCOUNT]
%2404% DO IF CONTFN(.AG[.I,ARGNPTR])
%2404% THEN RETURN TRUE; ! Found one
%2404%
%2404% END; ! It has an argument list
%2404%
%2404% RETURN FALSE; ! No non-LIBRARY functions
%2404%
%2404% END; ! library
%(***FOR AN ARITHMETIC***)%
RETURN BINARYCHK;
%(***FOR A TYPE CNV***)%
RETURN CONTFN(.CNODE[ARG2PTR]);
%(***FOR AN ARRAYREF***)%
RETURN
BEGIN
IF .CNODE[ARG2PTR] NEQ 0 THEN CONTFN(.CNODE[ARG2PTR])
ELSE 0
END;
%(***FOR A CMNSUB***)%
RETURN FALSE;
%(***FOR A NEG/NOT***)%
RETURN CONTFN(.CNODE[ARG2PTR]);
%(***FOR A SPECOP (P2MUL OR P2DIV) ***)%
RETURN CONTFN(.CNODE[ARG1PTR]);
%1440% %(***FOR FIELDREF - NOT SUPPORTED***)%
%1440% CGERR();
%1440%
%1440% %(***FOR STORECLS***)%
%1440% RETURN CONTFN(.CNODE[ARG2PTR]);
%1440%
%1440% %(***FOR REGCONTENTS***)%
%1440% RETURN FALSE;
%1440%
%1440% %(***FOR LABEL***)%
%1440% RETURN FALSE;
%1440%
%1440% %(***SHOULD NEVER BE CALLED FOR A STATEMENT***)%
%1440% CGERR();
%1440%
%1440% %(***FOR AN IOLIST-CLASS NODE***)%
%1440% BEGIN ! IOLIST-class nodes
%1440% CASE .CNODE[OPERSP] OF SET
%1440%
%1440% !DATACALL
%1440% RETURN CONTFN( .CNODE[ DCALLELEM ] );
%1440%
%1440% !SLISTCALL
%1440% RETURN ( CONTFN( .CNODE[ SCALLELEM ] ) OR
%1440% CONTFN( .CNODE[ SCALLCT ] ) );
%1440%
%1440% !IOLSTCALL
%1440% ! Search the linked list of IOLSCLS nodes under this node
%1440% RETURN FNINLIST( .CNODE[IOLSTPTR] );
%1440%
%1440% !E1LISTCALL
%1440% ! Search the linked list of array ref nodes
%1440% RETURN FNINLIST ( .CNODE[ELSTPTR] );
%1440%
%1440% !E2LISTCALL
%1440% BEGIN ! E2LISTCALL
%1440% REGISTER FNFOUND;
%1440% REGISTER PEXPRNODE ARGNODE;
%1440%
%1440% ! Search the linked list of nodes that point
%1440% ! to arrayrefs and counts. Only need to look
%1440% ! at the ARRAYREFs.
%1440% FNFOUND = FALSE;
%1440% ARGNODE = .CNODE[ELSTPTR];
%1440% WHILE .ARGNODE NEQ 0 DO
%1440% BEGIN
%1440% FNFOUND =.FNFOUND OR
%1440% CONTFN(.ARGNODE[E2ARREFPTR] );
%1440% ARGNODE = .ARGNODE[ CLINK ];
%1440% END;
%1440% RETURN .FNFOUND;
%1440% END; ! E2LISTCALL
%1440%
%1440% TES;
%1440% END; !IOLIST-class nodes
%1431% %(***FOR AN INLINE FN***)%
%1431% BEGIN
%1431% IF CONTFN(.CNODE[ARG1PTR]) THEN RETURN TRUE;
%1431% IF .CNODE[ARG2PTR] NEQ 0
%1431% THEN RETURN CONTFN(.CNODE[ARG2PTR])
%1431% ELSE RETURN FALSE;
%1431% END;
%1431% %(***FOR SUBSTRING***)%
%1431% BEGIN
%1431% IF CONTFN(.CNODE[ARG1PTR]) THEN RETURN TRUE;
%1431% IF CONTFN(.CNODE[ARG2PTR]) THEN RETURN TRUE;
%1431% IF CONTFN(.CNODE[ARG4PTR]) THEN RETURN TRUE;
%1431% RETURN FALSE;
%1431% END;
%2404% %(***FOR CONCATENATION***)%
%2404% BEGIN
%2404% ! CONCATENATION nodes do not count as function
%2404% ! references for the purposes of this routine, which
%2404% ! is concerned with possible side effects of function
%2404% ! references. These aren't a problem with
%2404% ! CONCATENATION nodes.
%2404%
%2404% LOCAL ARGUMENTLIST AG;
%2404% AG = .CNODE[ARG2PTR];
%2404%
%2404% INCR I FROM 2 TO .AG[ARGCOUNT] ! Skip first arg
%2404% DO IF CONTFN(.AG[.I,ARGNPTR])
%2404% THEN RETURN TRUE; ! Found one
%2404%
%2404% RETURN FALSE; ! Didn't find any
%2404% END;
TES;
END;
GLOBAL ROUTINE UNFLDO(DONODE)=
%(***************************************************************************
ROUTINE TO CHANGE A DO-LOOP NODE FROM AN AOBJN LOOP TO A NON-AOBJN LOOP.
THIS ROUTINE CAN ONLY BE CALLED AFTER THE DO-LOOP HAS BEEN EXPANDED BY
THE SEMANTICS ROUTINE "DOXPN", AND BEFORE REGISTER ALLOCATION HAS BEEN
PERFORMED FOR THE LOOP (BEFORE THE "COMPLEXITY" PASS.
IT IS CALLED
1. IN PHASE 1, WHEN THE LOOP INDEX IS FOUND TO BE REASSIGNED INSIDE THE LOOP
2. IN PHASE 2 SKELETON, FOR AOBJN LOOPS IN WHICH THE CTL VAL
IS TO LIVE IN A REGISTER, BUT IS THEN USED IN CONTEXTS THAT
REQUIRE A WHOLE WORD VALUE (IOLISTS, COMPUTED GOTO)
***************************************************************************)%
BEGIN
MAP PEXPRNODE DONODE;
OWN PEXPRNODE CTLCONST;
IF NOT .DONODE[FLCWD] THEN RETURN; !IF THIS LOOP ISNT AOBJN, RETURN
%(***THE CONTROL CONSTANT MUST BE SET TO THE LEFT HALF OF THE AOBJN CONST***)%
CTLCONST_.DONODE[DOLPCTL];
DONODE[DOLPCTL]_MAKECNST(INTEGER,0,
-(ARITHSHIFT(.CTLCONST[CONST2],-18)) );
DONODE[CTLNEG]_1;
DONODE[CTLIMMED]_1;
DONODE[SSIZONE]_1;
DONODE[FLCWD]_0;
END;
GLOBAL ROUTINE ARGCONE(FNNODE)=
BEGIN
!EXAMINE THE FUNCTION CALL NODE FNNODE. IF IT IS A
!REFERENCE TO A LIBRARY FUNCTION OF 1 ARGUMENT RETURN
!TRUE ELSE RETURN FALSE.
!USED IN DEFPT AND COMSUB
MAP BASE FNNODE;
REGISTER ARGUMENTLIST AG;
IF .FNNODE[OPERSP] EQL LIBARY THEN
BEGIN
AG_.FNNODE[ARG2PTR];
IF .AG[ARGCOUNT] EQL 1 THEN
RETURN(.AG[1,AVALFLG]);
END;
END;
GLOBAL ROUTINE LASTONE(WD)=
BEGIN
!EXAMINE CLOBBREGS TO DETERMINE WHICH REGS NEED TO
!BE SAVED. FIND THE POSITION OF THE TRAILING ONE.
!EXAMPLE:
! LET USE USE A SIX BIT VALUE OF WD OF 111011.
! BITCT INITIALLY BECOMES 3 (BITS NUMBER FROM
! LEFT TO RIGHT STARTING AT ZERO.
! IN THE UNTIL LOOP, THE FIRST VALUE OF
! T1 IS 100000. BITCT THEN BECOMES 4.
! THE LOOP TERMINATED SINCE WD^4 = 0. 4
! IS THE VALUE RETURNED.
OWN T1,BITCT,OBIT;
IF .WD EQL -1 THEN RETURN 13;
!WD WILL REALLY NEVER BE -1 SINCE A MAX OF
!13 BITS CAN BE SET IN IT FOR REGS 2-15.
IF .WD EQL 0 THEN RETURN -1;
BITCT_FIRSTONE(NOT .WD);
UNTIL (T1_.WD^.BITCT) EQL 0 DO
BEGIN
OBIT_.BITCT;
BITCT_FIRSTONE(NOT .T1) + .BITCT;
IF .OBIT EQL .BITCT THEN
BITCT_.BITCT+1;
END;
.BITCT-1
END;
GLOBAL ROUTINE KISNGL(X,Y)=
![1006] ROUTINE TO ROUND UP SINGLE PRECISION FROM DOUBLE PRECISION
%[1006]% BEGIN
%[1006]% !X IS THE HIGH ORDER KI-10 CNSTANT, Y IS LOW ORDER WORD
%[1006]% ! Use CNSTCM for folding based on /GFLOATING
%[1006]% C1H_.X;
%[1006]% C1L_.Y;
%[1006]% IF .GFLOAT
%[1006]% THEN COPRIX_KGFRL
%[1006]% ELSE COPRIX_KDPRL;
%[1006]% CNSTCM();
%[1006]% .C2H ! IS RETURNED
%[1006]% END;
END
ELUDOM