Trailing-Edge
-
PDP-10 Archives
-
FORTRAN-10_V7wLink_Feb83
-
util.bli
There are 13 other files named util.bli in the archive. Click here to see a list.
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
! OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1983
!AUTHORS: NORMA ABEL AND SARA MURPHY/HPW/DCE/SJW/EGM/TFV/CDM
MODULE UTIL(RESERVE(0,1,2,3),SREG=#17,VREG=#15,FREG=#16,DREGS=4,GLOROUTINES)=
BEGIN
GLOBAL BIND UTILV = 7^24 + 0^18 + #1535; ! Version Date: 11-Jan-83
%(
***** 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 Revision History *****
)%
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;
FORWARD UNFLDO;
EXTERNAL
%1006% C1H,
%1006% C1L,
%1006% C2H,
%1006% C2L,
CDONODE,
CGERR, ! Error routine
CHOSEN,
%1006% CNSTCM,
%1006% COPRIX,
%1274% CORMAN, ! Core manager routine
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
WHERE[IDSYMBOL]_.NEWNAME; !RENAME SYMBOL AND
WHERE[IDLINK]_.NEWBASE[IDLINK]; !LINK IT INTO
NEWBASE[IDLINK]_.WHERE !THE SYMBOL TABLE
END;
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 HAS JUST BEEN
*FOLDED*.
IT IS CALLED ONLY WHEN IT IS KNOWN THAT
CNODE IS A DATAOPR.
*****************************************************)%
BEGIN
LOCAL ANODE; MAP PEXPRNODE ANODE;
MAP PEXPRNODE CNODE;
ANODE_.CNODE[PARENT];
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
ELSE
IF .CNODE EQL .ANODE[ARG1PTR] THEN
ANODE[A1VALFLG] _ 1
ELSE
ANODE[A2VALFLG] _ 1;
END;
GLOBAL ROUTINE SETPIMMED(CNODE)=
%(****************************************************
ROUTINE SETS IMMED FLAGS IN THE PARENT OF CNODE.
CNODE IS THE OLD NODE THAT HAS JUST BEEN
*FOLDED*.
IT IS CALLED ONLY WHEN IT IS KNOWN THAT
CNODE IS A DATAOPR.
*****************************************************)%
BEGIN
LOCAL ANODE; MAP PEXPRNODE ANODE;
MAP PEXPRNODE CNODE;
ANODE_.CNODE[PARENT];
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 ELSE
!IT MUST BE AN EXPRESSION
%(***IF PARENT IS A FNCALL NODE, DO NOT SET IMMEDFLGS***)%
IF .ANODE[OPERSP] EQL FNCALL
THEN
BEGIN
END
ELSE
IF .CNODE EQL .ANODE[ARG1PTR] THEN
ANODE[A1IMMEDFLG] _ 1
ELSE
ANODE[A2IMMEDFLG] _ 1;
END;
!
!ROUTINES TO PERFORM LEAF SUBSTITUTION
!USED IN THREE PLACES
! 1. FOR STATEMENT FUNCTIONS TO SUBSTITUTE THE NEW
! VARIABLES FOR THE FORMALS
! 2. IN GLOBAL REGISTER ALLOCATION TO SUBSTITUTE REGCONTENTS NODES
! FOR VARIABLES
! 3. IN DO LOOP OPTIMIZATION IN PHASE 2 SKELETON TO SUBSTITUTE
! REGCONTENTS NODES FOR THE INDUCTION VARIBALE WHRE POSSIBLE
!THE VARIBALE SPECCASE IS USED TO HANDLE THE MINOR GLITCHES IN UNIFYING
!THESE THREE USES.
!SPECCASE=
! 1 FOR THE GLOBAL REGISTER ALLOCATION CASE
! TO MATERIALIZE IN FRONT OF A STATEMENT CONTAINING A FUNCTION CALL
! 2 FOR THE PHASE 2 SKELETON DO OPTIMIZATION CASE
! TO CAUSE THE CORRECT IMMEDIATE FLAG TO BE SET IN THE PARENT
! 0 FOR STATEMENT FUNCTIONS
!THE GLOBAL QQ IS ALSO USED AS A FLAG BOTH IN THE PHASE 2 SKELETON CASE
!AND THE GLOBAL OPTIMIZER . IN THE LATTER CASE IT PROMPTS RESTORING
!GLOBALLY ASSIGNED QUANTATIES TO REGISTERS. IN PHASE 2 SKELETON
!IT CAUSES THE SUBSTITUTION TO TERMINATE.
FORWARD LEAFSUBSTITUTE;
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
LOKCALST(.AG,.AG[ARGCOUNT],.GLOBREG[.I]<RIGHT>,.CHOSEN[.I]);
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 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
!STMT IS AN I/O STATEMENT.
!THIS ROUTINE CHECKS IORECORD AND IOUNIT FIELDS FOR
!REGISTERS TO SUBSTITUTE. THE USUAL SHEME APPLIES.
!GLOBREG CONTIANS THE POINTER TO THE VARIABLE; CHOSEN
!CONTAINS A POINTER 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 ALLOCA)
!OR COUNT FROM 1 (STATEMENT FUNCTIONS, LOCAL ALLOC).
MAP BASE STMT;
REGISTER BASE TMP;
LOWLIM_(IF .SPECCASE EQL 1 THEN 0 ELSE 1);
!IT COULD BE AN EXPRESSION
IF .STMT[IORECORD] NEQ 0 THEN
BEGIN
TMP_.STMT[IORECORD];
IF .TMP[OPRCLS] EQL DATAOPR THEN
STMT[IORECORD]_SWAPEM(.TMP)
ELSE
LEAFSUBSTITUTE(.TMP);
END;
TMP_.STMT[IOUNIT];
IF .TMP[OPRCLS] EQL DATAOPR THEN
STMT[IOUNIT]_SWAPEM(.STMT[IOUNIT])
ELSE
LEAFSUBSTITUTE(.STMT[IOUNIT]);
END;
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
!TO SUBSTITUTE A REGCONTENTS NODE INTO AN I/O STATEMENT
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);
END;
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);
TMP_.CLSTCALL[E1INCR];
IF .TMP[OPRCLS] EQL DATAOPR THEN
CLSTCALL[E1INCR]_SWAPEM(.TMP)
ELSE
LEAFSUBSTITUTE(.TMP);
!**;[1207], IOSUBSTITUTE, DCE, 6-Apr-81
!**;[1207], Substitute into assignment statement(s) for final loop value(s)
%[1207]% TMP_.CSTMNT;
%[1207]% CSTMNT_.CLSTCALL[ELPFVLCHAIN];
%[1207]% WHILE .CSTMNT NEQ 0 DO
%[1207]% BEGIN
%[1207]% LEAFSUBSTITUTE(.CSTMNT[LHEXP]);
%[1207]% LEAFSUBSTITUTE(.CSTMNT[RHEXP]);
%[1207]% CSTMNT_.CSTMNT[CLINK]
%[1207]% END;
%[1207]% CSTMNT_.TMP;
END;
!E2LISTCALL
BEGIN
IOCS(.CLSTCALL[SRCCOMNSUB]);
E1ORE2(.CLSTCALL);
!**;[1207], IOSUBSTITUTE, DCE, 6-Apr-81
!**;[1207], Substitute into assignment statement(s) for final loop value(s)
%[1207]% TMP_.CSTMNT;
%[1207]% CSTMNT_.CLSTCALL[ELPFVLCHAIN];
%[1207]% WHILE .CSTMNT NEQ 0 DO
%[1207]% BEGIN
%[1207]% LEAFSUBSTITUTE(.CSTMNT[LHEXP]);
%[1207]% LEAFSUBSTITUTE(.CSTMNT[RHEXP]);
%[1207]% CSTMNT_.CSTMNT[CLINK]
%[1207]% END;
%[1207]% CSTMNT_.TMP;
END;
TES;
END;
GLOBAL ROUTINE CONTVAR(CNODE,VAR)=
%(***************************************************************************
ROUTINE TO CHECK WHETHER THE EXPRESSION NODE CNODE CONTAINS THE VARIABLE
VAR ANYWHERE UNDER IT.
***************************************************************************)%
BEGIN
LOCAL PEXPRNODE ARGNODE;
MAP PEXPRNODE CNODE;
LOCAL ARGUMENTLIST ARGLST;
%1167% MAP BASE VAR;
%(***DEFINE MACRO TO CHECK BINARY NODES*****)%
MACRO BINARYCHK=
(CONTVAR(.CNODE[ARG1PTR],.VAR) OR CONTVAR(.CNODE[ARG2PTR],.VAR))$;
DEBGNODETST(CNODE); !FOR DEBUGGING ONLY, CHECK THAT CNODE IS NOT 0
%1167% ! If var is an arrayref, use the arrayname
%1167% IF .VAR[OPRCLS] EQL ARRAYREF
%1167% THEN VAR = .VAR[ARG1PTR];
CASE .CNODE[OPRCLS] OF SET
%(***FOR CNODE A BOOLEAN***)%
RETURN BINARYCHK;
%(***FOR DATA ITEM********)%
RETURN (.CNODE EQL .VAR);
%(***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;
RETURN FALSE
END
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;
%(***FOR CONCATENATION***)%
BEGIN END
TES;
END;
GLOBAL ROUTINE CONTFN(CNODE)=
%(***************************************************************************
ROUTINE TO CHECK WHETHER THE EXPRESSION NODE CNODE CONTAINS ANY FUNCTION
CALLS.
RETURNS TRUE IF IT DOES.
***************************************************************************)%
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% REGISTER FNFOUND; ! TRUE iff FOUND a fncall
%1440% FNFOUND = FALSE;
%1440% WHILE .ARGNODE NEQ 0 DO
%1440% BEGIN
%1440% FNFOUND = .FNFOUND OR CONTFN( .ARGNODE );
%1440% ARGNODE = .ARGNODE[ CLINK ];
%1440% END;
%1440% RETURN .FNFOUND;
%1440% END; ! of FNINLIST
MAP PEXPRNODE CNODE;
%(***DEFINE MACRO TO CHECK FOR EITHER SUBNODE OF A BINARY NODE***)%
MACRO BINARYCHK=
(CONTFN(.CNODE[ARG1PTR]) OR 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***)%
RETURN TRUE;
%(***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;
%1431% %(***FOR CONCATENATION***)%
%1431% RETURN TRUE ! (temp)
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