Trailing-Edge
-
PDP-10 Archives
-
bb-4157j-bm_fortran20_v11_16mt9
-
fortran-compiler/arrxpn.bli
There are 12 other files named arrxpn.bli in the archive. Click here to see a list.
!COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1972, 1987
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
!AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!AUTHOR: S. MURPHY/NEA/SJW/TFV/CKS/AHM/AlB/CDM/MEM
MODULE ARRXPN(SREG=#17,VREG=#15,FREG=#16,DREGS=4,RESERVE(0,1,2,3),GLOROUTINES)=
BEGIN
! REQUIRES FIRST, TABLES
GLOBAL BIND ARRXPV = #11^24 + 0^18 + #4532; ! Version Date: 19-Feb-86
%(
***** 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 V7 Development *****
1766 CDM 15-Jul-83
Compiler puts constant array ref offset calculations in TARGADDR
whenever possible. TARGADDR is a half word quantity (17 bit
plus 1 bit for sign) which can not store large numbers. Some
large positive numbers may be truncated and appear to be
negative when retrieved, since the retrieved offset is sign
extended. (Also negative numbers can appear to be positive the
same way.) Before storing into TARGADDR, check if the offset
will fit.
Removed OWN variables SSVARFLG (replaced its use with existing
SSVARPTR) and SSCONSTPTR (never referenced) in ARRXPN.
***** Begin Version 10 *********
2253 AlB 28-Dec-83
Compatibility flagging of non-integer subscripts.
Routines:
ARRXPND, PROARRXPN
2271 AlB 18-Jan-84
Compatibility flagging to check to see if substring bounds in a
DATA statement are constants. ANSI-77 specifies that one cannot
use implied DO-loops which modify the substring bounds, so the
bound cannot be a non-constant expression.
Routines:
DATASUBCHK LEGLDATASUB
2463 AHM 8-Oct-84
Use new OPERSP symbol ARREFSMALL when creating all ARRAYREF
nodes in ARRXPND and PROARRXPN.
***** End V10 Development *****
2561 CDM 21-NOV-85
When using IMPLICIT NONE with /DEBUG:BOUNDS or /DEBUG:ALL, PROAR.
and PROSB. get warnings for not being explicitly defined. We are
now making sure that the compiler knows they are library functions
and not user symbols.
***** End Revision History *****
***** Begin Version 11 *****
4515 CDM 20-Sep-85
Phase I for VMS long symbols. Create routine ONEWPTR for Sixbit
symbols. For now, return what is passed it. For phase II, return
[1,,pointer to symbol].
4516 CDM 2-Oct-85
Phase I.I for VMS long symbols. Pass Sixbit to all error message
routines, do not pass addresses of Sixbit anymore. In later edits
this will pass [length,,pointer to symbol] instead of a pointer to
this to the error message routines.
4524 CDM 21-Nov-85
Additions to edit 2561. Fill in IDLIBFNFLG for FDDT.
4527 CDM 1-Jan-86
VMS Long symbols phase II. Convert all internal symbols from
one word of Sixbit to [length,,pointer].
4532 MEM 19-Feb-86
Set ARGPARENT in arg block for PROSB. call.
ENDV11
)%
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,
%2253% E260, !Extension to Fortran-77: Non-integer subscript
%2271% E272, !Extension to Fortran-77: Non-constant substring bounds
ENTRY,
FATLERR,
ISN,
KTYPCB,
KTYPCG,
MAKEPR, !ROUTINE TO BUILD AN EXPRESSION NODE
MAKPR1,
NAME,
%4515% ONEWPTR, ! Returns [1,,pointer] to Sixbit argument
SAVSPACE, !RETURNS CORE TO FREE STORAGE
%2253% TBLSEARCH,
%2253% WARNERR; !Put out warning message
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>+1, 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
DIMSUBENTRY DIMLSTPTR, ! Subentry for a given dimension
SSLSTP1; ! Used to walk thru subscripts
OWN
PEXPRNODE ARG1NODE, ! ARG1PTR of add or sub ss
PEXPRNODE ARG2NODE, ! ARG2PTR of add or sub ss
DIMENTRY ARRDIMENTRY, ! Dimension table entry for this array
PEXPRNODE ARREFNODE, ! Ptr to array ref node built
PEXPRNODE DIMFNODE, ! Expression node for the "factor"
PEXPRNODE SSNODE, ! Ptr to expression node for a subscrpt
! corresponding to that dimension
SSCNSTPTR, ! Ptr to constant node with constant
! part in it
SSCNSTVAL, ! Constant part of subscript expression
PEXPRNODE SSVARPTR; ! Expression for runtime address
! calculation
ARRDIMENTRY_.ARRNAMENTRY[IDDIM];
! Check for wrong number of subscripts
IF .ARRDIMENTRY[DIMNUM] NEQ (.SSLSTPTR<LEFT>+1)
%4516% THEN RETURN FATLERR(.ARRNAMENTRY[IDSYMBOL],.ISN,E27<0,0>);
%(***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;
! Zero pointer to the runtime address calculation
%1766% SSVARPTR = 0;
%(***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***)%
%2253% IF .SSNODE[VALTP1] NEQ INTEG1
%2253% THEN
%2253% BEGIN
%2253% IF FLAGANSI THEN WARNERR(.ISN,E260<0,0>); ! Comp flagger
%2253% SSNODE=CNVNODE(.SSNODE,INTEGER,0) ! Convert to integer
%2253% END;
%(**MULTIPLY THE SUBSCRIPT BY A FACTOR DETERMINED
BY THE PRECEEDING DIMENSIONS****)%
%(**THIS FACTOR MAY BE A VARIABLE, IF PRECEEDING DIMENSIONS
WERE VARIABLES****)%
! If factor is a variable, generate nodes to multiply ss
! by this variable and add it into the variable term
IF .DIMLSTPTR[VARFACTFLG]
THEN
BEGIN
SSNODE_MAKPR1(0,ARITHMETIC,MULOP,INDEX,.SSNODE,.DIMFNODE);
%1766% IF .SSVARPTR NEQ 0
THEN SSVARPTR _ MAKPR1(0,ARITHMETIC,ADDOP,INDEX,.SSVARPTR,.SSNODE)
ELSE SSVARPTR _ .SSNODE;
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);
%1766% IF .SSVARPTR NEQ 0
THEN SSVARPTR _ MAKPR1(0,ARITHMETIC,ADDOP,INDEX,.SSVARPTR,.SSNODE)
ELSE SSVARPTR _ .SSNODE
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
%1766% IF .SSVARPTR NEQ 0
THEN SSVARPTR _ MAKPR1(0,ARITHMETIC,ADDOP,INDEX,.SSVARPTR,.ARRDIMENTRY[ARAOFFSET])
ELSE SSVARPTR _ .ARRDIMENTRY[ARAOFFSET];
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
%1766% IF .SSVARPTR NEQ 0
THEN ! Ptr to symbol that contains the base address
SSVARPTR _ MAKPR1(0,ARITHMETIC,ADDOP,INDEX,.SSVARPTR,
.ARRDIMENTRY[ARADDRVAR])
ELSE ! If do not yet have a variable term, set the
! variable term to be the base address
SSVARPTR _ .ARRDIMENTRY[ARADDRVAR];
END;
! If the array is type character, or the constant is too big to
! store in the TARGADDR field, explicitly add in the constant
! part and set SSCNSTVAL to 0.
%1250% IF .ARRNAMENTRY[VALTYPE] EQL CHARACTER
%1766% OR NOT STORETARGADDR(.SSCNSTVAL)
THEN
BEGIN ! Add in constant part
%1436% ! Flag for character operator used in prog
%1766% IF .ARRNAMENTRY[VALTYPE] EQL CHARACTER
%1436% THEN CHARUSED = TRUE;
! Make constant node for constant part
SSCNSTPTR _ MAKECNST(INTEGER,0,.SSCNSTVAL);
! Make an add node, adding constant into address offset
! expression.
%1766% IF .SSVARPTR NEQ 0
THEN ! Already have variable part
SSVARPTR _ MAKPR1(0,ARITHMETIC,ADDOP,INTEGER,.SSVARPTR,.SSCNSTPTR)
ELSE ! No variable part, make one
SSVARPTR _ .SSCNSTPTR;
! Set constant part to 0, it's been explicitly added in
SSCNSTVAL _ 0;
END; ! Add in constant part
%(****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).
********)%
%2463% ARREFNODE _ MAKEPR(ARRAYREF,ARREFSMALL,.ARRNAMENTRY[VALTYPE],
%1766% .ARRNAMENTRY,.SSVARPTR);
%(***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; ! Array ref created
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
%1766% LOCAL BASE OFFSETNODE; ! Offset calculation
%(***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;
%4515% ENTRY[0] = ONEWPTR(SIXBIT'PROAR.');
PROARSYM_TBLSEARCH(); !MAKE THE SYM TABLE ENTRY IF THERE ISNT ONE
%4524% IF NOT .FLAG ! if TBLSEARCH made a new entry
%4524% THEN ! fill in its VALTYPE and stuff
%4524% BEGIN
PROARSYM[VALTYPE]_INTEGER; !FILL IN TYPE FIELD
PROARSYM[OPERSP]_FNNAME;
%4524% PROARSYM[IDPSECT] = PSCODE;
%2561% PROARSYM[IDLIBFNFLG] = 1; ! PROAR. is a library function.
%4524% END;
%(**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
! 1ST arg is seq number of this stmnt
ARGLST[1,ARGNPTR]_MAKECNST(INTEGER,0,.ISN);
ARGLST[1,AVALFLG]_1;
! Dimension table entry for the array
ARRDIMENTRY_.ARRNAMENTRY[IDDIM];
! 2nd arg is the label that will be on the dimension block for
! this array
ARGLST[2,ARGNPTR]_.ARRDIMENTRY[ARADLBL];
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
%2253% BEGIN
%2253% IF FLAGANSI THEN WARNERR(.ISN,E260<0,0>); ! Comp flagger
%2253% SSNODE=CNVNODE(.SSNODE,INTEGER,0) ! Convert to integer
%2253% END;
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
%2463% ARREFNODE_MAKEPR(ARRAYREF,ARREFSMALL,.ARRNAMENTRY[VALTYPE],
.ARRNAMENTRY,.FNCALLNODE); !MAKE THE ARRAY REF NODE
! If array is not type CHARACTER and array is not adjustably
! dimensioned, and constant is not too big to store in the
! TARGADDR field, then add the constant offset in with the base
! address.
OFFSETNODE_.ARRDIMENTRY[ARAOFFSET];
%1250% IF .ARRNAMENTRY[VALTYPE] NEQ CHARACTER THEN
IF NOT .ARRDIMENTRY[ADJDIMFLG]
THEN ! Check if offset should be stored in TARGADDR
%1766% IF STORETARGADDR(.OFFSETNODE[CONST2])
THEN ARREFNODE[TARGET] = .OFFSETNODE[CONST2] AND #777777
%1766% ELSE
%1766% BEGIN ! Make add node adding constant and PROAR. result
%1766%
%1766% FNCALLNODE[PARENT] = ARREFNODE[ARG2PTR] =
%1766% MAKPR1(.ARREFNODE,ARITHMETIC,ADDOP,INTEGER,
%1766% .OFFSETNODE,.FNCALLNODE);
%1766%
%1766% RETURN .ARREFNODE;
%1766%
%1766% END; ! Make add node adding constant and PROAR. result
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
%2271% OWN CONBOUND; ! False if substring bounds are not constant
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***)%
%2271% ! If compatibility flagging is being done, check to
%2271% ! see if all substring bounds are constant, and if not
%2271% ! put out a flagger warning.
%1416% IF .ARGNODE[OPRCLS] EQL SUBSTRING
%1416% THEN
%1416% BEGIN
%2271% CONBOUND=TRUE; ! Becomes false when non-constant bound is found
%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);
%2271% IF NOT .CONBOUND
%2271% THEN IF FLAGANSI THEN WARNERR(.ISN,E272<0,0>);
%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
%2271% THEN
%2271% BEGIN
%2271% CONBOUND=FALSE; ! Non-constant
%2271% RETURN ONLST(.EXPR,.OIXCT,.OINDEXLIST)
%2271% END
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.
%4515% ENTRY = ONEWPTR(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;
%2561% PROSBSYM[IDLIBFNFLG] = 1; ! PROSB. is a library function.
END;
FNCALLNODE = MAKEPR(FNCALL,LIBARY,INTEGER,.PROSBSYM,.ARGLST);
! Fill in arg block
ARGLST[ARGCOUNT] = 5; ! arg count is 5
%4532% ARGLST[ARGPARENT] = .FNCALLNODE;
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;
%4532% !The fifth arg is transformed to an address where the long name
%4532% !is listed when the arg block is output in CGARGS
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