Trailing-Edge
-
PDP-10 Archives
-
FORTRAN-10_V7wLink_Feb83
-
arrxpn.bli
There are 12 other files named arrxpn.bli in the archive. Click here to see a list.
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
! OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1983
!AUTHOR: S. MURPHY/NEA/SJW/TFV/CKS/AHM
MODULE ARRXPN(SREG=#17,VREG=#15,FREG=#16,DREGS=4,RESERVE(0,1,2,3),GLOROUTINES)=
BEGIN
! REQUIRES FIRST, TABLES
GLOBAL BIND ARRXPV = 7^24 + 0^18 + #1714; ! Version Date: 11-Jan-83
%(
***** Begin Revision History *****
47 ----- ----- FIX BUG IN "PROARRXPN" TO CONVER SUBSCRIPTS OF
PROTECTED ARRAYS TO INTEGER
48 ----- ----- CHANGE ERROR CALLS TO FATLERR/WARNERR
49 ----- ----- MAKE ONLIST A LOCAL ROUTINE
50 ----- ----- 49 IS NOT ENOUGH. CHANGE THE ROUTINE NAME
SO THAT WE CAN STILL ASSEMBLE WITH MACRO
51 ----- ----- MAKE PROARRXPN RESET BTTMMSTFLG SO THAT SUBPROGRAMS
THAT ARE BOTTOM-MOST WILL SAVE/RESTORE 16 ANYWAY.
52 VER5 ----- MAKE SUBSCRIPT EXPR TRESS LEFT BALANCED
***** Begin Version 6 *****
53 761 TFV 1-Mar-80 -----
Add KTYPCG for type conversions under /GFLOATING.
***** Begin Version 7 *****
54 1250 CKS 6-Aug-81
Modify for CHARACTER arrays. Explicitly add the constant part of
the subscript expression into the expression node; leave TARGET alone.
Don't add the base address of a character formal array to the subscript
expression.
55 1416 CKS 9-Nov-81
Check substring bounds as well as subscripts in DATASUBCHK.
Also allow ** in subscript and substring expressions.
56 1436 SRM 16-Dec-81
Set CHARUSED if there is a ref to a character array element
1503 AHM 8-Mar-82
Cancel part of edit 1250 by making array bounds checking call
the routine PROAR. (again). The name had been PROTA. for a
while, but different names were not necessary after all.
1505 AHM 9-Mar-82
Set the psect of the symbol table entry for PROAR. to .CODE.
1551 AHM 3-Jun-82
Remove edit 1505 from this module because external references
will not have a psect index set in the STE.
1554 CKS 7-Jun-82
Add routine PROSUB to generate call to PROSB., the substring
bound checking routine.
1714 CKS 11-Jan-83
Copy ARRAYREF nodes properly in COPYEXPR.
***** End Revision History *****
)%
FORWARD
ARRXPND,
PROARRXPN, !ROUTINE TO CREATE AN ARRAYREF NODE IN WHICH
! THE SS IS A CALL TO THE LIBRARY ROUTINE
! "PROAR.". USED FOR PROTECTED ARRAYS.
LEGLDATASUB,
ONLST,
%1554% PROSUB,
%1554% COPYEXPR;
EXTERNAL
CHARUSED, ! Flag for character operator used
! in program
CNSTCMB,
CNVNODE,
CORMAN,
E173, !ERROR MESSAGE POINTERS
E26,
E27,
ENTRY,
FATLERR,
ISN,
KTYPCB,
KTYPCG,
MAKEPR, !ROUTINE TO BUILD AN EXPRESSION NODE
MAKPR1,
NAME,
SAVSPACE, !RETURNS CORE TO FREE STORAGE
TBLSEARCH;
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;
SWITCHES NOSPEC;
GLOBAL ROUTINE ARRXPND(ARRNAMENTRY,SSLSTPTR)=
%(********
THIS ROUTINE EXPANDS AN ARRAY ADDRESS CALCULATION.
IT IS CALLED WITH THE ARGUMENTS
ARRNAMENTRY - PTR TO THE SYMBOL TABLE ENTRY FOR THE ARRAY
NAME
SSLSTPTR- LH CONTAINS THE NUMBER OF SUBSCRIPTS MINUS 1
RH IS A PTR TO A LIST OF SUBSCRIPTS OF THE FORM
PTR1
PTR2
.
.
.
PTRN
WHERE CT SPECIFIES THE NUMBER OF SUBSCRIPTS
PTR1-PTRN ARE POINTERS TO EXPRESSION NODES FOR
SUBSCRIPTS 1-N.
THE ROUTINE FIRST CHECKS THAT THE NUMBER OF SUBSCRIPTS(SSLSTPTR<LEFT>
IS EQUAL TO THE NUMBER OF DIMENSIONS. IF NOT THEN A
FATAL ERROR MESSAGE IS GENERATED.
THIS ROUTINE CREATES AN "ARRAYREF" NODE FOR THIS ARRAY REFERENCE
AND RETURNS A POINTER TO IT.
********)%
BEGIN
MAP SYMTABENTRY ARRNAMENTRY;
REGISTER SSLSTP1;
OWN PEXPRNODE SSNODE; !PTR TO EXPRESSION NODE FOR A GIVEN SUBSCRIPT
OWN DIMENTRY ARRDIMENTRY; !DIMENSION TABLE ENTRY FOR THIS ARRAY
REGISTER DIMSUBENTRY DIMLSTPTR; !SUBENTRY FOR A GIVEN DIMENSION
OWN PEXPRNODE DIMFNODE; !EXPRESSION NODE FOR THE "FACTOR" CORRES
! PONDING TO THAT DIMENSION
OWN SSVARFLG; !THIS FLAG IS SET IF SOME PART OF
! THE ADDRESS MUST BE COMPUTED AT RUN TIME
OWN SSCNSTVAL; ! CONSTANT PART OF SUBSCRIPT EXPRESSION
OWN SSCNSTPTR; ! PTR TO CONSTANT NODE WITH CONSTANT PART IN IT
OWN PEXPRNODE SSCONSTPTR:SSVARPTR;
OWN PEXPRNODE ARREFNODE; !PTR TO ARRAY REF NODE BUILT
OWN PEXPRNODE ARG1NODE:ARG2NODE; !WHEN A SS IS ADD OR SUB THESE
! PT TO THE 2 ARGS OF THAT OPERATOR
ARRDIMENTRY_.ARRNAMENTRY[IDDIM];
IF .ARRDIMENTRY[DIMNUM] NEQ (.SSLSTPTR<LEFT>+1)
THEN RETURN FATLERR( ARRNAMENTRY[IDSYMBOL],.ISN,E27<0,0>);
!WRONG NUMBER OF SUBSCRIPTS
%(***IF THE USER SPECIFIED THAT SUBSCRIPT BOUNDS CHECKING WAS TO
BE PERFORMED ON ALL ARRAYS (BY USING THE "BOUNDS" SWITCH)
DO NOT EXPAND THE ADDRESS CALCULATION -
INSTEAD CALL A FN AT RUN TIME WITH
ALL THE INDIVIDUAL SUBSCRIPTS**)%
IF .FLGREG<BOUNDS> THEN RETURN PROARRXPN(.ARRNAMENTRY,.SSLSTPTR);
%(***EXPAND ADDRESS CALCULATION. REPLACE THE SUBSCRIPT LIST BY EXPRESSION
NODE FOR THE SUM OF THE PRODUCTS OF EACH SUBSCRIPT BY A FACTOR
CORRESPONDING TO THAT DIMENSION OF THE ARRAY. KEEP SUM OF CONSTANT
TERMS SEPARATE FROM SUM OF VARIABLE TERMS.
***)%
%(***INIT SUM OF CONSTANT TERMS TO 0**)%
SSCNSTVAL_0;
%(***INIT FLAG FOR "SOME PART OF THE ADDRESS CALC MUST BE DONE AT RUN TIME" TO FALSE***)%
SSVARFLG_FALSE;
%(***GET PTR TO DIMENSION SUBENTRY FOR 1ST DIMENSION OF THIS ARRAY**)%
DIMLSTPTR_ARRDIMENTRY[FIRSTDIM];
%(**GET PTR TO PTR TO NODE FOR 1ST SUBSCRIPT**)%
SSLSTP1_.SSLSTPTR<RIGHT>;
DECR CT FROM .SSLSTPTR<LEFT> TO 0
DO
BEGIN
[email protected];
DIMFNODE_.DIMLSTPTR[DIMFACTOR];
%(****IF THIS SS IS NOT OF VALTYPE INTEGER, CONVERT IT***)%
IF .SSNODE[VALTP1] NEQ INTEG1 THEN SSNODE_CNVNODE(.SSNODE,INTEGER,0);
%(**MULTIPLY THE SUBSCRIPT BY A FACTOR DETERMINED
BY THE PRECEEDING DIMENSIONS****)%
%(**THIS FACTOR MAY BE A VARIABLE, IF PRECEEDING DIMENSIONS
WERE VARIABLES****)%
IF .DIMLSTPTR[VARFACTFLG]
THEN
%(**IF FACTOR IS A VARIABLE, GENERATE NODES TO MULTIPLY SS BY THIS VARIABLE
AND ADD IT INTO THE VARIABLE TERM**)%
BEGIN
SSNODE_MAKPR1(0,ARITHMETIC,MULOP,INDEX,.SSNODE,.DIMFNODE);
IF .SSVARFLG
THEN
SSVARPTR_MAKPR1(0,ARITHMETIC,ADDOP,INDEX,.SSVARPTR,.SSNODE)
ELSE
BEGIN
SSVARFLG_TRUE;
SSVARPTR_.SSNODE;
END;
END
ELSE
%(*****IF FACTOR FOR THIS DIMENSION IS A CONSTANT (IE ALL PRECEEDING DIMENSIONS
WERE OF CONSTANT SIZE)*********)%
BEGIN
%(***CHECK FOR A SUBSCRIPT OF THE FORM "X+C" , "X-C", "C+X", "C-X"
WHERE C IS A CONSTANT. REMOVE THE CONSTANT PART OF THE
PRODUCT OF "DIMENSION FACTOR" AND SUBSCRIPT AND
ADD IT INTO THE CONSTANT PORTION OF THE ADDRESS******)%
IF ADDORSUB(SSNODE)
THEN
BEGIN
ARG1NODE_.SSNODE[ARG1PTR];
ARG2NODE_.SSNODE[ARG2PTR];
IF .ARG2NODE[OPR1] EQL CONSTFL
THEN
%(***IF HAVE X+K OR X-K****)%
BEGIN
SSCNSTVAL_ (IF SUBORDIV(SSNODE)
THEN (.SSCNSTVAL - .ARG2NODE[CONST2]*.DIMFNODE[CONST2])
ELSE (.SSCNSTVAL + .ARG2NODE[CONST2]*.DIMFNODE[CONST2]));
SSNODE_.ARG1NODE;
END
ELSE
IF .ARG1NODE[OPR1] EQL CONSTFL
THEN
%(***IF HAVE K+X OR K-X*****)%
BEGIN
SSCNSTVAL_.SSCNSTVAL+.ARG1NODE[CONST2]*.DIMFNODE[CONST2];
SSNODE_ (IF SUBORDIV(SSNODE)
THEN
MAKPR1(0,NEGNOT,NEGOP,INDEX,0,.ARG2NODE)
ELSE .ARG2NODE);
END
END;
IF .SSNODE[OPR1] EQL CONSTFL
THEN
%(***IF SS AND FACTOR ARE BOTH CONSTANTS, ADD
THEIR PRODUCT INTO THE CONSTANT TERM FOR
THIS ADDRESS CALCULATION
***)%
SSCNSTVAL_.SSCNSTVAL+.DIMFNODE[CONST2]*.SSNODE[CONST2]
ELSE
%(**IF SS IS A VARIABLE AND FACTOR IS A CONSTANT, GENERATE
NODES TO MULTIPLY THEM AND ADD THE PRODUCT
INTO THE VARIABLE TERM***)%
BEGIN
IF .DIMFNODE[CONST2] NEQ 1
THEN
%(****IF FACTOR IS NOT 1, MULTIPLY BY IT***)%
SSNODE_MAKPR1(0,ARITHMETIC,MULOP,INDEX,.SSNODE,.DIMFNODE);
IF .SSVARFLG
THEN
SSVARPTR_MAKPR1(0,ARITHMETIC,ADDOP,INDEX,.SSVARPTR,.SSNODE)
ELSE
BEGIN
SSVARFLG_TRUE;
SSVARPTR_.SSNODE
END
END;
END;
SSLSTP1_.SSLSTP1+1;
DIMLSTPTR_.DIMLSTPTR+DIMSUBSIZE;
END;
%(***ADD IN THE ARRAY OFFSET FOR THIS ARRAY -
IF THE DIMENSIONS ARE CONSTANT THEN THIS WILL BE A CONSTANT
AND SHOULD BE ADDED INTO THE CONSTANT TERM.
IF THE DIMENSIONS ARE VARIABLE, THEN THIS VALUE WILL BE
COMPUTED UPON ENTERING THE SUBROUTINE AND STORED IN A
TEMPORARY WHICH SHOULD BE ADDED INTO THE VARIABLE TERM.
*********)%
IF .ARRDIMENTRY[ADJDIMFLG]
THEN
BEGIN
IF .SSVARFLG
THEN
SSVARPTR_MAKPR1(0,ARITHMETIC,ADDOP,INDEX,.SSVARPTR,.ARRDIMENTRY[ARAOFFSET])
ELSE
BEGIN
SSVARPTR_.ARRDIMENTRY[ARAOFFSET];
SSVARFLG_TRUE
END
END
ELSE
BEGIN
OWN PEXPRNODE OFFSETNODE;
OFFSETNODE_.ARRDIMENTRY[ARAOFFSET];
SSCNSTVAL_.SSCNSTVAL+.OFFSETNODE[CONST2];
END;
%(***IF THE ARRAY IS A FORMAL(AND THE ARRAY IS NOT ADJUSTABLY DIMENSIONED - IN WHICH CASE
THE "OFFSET" VALUE INCLUDES THE BASE VAL), ADD THE BASE INTO THE VARIABLE TERM.
DON'T DO THIS FOR CHARACTER ARRAYS - THE BASE ADDRESS IS THE ADDRESS OF A
DESCRIPTOR.
***)%
IF .ARRNAMENTRY[FORMLFLG] AND NOT .ARRDIMENTRY[ADJDIMFLG]
THEN
%1250% IF .ARRNAMENTRY[VALTYPE] NEQ CHARACTER
%1250% THEN
BEGIN
%(***IF ALREADY HAVE A VARIABLE TERM, ADD THE BASE INTO THAT EXPRESSION***)%
IF .SSVARFLG
THEN
SSVARPTR_MAKPR1(0,ARITHMETIC,ADDOP,INDEX,.SSVARPTR,
.ARRDIMENTRY[ARADDRVAR]) !PTR TO SYMBOL THAT
! CONTAINS THE BASE ADDRESS
ELSE
%(***IF DO NOT YET HAVE A VARIABLE TERM, SET THE VARIABLE TERM
TO BE THE BASE ADDRESS***)%
BEGIN
SSVARPTR_.ARRDIMENTRY[ARADDRVAR];
SSVARFLG_TRUE
END;
END;
% [1250] (*** IF THE ARRAY IS TYPE CHARACTER, EXPLICITLY ADD IN THE CONSTANT
PART AND SET SSCNSTVAL TO 0. ***)%
IF .ARRNAMENTRY[VALTYPE] EQL CHARACTER
THEN
BEGIN ! [1250] CHARACTER ARRAY REF
%1436% CHARUSED = TRUE; ! Flag for character operator used
%1436% ! in prog
! Make constant node for constant part
SSCNSTPTR _ MAKECNST(INTEGER,0,.SSCNSTVAL);
! Put explicit add of constant part into expression
IF .SSVARFLG
THEN ! Already have variable part
SSVARPTR _ MAKPR1(0,ARITHMETIC,ADDOP,INTEGER,.SSVARPTR,.SSCNSTPTR)
ELSE
BEGIN ! No variable part, make one
SSVARPTR _ .SSCNSTPTR;
SSVARFLG _ TRUE;
END;
SSCNSTVAL _ 0; ! Set constant part to 0, it's been
! explicitly added in
END; ! [1250] CHARACTER ARRAY REF
%(****MAKE THE ARRAYREF NODE FOR THIS REFERENCE. ARG1PTR SHOULD PT TO THE
SYMBOL TABLE ENTRY FOR THE ARRAY NAME; ARG2PTR SHOULD PT TO THE
ADDRESS CALCULATION (OR BE EQUAL TO 0 IF NO RUNTIME CALCULATION
IS NEEDED).
********)%
ARREFNODE_ MAKEPR(ARRAYREF,0,.ARRNAMENTRY[VALTYPE],.ARRNAMENTRY,
(IF .SSVARFLG THEN .SSVARPTR ELSE 0) );
%(***PUT THE CONSTANT TERM INTO THE ARRAYREF NODE (ONLY USE THE LAST 18 BITS.)***)%
ARREFNODE[TARGET]_.SSCNSTVAL AND #777777;
%(****RETURN THE SSLST TO FREE STORAGE***)%
SAVSPACE(.SSLSTPTR<LEFT>,@SSLSTPTR);
%(***IF SS CALCULATION IS A SINGLE DATA ITEM (OR CONSTANT), SET A2VALFLG ***)%
SSNODE_.ARREFNODE[ARG2PTR];
IF .SSNODE[OPRCLS] EQL DATAOPR OR .SSNODE EQL 0
THEN ARREFNODE[A2VALFLG]_1
ELSE SSNODE[PARENT]_.ARREFNODE;
RETURN .ARREFNODE;
END; !END OF "ARRXPND"
GLOBAL ROUTINE PROARRXPN(ARRNAMENTRY,SSLSTPTR)=
%(***************************************************************************
Creates an ARRAYREF node for a reference to an element of an array on
which array bounds checking is to be performed. The expression for
the address calculation under such an ARRAYREF will be a function call
node for the library function PROAR. with the following parameters:
Sequence number of statement containg this reference
Pointer to the dimension block for this array (Created in DEBUG.BLI)
Pointer to 1st subscript
Pointer to 2nd subscript
Etc.
The arguments to this routine are:
ARRNAMENTRY - Pointer to the STE for the array name
SSLSTPTR - Left half contains the number of subscripts minus 1. Right
half is a pointer to a list of pointers to expression nodes for the
individual subscripts.
***************************************************************************)%
BEGIN
STRUCTURE PVECTOR[I]=(@.PVECTOR+.I)<0,36>; !STRUCTURE FOR A PTR TO A VECTOR
MAP PVECTOR SSLSTPTR;
MAP BASE ARRNAMENTRY;
OWN BASE ARRDIMENTRY; !DIMENSION TABLE ENTRY FOR THIS ARRAY
REGISTER PEXPRNODE SSNODE; !EXPRESSION NODE FOR A GIVEN SUBSCRIPT
REGISTER PEXPRNODE FNCALLNODE; !FUNCTION CALL NODE FOR THE CALL TO "PROAR."
REGISTER ARGUMENTLIST ARGLST; !ARG LIST FOR ARGS TO "PROAR."
OWN BASE PROARSYM; !SYMBOL TABLE ENTRY FOR THE FN NAME "PROAR."
OWN PEXPRNODE ARREFNODE; !THE ARRAY REF NODE BUILT HERE
%(***RESET FLAG SO THAT 16 WILL ALWAYS BE SAVED/RESTORED***)%
FLGREG<BTTMSTFL>_0;
%(**GET CORE FORTHE ARGUMENT LIST**)%
NAME<LEFT>_ARGLSTSIZE(.SSLSTPTR<LEFT>+1 !NUMBER OF SUBSCRIPTS
+2); ! PLUS 2 IS THE NUMBER OF ARGS TO "PROAR."
ARGLST_CORMAN();
%(**GET THE SYMBOL TABLE ENTRY FOR THE ROUTINE NAME "PROAR."**)%
NAME_IDTAB;
%1503% ENTRY[0]_SIXBIT'PROAR.';
PROARSYM_TBLSEARCH(); !MAKE THE SYM TABLE ENTRY IF THERE ISNT ONE
PROARSYM[VALTYPE]_INTEGER; !FILL IN TYPE FIELD
PROARSYM[OPERSP]_FNNAME;
%(**MAKE THE FUNCTION CALL NODE FOR THE CALL TO "PROAR."**)%
FNCALLNODE_MAKEPR(FNCALL,LIBARY,INTEGER,.PROARSYM,.ARGLST);
FNCALLNODE[VALTYPE]_INTEGER;
ARGLST[ARGCOUNT]_.SSLSTPTR<LEFT>+1+2; !NUMBER OF SUBSCRIPTS PLUS 2
ARGLST[1,ARGNPTR]_MAKECNST(INTEGER,0,.ISN); !1ST ARG IS SEQ NUMBER OF THIS STMNT
ARGLST[1,AVALFLG]_1;
ARRDIMENTRY_.ARRNAMENTRY[IDDIM]; !DIMENSION TABLE ENTRY FOR THE ARRAY
ARGLST[2,ARGNPTR]_.ARRDIMENTRY[ARADLBL]; !2ND ARG IS THE LABEL THAT WILL BE ON
! THE DIMENSION BLOCK FOR THIS ARRAY
ARGLST[2,AVALFLG]_1;
%(**HAVE A PARAMETER FOR EACH OF THE INDIVIDUAL SUBSCRIPTS**)%
INCR I FROM 0 TO .SSLSTPTR<LEFT>
DO
BEGIN
SSNODE_.SSLSTPTR[.I]; !EXPRESSION NODE FOR THIS SUBSCRIPT
IF .SSNODE[VALTP1] NEQ INTEG1 !IF SUBSCRIPT IS NOT INTEGER
THEN
SSNODE_CNVNODE(.SSNODE,INTEGER,0); ! CONVERT IT
ARGLST[.I+3,ARGNPTR]_.SSNODE;
IF .SSNODE[OPRCLS] EQL DATAOPR !IF SUBSCRIPT IS A LEAF
THEN ARGLST[.I+3,AVALFLG]_1 ! SET VALFLG IN ARG LIST
ELSE SSNODE[PARENT]_.FNCALLNODE; ! OTHERWISE SET PARENT FOR THE SS EXPR
END;
SAVSPACE(.SSLSTPTR<LEFT>,.SSLSTPTR); !RETURN THE SS LIST TO FREE STORAGE
ARREFNODE_MAKEPR(ARRAYREF,0,.ARRNAMENTRY[VALTYPE],.ARRNAMENTRY,.FNCALLNODE); !MAKE THE ARRAY REF NODE
%1250% IF .ARRNAMENTRY[VALTYPE] NEQ CHARACTER !IF ARRAY IS NOT TYPE CHARACTER
%1250% THEN
IF NOT .ARRDIMENTRY[ADJDIMFLG] !IF THIS ARRAY IS NOT ADJUSTABLY DIMENSIONED,
THEN ! THEN ADD THE CONSTANT OFFSET IN WITH
BEGIN ! THE BASE ADDRESS
OWN BASE OFFSETNODE;
OFFSETNODE_.ARRDIMENTRY[ARAOFFSET];
ARREFNODE[TARGET]_.OFFSETNODE[CONST2] AND #777777
END;
FNCALLNODE[PARENT]_.ARREFNODE; !PARENT PTR IN THE FN CALL NODE
! POINTS TO THE ARRAYREF NODE
RETURN .ARREFNODE
END; ! of PROARRXPN
%(***OWN VARIABLES USED BY THE DATA-STMNT CHECKING ROUTINES BELOW***)%
OWN OINDEXLIST; !OWN IN WHICH SAVE PTR TO LIST OF LEGAL INDICES AS RECURSE
! THRU THE EXPRESSION TREES CHECKING FOR LEGAL SUBSCRIPTS
! (SINCE FOR EACH CALL TO DATASUBCHK THIS THEN STAYS CONSTANT)
OWN OIXCT; !OWN IN WHICH SAVE IXCT AS RECURSE
GLOBAL ROUTINE DATASUBCHK(DATACALLS,IXCT,INDEXLIST)=
%(***************************************************************************
THIS ROUTINE CHECKS A LIST OF DATACALLS TO DETERMINE WHETHER THEY
ARE LEGAL DATA-ITEMS FOR A DATA STATEMENT.
IT IS CALLED WITH THE ARGS:
DATACALLS- A LINKED LIST OF DATACALL NODES, DO-STMNT NODES, AND
CONTINUE STMNT NODES. DATACALL NODES WHICH ARE INSIDE
OF ANY IMPLIED DO-LOOPS ON THIS LIST WILL BE IGNORED.
INDEXLIST- A LIST OF PTRS TO THE SYMBOL TABLE ENTRIES FOR ALL
VARIABLES WHICH ARE DO-INDICES ON IMPLIED DO LOOPS THAT
CONTAIN THE LIST OF DATACALLS WITHIN THEM
IXCT- CT OF THE NUMBER OF INDICES ON INDEXLIST
THIS ROUTINE CHECKS EACH DATACALL NODE ON THE LIST OF DATACALLS WHICH
IS NOT INSIDE OF ANY DO-LOOPS THAT ARE ON THE LIST. FOR EACH ARRAYREF
UNDER THESE TOP-LEVEL DATACALLS, IT CHECKS THAT THE ADDRESS CALCULATION
INCLUDES NO OPERATIONS OTHER THAN ADD,SUB,MUL,DIV,AND POWER AND
NO TERMS OTHER THAN INTEGER CONSTANTS AND VARIBLES WHICH ARE ON
THE LIST "INDEXLIST" (IE WHICH ARE INDICES ON LOOPS THAT INCLUDE THESE
DATACALLS)
RETURNS TRUE IF THE ABOVE CONDITION IS SATISFIED.
***************************************************************************)%
BEGIN
OWN BASE CDATAELEM;
%(***IF SYNTAX DETECTED AN ERROR IN THIS STMNT EARLIER, THEN
THIS ROUTINE WILL BE CALLED WITH "DATACALLS" EQUAL
TO #777777. IF SO, JUST RETURN***)%
IF .DATACALLS EQL #777777 THEN RETURN FALSE;
%(***PUT THE 2 ARGS INDEXLIST AND IXCT INTO "OWN" TYPE VARS SO DONT HAVE
TO PASS THEM AS ARGS OVER AND OVER AS RECURSE (THEY NEVER CHANGE)***)%
OINDEXLIST_.INDEXLIST;
OIXCT_.IXCT;
CDATAELEM_.DATACALLS; !PTR TO 1ST ELEM ON DATA-ITEM LIST
%(***GO THRU LIST OF DATA-ITEMS, EXAMINING ALL TOP-LEVEL DATACALLS***)%
UNTIL .CDATAELEM EQL 0
DO
BEGIN
IF .CDATAELEM[OPRCLS] EQL STATEMENT
THEN
BEGIN
%(***WHEN ENCOUNTER A DO-STMNT, SKIP TO THE CONTINUE THAT
TERMINATES THE DO***)%
IF .CDATAELEM[SRCID] EQL DOID
THEN
BEGIN
OWN BASE ENDLAB;
ENDLAB_.CDATAELEM[DOLBL];
CDATAELEM_.ENDLAB[SNHDR];
END;
%(***IGNORE CONTINUE STMNTS***)%
END
ELSE
IF .CDATAELEM[OPERATOR] EQL DATACLFL
THEN
BEGIN
OWN PEXPRNODE ARGNODE;
ARGNODE_.CDATAELEM[DCALLELEM];
%1416% %(***EXAMINE SUBSTRING BOUNDS***)%
%1416% IF .ARGNODE[OPRCLS] EQL SUBSTRING
%1416% THEN
%1416% BEGIN
%1416% IF NOT LEGLDATASUB(.ARGNODE[ARG1PTR])
%1416% THEN (FATLERR(.ISN,E173<0,0>); RETURN FALSE);
%1416% IF NOT LEGLDATASUB(.ARGNODE[ARG2PTR])
%1416% THEN (FATLERR(.ISN,E173<0,0>); RETURN FALSE);
%1416% ARGNODE _ .ARGNODE[ARG4PTR];
%1416% END;
%(***WANT TO EXAMINE THE ADDRESS CALC UNDER ANY ARRAYREF***)%
IF .ARGNODE[OPRCLS] EQL ARRAYREF
THEN
BEGIN
IF NOT LEGLDATASUB(.ARGNODE[ARG2PTR])
%(***IF SUBSCRIPT CONTAINS VARIABLES NOT
USED AS LOOP INDICES OR OPERATORS OTHER
THAN +,-,*,/***)%
THEN (FATLERR(.ISN,E26<0,0>);RETURN FALSE);
END;
END;
CDATAELEM_.CDATAELEM[CLINK];
END;
RETURN TRUE;
END;
GLOBAL ROUTINE LEGLDATASUB(EXPR)=
%(***************************************************************************
CHECKS WHETHER THE ARG "EXPR" IS A LEGAL SUBSCRIPT EXPRESSION
FOR A DATACALL UNDER A DATASTATEMENT. THE GLOBAL "OINDEXLIST"
IS ASSUMED TO HAVE BEEN SET UP TO CONTAIN A PTR TO A LIST OF
PTRS TO SYMBOL TABLES ENTRIES FOR INDICES OF IMPLIED DO LOOPS THAT INCLUDE THE
DATACALL NODE IN QUESTION.
A SUBSCRIPT EXPRESSION IS LEGAL IFF ALL TERMS ARE EITHER INTEGER
CONSTANTS OR VARIABLES ON "OINDEXLIST", AND ALL OPERATORS ARE
ADD,SUB,MUL,DIV,OR POWER
***************************************************************************)%
BEGIN
MAP PEXPRNODE EXPR;
IF .EXPR EQL 0 THEN RETURN TRUE
ELSE
IF .EXPR[OPERATOR] EQL INTCONST
THEN RETURN TRUE !INTEGER CONSTANT
ELSE
%(***FOR AN INTEGER VARIABLE, DETERMINE WHETHER IT IS ON THE LIST OF LEGAL VARIABLES***)%
IF .EXPR[OPR1] EQL VARFL
THEN RETURN ONLST(.EXPR,.OIXCT,.OINDEXLIST)
ELSE
%(***FOR A LEGAL ARITHMETIC OP (ADD,SUB,MUL,DIV,OR POWER), DETERMINE THAT BOTH ARGS
ARE LEGAL EXPRESSIONS***)%
%1416% IF .EXPR[OPRCLS] EQL ARITHMETIC
THEN
BEGIN
IF NOT LEGLDATASUB(.EXPR[ARG1PTR])
THEN RETURN FALSE
ELSE
RETURN LEGLDATASUB(.EXPR[ARG2PTR])
END
ELSE
%(***FOR OPERATION NEGATE (UNARY MINUS) - THE ARG MUST BE LEGAL***)%
IF .EXPR [OPR1] EQL NEGFL
THEN RETURN LEGLDATASUB(.EXPR[ARG2PTR])
ELSE
RETURN FALSE
END;
ROUTINE ONLST(VARTOMATCH,LSTLNTH,LISTTOMATCH)=
%(***************************************************************************
DETERMINE WHETHER "VARTOMATCH" IS AN ELEMENT IN THE VECTOR POINTED TO
BY "LISTTOMATCH". LSTLNTH IS THE NUMBER OF ELEMENTS ON LISTTOMATCH.
***************************************************************************)%
BEGIN
%(***DEFINE A STRUCTURE FOR A PTR TO A VECTOR IN WHICH
ONLY THE RIGHT HALF OF EACH ENTRY SHOULD BE EXAMINED***)%
STRUCTURE PVECTOR[CT]=
(@.PVECTOR+.CT)<0,18>;
MAP PVECTOR LISTTOMATCH;
INCR I FROM 0 TO (.LSTLNTH-1)
DO
BEGIN
IF .LISTTOMATCH[.I] EQL .VARTOMATCH
THEN RETURN TRUE
END;
%(***IF NEVER FIND IT***)%
RETURN FALSE;
END;
GLOBAL ROUTINE PROSUB (SSNODE) = ! [1554] New
! Insert call to PROSB. to do substring range checking. Only do this if
! /DEBUG:BOUNDS.
!
! This routine effectively replaces a substring
!
! A(I:J)
!
! with
!
! A(I: PROSB.(A,I,J,ISN,'A') )
!
! where PROSB. will return J, and also checks that I and J are legal substring
! bounds. The descriptor for A gives A's length. The ISN and variable name
! arguments are provided for the error message.
BEGIN
MAP BASE SSNODE;
REGISTER BASE A:FNCALLNODE;
REGISTER ARGUMENTLIST ARGLST;
LOCAL BASE PROSBSYM;
! If we're not doing bounds checking, return the node untouched
IF NOT .FLGREG<BOUNDS> THEN RETURN .SSNODE;
! Make arg list and FNCALL node
NAME<LEFT> = ARGLSTSIZE(5); ! get a block for 5 args
ARGLST = CORMAN();
NAME = IDTAB; ! get ID table entry for PROSB.
ENTRY = SIXBIT 'PROSB.';
PROSBSYM = TBLSEARCH();
IF NOT .FLAG ! if TBLSEARCH made a new entry
THEN ! fill in its VALTYPE and stuff
BEGIN
PROSBSYM[VALTYPE] = INTEGER;
PROSBSYM[OPERSP] = FNNAME;
PROSBSYM[IDPSECT] = PSCODE;
END;
FNCALLNODE = MAKEPR(FNCALL,LIBARY,INTEGER,.PROSBSYM,.ARGLST);
! Fill in arg block
ARGLST[ARGCOUNT] = 5; ! arg count is 5
ARGLST[1,ARGNPTR] = A = COPYEXPR(.SSNODE[ARG4PTR],.FNCALLNODE);
ARGLST[1,AVALFLG] = (.A[OPRCLS] EQL DATAOPR);
ARGLST[2,ARGNPTR] = COPYEXPR(.SSNODE[ARG2PTR],.FNCALLNODE);
ARGLST[2,AVALFLG] = .SSNODE[A2VALFLG];
ARGLST[3,ARGNPTR] = COPYEXPR(.SSNODE[ARG1PTR],.FNCALLNODE);
ARGLST[3,AVALFLG] = .SSNODE[A1VALFLG];
ARGLST[4,ARGNPTR] = MAKECNST(INTEGER,0,.ISN);
ARGLST[4,AVALFLG] = 1;
IF .A[OPRCLS] EQL ARRAYREF THEN A = .A[ARG1PTR];
ARGLST[5,ARGNPTR] = MAKECNST(INTEGER,0,.A[IDSYMBOL]);
ARGLST[5,AVALFLG] = 1;
! Replace the upper bound expr with the PROSB. call
SSNODE[ARG1PTR] = .FNCALLNODE;
SSNODE[A1VALFLG] = 0;
FNCALLNODE[PARENT] = .SSNODE;
! Set flag saying ac 16 must be saved
FLGREG<BTTMSTFL> = 0;
! Done. Return altered substring node
RETURN .SSNODE;
END; ! PROSUB
ROUTINE COPYEXPR (CNODE, PARNODE) = ! [1554] New
! Routine to copy an expression tree
BEGIN
MAP BASE CNODE;
REGISTER BASE T;
IF .CNODE[OPRCLS] EQL DATAOPR THEN RETURN .CNODE;
IF .CNODE[OPRCLS] EQL LABOP THEN RETURN .CNODE;
NAME<LEFT> = IF .CNODE[OPRCLS] EQL SUBSTRING THEN EXSIZ+1 ELSE EXSIZ;
T = CORMAN();
T[PARENT] = .PARNODE; ! set parent pointer
T[CW1] = .CNODE[CW1]; ! copy [EXPFLAGS] and [OPERATOR]
%1714% T[CW2] = .CNODE[CW2]; ! copy [TARGET]
IF .CNODE[ARG1PTR] NEQ 0 ! copy arg 1
THEN T[ARG1PTR] = COPYEXPR(.CNODE[ARG1PTR],.T);
IF .CNODE[OPRCLS] EQL FNCALL ! copy arg 2
THEN
BEGIN ! copy arg list
REGISTER ARGUMENTLIST OARGLST:NARGLST;
OARGLST = .CNODE[ARG2PTR];
NAME<LEFT> = ARGLSTSIZE(.OARGLST[ARGCOUNT]);
NARGLST = CORMAN();
T[ARG2PTR] = .NARGLST;
INCR I FROM -ARGHDRSIZ+1 TO 0 DO
NARGLST[.I,0,FULL] = .OARGLST[.I,0,FULL];
INCR I FROM 1 TO .OARGLST[ARGCOUNT] DO
BEGIN
NARGLST[.I,ARGNPTR] =
COPYEXPR(.OARGLST[.I,ARGNPTR],.T);
NARGLST[.I,AVALFLG] = .OARGLST[.I,AVALFLG];
END;
END ! copy arg list
ELSE IF .CNODE[ARG2PTR] NEQ 0 ! copy ordinary arg 2
THEN T[ARG2PTR] = COPYEXPR(.CNODE[ARG2PTR],.T);
IF .CNODE[OPRCLS] EQL SUBSTRING ! copy arg 4
THEN T[ARG4PTR] = COPYEXPR(.CNODE[ARG4PTR],.T);
RETURN .T;
END; ! COPYEXPR
END ELUDOM