Trailing-Edge
-
PDP-10 Archives
-
CFS_TSU04_19910205_1of1
-
update/ftncsr/act1.bli
There are 26 other files named act1.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: T.E. OSTEN/FJI/MD/SJW/JNG/DCE/TFV/CKS/AHM/CDM/RVM/SRM/TGS/AlB/MEM
MODULE ACT1(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4)=
BEGIN
GLOBAL BIND ACT1V = #11^24 + 0^18 + #4576; ! Version Date: 11-Nov-87
%(
***** Begin Revision History *****
69 ----- ----- MAKE USE COUNT FOR IMPLIED DO LOOP LABELS
2 INSTEAD OF 1
70 ----- ----- GENERATE LABELS FOR DIMENSION BLOCKS FOR ARRAYS
THAT ARE PROTECTED (ALSO - COMMENT OUT CODE IN
"BLDARRAY" THAT APPEARS TO PROCESS MULTIPLE
ARRAYS SPECIFIED BY THE SAME DIMENSION SPECIFICATION)
71 ----- ----- FIX OPERSP FIELD OF SLIST CALLS
72 ----- ----- MODIFY "BLDARRAY" TO GENERATE DIMENSION LABELS
FOR ALL ARRAYS IF THE "BOUNDS" SWITCH WAS SPECIFIED.
(WE HAVE DONE AWAY WITH THE "ISPROT" FLAG ON INDIVIDUAL
ARRAYS)
76 ----- ----- DETECT UNDETECTED SUBSCRIPTED IMPLICIT DO INDICES
77 ----- ----- PUT PARAMETER STUFF IN NAMCHK AND NAMDEF.
PUT *N OVERRIDE IN BLDARRAY.
CHANGE NO PARAMETERS IN FUNCTION TO WARNING
78 ----- ----- IN FUNCGEN - NO LONGER SET FNNAME ON FUNCTIONS.
- PROGNAME IS NOW SET IN ACTION PNAMSET
79 ----- ----- MAKE A LINKED LIST OF ENTRY POINT NAMES IN FUNCGEN
80 ----- ----- ALLOW DIMENSION A(1:3)
81 ----- ----- DUMMIES CAN BE IN EXTERNAL STATEMENTS
82 ----- ----- CLEAR THE NOALOC BIT IN THE OTHER PLACE
WHERE THE SPECIAL FORMAL ARRAY PSEUDOSYMBOL TABLE
ENTRY IS GENERATED - FUNCGEN
83 ----- ----- CHANGE NAMDEF AND NAMCHK TO INTERPRET THE &/* EXTERNAL
STATEMENT PROPERLY
84 ----- ----- FIX BLDARRAY SO THAT IT ACCEPTS THE TYPE INFORMATION
FOR TYPE STATEMENTS BEFORE THE DIMENSION INFORMATION
RATHER THAN AFTER
85 ----- ----- CHECK FOR DUPLICATE DUMMY ARGS IN FUNCTIONS,
SUBROUTINES AND ENTRYS
86 ---- ----- HAVE BLDDIM USE DVARFLGS TO CLEAR THE FLAGS IN
THE DIMENSION TABLE ENTRY.
87 ----- ----- DETECT THE CASE OF AN IMPLIED DO SPEC WITHOUT
PRECEEDING VARIABLE LIST OF SOME SORT - DATALIST
88 ----- ----- ISSUE A WARNING MESSAGE WHEN LABEL INDICATORS
APPEAR IN THE FORMAL ARGUMENT LIST OF A FUNCTION
FUNCGEN
89 ----- ----- FIX BLDARRAY SO THAT IT WILL REVERSE
THE CALCULATED DIMENSIONS OF AN ARRAY WHICH
HAS GONE TO DOUBLE PRECISION DUE TO
AN IMPLICIT STATEMENT AND IS THEN EXPLICITLY TYPED
TO SINGLE PRECISION
90 ----- ----- CHECK IN BLDDIM TO BE SURE THAT DIMENSIONS
ARE WITHIN A RESPECTABLE RANGE
91 ----- ----- IN BLDDIM, CHANGE REFERENCE TO "DEBUG" FLAG
TO "DBGDIMN" FLAG
92 ----- ----- FUNCGEN - FIX DUPLICATE DUMMY PARAMETER CHECK SO
IT REALLY WORKS
93 ----- ----- MAKE A CHECK FOR DO INDEX MODIFICATION IN NAMSET
SO THAT ALL CASES ARE CHECKED
94 ----- ----- NAMSET WAS NOT CALLED FOR IMPLICIT DO INDICES
95 ----- ----- BLDDIM - CHECK FOR ZERO SINGLE DIMENSION
96 ----- ----- WITH THE ADVENT OF SIGNED PARAMETERS - BULDDIM
MUST BE PREPARED TO CHECK THE SIGN OF THE NUMBER
NOT JUST WHETHER OR NOT A - WAS
PRESENT
97 ----- ----- EXTEND NAMDEF TO DETECT REFERENCE TO DUMMY PARAMETERS
BEFORE THEY HAVE BEEN DEFINED
***** Begin Version 4A *****
99 230 ----- RESTORE NOALLOC BIT WHEN ADJUSTABLE DIMENSION
IS NOT YET DEFINED, (MD)
100 232 ----- FIX BLDUNIT - IT NEEDED ONE MORE LEVEL OF
INDIRECTION IN THE RECORD NUMBER PROCESSING., (MD)
101 235 ----- FIX NAMELIST PROBLEMS
USING NEW PARAMETER NMLSTITM, (DT/MD)
102 265 15946 ADD CHECK FOR VARIABLE IN DATA STATEMENT TWICE, (JNT)
103 272 ----- CHANGE 102 TO ONLY CHECK SIMPLE VARIABLES, NOT ARRAYS,
(JNT)
***** Begin Version 5 *****
104 VER5 ----- SHARE .I OFFSET IN DIMENTRY FOR ARRAYS
WITH VARIABLE UPPER BOUND (LINK DIM ENTRIES), (SJW)
105 410 ----- MAKE DTABPTR GLOBAL SO WILL BE INITIALIZED TO 0, (SJW)
106 414 QA625 FIX SHARING .I OFFSET SO ONLY SHARES DIM2 .I
IF DIM1 SAME, (SJW)
107 415 18964 DON'T DESTROY SYMBOL TABLE ENTRY FOR A FORMAL
FUNCTION IF A LATER ENTRY STATEMENT SEEN WITH
THE FUNCTION AS A PARAMETER.
108 423 QA709 FIX PATCH 414: DIMNUM=1 => ARRAY HAS 1 DIM NOT 2, (SJW)
109 460 19477 TEST FOR OVERSIZED DIMENSIONING CORRECTLY, (DCE)
***** Begin Version 5A *****
110 567 22284 MAKE EXTERNAL STMNT APPLY TO ALL ENTRY POINT PARAMS
111 571 22378 FIX V5 OPTIMIZATION THAT SHARES 2ND OFFSET OF
FORMAL ARRAYS IF 1ST DIMENSIONS = SO ALL WILL
WORK IF ARRAY SUBSEQUENTLY TYPED DIFFERENTLY
(DIFFERENT # WORDS) THAN WHEN SHARING 1ST DONE, (SJW)
112 572 21825 CHECK IMPLIED DO INDEX FOR ALREADY ACTIVE (FROM
AN ENCLOSING IMPLIED OR REAL DO), (SJW)
113 601 Q20-26 FIX EDIT 572 TO CHECK IMPLIED DO INDEX IN DATA
STATEMENT FOR ALREADY ACTIVE FROM AN ENCLOSING
IMPLIED DO, (SJW)
***** Begin Version 5B *****
114 627 23755 FIX EDIT 571 TO CORRECTLY ADJUST ALL DIMENSION
TABLE MULTIPLICATIVE FACTORS BY THE RIGHT
CONSTANT IF AN ARRAY IS LATER DISCOVERED TO
REQUIRE A DIFFERENT NUMBER OF WORDS PER ENTRY
THAN ORIGINALLY THOUGHT. EDIT 571 ONLY FIXED
THE FIRST SUBSCRIPT., (JNG)
115 635 24868 FIX DATALIST TO RETURN -1 IF IT GETS E66
(CANNOT INIT DUMMY PARAMETER IN DATA), (JNG)
116 663 25643 FIX TYPING OF FORMAL FUNCTIONS (EXTERNAL STMNTS), (DCE)
117 717 26560 GIVE REASONABLE ERROR MESSAGE FOR
REPEATED PARAMETER STATEMENT, (DCE)
118 741 ----- ADD SLASHWARN ROUTINE, (DCE)
***** Begin Version 6 *****
119 760 TFV 1-Jan-80 -----
Add routines to handle keywords in I/O control lists
127 1132 AHM 22-Sep-81 Q10-06347
Fix casing of some error message fragments.
128 1136 AHM 19-Oct-81 Q20-01652,Q20-01656
Delete code that unjustifiably decremented SNREF for labels
in BLDKEY, since it screwed up optimizations.
1155 EGM 9-Jun-82
Allow BLDARRAY to continue processing ONEARRAY list after semantic
errors are seen. This allows detection of multiple errors per
statement, and frequently eliminates annoying 'not dimensioned'
errors.
***** Begin Version 7 *****
120 1202 DCE 1-Jul-80 -----
Add code to handle expressions on output lists. Separate out
the routine LISTIO to handle the cases. Also add routine CCONST
to handle the especially difficult complex constants in I/O lists.
Rework DATALIST to only include code for DATA lists (not I/O lists).
Add BLDIOLSCLS routine as subsidiary routine.
121 1203 DCE 21-Nov-80 -----
Fix up various problems with CCONST, especially with GFLOAT numbers.
Change the way complex constants are handled with the new I/O list
processing.
122 1212 TFV 29-Apr-81 ------
Change LITERAL to HOLLERITH in BLDIOLSCLS.
123 1213 TFV 20-May-81 ------
Fix BLDARRAY to handle character data. Fetch the length from the
stack. It is deposited by ASTER. Fix BLDDIM and BLDARRAY to calculate
array size, array offset, and factors; character data uses character
count not word count.
124 1214 CKS 8-Jun-81
Use DOIFSTK instead of LASDOLABEL<LEFT> to stack implied DOs.
125 1250 CKS 6-Aug-81
Make BLDDIM always allocate a .I temp for factor 1 of adjustable
character arrays
126 1242 CKS 22-Sep-81
Modify the code that calculates number of elements in an array to
know about character arrays
129 1400 CKS 20-Oct-81
In FUNCGEN, allow FUNCTION statements to have a null argument list
130 1407 CKS 27-Oct-81
Fix BLDIOLSCLS so character constants in IO lists go out as DATACALLs
not SLISTs.
131 1410 CKS 28-Oct-81
Fix BLDARRAY to know about modified syntax of COMMON statement. Other
declarations call BLDARRAY with the syntax tree resulting from
+ONEARRAY. COMMON now calls it with the tree +(ONEARRAY), which
contains an additional level of indirection.
132 1412 CKS 4-Nov-81
Allow statement function and common block to have same name
133 1413 CDM 4-Nov-81
Change FUNCGEN to use argument structure ARGUMENTLIST in the
assignments of argument nodes.
134 1416 CKS 9-Nov-81
Add BLDSUBVAR to do semantics for SUBVARSPEC. It returns a
DATAOPR or ARRAYREF or SUBSTRING node. Have DATALIST call
BLDSUBVAR instead of BLDVAR so DATA statements can have substrings.
135 1422 TFV 12-Nov-81 ------
Change FUNCGEN to generate an extra argument for character
functions. It is the first argument and is the result of the
character function. It points to the symbol table entry for the
function name.
136 1423 CKS 19-Nov-81
Don't allow character function names to be initialized by DATA
statements.
137 1432 RVM 8-Dec-81
Make routine BLDKEY allow integer variables to be values of the
FMT= keyword in I/O statements. Fix wrong error messages given
when an asterisk or a name is incorrectly given as the value of
a keyword. Also, change the code so that it does not explicitly
manipulate VREG.
138 1434 TFV 14-Dec-81
Modify BLDARRAY to handle the case FUNCTION FOO(...) followed by
CHARACTER*n FOO. FOO becomes a character function and a new
argument list is built using CHARGLIST.
139 1442 RVM 17-Dec-81
Modify BLDFORMAT and KORFBLD to allow INTEGER variable format
specifiers even without the FMT= keyword.
140 1444 CKS 18-Dec-81
Attempt to READ into a substring gives "?Expression illegal in input
list". Change check to allow substrings in input lists.
141 1457 RVM 12-Jan-82
Fix BLDFORMAT to allow INTEGER variable format specifiers in
ENCODE/DECODE statements (Edit 1442 did not quite accomplish
this). Also, fix a poor error message that implies that name
lists are legal format specifiers in ENCODE/DECODE statements.
142 1464 RVM 26-Jan-82
Fix a error message to reflect the existence of the INTRINSIC
statement.
143 1466 CDM 1-Feb-82
Add code to FUNCGEN to link together entry statements.
Also fix FUNCGEN so that it creates an argument list for character
functions's return values even if the user specified no arguments
in the definition.
144 1471 RVM 5-Feb-82
Make the macro SIZOFARRAY into a GLOBAL ROUTINE. Also, rearrange its
code and add some comments.
145 1473 SRM 8-Feb-82
Set CHARUSED when NAMSET or NAMREF is called for character variables
1505 AHM 9-Mar-82
Set the psect index to PSDATA when creating symbol table
entries for various temps in TMPGEN and for the variable that
holds non-adjustable formal array base addresses in FUNCGEN
and BLDDIM.
1510 RVM 14-Feb-82
Implement assumed-size arrays. Modify BLDDIM to process an asterisk
as the upper bound of the last dimension of an array. Put a check
in SIZOFARRAY to make sure it is not called to get the size of an
assumed-size array. Put a check in BLDIOLSCLS to make assumed-size
arrays illegal in I/O lists. As an extra to this edit, do some clean
up of BLDDIM (it really needs it).
1511 CDM 17-Mar-82
Error processing for common variables given in a SAVE statement.
1514 RVM 22-Mar-82
Define mask in NAMDEF to disallow formal arguments as intrinsic
functions.
1527 CKS 9-Apr-82
Modify BLDDIM to read changed tree shape. Dimension bounds can
now be constant expressions.
1530 TFV 4-May-82
Modify BLDIOLSCLS and DATALIST to use symbols for the sizes of
IOLSLCS nodes.
1550 CKS 1-Jun-82
Insert some SAVSPACE calls in LISTIO
1560 TFV 14-Jun-82
Modify BLDDIM to give an array too large error for character
arrays greater than or equal to CHARSPERWORD * 2 ** 18
characters and numeric arrays greater than or equal to 2 ** 18
words.
1575 TFV 7-Jul-82
Modify BLDARRAY to handle 'var * len (subs) * len' in type
declarations.
1670 CKS 10-Nov-82
Allow arbitrary expressions as adjustable array dimension bounds.
1715 RVM 12-Jan-83
Add comment to NAMSET about the use of the STORD attribute.
***** End V7 Development *****
1741 CDM 7-APR-83
Give error message for a implied DO index that is character.
1743 CDM 19-APR-83
Fill in parent pointer for array expression node.
1754 CDM 26-May-83
Remove incorrect error message saying that the use of a variable
in an adjustably dimensioned array declaration is illegal before
defining it as a dummy in an ENTRY statement later in the
program. Also start giving error messages (again) for using
variables in these declarations that are not later declared to
be dummys or in common.
1767 CDM 20-Jul-83
Correct edit 1743 which fills in parent pointers
indiscriminately without checking to see if they are expressions
first.
1773 TGS 9-Aug-83 SPR:10-34064
When checking in DATALIST for an illegal attempt to initialize a
character function name in a DATA statement, do not issue a
fatal error if a DATA statement initializes a character variable
with the same name as a PROGRAM, SUBROUTINE or BLOCK DATA
statement. In this case IDATTRIBUT(FENTRYNAME) may have been
set by PROGSTA and the variable be of type character even though
no character function is being initialized. Nail the illegal
case down by also checking if FLGREG<PROGTYP> is FNPROG.
2051 TFV 27-Apr-84
Fix FUNCGEN to set the character length for entry points in
character functions properly. They were inheriting the length
from the last CHARACTER declaration.
***** Begin Version 10 *****
2224 RVM 3-Oct-83
Set the PSECT fields for arrays to the proper values under
/EXTEND. Note that formal arrays can never be in .LARG. (but
of course an actual corresponding to a foral can be), so never
set the PSECT fields for these arrays to .LARG. and set the
PSECT fields to .DATA. everytime an array becomes a formal.
2253 AlB 28-Dec-83
Added compatibility flagging for return labels in argument list.
Routine:
FUNCGEN
2270 AlB 6-Jan-84
Added VAX compatibility flagging to catch items with duplicated names.
NAMELISTs, EXTERNALs, statement functions and PARAMETERs can no longer
be the same name as an item in a NAMELIST list.
NAMELIST and EXTERNAL names can no longer be same as variable names.
PARAMETER names can no longer be same as an array name.
2276 AlB 26-Jan-84
Fixed bug caused by Edit 2270: It was erroneously flagging the
EXTERNAL items which were dummy arguments.
Added routine COMPFLAG, which does compatibility flagging for
conflicts between our intrinsic functions & subroutines, and
those for VAX and Fortran-77. This routine is called from NAMCHK.
2277 AlB 26-Jan-84
Reworked COMPFLAG so that it was less stringent about complaints
regarding those names which are intrinsic routines on VAX, but
mean nothing to Fortran-10/20.
Added one element to the set in the CASE statement in NAMDEF.
INTRSCDEF was never in the CASE set, even though INTRSTA calls
NAMDEF with INTRSCDEF as a type. This has been a bug since at
least edit 1514.
This new CASE set element does nothing unless compatibility
flagging is being done. If flagging is being done, it issues a
flagger warning if the INTRINSIC routine name is not recognized
by the VAX.
2300 AlB 27-Jan-84
Changed the argument list for COMPFLAG in order to better specify
that which we are checking in compatibility flagger.
Changed the order of tests in COMPFLAG, so that only things which
look like function names are tested. This prevents the testing of
all ordinary things, and thus speeds the flagger process considerably.
Made some minor format modifications in order to conform to
programming conventions.
2303 AlB 3-Feb-84
Remove the CFFSNAME variable, and instead reference the symbol table
to get name to stick into warning messages; WARNLEX will now print
the correct name (or at least the 'dotted' version of that name).
Added a test in NAMDEF to check to see if an INTRINSIC name was
known to Fortran-77, and complain if not. This change, plus some
rework to satisfy programming conventions, caused an entire rewrite
of one element of the CASE set.
2322 CDM 27-Apr-84
Fix array subscript calculations for /EXTEND to use a full word
to calculate arithmetic. In PROCEQUIV and BLDDIM, check an
array reference against the correct maximum size of an array
declaration /EXTEND. In BLDDIM, call CNSTCM for array
calculations to give underflow/overflow messages for illegal
declarations. Otherwise arrays that are too large may not be
detected since their size will overflow.
2327 RVM 23-Mar-84
Among other things, put CHARACTER variables into the proper
PSECTS. It turned out that setting the proper psects for
variables turned out to be much more complicated than was first
thought. The distributed nature of FORTRAN's declaration syntax
require the compiler to set the psects for a variable four times
in some cases. Thus a general purpose routine named SETPSECTS
was created that will set the psect fields properly for any type
of variable passed to it. (Although all parts of the compiler
could use SETPSECTS, not all do for the sensible reason that
local knowledge about a variable make the extensive case analysis
of SETPSECTS unnecessary in that case.)
Make sure all formals are put in the .DATA. psect.
2340 AlB 13-Apr-84
Removed the COMPFLAG tests which flag those functions which are
intrinsic for us, but not VAX and/or ANSI. This flagging is done
at run-time, and need not be done by the compiler.
Since this edit so totally eviscerated COMPFLAG, that routine was
removed, and its one call was replaced by a single flagger test.
2343 RVM 18-Apr-84
Make SETPSECTS know about COMMON variables.
2455 MEM 30-Aug-84
Replace all references to VAX with VMS.
2473 CDM 29-Oct-84
Add IMPLICIT NONE for the Military Standard MIL-STD-1753.
2504 CDM 27-Nov-84
Make 127 dimensions of arrays work, as advertised in the Fortran
manual. STK was used as a temporary holding area for the array
bounds information in BLDDIM, and since the size is static, was
being run over into the CHNLTB channel table. Don't use of STK for
temporary storage. This was done way back (according to V5
sources) because BLDDIM had many RETURNs for error conditions.
This would save on dynamic memory if an error occured. There is
only one RETURN in there currently, at the end of the routine. The
size of the the memory needed is not changed by processing the
dimensions, so we'll get the memory needed early and forget using
STK!
Also clean up a little. Remove binds to magic locations in STK
which just happened to be locations in the array dimension table.
This is what REQUIRE files are for! Make them local variables
where needed for temporary calculations, or replace with the
structure reference into the dimension table when it is really
wanted to be referenced. Add in some old edit numbers from V5A
sources.
2507 CDM 20-Dec-84
Add enhancement for IMPLICIT NONE (edit 2473) after code inpsection.
Check more cases, and add a symbol table walk at the back
end to catch unreferenced variables.
2520 CDM 12-Feb-85 QAR 853033
Add to edit 2504. Use correct pointer into array dimension
table, not into the dimesions themselves.
***** End V10 Development *****
2531 CDM 10-Apr-85
Produce an error message if trying to put a subroutine name in an
I/O statement list.
2562 JB 9-Dec-85
When using IMPLICIT NONE, a symbol in an EXTERNAL statement gets a
warning that it must be explicitly declared. If the symbol isn't
used as a function in the same program it shouldn't get the warning
because function types must be explicitly declared, whereas
subroutines needn't be. We added a check for this.
2567 MEM 6-Feb-86
Dimsension table was shared between two arrays if the upper
bounds are the same and the lower bound of the first array is 1.
This is bad news for subsequent arrays with the same upper bound
but with different lower bounds.
2570 MEM 19-Feb-86
When we have adjustably dimensioned arrays, .Innnn variables are
created. A use count (IDUSECNT) is associated with each variable that
tells the number of uses of that variable - if this use count drops to
zero then we don't need to allocate the variable. When some of the
dimensions of an array are constant and some are variable, the IDUSECNT
field was being set in the constant table entries. This should not be.
***** End Revision History *****
***** Begin Version 11 *****
4512 CDM 26-Aug-85
Delete old never called routines. TMPGEN, STRNGSCAN, ZSIXBIT.
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.
4527 CDM 1-Jan-86
VMS Long symbols phase II. Convert all internal symbols from
one word of Sixbit to [length,,pointer].
***** End V11 Development *****
4576 DCE 11-Nov-87
Bad statement number due to missing dot.
***** End Revision History *****
ENDV11
)%
!++
! These are the action routines for the BNF.
!
! To return a value to the BNF, return:
!
! -1 Didn't find what I wanted.
!
! 0 Success, I found what I wanted.
!--
SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE ASHELP.BLI;
SWITCHES LIST;
SWITCHES NOSPEC;
FORWARD
NAMDEF(2),
NAMSET(2),
NAMREF(2),
NAMCHK(2),
FUNCGEN(2),
TYPEGEN(1),
BLDDIM(1),
AJDIMSTK(1),
CHKCOMMON(1),
CHKTYPE(1),
BLDARRAY(1),
BLKSRCH(1),
BLDVAR(1),
BLDSUBVAR(1),
CCONST(2),
SETPSECTS(1), ![2327] Set IDPSECT and IDPSCHARS for variable
SIZOFARRAY(1),
BLDIOLSCLS(1),
LISTIO(1),
DATALIST(1);
GLOBAL SETUSE; !SET TO INDICATE WHETHER VARIABLE IS BEING
!SET (ASSIGNED TO) OR USED (REFERENCED)
EXTERNAL
%2322% ADDINT, ! Add two integers
ARRXPND,
%2224% BIGARY, !The size the smallest array to put into .LARG.
C1H,
C1L,
C2H,
C2L,
%2253% CFLEXB, ! Put out compatibility warning
%2276% CFSRCLIB, ! Search table of incompatible functions/subroutines
CGERR,
%1434% CHARGLIST, ! Routine to build a character function argument list
! from a non-character function argument list.
CHLEN, ! CHLEN is used to hold the length for CHARACTER decl's
%1473% CHARUSED, ! Global flag for character data is used
CKDOINDEX, ! CHECK DO INDEX ALREADY ACTIVE
%4527% CMPSYM, ! Compare two [length,,pointer] symbols
CNSTCM,
CNVNODE,
COPRIX,
COMBLKPTR,
CORMAN,
CREFIT,
CURDOINDEX, ! PTR to current DO index variable
%2507% DATASTA, ! Routine for processing DATA statements.
DATASUBCHK,
DIMSTK,
DINODE DOIFSTK, ! Stack of open DO and IF stmts
DOCHECK, ! Remove DO label from active DO list
DOXPN,
DTABPTR, ! Head of dim entry list
E21, ! DO index already active message
E115, ! Bad DO index message
E125,
E126,
E128, ! Empty list, ie, (I=1,10)
E129,
E136,
E137, ! Variable dimensions only allowed in subprograms
E141, ! Array too large
E145,
E146, ! Expression illegal in input list
%1741% E160, ! Can't assign numeric to character variable
E174,
E189, ! Only upper bound of last dimension may be asterisk
E190, ! Assumed size arrays only allowed in subprograms
E191, ! Assumed size arrays can not be used . . .
%1511% E192, ! Illegal in SAVE statement message
%1575% E205, ! Size modifier conflict in type declaration
%2276% E238, ! Extension to Fortran-77: Not intrinsic in ANSI
%2455% E273, ! VMS incompatibility: xxxxx same as entry point
%2455% E276, ! VMS incompatibility: xxxxx same as namelist
%2455% E279, ! VMS incompatibility: xxxxx same as variable or statement function
%2455% E288, ! Fortran-77 or VMS: Return label $ (or &)
%2455% E297, ! VMS incompatibility: Not intrinsic on VMS
%2473% E304, ! Must declare variables with IMPLICIT NONE
BASE ENTPREVIOUS, ! Address of the previous entry statement or 0.
%2507% ENTRSTA, ! Routine for processing ENTRY statements.
%2473% EQUISTA, ! Routine for processing EQUIVALENCE statements.
FARRY,
FATLEX,
GENLAB, ! Make a label table entry for a compiler generated label
IDTYPE,
%2473% IMPNONE, ! Flag to indicate if IMPLICIT NONE was given
%1754% INADJDIM, ! We are in parsing a statement they could have
%1754% ! an adjustable dimensioned array declaration.
INITLTEMP,
KDPRL,
KTYPCB,
KTYPCG,
LABREF,
LASDOLABEL, ! Ptr to target of most recent DO stmt
LEXLINE,
MAKPR1, ! Make a expression node.
MAKESUBSTR,
MULENTRY, ! Pointer to first entry point name
%2322% MULINT, ! Multiplies two integers
NAME,
NAMLSTOK,
NEWENTRY,
NONIOINIO,
ONEPLIT,
PROGNAME,
SAVSPACE,
SORCPTR, ! Pointer to the first program statement
SP,
STK,
STMNDESC, ! Current statement description block.
%2322% SUBINT, ! Subtracts two integers
TBLSEARCH,
TYPE,
TMPCNT[4],
%2322% VMSIZE; ! Size of virtual memory
% THE FOLLOWING TABLE IS USED TO PRODUCE THE ERROR MESSAGES
IT IS BASED UPON THE BIT POSITION OF THE CONFLICTING IDATTRIBUT
FIELD BIT %
BIND DUMDUM = PLIT (
%1464% R18 NAMES R23 NAMES 'as INTRINSIC or EXTERNAL?0',
%1132% R22 NAMES 'as dummy parameter?0',
%1132% R19 NAMES 'in type statement?0',
%1132% R24 NAMES 'in DATA statement?0',
%1132% R26 NAMES 'in COMMON?0',
%1132% R27 NAMES 'in EQUIVALENCE?0',
%1132% R28 NAMES 'as an entry point name?0',
%2270% R29 NAMES 'in NAMELIST?0',
%1132% R33 NAMES 'as statement function?0',
%1132% R34 NAMES 'as COMMON block?0',
%1132% R35 NAMES 'as NAMELIST?0',
%1132% AYORFN NAMES ' as an array or FUNCTION?0',
%1132% AY NAMES 'as an array?0',
%1132% FNN NAMES 'as a FUNCTION?0',
%2270% IDENT NAMES 'as an identifier?0'
);
![2531] moved from NAMCHK
! For use with the E15 "xxx is not yyy" error message
BIND DUMO = PLIT (
VAORAY NAMES 'a variable or array?0',
VARIB NAMES 'a scalar variable?0',
AAY NAMES 'an array?0',
AFN NAMES 'a subprogram name?0' );
GLOBAL ROUTINE NAMDEF(TYPE,ID)=
BEGIN
! Checks for inconsistencies for the symbol ID passed in useage
! TYPE.
!
! Arguments:
! ID - pointer to symbol table entry
! TYPE - Indicator of use of symbol to check validity of.
MAP BASE ID;
! The following binds are used to make the symbol table attribute
! field masks
BIND
NAMLST = 1^35, ! NAMELIST
CMNBLK = 1^34, ! common block
STFN = 1^33, ! statement function
ENTPNT = 1^28, ! entry point
EXTERN = 1^23, ! EXTERNAL
EXTRSGN = 1^18, ! user function
TYPED = 1^19, ! type statement
EXTBTH = 1^18 + 1^23,
%2270% NAMIN = 1^29, ! in NAMELIST
EQVIN = 1^27, ! Equivalence
COMIN = 1^26, ! in common block
DATAIN = 1^24, ! in DATA
DUMIEE = 1^22, ! dummy parameter
%2270% DATADEF = NAMIN+EQVIN+COMIN+DATAIN, ! some kind of variable
%2455% VMSVAR = DATADEF+STFN; ! Variable or statement function
! The following are masks (indexed by TYPE) of the symbol table
! IDATRIBUTE field. If the TYPE .and. ID are non-zero then
! there is a conflict indicating an error.
%2276% BIND DEFMASK = UPLIT (
%ARRYDEF% NAMLST + STFN + ENTPNT + EXTBTH,
%ARRYDEFT% NAMLST + STFN + ENTPNT + EXTBTH + TYPED,
%2270% %STFNDEF% NAMLST + STFN + ENTPNT + EXTBTH + DATADEF + DUMIEE,
%2276% %EXTDEF% NAMLST + STFN + ENTPNT + EXTBTH + DATADEF,
%2270% %NMLSTDEF% NAMLST + STFN + ENTPNT + EXTBTH + DUMIEE + DATADEF,
%VARARY% NAMLST + STFN + EXTBTH + COMIN + DUMIEE,
%IDDEFT% NAMLST + TYPED,
%2270% %IDDEFINE% NAMLST + STFN + ENTPNT + DATADEF, %DUMMY PARAMETERS%
%ENTRYDEF% NAMLST + STFN + ENTPNT + EXTBTH + CMNBLK + DUMIEE,
%2276% %EXTDEFS% NAMLST + STFN + ENTPNT + EXTBTH + CMNBLK + DATADEF,
%CMNBLK% ENTPNT + EXTRSGN,
%2270% %PARADEF% NAMLST + CMNBLK + STFN + ENTPNT + EXTBTH + DATADEF + DUMIEE,
%NMLSTITM% NAMLST + STFN + EXTBTH + DUMIEE,
%2270% %INTRSCDEF% NAMLST + STFN + ENTPNT + EXTBTH + DATADEF + DUMIEE
);
!***************************************************************
! NAMDEF is referenced from the following routines with the
! following types:
!
! Semantic routine - types
!
! TYPE STATEMENTS ARRYDEFT, IDDEFT
! FUNCTION ENTRYDEF, IDDEF
! SUBROUTINE ENTRYDEF, IDDEF
! ENTRY ENTRYDEF, IDDEF
! PROGRAM ENTRYDEF
! BLOCKDATA ENTRYDEF
! DIMENSION ARRYDEF
! COMMON VARARY, CMNBLK, ARYDEF
! EXTERNAL EXTDEF, EXTDEFS(LIB FUNCTION)
%2277% ! INTRINSIC INTRSCDEF
! NAMELIST NMLSTDEF, VARARY
! STATEMENT FUNCTION STFNDEF
! PARAMETER PARADEF
!
!
! Note that EQUIVALENCE and DATA statements reference NAMSET
! rather than NAMDEF. This is done mainly for convience. If
! they could be changed to reference NAMREF it might be
! possible, with a little thought, to detect instances of
! definition after reference.
!***************************************************************
! This mask defines which types can be the same as an entry
! point name as long as its not in a function
BIND OKSAMEASENTRY = 1^ARRYDEF + 1^ARRYDEFT + 1^STFNDEF +
1^EXTDEF + 1^NMLSTDEF + 1^IDDEFINE ;
%2276% BIND PDEFAS = UPLIT (
%2270% R18,R19,0,0,R22,R23,R24,0,R26,R27,R28,R29,0,0,0,R33,R34,R35 );
REGISTER R;
IF .FLGREG<CROSSREF> THEN CREFIT( .ID, SETT );
! Check the attributes. If the intended use and any previous
! definition in the symbol table conflict (the AND is non zero),
! continue checking and assign to R.
IF ( R _ .DEFMASK[.TYPE]<LEFT> AND .ID[IDATTRIBUT(ALLOFTHEM)] ) NEQ 0
THEN
! Allow statement functions , arrays , namelists , and
! possible library functions to be the same as entry
! point names providing that this is not a function.
IF ( 1^(.TYPE) AND OKSAMEASENTRY ) EQL 0
OR .FLGREG<PROGTYP> EQL FNPROG
OR .R NEQ ENTPNT^(-18)
THEN
! Allow entry point definitions to be the same
! as namelist, statement functions, and possible
! library functions as long as its not a
! function
IF .TYPE NEQ ENTRYDEF
OR .FLGREG<PROGTYP> EQL FNPROG
OR ( .R NEQ NAMLST^(-18)
AND .R NEQ STFN^(-18)
AND .R NEQ EXTERN^(-18) )
THEN
! Its a conflicting definition - give error
%4516% RETURN FATLEX( .PDEFAS[35-FIRSTONE(.R)], .ID[IDSYMBOL], E34<0,0> );
%2270% ! We must do just a bit more checking. If we find a fatal error,
%2270% ! assign VREG a positive value: the PLIT to be inserted in the error
%2270% ! message.
%2455% ! VMS incompatibilities give VREG a negative value: the error message
%2270% ! number.
%2270% ! When the CASE statement is completed, VREG is checked and appropriate
%2270% ! action taken.
VREG _ 0;
VREG _ CASE .TYPE OF SET
%ARRYDEF% BEGIN
IF .ID[OPRSP1] NEQ VARIABL1 THEN AYORFN
%2270% ELSE
%2455% IF FLAGVMS
%2455% THEN ! Flagging VMS incompatibilities
%2270% IF .ID[IDATTRIBUT(FENTRYNAME)]
%2270% THEN -(E273<0,0>) ! Same name as entry point
END;
%ARRYDEFT% BEGIN
IF .ID[OPRSP1] NEQ VARIABL1 THEN AYORFN
END;
%STFNDEF% BEGIN
IF .ID[OPRSP1] NEQ VARIABL1 THEN AYORFN
%2270% ELSE
%2455% IF FLAGVMS
%2455% THEN ! Flagging VMS incompatibilities
%2270% IF .ID[IDATTRIBUT(FENTRYNAME)]
%2270% THEN -(E273<0,0>) ! Same name as entry point
END;
%EXTDEFS% BEGIN
IF .ID[OPRSP1] EQL ARRAYNM1 THEN AY
END;
%NMLSTDEF% BEGIN
IF .ID[OPRSP1] NEQ VARIABL1 THEN AYORFN
%2270% ELSE
%2270% IF NOT .ID[IDATTRIBUT(NOALLOC)] THEN IDENT
%2270% ELSE
%2455% IF FLAGVMS
%2455% THEN ! Flagging VMS incompatibilities
%2270% IF .ID[IDATTRIBUT(FENTRYNAME)]
%2270% THEN -(E273<0,0>) ! Same name as entry point
END;
%VARARY% BEGIN
IF .ID[OPRSP1] EQL FNNAME1 THEN FNN
END;
%IDDEFT% BEGIN END;
%IDDEF% BEGIN
%CHECK HERE TO SEE THAT DUMMY PARAMETERS
HAVE NEVER BEEN REFERENCED %
IF NOT .ID[IDATTRIBUT(NOALLOC)]
AND NOT .ID[IDATTRIBUT(DUMMY)]
THEN RETURN FATLEX(.ID[IDSYMBOL],E136<0,0>)
%2270% ELSE
%2455% IF FLAGVMS
%2270% THEN ! Compatibility check
%2270% IF .ID[IDATTRIBUT(FENTRYNAME)]
%2270% THEN -(E273<0,0>) ! Same name as entry point
END;
%2270% ! Entry definition
%2270% ! It cannot be a function name.
%2270% ! If it is an entry into a function subprogram, it cannot be an array name.
%2455% ! If VMS incompatibilities are being checked, it cannot be a NAMELIST name
%2270% ! nor a variable.
%ENTRYDEF% BEGIN
%2270% IF (R=.ID[OPRSP1]) EQL FNNAME1 AND NOT .ID[IDATTRIBUT(NOALLOC)] THEN FNN
%2270% ELSE
%2270% IF .FLGREG<PROGTYP> EQL FNPROG
%2270% THEN ! It is in FUNCTION subprogram
%2270% IF .R EQL ARRAYNM1
%2270% THEN AY ! It is array
%2270% ELSE
%2455% IF FLAGVMS
%2270% THEN ! Test for incompatibilities
%2270% IF .ID[IDATTRIBUT(NAMNAM)]
%2270% THEN -(E276<0,0>)
%2270% ELSE 0
%2270% ELSE 0
%2270% ELSE ! It is not in FUNCTION subprogram
%2455% IF FLAGVMS
%2270% THEN ! Testing incompatibilities
%2270% IF .R EQL ARRAYNM1 THEN -(E279<0,0>)
%2270% ELSE
%2270% IF .ID[IDATTRIBUT(NAMNAM)] THEN -(E276<0,0>)
%2270% ELSE
%2455% IF (.ID[IDATTRIBUT(ALLOFTHEM)] AND VMSVAR^(-18)) NEQ 0 OR
%2270% NOT .ID[IDATTRIBUT(NOALLOC)]
%2270% THEN -(E279<0,0>) ! It is variable
END;
%EXTDEF% BEGIN
IF .ID[OPRSP1] EQL ARRAYNM1 THEN AY
%2270% ELSE
%2270% IF NOT .ID[IDATTRIBUT(NOALLOC)] THEN IDENT
END;
%CMNBLK% BEGIN
IF .ID[OPRSP1] EQL FNNAME1 AND NOT .ID[IDATTRIBUT(NOALLOC)] THEN FNN
END;
%PARADEF% BEGIN
%2270% IF .ID[OPRSP1] EQL ARRAYNM1
%2270% THEN AY ! It is array
%2270% ELSE
IF NOT .ID[IDATTRIBUT(NOALLOC)]
%2270% THEN IDENT ! It is identifier
![717] IF ALREADY DEFINED AS PARAMETER (IF THIS IS A REDUNDANT
![717] PARAMETER DEFINITION OR REDEFINITION) GIVE FATAL ERROR
%[717]% ELSE IF .ID[IDATTRIBUT(PARAMT)] THEN .LEXNAM[CONSTLEX]
END;
%2277% %NMLSTITM% BEGIN
IF .ID[OPRSP1] EQL FNNAME1 THEN FNN
%2270% ELSE
%2455% IF FLAGVMS
%2270% THEN ! Compatibility flagging
%2270% IF .ID[IDATTRIBUT(FENTRYNAME)] AND
%2270% .FLGREG<PROGTYP> NEQ FNPROG
%2270% THEN ! Same name as entry point
%2270% -(E273<0,0>)
%2277% END;
%2277% %INTRSCDEF% BEGIN
%2303% LOCAL VALBITS; ! Value reurned by CFSRCLIB
%2303%
%2303% IF FLAGEITHER
%2303% THEN IF (VALBITS = CFSRCLIB(.ID)) NEQ 0
%2303% THEN
%2303% BEGIN ! Compatibility checks
%2303%
%2455% IF FLAGVMS ! See if VMS knows about it
%2455% THEN IF (.VALBITS AND CFNOTFNVMS) NEQ 0
%4516% THEN WARNLEX(.ID[IDSYMBOL],E297<0,0>);
%2303%
%2303% IF FLAGANSI ! See if ANSI knows about it
%2303% THEN IF (.VALBITS AND CFNOTFNF77) NEQ 0
%2303% THEN WARNLEX(.ID[IDSYMBOL],E238<0,0>);
%2303%
%2303% END; ! Compatibility checks
%2303%
%2303% VREG = 0 !Pretend there was no error
END
TES;
! If error was found above, then give error message now.
%2270% IF .VREG GTR 0
%2270% THEN ! Fatal error
%4516% RETURN FATLEX ( .VREG, .ID[IDSYMBOL], E34<0,0>)
%2270% ELSE
%2270% IF .VREG LSS 0
%2270% THEN ! Compatibility warning
%2270% BEGIN
%4516% WARNLEX(.ID[IDSYMBOL],-.VREG);
%2270% VREG=0 ! Reset to pretend there was no error
%2270% END
END; ! of NAMDEF
GLOBAL ROUTINE NAMSET(TYPE, ID)=
!++
! The symbol pointed to by ID and defined by TYPE is being set
! (assigned into).
!--
BEGIN
MAP BASE ID;
%CHECK FOR DO INDEX MODIFICATION%
IF CKDOINDEX ( .ID )
THEN IF .LABOK(@STMNDESC) EQL 0 !FORGET DATA AND EQUIV
THEN FATLEX(E77<0,0>); !MODIFICATION WARNING
%1473% ! If variable being set is type character, set the CHARUSED
%1473% ! flag
%1473% IF .ID[VALTYPE] EQL CHARACTER
%1473% THEN CHARUSED = TRUE;
ID[IDATTRIBUT(STORD)] _ 1;
IF .FLGREG<CROSSREF> THEN CREFIT( .ID, SETT );
RETURN NAMCHK ( .TYPE , .ID )
END; ! of NAMSET
GLOBAL ROUTINE NAMREF(TYPE, ID)=
BEGIN % THE SYMBOL POINTED TO BY ID AND DEFINED BY TYPE IS BEING
REFERENCED %
![1715] Note that this is not the only place that sets
![1715] the STORD attribute. The modules ACT1 and DOXPN
![1715] also set it.
%1473% MAP BASE ID;
%1473% ! If variable being referenced is type character, set the CHARUSED
%1473% ! flag
%1473% IF .ID[VALTYPE] EQL CHARACTER
%1473% THEN CHARUSED = TRUE;
IF .FLGREG<CROSSREF> THEN CREFIT( .ID, USE );
RETURN NAMCHK ( .TYPE, .ID )
END; ! of NAMREF
GLOBAL ROUTINE NAMCHK(TYPE, ID)=
!++
! Check to see if we have what we think we have and if not, output
! an error message.
!--
BEGIN
% THE FOLLOWING BINDS ARE USED TO MAKE THE SYMBOL TABLE ATTRIBUTE
FIELD MASKS %
BIND
NAMLST = 1^35,
CMNBLK = 1^34,
STFN = 1^33,
ENTPNT = 1^28,
EXTERN = 1^23,
EXTRSGN = 1^18,
TYPED = 1^19,
EXTBTH = 1^18 + 1^23,
EQVIN = 1^27,
COMIN = 1^26,
DATAIN = 1^24,
DUMIEE = 1^22;
MAP BASE ID;
%2507% ! If IMPLICIT NONE is given, then we must insure that the
%2507% ! variable is declared in a type statement,
%2507% ! Unless:
%2507% ! - the warning has already been given for this symbol
%2507% ! - the symbol is a subroutine name
%2507% ! - the symbol is a library function name
%2507% ! - we're parsing a DATA, ENTRY, or EQUIVALENCE statement
%2473% IF .IMPNONE ! IMPLICIT NONE
%2473% THEN IF NOT .ID[IDIMPLNONE] ! Message already given?
%2473% THEN IF NOT .ID[IDATTRIBUT(INTYPE)] ! In declaration?
%2507% THEN IF NOT .ID[IDSUBROUTINE] ! Subroutine
%2562% THEN IF NOT .ID[IDATTRIBUT(INEXTERN)] ! In EXTERNAL statement
%2473% THEN IF NOT (.ID[OPR1] EQL FNNAMFL ! External name
%2473% AND .ID[IDLIBFNFLG]) ! library function
%2507% THEN IF .STMNROUTINE(@STMNDESC) NEQ DATASTA<0,0> ! DATA
%2507% THEN IF .STMNROUTINE(@STMNDESC) NEQ ENTRSTA<0,0> ! ENTRY
%2473% THEN IF .STMNROUTINE(@STMNDESC) NEQ EQUISTA<0,0> ! EQUIVALENCE
%2473% THEN
%2473% BEGIN ! Give a warning, this symbol must be declared!
%2473%
%2473% FATLERR(.ID[IDSYMBOL], .ISN, E304<0,0>);
%2473% ID[IDIMPLNONE] = 1; ! Gave a message
%2473%
%2473% END; ! Give a warning, this symbol must be declared!
VREG _ 0;
VREG _ CASE .TYPE OF SET
BEGIN %VARYREF%
IF .ID[OPRSP1] EQL FNNAME1
OR .ID[IDATTRIBUT(NAMNAM)]
THEN VAORAY
END; %VARYREF%
BEGIN %VARIABL1%
IF .ID[OPRSP1] NEQ VARIABL1
OR .ID[IDATTRIBUT(NAMNAM)]
THEN VARIB
END; %VARIABL1%
BEGIN %ARRAYNM1%
IF .ID[OPRSP1] NEQ ARRAYNM1
THEN AAY
END; %ARRAYNM1%
BEGIN %FNNAME1%
IF .ID[OPRSP1] EQL FNNAME1
THEN
BEGIN
%CHECK TO SEE THAT POSSIBLE LIBRARY FUNCTIONS
WHICH TURNED OUT NOT TO BE LIBRARY FUNCTIONS
ARE NOT CONFLICTING WITH ANY GLOBAL NAMES %
%1412% IF .ID[IDATTRIBUT(COMBL)]
%1412% THEN IF NOT .ID[IDATTRIBUT(SFN)]
%4516% THEN FATLEX(R34,.ID[IDSYMBOL],E34<0,0>);
%1412% IF .ID[IDATTRIBUT(FENTRYNAME)]
%4516% THEN FATLEX(R28,.ID[IDSYMBOL],E34<0,0>);
0
END
ELSE
BEGIN
IF .ID[OPRSP1] EQL ARRAYNM1 OR NOT .ID[IDATTRIBUT(NOALLOC)] OR ISDEFIND(ID)
OR .ID[IDATTRIBUT(COMBL)]
THEN AFN !ITS A VARIABLE OR ARRAY
ELSE
BEGIN
ID[OPERSP] _ IF .ID[IDATTRIBUT(DUMMY)]
THEN FORMLFN ELSE FNNAME;
0
END
END
END; %FNNAME1%
BEGIN %NMLSTREF%
%NO CONFLICTS HERE%
0
END; %NMLSTREF%
BEGIN %PARAREF%
RETURN .ID[IDPARAVAL]
END %PARAREF%
TES;
%2270% ! If error found, put out error message.
IF .VREG NEQ 0
%4516% THEN RETURN FATLEX (.VREG, .ID[IDSYMBOL],E15<0,0> );
%2455% !If flagging VMS incompatibilities, warn the user if this name is the
%2340% !same as a non-function entry point
%2455% IF FLAGVMS
%2340% THEN IF .ID[IDATTRIBUT(FENTRYNAME)]
%2340% THEN IF .FLGREG<PROGTYP> NEQ FNPROG
%2340% THEN
%2340% BEGIN
%4516% WARNLEX(.ID[IDSYMBOL],E273<0,0>);
%2340% VREG=0 ! Because WARNLEX clobbers it
%2340% END;
%1754% ! Check if we should mark the variable "to be allocated". If
%1754% ! parsing a type specification statement or DIMENSION statement,
%1754% ! then this ID is part of an adjustable dimension array
%1754% ! declaration. If it is not a dummy or in common yet (it may be
%1754% ! in a later COMMON or ENTRY statement), we should not allocate
%1754% ! the variable yet (error message processing on whether the
%1754% ! dummy is used before it is defined), and queue it up for later
%1754% ! checking that it does defined as either.
%1754%
%1754% IF .INADJDIM
%1754% AND NOT (.ID[IDATTRIBUT(DUMMY)] OR .ID[IDATTRIBUT(INCOM)])
%1754% THEN ! Check later in routine CKAJDI...
%1754% AJDIMSTK(.ID)
%1754% ELSE ! Indicate that we are using this name and that it
%1754% ! should be allocated.
ID[IDATTRIBUT(NOALLOC)] = 0;
END; ! of NAMCHK
GLOBAL ROUTINE FUNCGEN(FPNT, TYPEFLG)=
BEGIN
LOCAL BASE R1;
REGISTER BASE T2;
MAP BASE FPNT;
REGISTER BASE T1:R2;
%1422% LOCAL
%1422% NUMARGS, ! The actual number of arguments for a function
%1422% ARGOFFSET; ! Used when copying the argument list from STK
%1413% LOCAL ARGUMENTLIST ARGNODE;
%1413% LOCAL CNT;
MACRO
FCTN = 4$,
ENT=1$;
!----------------------------------------------------------------------
!
!THIS ROUTINE IS CALLED WITH THE PARAMETER FPNT POINTING TO
!THE LIST:
!
!IDENTIFIER (20^18+LOC) - SUBPROGRAM NAME
! CHLEN if TYPEFLG is 1
!OPTION 0 - NO ARGUMENTS, ILLEGAL IF THIS IS A FUNCTION
! OR
!OPTION 1 - ARGUMENT LIST POINTER FOLLOWS
! OPTION 0 - NAME()
! OPTION 1 - NAME(ARGS)
! COUNT^18+LOC - POINTS TO LIST POINTER
! 1^18+LOC - POINTS TO LIST OF
! CHOICE 1 - DUMMY ARGUMENT
! IDENTIFIER (20^18+LOC)
! CHOICE 2 - DUMMY LABEL
!
!THE LOCATION TYPE IS NON-ZERO (4) FOR A FUNCTION STATEMENT
!AND ZERO FOR A SUBROUTINE OR ENTRY STATEMENT. IF THE FUNCTION
!WAS TYPED, IDTYPE WILL CONTAIN THE TYPE OTHERWISE IT CONTAINS -1
!
! TYPEFLG is 1 for the case 'datatype FUNCTION ...'
! TYPEFLG is 0 for the cases 'FUNCTION ...', 'SUBROUTINE ...', and
! 'ENTRY ...'
!
!----------------------------------------------------------------------
R1_.FPNT[ELMNT]; !R1_LOC (SUBPROGRAM NAME)
%2507% IF .FLGREG<PROGTYP> EQL SUPROG
%2507% THEN R1[IDSUBROUTINE] = 1; ! Mark as subroutine name
IF NAMDEF( ENTRYDEF, .R1) LSS 0 THEN RETURN .VREG;
%1213% ! Fetch info from tree based on TYPEFLG parameter
%1213% IF .TYPEFLG EQL 1
%1213% THEN
%1213% BEGIN
%1213% ! 'datatype FUNCTION ...' form
%1213% CHLEN _ .FPNT[ELMNT1]; ! character count for character data
%1213% T1 _ .FPNT[ELMNT2]; ! flag for arguments specified
%1213% T2 _ .FPNT[ELMNT3]; ! pointer to arg list
%1213% END
%1213% ELSE
%1213% BEGIN
%1213% ! 'FUNCTION/SUBROUTINE/ENTRY ...' form
%1213% T1 _ .FPNT[ELMNT1]; ! flag for arguments specified
%1213% T2 _ .FPNT[ELMNT2]; ! pointer to arg list
%1213% END;
%1400% IF .T1 NEQ 0 ! First option word says whether
%1400% THEN ! parens are present
%1400% T1 _ .T2[ELMNT]; ! If so, get next option, whether
! anything is inside the parens
%1466% ! If we have a charcter function, we need a return value (in an
%1466% ! argument list) whether or not the user specified arguments in the
%1466% ! definition.
%1422% IF .IDTYPE NEQ CHARACTER
%1422% THEN
%1422% BEGIN ! Not a character function
%1466% NUMARGS = 0; ! No arguments needed for return value.
%1422% ARGOFFSET = 1; ! Start copying at first argument
%1422% END ! Not a character function
%1422% ELSE
%1422% BEGIN ! Character function
%1422% ! Character functions have the descriptor for the result as
%1422% ! their first argument
%1422% NUMARGS = 1; ! Extra arg needed for return value
%1422% ARGOFFSET = 2; ! Start copying at second argument
%1422% END; ! Character function
%1466% ! Create the arument list. If no arguments are specified, but it
%1466% ! is a character function, we still need an argument list for the
%1466% ! return value.
%1213% IF .T1 EQL 0
THEN
%1466% BEGIN ! No arguments
%1466% IF .IDTYPE EQL CHARACTER
%1466% THEN
%1466% BEGIN ! Arglist needed for return value
%1466%
%1466% NAME<LEFT> = ARGLSTSIZE(.NUMARGS);
%1466% ARGNODE = R2 = CORMAN(); ! Get some space
%1466% ARGNODE[ARGCOUNT] = .NUMARGS; ! Number of args
%1466% END
%1466% ELSE ! Arglist not needed
R2_0; ! Pointer to arglist is zero.
END ! No arguments
ELSE
BEGIN ! Has arguments
!-------------------------------------------------------------
!CREATE AN ARGUMENT LIST ON THE UNUSED PORTION OF THE
!LEXEME STACK (STK[2] THRU STK[100]). THIS IS NECESSARY
!BECAUSE THE EXACT NUMBER OF ARGUMENTS IS NOT KNOWN.
!THE ARGUMENT LIST PRODUCED BY SYNTAX CONTAINS 2 WORDS
!(CHOICE 1) FOR EACH DUMMY ARGUMENT BUT ONLY 1 WORD
!FOR EACH DUMMY LABEL (CHOICE 2). THE PROPORTION OF
!EACH ARGUMENT TYPE IS NOT KNOWN UNTIL THE LIST IS SCANNED.
!------------------------------------------------------------
T1_.T2[ELMNT1];
SAVSPACE(1,@T2);
T2_STK[3]<0,0>; !T1_LOC(GENERATED ARG LIST),SET COUNT T2 TO LOC OF ARGLIST
INCR ALST FROM @T1 TO @T1+.T1<LEFT>DO
BEGIN
MAP BASE ALST;
T2_.T2+1;
IF .ALST[ELMNT] EQL 1 THEN !DUMMY ARGUMENT
BEGIN
T2[ELMNT]_R2<RIGHT>_.ALST[ELMNT1];
IF NAMDEF(IDDEFINE, .R2 ) LSS 0 THEN RETURN .VREG;
IF .R2[OPRCLS] EQL DATAOPR THEN T2[P1AVALFLG] _ 1;
![663] WE ARE TRYING TO ASSIGN TYPE INFORMATION TO PARAMETERS OF
![663] SUBROUTINE AND ENTRY STATEMENTS. THERE MAY BE INFORMATION
![663] ALREADY PRESENT REGARDING THESE VARIABLES, SO WE NEED TO BE
![663] VERY CAREFUL. IF THE VARIABLE HAS ALREADY BEEN DIMENSIONED,
![663] THEN WE KNOW THAT IT IS A FORMLARRAY. OTHERWISE, WE MIGHT
![663] HAVE SEEN IT PREVIOUSLY IN AN EARLIER SUBROUTINE OR ENTRY
![663] STATEMENT IN WHICH CASE WE NEED TO RETAIN THE SAME TYPE.
![663] SO IF IT IS EITHER A FORMLFN OR A FORMLVAR, RETAIN THAT TYPE
![663] INFORMATION. FINALLY, IT MIGHT HAVE OCCURRED AS A FUNCTION
![663] NAME (AS IN AN EXTERNAL DECLARATION) - IN THIS CASE CHANGE
![663] THE TYPE TO FORMLFN SO THAT SPACE WILL BE ALLOCATED FOR THE
![663] VARIABLE NAME. IF NONE OF THE ABOVE, THEN THE VARIABLE
![663] IS A SIMPLE ONE - FORMLVAR.
%[663]% IF .R2[IDDIM] EQL 0 THEN
%[663]% (IF .R2[OPERSP] NEQ FORMLFN THEN
%[663]% IF .R2[OPERSP] EQL FNNAME
%[663]% THEN R2[OPERSP]_FORMLFN
%[663]% ELSE R2[OPERSP]_FORMLVAR)
%[663]% ELSE
BEGIN
LOCAL BASE DIMPTR;
R2[OPERSP] _ FORMLARRAY;
DIMPTR _ .R2[IDDIM];
IF .DIMPTR[ARADDRVAR] EQL 0
THEN IF NOT .DIMPTR[ADJDIMFLG]
THEN
BEGIN
LOCAL BASE PTRVAR;
ENTRY[0] _ .R2[IDSYMBOL];
NAME _ IDTAB;
PTRVAR _ NEWENTRY();
PTRVAR[VALTYPE] _ INTEGER;
PTRVAR[OPERSP] _ FORMLVAR;
!LET THIS BE ALLOCATED
PTRVAR[IDATTRIBUT(NOALLOC)] _0;
! The variable that holds
! the array base is in the
! .DATA. psect
%1505% PTRVAR[IDPSECT] = PSDATA;
DIMPTR[ARADDRVAR] _ .PTRVAR;
END;
END;
R2[IDATTRIBUT(DUMMY)]_-1; !DUMMY ARGUMENT
%2224% !Formals are never in any PSECT but .DATA.
%2224% R2[IDPSECT] = PSDATA;
%2327% R2[IDPSCHARS] = PSOOPS;
%1511% ! Dummy arguments cannot be in SAVE
%1511% ! statements. If this was in a SAVE and is
%1511% ! in an ENTRY, give error.
%1511% IF .R2[IDSAVVARIABLE]
%1511% THEN FATLERR(.R2[IDSYMBOL],
%1511% UPLIT(ASCIZ'Dummy variable'),.ISN,
%1511% E192<0,0>);
IF .FLGREG<PROGTYP> EQL FNPROG
THEN IF .R2<RIGHT> EQL .R1<RIGHT>
THEN ! ARGUMENT IS SAME AS FUNCTION
%4516% FATLEX(.R2[IDSYMBOL], E71<0,0>);
END
ELSE
BEGIN
FLGREG<LABLDUM> _ 1; !SET DUMMY LABLES FLAG
IF .FLGREG<PROGTYP> EQL FNPROG
THEN WARNLEX (E129<0,0>);
!ISSUE WARNING BECAUSE FUNCTIONS WITH
! MULTIPLE RETURNS CANNOT BE REFERENCED
! AS FUNCTIONS
T2[ELMNT]_0 !DUMMY LABEL
END;
IF .ALST[ELMNT] LEQ 2
%2253% THEN ! Argument is neither $ nor &
%2253% ALST=.ALST+1 ! Skip by 1
%2253% ELSE ! Argument is $ or &
%2253% IF FLAGEITHER ! Compatibility flagger
%2253% THEN
%2253% IF .ALST[ELMNT] EQL 3
%2253% THEN CFLEXB(UPLIT '$?0',E288<0,0>) ! $
%2253% ELSE CFLEXB(UPLIT '&?0',E288<0,0>) ! &
END;
SAVSPACE(.T1<LEFT>,@T1);
!--------------------------------------------------------------
!THE FOLLOWING CODE SETS UP T1 AS THE BLT POINTER
!(SOURCE ADDRESS ^18+ DESTINATION ADDRESS AND T2 AS THE FINAL
!ADDRESS. R2 POINTS TO THE BEGINNING OF THE ARG BLOCK CREATED.
!ITS FIRST WORD CONTAINS THE ARG COUNT.
!--------------------------------------------------------------
STK[2]_0; !LINK WORD
T2_.T2-STK[3]<0,0>; !NUMBER OF ARGUMENTS
% CHECK FOR DUPLICATE ARGUMENTS %
INCR PRM FROM STK[4]<0,0> TO STK[4]<0,0>+.T2-2
DO
BEGIN
MAP BASE PRM;
LOCAL BASE PLST:ID1:ID2;
IF ( ID1 _ @@PRM ) NEQ 0 !IE AN IDENTIFIER
THEN
BEGIN
PLST _ .PRM+1;
DO
BEGIN
IF ( ID2 _ @@PLST ) NEQ 0 !IDENTIFIER
THEN
BEGIN
IF .ID1[IDSYMBOL] EQL .ID2[IDSYMBOL]
THEN RETURN FATLEX(.ID1[IDSYMBOL],E87<0,0>)
END
END
UNTIL (PLST _ .PLST+1) EQL STK[3]<0,0>+.T2+1;
END;
END;
%1466% NUMARGS = .T2 + .NUMARGS; ! Total number of arguments
%1422% NAME<LEFT> = ARGLSTSIZE(.NUMARGS); ! Size of arg block needed
%1422% R2 = CORMAN();
%1413% ARGNODE _ .R2;
%1422% ARGNODE[ARGCOUNT] _ .NUMARGS; ! Number of arguments
%1422% ! Copy ARGNODEs from STK. The first is in STK[4]
%1422% INCR CNT FROM .ARGOFFSET TO .NUMARGS
%1422% DO ARGNODE[.CNT,ARGFULL] = .STK[4 + .CNT - .ARGOFFSET];
END; ! Has arguments
NAME _ IDOFSTATEMENT _ ENTRDATA;
NAME<RIGHT> _ SORTAB;
T1 _ NEWENTRY();
%1422% IF .IDTYPE EQL CHARACTER
%1422% THEN
%1422% BEGIN
%1422% ! First argument points to the symbol table entry for the
%1422% ! function name. It is used for the value returned by the
%1422% ! by the function. Set the DUMMY IDATTRIBUT field.
%1422% ARGNODE[1,ARGFULL] = .R1;
%1422% R1[IDATTRIBUT(DUMMY)] = 1;
%2327% ! Put the return value, a dummy variable, into the proper
%2327% ! Psects.
%2327% R1[IDPSECT] = PSDATA;
%2327% R1[IDPSCHARS] = PSOOPS;
%1422% END;
%1213% ! If this function has a type, set valtype and character count
%2051% IF .TYPEFLG GTR 0
%1213% THEN
%1213% BEGIN
%1213% R1[IDATTRIBUT(INTYPE)] _ -1;
%1213% R1[VALTYPE] _ .IDTYPE;
%1213% R1[IDCHLEN] _ .CHLEN;
%1213% END;
IF .TYPE EQL ENT THEN
BEGIN
T1[ENTNUM] _ -1;
%LINK UP THE ENTRY POINTS FOR REL OUTPUT%
R1[IDENTLNK] _ .MULENTRY;
MULENTRY _ .R1;
END;
R1[IDATTRIBUT(FENTRYNAME)] _ 1; !SET ENTRY NAME BIT
T1[ENTSYM] _ @R1; ! Symbol table entry
T1[ENTLIST] _ @R2; ! Argument list
%1466% ! Set up the link from one entry point to the next. ENTPREVIOUS
%1466% ! has the address of the last entry statement node. If first entry
%1466% ! point, then set the global variable for the first time.
%1466% IF .ENTPREVIOUS NEQ 0 ! 1st entry point?
%1466% THEN ENTPREVIOUS[ENTLINK] _ .T1;
%1466% ENTPREVIOUS _ .T1; ! For next entry processing
%1466% T1[ENTLINK] _ 0; ! End of the link
SAVSPACE(.FPNT<LEFT>,@FPNT);
END; ! of FUNCGEN
GLOBAL ROUTINE TYPEGEN(TLST)=
BEGIN
LOCAL BASE T1;
REGISTER BASE T2; REGISTER BASE R1:R2;
!-----------------------------------------------------------------------
! THIS ROUTINE IS CALLED WITH THE PARAMETER TLST
! POINTING TO A LIST OF ELEMTNTS. EACH
! ELEMENT POINTS TO A LIST OF SCALAR OR ARRAY DEFINITIONS
! (ONEARRAY) FOLLOWED BY AN OPTIONAL LIST OF VALUES. UNTIL
! THE ROUTINES TO HANDLE DATA SPECIFICATIONS HAVE BEEN
! WRITTEN THESE VALUE LISTS WILL BE IGNORED.
!-----------------------------------------------------------------------
INCR DLST FROM @TLST TO @TLST+.TLST<LEFT> DO
BEGIN
MAP BASE DLST;
R1_.DLST[ELMNT];
!IF A VALUELIST IS PRESENT THEN BLDARRAY
!MUST SAVE ALL THE SCALAR AND ARRAY NAMES IT FINDS, PROBABLY ON THE STACK
IF BLDARRAY(.R1[ELMNT]) LSS 0 THEN RETURN .VREG;
IF.R1[ELMNT1] NEQ 0 THEN !OPTIONAL VALUELIST IS PRESENT
BEGIN
%2455% ! Optional valuelist is a VMS extension. Should be done a la DATALIST.
%1213% ! The code has never worked, so make it a fatal error for now.
%1213% FATLEX(E84<0,0>);
%1213% T1_.R1[ELMNT2]; !T1_LOC(VALUELIST) for savespace
%1213% ! Comment out rest of optional valuelist code
! T2_.T1[ELMNT1]; !T2_LOC(LIST OF CONSTANTS)
! INCR CLST FROM @T2 TO @T2+.T2<LEFT> BY 2 DO
! BEGIN
! MAP BASE CLST;
! IF .CLST[ELMNT] EQL 1 THEN !CONSTANT POSSIBLY A REPEAT COUNT
! BEGIN
! R1_.CLST[ELMNT1];
! IF .R1[ELMNT1] NEQ 0 THEN
! BEGIN !SAVE REPEATED CONSTANT SPACE
! R2_.R1[ELMNT2];SAVSPACE(.R2<LEFT>,@R2)
! END;
! SAVSPACE(.R1<LEFT>,@R1); !SAVE CONSTANT SPACE
! END;
! END; SAVSPACE(.T2<LEFT>,@T2); !SAVE CONSTANT LIST SPACE
SAVSPACE(.T1<LEFT>,.T1); !SAVE VALUE LIST SPACE
END
END;
END; ! of TYPEGEN
ROUTINE AJDIMSTK(PTR)=
BEGIN
!***************************************************************
! Save this variable name on a stack because it is currently not
! in COMMON or a dummy but it might be after some ENTRY
! statements
!***************************************************************
REGISTER R1;
NAME<LEFT> = 2; !2 WORD ENTRIES
R1 = CORMAN();
IF .DIMSTK EQL 0
THEN DIMSTK<LEFT> = .R1;
(.R1)<RIGHT> = .DIMSTK<RIGHT>;
DIMSTK<RIGHT> = .R1;
(.R1+1)<RIGHT> = .PTR;
(.R1+1)<LEFT> = .LEXLINE
END; ! of AJDIMSTK
ROUTINE BLDDIM(SSLST)= ![1510] Do a lot of cleanup
!++
! FUNCTIONAL DESCRIPTION:
!
! Builds array dimension table information.
!
! FORMAL PARAMETERS:
!
! SSLST points to a list of subscripts of the form:
!
! Option 0 - Subscript is upper bound, lower bound is one
! Choice 1 - Subscript is a CONSTANT
! CONSTANT (21^18+LOC)
! Choice 2 - Subscript is an IDENTIFIER
! IDENTIFIER (20^18+LOC)
! Choice 3 - Subscript is an ASTERISK
!
!
! Option 1 - Subscript is lower bound
! COUNT^18+LOC - pointer to upper bound
! DIVIDE
! Choice 1 - Subscript is a CONSTANT
! CONSTANT (21^18+LOC)
! Choice 2 - Subscript is an IDENTIFIER
! IDENTIFIER (20^18+LOC)
! Choice 3 - Subscript is an ASTERISK
!
! IMPLICIT INPUTS:
!
! Unknown
!
! IMPLICIT OUTPUTS:
!
! Unknown
!
! ROUTINE VALUE:
!
! Returns pointer to dimension information.
!
! SIDE EFFECTS:
!
! Unknown
!
!--
BEGIN
REGISTER
BASE BOUND, ! An upper or lower bound for a dimension.
BASE T1, ! Pointer to list of subscripts during the
! first part of this routine. Used for dif-
! ferent things during second part of routine.
%1213% BASE T2; ! Pointer to dimension table while the
! option list is scanned. Used for different
! things during second part of this routine.
%1510% LOCAL
%2504% A0F, ! TEMP DFACTOR (0)
%2504% AOFF, ! Temp ARAOFF
%2504% BASE ARRDIMEN, ! Array dimension node
%2504% ASIZE, ! TEMP ARASIZ
%1510% ASSUMEDSIZE, ! Set to TRUE iff an array is assumed-size.
%1510% DNUM, ! The number of dimensions
%1560% SAVET1; ! Save T1 for SAVSPACE call
MAP BASE FARRY;
LABEL LDECR, CHECKTHIS;
%4516% MACRO ERR31 = FATLEX(.FARRY[IDSYMBOL], E31<0,0> ) $,
%4516% ERR74 = FATLEX(.FARRY[IDSYMBOL], E74<0,0> ) $,
%1510% ERR141 = FATLEX(.FARRY[IDSYMBOL], E141<0,0>) $,
%4516% ERR189 = FATLEX(.FARRY[IDSYMBOL], E189<0,0>) $,
%1510% ERR190 = FATLEX(E190<0,0>) $,
%1510% ERR137 = FATLEX(E137<0,0>) $;
%1510% BIND INFINITY = 1^35-1;
BIND ADJUSTABLE=STK[2];
!------------------------------------------------------------------------------
!Omitting the extra code to fetch constants and store values, the array
!size, array offset, and subscript multiplication factor are calculated
!in the following manner:
!
!IF .IDTYPE GEQ DOUBLPREC THEN WORDSIZE = 2 ELSE WORDSIZE = 1;
!ARRAYSIZE = .WORDSIZE;ARRAYOFFSET = 0;
!INCR I FROM 1 TO NUMBEROF DIMENSIONS DO
!BEGIN
! FACTOR(.I) = .ARRAYSIZE;
! ARRAYOFFSET = .ARRAYOFFSET+.FACTOR(.I)*.LOWERLIMIT(.I);
! SUBSCRIPTSIZE = .UPPERLIMIT(.I)-.LOWERLIMIT(.I)+1;
! ARRAYSIZE = .ARRAYSIZE*.SUBSCRIPTSIZE;
!END;
!
!For example:
!
! DOUBLE PRECISION A(2:5,3:5,4:5)
!
!would produce
!
!FACTOR= 2 8 24
!ARRAYOFFSET= 4 28 124
!SUBSCRIPTSIZE= 4 3 2
!ARRAYSIZE= 8 24 48
!
!Thus using BLISS notation, the second element of A, A(3,3,4) is
!.(A+2*3+8*3+24*4-124) which equals .(A+2) . The array size specifies
!the number of words occupied by the array, thus in the above example
!array A occupies locations A thru A+47.
!------------------------------------------------------------------------------
! Initially clear some flags and stuff.
ADJUSTABLE = AOFF = 0;
%1510% ASSUMEDSIZE = FALSE;
%1213% ! Use character count for CHARACTER data, one or two words for others
%1250% ! If a character array has element length (*), it's adjustably
%1250% ! dimensioned, even if all array bounds are constants.
%1213% IF .IDTYPE EQL CHARACTER
%1213% THEN
%1250% IF .CHLEN EQL LENSTAR
%1250% THEN ADJUSTABLE = -1
%1213% ELSE ASIZE = .CHLEN
%1213% ELSE IF .IDTYPE GEQ DOUBLPREC
%1213% THEN ASIZE = 2
%1213% ELSE ASIZE = 1;
! Calculate number of dimensions
%1510% DNUM = .SSLST<LEFT> + 1;
! Create the array dimension table entry
%2504% NAME<LEFT> = DIMSIZ + .DNUM * DIMSUBSIZE; ! Size of entry
NAME<RIGHT> = DIMTAB; ! Type of entry
%2504% ARRDIMEN = NEWENTRY(); ! Entry
%2504% ARRDIMEN[DIMNUM] = .DNUM; ! Num of dimensions
! Address of first element. This is incremented in the loop below
! so that we are always looking at the "first" (0th) element
! (apparently because this make more optimized code, not having a
! variable for the index), even though it is really the Nth
! element. Ugh.
%2504% T2 = .ARRDIMEN;
INCR SS FROM @SSLST TO @SSLST+.SSLST<LEFT> DO
BEGIN ! Loop through list of dimension bounds
MAP BASE SS;
T2[DVARFLGS(0)] = 0;
T1 = .SS[ELMNT];
BOUND = .T1[ELMNT]; ! Get Ptr to upper or lower bounds
%1510% ! Make sure the bounds is asterisk or integer
%1510% IF .BOUND NEQ ASTERISK^18
%1510% THEN IF .BOUND[VALTYPE] NEQ INTEGER THEN ERR31;
CASE .T1[ELMNT1] OF SET
BEGIN ! Option 0 - lower limit is 1 by default
! Store Lower Bound
T2[DIMENL(0)] = .ONEPLIT;
%1527% IF .BOUND<LEFT> EQL CONSTLEX
THEN
BEGIN !Choice 1: BOUND is a constant pointer
! Don't allow upper bound to be lower than
! lower bound.
IF .BOUND[CONST2] LSS 1 THEN ERR74;
END ! of choice 1: BOUND is a constant pointer
%1670% ELSE IF .BOUND<LEFT> EQL ASTERISK
THEN
%1510% BEGIN ! Choice 2: BOUND is an asterisk
%1510%
%1510% ! Make sure that is is the last subscript.
%1510% IF .SS NEQ .SSLST + .SSLST<LEFT>
%1510% THEN ERR189;
%1510%
%1510% ! The upper bound is +infinity
%1510% BOUND = MAKECNST(INTEGER, 0, INFINITY);
%1510%
%1510% ! The array is an Assumed Size Array
%1510% ASSUMEDSIZE = TRUE;
%1510% END ! Choice 2: BOUND is an asterisk
%1670% ELSE
BEGIN ! Choice 3: BOUND is an expression
T2[DVARUBFLG(0)] = 1;
ADJUSTABLE = -1;
END; ! Choice 3: BOUND is an expression
! Store upper bound;
T2[DIMENU(0)] = .BOUND;
IF .ADJUSTABLE EQL 0
THEN
BEGIN
T2[DFACTOR(0)] = MAKECNST(INTEGER, 0, .ASIZE);
%2322% ! AOFF <= .AOFF - .ASIZE
%2322% AOFF = SUBINT(.AOFF, .ASIZE);
%1510% IF NOT .ASSUMEDSIZE
%1510% THEN
%1510% BEGIN ! Calculate Array Size
%2322% ! Following program is illegal (array
%2322% ! DD has too many characters) and will
%2322% ! overflow below:
%2322% ! PARAMETER (LARGE="377777 777777)
%2322% ! CHARACTER DD(LARGE)*(LARGE)
%2322% ! END
%2322%
%2322% ! ASIZE <= .ASIZE * .BOUND[CONST2]
%2322%
%2322% ASIZE = MULINT(.ASIZE,.BOUND[CONST2]);
%1510% END ! of calculate array size
END
ELSE
BEGIN
T2[DVARFACTFLG(0)] = 1;
T2[DFACTOR(0)] = 0;
END;
END; ! of option 0 - lower limit is 1 by default
BEGIN ! Option 1 - both lower and upper limits are specified
%1527% IF .BOUND<LEFT> EQL ASTERISK
%1527% THEN
%1510% BEGIN ! BOUND is an asterisk
%1510% ERR189;
%1510% END ! BOUND is an asterisk
%1670% ELSE IF .BOUND<LEFT> EQL CONSTLEX
%1670% THEN .VREG !do nothing
ELSE
BEGIN ! BOUND is an expression
T2[DVARLBFLG(0)] = 1;
ADJUSTABLE = -1;
END; ! BOUND is an expression
T2[DIMENL(0)] = .BOUND; !LOWER BOUND
T1 = .T1[ELMNT2]; ! Get ptr to upper bound block
SAVET1 = .T1; ! Saving ptr for SAVSPACE call later
!T1 now points to upper bound part
BOUND = .T1[ELMNT1];
%1510% ! Make sure the bounds is asterisk or integer.
%1510% IF .BOUND NEQ ASTERISK ^ 18
%1510% THEN IF .BOUND[VALTYPE] NEQ INTEGER THEN ERR31;
%1527% IF .BOUND<LEFT> EQL ASTERISK
%1527% THEN
%1510% BEGIN ! BOUND is an asterisk
%1510%
%1510% ! Make sure that is is the last subscript.
%1510% IF .SS NEQ .SSLST + .SSLST<LEFT>
%1510% THEN ERR189;
%1510%
%1510% ! The upper bound is +infinity
%1510% BOUND = MAKECNST(INTEGER, 0, INFINITY);
%1510%
%1510% ! The array is an assumed size array.
%1510% ASSUMEDSIZE = TRUE;
%1510%
%1510% END ! BOUND is an asterisk
%1670% ELSE IF .BOUND<LEFT> EQL CONSTLEX
%1670% THEN .VREG ! do nothing
ELSE
BEGIN ! BOUND is an expression
T2[DVARUBFLG(0)] = 1;
ADJUSTABLE = -1;
END; ! BOUND is an expression
T2[DIMENU(0)] = .BOUND;
IF .ADJUSTABLE EQL 0
THEN
BEGIN
LOCAL BASE LOBOUND, BASE UPBOUND;
LOBOUND = .T2[DIMENL(0)];
UPBOUND = .T2[DIMENU(0)];
! Make sure that the lower bounds is not
! greater than the upper bounds.
IF .LOBOUND[CONST2] GTR .UPBOUND[CONST2]
THEN ERR74;
T2[DFACTOR(0)] = MAKECNST(INTEGER, 0, .ASIZE);
%2322% ! Following program is illegal and gets
%2322% ! an overflow;
%2322% ! PARAMETER (LARGE="377777 777777)
%2322% ! CHARACTER A(LARGE-1:LARGE)*(LARGE)
%2322% ! END
%2322%
%2322% ! AOFF <= .AOFF - (.ASIZE * .LOBOUND[CONST2])
%2322%
%2322% AOFF = SUBINT(.AOFF, MULINT(.ASIZE,.LOBOUND[CONST2]) );
%1510% IF NOT .ASSUMEDSIZE
%1510% THEN
%1510% BEGIN ! Calculate array size
%2322% ! Below programs are illegal and
%2322% ! overflow:
%2322% ! PARAMETER (LARGE="377777 777777)
%2322% ! CHARACTER A(2:LARGE)*(LARGE/2)
%2322% ! END ! Overflow on multiplation
%2322% !
%2322% ! PARAMETER (LARGE="377777 777777)
%2322% ! PARAMETER (NEG = -LARGE)
%2322% ! DIMENSION A(NEG:LARGE)
%2322% ! END ! Overflow on subtraction
%2322%
%2322% ! ASIZE <= .ASIZE * (.UPBOUND[CONST2]
%2322% ! - .LOBOUND[CONST2] + 1)
%2322%
%2322% BOUND = SUBINT(.UPBOUND[CONST2],
%2322% .LOBOUND[CONST2]);
%2322% ASIZE = MULINT(.ASIZE,
%2322% ADDINT(.BOUND, 1));
%1510% END ! of calculate array size
END
ELSE
BEGIN
T2[DVARFACTFLG(0)] = 1;
T2[DFACTOR(0)] = 0;
END;
SAVSPACE(.SAVET1<LEFT>,.SAVET1);
END ! of option 1-both lower and upper limits are specified
TES;
T1 = .SS[ELMNT]; !FOR SAVSPACE CALL
SAVSPACE(.T1<LEFT>,.T1);
%2504% T2 = .T2 + DIMSUBSIZE; ! Next subscript entry
END; ! of loop through list of dimension bounds
IF .ADJUSTABLE NEQ 0
THEN
BEGIN !ADJUSTABLE
!--------------------------------------------------------------
! IF THE DIMENSIONS ARE ADJUSTABLE CREATE A SPECIAL SET OF
! TEMPS TO BE USED BY ADJ. TO CALCULATE THE MULTIPLICATIVE
! FACTORS. ALSO SET ADJDIMFLG
!
!FOR ADJ. THEY MUST BE IN A SPECIAL ORDER
!ASIZE
!OFFSET
!FACTOR N-1
! .
! .
! .
!FACTOR 1
!--------------------------------------------------------------
LOCAL BASE PTR;
LOCAL DIMENTRY E;
!CHECK TO SEE IF ADJUSTABLES ARE LEGAL
IF .FLGREG<PROGTYP> NEQ SUPROG THEN
IF .FLGREG<PROGTYP> NEQ FNPROG
THEN ERR137;
! If this is not a dummy variable yet, push it on the the
! stack for checking later.
IF NOT .FARRY[IDATTRIBUT(DUMMY)] THEN AJDIMSTK(.FARRY);
ASIZE = INITLTEMP(INTEGER);
%2504% ARRDIMEN[ARAOFFSET] = INITLTEMP(INTEGER);
%1250% ! Use .I temp for CHARACTER data, one or two words for others
%1213% IF .IDTYPE EQL CHARACTER
%1250% THEN A0F = INITLTEMP(INTEGER)
%1213% ELSE IF .FARRY[DBLFLG] ! One or two words
%1213% THEN A0F = MAKECNST (INTEGER, 0, 2)
%1213% ELSE A0F = .ONEPLIT;
%2504% ARRDIMEN[DFACTOR(0)] = .A0F;
! Process the dimensions in reverse order (last to first).
! T2 is set up from the last INCR loop where we went from
! first to last to point to the last. Another "ugh", we
! are still referencing each dimension as if it were the
! first.
DECR I FROM .DNUM - 1 TO 1
DO
LDECR: BEGIN ! For each subscript
%2504% T2 = .T2 - DIMSUBSIZE; ! DIMSUBENTRY (I)
IF .T2[DFACTOR(0)] NEQ 0
THEN LEAVE LDECR;
IF NOT .T2[DVARUBFLG (0)] OR
%414% .T2[DIMENL (0)] NEQ .ONEPLIT OR
%414% .I NEQ 1
%[1250]% OR .IDTYPE EQL CHARACTER
THEN
BEGIN
T2[DFACTOR (0)] = INITLTEMP (INTEGER);
LEAVE LDECR;
END;
%414% !I == 1 => T2 [...(0)] IS FOR 2ND DIM
PTR = .DTABPTR <RIGHT>;
WHILE .PTR NEQ 0 DO
BEGIN
E = .PTR;
CHECKTHIS: BEGIN
%423% IF .E [DIMNUM] LSS 2
THEN LEAVE CHECKTHIS;
IF NOT .E [ADJDIMFLG]
THEN LEAVE CHECKTHIS;
IF .E [DFACTOR (0)] NEQ .A0F ! SAME ELEMENT SIZE
THEN LEAVE CHECKTHIS;
%414% ! If dim1 same, then share factor for dim2
%2567% IF .E[DIMENU (0)] EQL .T2[DIMENU (-1)]
%2567% THEN IF .E[DIMENL(0)] EQL .T2[DIMENL(-1)]
%2567% THEN IF .E [DIMENL (0)] EQL .ONEPLIT
THEN
BEGIN
%571% PTR = .E [DFACTOR (1)];
%571% T2[DFACTOR (0)] = .PTR;
%2570% IF .PTR[OPR1] EQL VARFL
%2570% THEN IF .PTR[IDDOTO] EQL SIXBIT ".I"
%2570% THEN PTR [IDUSECNT] = .PTR [IDUSECNT] + 1; ! UPDATE SHARING COUNT
LEAVE LDECR;
END;
END; ! OF CHECKTHIS
PTR = .E [ARALINK]; ! NEXT ENTRY
END; ! Of WHILE .PTR NEQ 0
%571% PTR = INITLTEMP (INTEGER); ! NO MATCH FOUND
%571% T2 [DFACTOR (0)] = .PTR;
%571% PTR [IDUSECNT] = 1; ! 1ST USAGE: NO SHARING
END; ! Of LDECR
%2504% T2 = .T2 - DIMSUBSIZE; ! SUBENTRY (0)
%[1250]% ! Numeric arrays have factor #1 constant. (1 for single word arrays,
%[1250]% ! 2 for double word arrays.) Character arrays have factor #1 stored
%[1250]% ! in a .I temp at runtime. The .I temp is generated above.
%[1250]% IF .IDTYPE EQL CHARACTER
%[1250]% THEN T2[DVARFACTFLG(0)] = 1
ELSE T2[DVARFACTFLG(0)] = 0;
%2520% ARRDIMEN[ADJDIMFLG] = 1;
END !ADJUSTABLE
%2504% ELSE ARRDIMEN[ARAOFFSET] = MAKECNST(INTEGER,0,.AOFF); !MAKE CONST NODE FOR OFFSET VALUE
%1510% IF .ASSUMEDSIZE
%1510% THEN
%1510% BEGIN
%1510% ! Check if assumed-size arrays are legal
%1510% IF .FLGREG<PROGTYP> NEQ SUPROG THEN
%1510% IF .FLGREG<PROGTYP> NEQ FNPROG
%1510% THEN ERR190;
%1510%
%1510% ! Check for Assumed Size Array not a DUMMY argument.
%1510% ! If isn't yet, then save it on the stack to be checked
%1510% ! later for being a DUMMY argument.
%1510% IF NOT .FARRY[IDATTRIBUT(DUMMY)] THEN AJDIMSTK(.FARRY);
%1510%
%1510% ! Set the Assumed Size Array flag.
%2520% ARRDIMEN[ASSUMESIZFLG] = 1
%1510%
%1510% END; ! End of check if assumed-size arrays are legal
SAVSPACE(.SSLST<LEFT>,.SSLST);
%2504% ARRDIMEN[ARADLBL] = 0; ! "FOR SAFETY"
%2504% ARRDIMEN[ARALINK] = .DTABPTR<RIGHT>; ! LINK THIS ENTRY INTO LIST
%2504% DTABPTR<RIGHT> = .ARRDIMEN; ! NEW LIST HEAD
IF .FARRY[OPERSP] EQL FORMLARRAY
THEN
( IF .ADJUSTABLE EQL 0
THEN BEGIN
!MAKE A POINTER VARIABLE TO BE A COPY OF ARRAY'S SYMBOL TABLE NODE
!AND PUT IT IN THE DIMENSON NODE
LOCAL BASE PTRVAR;
ENTRY[0] = .FARRY[IDSYMBOL];
NAME = IDTAB;
PTRVAR = NEWENTRY();
PTRVAR[IDATTRIBUT(NOALLOC)] = 0; !LET THIS BE ALLOCATED
PTRVAR[VALTYPE] = INTEGER;
PTRVAR[OPERSP] = FORMLVAR; !MAKE IT A FORMAL DUMMY
! The variable that holds the array base is in the .DATA. psect
%1505% PTRVAR[IDPSECT] = PSDATA;
%2504% ARRDIMEN[ARADDRVAR] = .PTRVAR; !PTR VARIABLE TO DIMENSION NODE
END;
)
%2504% ELSE ARRDIMEN[ARADDRVAR] = 0;
%2224% ! Check the size of this array. Complain if the array is
%2224% ! absurdly large to fit into virtual memory!
%2224% IF NOT .ASSUMEDSIZE
%2224% THEN
%2224% BEGIN ! Check for total space needed for this array.
%2224%
%2224% IF .IDTYPE EQL CHARACTER
%2224% THEN
%2224% BEGIN ! Character array - Check number of characters
%2224%
%2322% IF .ASIZE GEQ (CHARSPERWORD * .VMSIZE)
%2224% THEN ERR141;
%2224%
%2224% END ! Character array
%2224% ELSE ! Numeric array
%2322% IF .ASIZE GEQ .VMSIZE THEN ERR141;
%2224%
%2224% END; ! Check for total space needed for this array.
%2504% ARRDIMEN[ARASIZ] = .ASIZE; ! Size of array
%2504% RETURN .ARRDIMEN; ! Ptr to dimension node
END; ! of BLDDIM
ROUTINE CHKCOMMON(T1)=
BEGIN
! Checks common declarations
MACRO
%4516% ERR42=RETURN FATLEX(.T1[IDSYMBOL], E42<0,0>)$,
%4516% ERR34(X)=RETURN FATLEX(PLIT'X?0', .T1[IDSYMBOL], E34<0,0>)$;
MAP BASE T1;
BIND BASE CBLOCK=STK[2];
%1511% EXTERNAL E192;
IF .T1[IDATTRIBUT(INCOM)]
THEN ERR42
ELSE IF .T1[IDATTRIBUT(DUMMY)] THEN ERR34(DUMMY);
%1511% ! If this variable was specified in a SAVE, then give an error,
%1511% ! this isn't allowed.
%1511% IF .T1[IDSAVVARIABLE]
%1511% THEN FATLERR(.T1[IDSYMBOL], UPLIT(ASCIZ'COMMON variable'),
%4576% .ISN,E192<0,0>);
T1[IDATTRIBUT(INCOM)] = 1;
IF .CBLOCK<LEFT> EQL 0 THEN
BEGIN
CBLOCK<LEFT> = CBLOCK<RIGHT> = @T1;
END
ELSE
BEGIN
CBLOCK[IDCOLINK] = @T1;
CBLOCK<RIGHT> = @T1;
END;
END; ! of CHKCOMMON
ROUTINE CHKTYPE(OEPNT)=
BEGIN
!***************************************************************
! Check the type declarations for a ONEARRAY element. OEPNT is
! the pointer to the syntactic tree for the type decalration.
! The tree is:
! pointer to identifier pointer to identifier
! chlen1 chlen1
! flag1 flag1
! type1 type1
! 0 (no subscripts) 1 (subscripts)
! chlen2 pointer to subscripts
! flag2 chlen2
! type2 flag2
! type2
!***************************************************************
%1575% ! Written by TFV on 7-Jul-82
REGISTER BASE ID;
BIND
LEN1 = .(.OEPNT)[1],
FLG1 = .(.OEPNT)[2],
TYP1 = .(.OEPNT)[3],
HASSUBS = .(.OEPNT)[4],
LEN2 = .(.OEPNT)[5 + HASSUBS],
FLG2 = .(.OEPNT)[6 + HASSUBS],
TYP2 = .(.OEPNT)[7 + HASSUBS];
ID = @.OEPNT; ! Pointer to identifier
IDTYPE = TYP1; ! Set datatype to first one
IF TYP1 NEQ TYP2
THEN
BEGIN ! The two types are different
! If the user specified both, there is a conflict
IF FLG1 NEQ 0
THEN IF FLG2 NEQ 0
THEN RETURN FATLEX(.ID[IDSYMBOL], E205<0,0>);
IF FLG2 THEN IDTYPE = TYP2 ! Set datatype to specified one
END; ! The two types are different
IF .IDTYPE EQL CHARACTER
THEN
BEGIN ! Check for identical character lengths
CHLEN = LEN1; ! Set length for character data to first length
! If both lengths were specified and differ, there is a
! conflict - give an error
IF LEN1 NEQ LEN2
THEN IF FLG1 NEQ 0
THEN IF FLG2 NEQ 0
THEN RETURN FATLEX(.ID[IDSYMBOL], E205<0,0>);
IF FLG2 NEQ 0
THEN CHLEN = LEN2; ! Set length for character data to
! specified length
END; ! Check for identical character lengths
RETURN
END; ! of CHKTYPE
GLOBAL ROUTINE BLDARRAY(LPNT)=
BEGIN
REGISTER
%1213% BASE T2,
BASE T1;
LOCAL
%1575% HASSUBS, ! Option for subscripts specified
%1575% BASE SPNT, ! Pointer to subscripts
BASE R2,
BASE R1,
POINTER,
%1155% BLDSTATUS, !Deferred return status, 0=All OK,
%1155% ! -1=Error in 1 or more items
BASE PTR, !To march down dimension entry list
DIMENTRY E, !One element on that list
%1434% BASE ENTNODE,
%1434% BASE ENTIDSYM,
%1434% ARGUMENTLIST ARGLIST;
LABEL OUT, CHECKTHIS;
MACRO
%4516% ERR4=(RETURN FATLEX(.T1[IDSYMBOL], PLIT'VARIABLE', E4<0,0>))$;
!----------------------------------------------------------------------
! THE PARAMETER LPNT POINTS TO A LIST OF ONEARRAY'S, THAT IS TO SAY
! EACH ELEMENT OF THE LIST POINTED TO BY LPNT IS A POINTER TO A LIST
! OF THE FORM:
!
!IDENTIFIER (20^18+LOC) - FIRST ARRAY NAME
!OPTION 0 OR OPTION 1 - ADDITIONAL ARRAY NAMES AND SUBSCRIPTS FOLLOW
! COUNT^18+LOC - LIST POINTER
!VARIABLE TYPE - ONLY IF THIS IS A TYPE STATEMENT
!
! THE LOCATION IDTYPE CONTAINS THE VARIABLE TYPE TO BE SET IN EACH
! ARRAY NAME. IF IDTYPE IS LESS THAN ZERO, NO TYPE IS SPECIFIED AND AN
! OPTION 0 (NO SUBSCRIPTS) IS ILLEGAL. IDTYPE IS SET LESS THAN ZERO FOR
! DIMENSION, AND GLOBAL STATEMENTS.
! IDTYPE FOR TYPE STATEMENTS IS NOW IN THE TREE IN ORDER TO IMPLIMENT
! THE *N TYPE OVERRIDE FEATURE.
!----------------------------------------------------------------------
%1155% BLDSTATUS_0; !Assume all items are OK
INCR OA FROM .LPNT TO .LPNT + .LPNT<LEFT> DO
BEGIN !Loop though list
MAP BASE OA; ! OA stands for onearray
R1 = .OA[ELMNT];
%1410% IF .TYPE EQL 5 ! If in a common statement,
%1410% THEN R1 = .R1[ELMNT]; ! Follow from +(onearray) to +onearray
FARRY = T1 = .R1[ELMNT];
IF .TYPE EQL 4 ! Type statement
THEN
BEGIN
! Call CHKTYPE to check any *size modifiers. It
! sets CHLEN and IDTYPE
CHKTYPE(.R1);
%1434% ! Setup for the case FUNCTION FOO(...) followed
%1434% ! by CHARACTER*n FOO. In that case FOO becomes
%1434% ! a character function and needs a different
%1434% ! argument block.
%1434% IF .FLGREG<PROGTYP> EQL FNPROG
%1434% THEN
%1434% BEGIN
%1434% ENTNODE = .SORCPTR<RIGHT>;
%1434% ENTIDSYM = .ENTNODE[ENTSYM];
%1434% ARGLIST = .ENTNODE[ENTLIST];
%1434% END
%1434% ELSE ENTIDSYM = 0;
%1575% HASSUBS = .R1[ELMNT4]; ! Option word for subs
%1575% SPNT = .R1[ELMNT5]; ! Pointer to subs
END
ELSE
%1213% BEGIN
%1213% ! Get datatype and character count from symbol table
%1213% CHLEN = .T1[IDCHLEN];
%1213% IDTYPE = .T1[VALTYPE];
%1575% HASSUBS = .R1[ELMNT1]; ! Option word for subs
%1575% SPNT = .R1[ELMNT2]; ! Pointer to subs
%1213% END;
%1575% IF .HASSUBS EQL 0 THEN
BEGIN
! Option 0 - no subscripts
CASE .TYPE OF SET
ERR4; ! DIMENSION
BEGIN ! GLOBAL
!IF .T1[IDATTRIBUT(INCOM)]THEN ERR34(COMMON)
! ELSE IF .T1[IDATTRIBUT(INEXTERN)]THEN ERR34(EXTERNAL);
!T1[IDATTRIBUT(INGLOB)]_1
END;
BEGIN !EXTERNAL
!GONE
END;
BEGIN !PROTECT
!GONE
END;
BEGIN !Type declaration
%1213% ! OLDSIZE is the element size from the symbol
%1213% ! table entry. NEWSIZE is the element size
%1213% ! from the type declaration
%1213% LOCAL OLDSIZE, NEWSIZE;
LABEL ADJ;
IF .T1[IDDIM] NEQ 0
THEN
ADJ:BEGIN
%1213% ! Recompute array size, array
%1213% ! offset, and factors if the
%1213% ! element size has changed
%1213% ! including type changes to/from
%1213% ! character.
%1213% ! Compute new size for element
%1213% IF .IDTYPE EQL CHARACTER
%1213% THEN NEWSIZE = .CHLEN
%1213% ELSE IF .IDTYPE GEQ DOUBLPREC
%1213% THEN NEWSIZE = 2
%1213% ELSE NEWSIZE = 1;
%1213% ! Compute old size for element
%1213% IF .T1[VALTYPE] EQL CHARACTER
%1213% THEN OLDSIZE = .T1[IDCHLEN]
%1213% ELSE IF .T1[VALTYPE] GEQ DOUBLPREC
%1213% THEN OLDSIZE = 2
%1213% ELSE OLDSIZE = 1;
%1213% ! Don't recompute if old and new sizes are the same
%1213% IF .OLDSIZE EQL .NEWSIZE THEN LEAVE ADJ;
R2 = .T1[IDDIM];
IF NOT .R2[ADJDIMFLG]
THEN
BEGIN
R2[ARASIZ] = (.R2[ARASIZ]*.NEWSIZE ) / .OLDSIZE;
T2 = .R2[ARAOFFSET];
R2[ARAOFFSET] = MAKECNST(INTEGER,0,( .T2[CONST2] * .NEWSIZE ) / .OLDSIZE );
DECR I FROM .R2[DIMNUM]-1 TO 0 DO
BEGIN
T2 = .R2[DFACTOR(.I)];
R2[DFACTOR(.I)] = MAKECNST(INTEGER,0, ( .T2[CONST2] * .NEWSIZE ) / .OLDSIZE );
END
END
ELSE
BEGIN !DO ONLY FOR FIRST FACTOR IF ADJUSTABLE
%[627]% DECR I FROM .R2[DIMNUM]-1 TO 0 DO
%[627]% IF NOT .R2[DVARFACTFLG(.I)] THEN
%[627]% BEGIN
%[627]% T2 = .R2[DFACTOR(.I)];
%[627]% R2[DFACTOR(.I)] = MAKECNST(INTEGER,0, ( .T2[CONST2] * .NEWSIZE ) / .OLDSIZE );
%[627]% END;
OUT: BEGIN
IF .R2 [DIMNUM] LSS 2
THEN LEAVE OUT;
IF NOT .R2 [DVARUBFLG (1)]
THEN LEAVE OUT;
IF .R2 [DIMENL (1)] NEQ .ONEPLIT
THEN LEAVE OUT;
T2 = .R2 [DFACTOR (1)];
%2570% IF .T2[OPR1] EQL VARFL
%2570% THEN IF .T2[IDDOTO] EQL SIXBIT ".I"
%2570% THEN
%2570% BEGIN
%2570% T2 [IDUSECNT] = .T2 [IDUSECNT] - 1;
%2570% IF .T2 [IDUSECNT] EQL 0
%2570% THEN T2 [IDATTRIBUT (NOALLOC)] = 1; ! NOT SHARED NOW: DON'T ALLOC
%2570% END;
PTR = .DTABPTR<RIGHT>;
WHILE .PTR NEQ 0
DO BEGIN
E = .PTR;
CHECKTHIS: BEGIN
IF .E EQL .R2 ! DON'T SHARE WITH YOURSELF
THEN LEAVE CHECKTHIS;
IF .E [DIMNUM] LSS 2
THEN LEAVE CHECKTHIS;
IF NOT .E [ADJDIMFLG]
THEN LEAVE CHECKTHIS;
IF .E [DFACTOR (0)] NEQ .R2 [DFACTOR (0)] ! SAME ELEMENT SIZE ?
THEN LEAVE CHECKTHIS;
IF .E [DIMENU (0)] NEQ .R2 [DIMENU (0)]
THEN LEAVE CHECKTHIS;
IF .E [DIMENL (0)] NEQ .ONEPLIT
THEN LEAVE CHECKTHIS;
! DIM 1 SAME: SHARE FACTOR FOR DIM2
PTR = .E [DFACTOR (1)];
R2 [DFACTOR (1)] = .PTR;
%2570% IF .PTR[OPR1] EQL VARFL
%2570% THEN IF .PTR[IDDOTO] EQL SIXBIT ".I"
%2570% THEN PTR [IDUSECNT] = .PTR [IDUSECNT] + 1; ! UPDATE SHARING COUNT
LEAVE OUT;
END; ! OF CHECKTHIS
PTR = .E [ARALINK]; ! NEXT ENTRY
END; ! OF WHILE .PTR NEQ 0
%2570% IF .T2[OPR1] EQL VARFL
%2570% AND .T2[IDDOTO] EQL SIXBIT ".I"
%2570% AND .T2 [IDUSECNT] EQL 0 ! NO MATCH FOUND
THEN T2 [IDATTRIBUT (NOALLOC)] = 0 ! USE OLD .I WHICH WAS DEALLOCED
ELSE T2 = INITLTEMP (INTEGER); ! GET NEW .I TEMP
R2 [DFACTOR (1)] = .T2;
T2 [IDUSECNT] = 1; ! 1ST USAGE: NO SHARING
END; ! OF OUT
END
END; !ADJ BLOCK
%1155% IF NAMDEF(IDDEFT, .T1) LSS 0
%1155% THEN BLDSTATUS = .VREG
%1155% ELSE
%1155% BEGIN !No semantic error
T1[IDATTRIBUT(INTYPE)] = 1;
T1[VALTYPE] = .IDTYPE;
%1434% IF .IDTYPE EQL CHARACTER
%1434% THEN
%1434% BEGIN ! Character data
%1434% ! Put length for CHARACTER
%1434% ! variables into symbol table.
%1434% ! If this is the subprogram
%1434% ! entry, call CHARGLIST to redo
%1434% ! the argument list.
%1434% T1[IDCHLEN] = .CHLEN;
%1434% IF .FLGREG<PROGTYP> EQL FNPROG THEN
%1434% IF .T1[IDSYMBOL] EQL .ENTIDSYM[IDSYMBOL]
%1434% THEN
%1434% BEGIN
%1434% ENTNODE[ENTLIST] = ARGLIST = CHARGLIST(.ARGLIST);
%1434% ARGLIST[1, ARGFULL] = .ENTIDSYM;
%1434% ENTIDSYM[IDATTRIBUT(DUMMY)] = 1;
%1434% END;
%1434% END; ! Character data
%1155% END; ! No semantics error
%2327% !Set the psect fields for the declared variable
%2327% SETPSECTS(.T1);
END; !Type declaration
BEGIN !COMMON
IF NAMDEF( VARARY, .T1) LSS 0
%1155% THEN BLDSTATUS = .VREG
%1155% ELSE
!CHECK COMMON DECLARATION
%1155% IF CHKCOMMON(.T1) LSS 0
%1155% THEN BLDSTATUS = .VREG;
END !COMMON
TES;
END ! Option 0 - No subscripts
ELSE
BEGIN !OPTION 1 - ARRAY NAMES AND SUBSCRIPTS
MAP BASE FARRY;
LOCAL SAVSTK;
CASE @TYPE OF SET
BEGIN %DIMENSION%
IF NAMDEF(ARRYDEF,.T1) LSS 0
%1155% THEN BLDSTATUS = .VREG
END;
BEGIN !GLOBAL
!IF .T1[IDATTRIBUT(INCOM)] THEN ERR34(COMMON)
! ELSE IF .T1[IDATTRIBUT(INEXTERN)] THEN ERR34(EXTERNAL);
!T1[IDATTRIBUT(INGLOB)]_1
END;
BEGIN !EXTERNAL
END;
BEGIN !PROTECT
END;
BEGIN !Type declaration
IF NAMDEF(ARRYDEFT,.T1) LSS 0
%1155% THEN BLDSTATUS = .VREG
%1155% ELSE
%1155% BEGIN ! NAMDEF didnt find error
T1[IDATTRIBUT(INTYPE)] = 1;
T1[VALTYPE] = .IDTYPE;
%1213% ! Put length for CHARACTER variables
%1213% ! into symbol table
%1213% IF .IDTYPE EQL CHARACTER
%1213% THEN T1[IDCHLEN] = .CHLEN;
%1155% END; ! NAMDEF didnt find error
END; ! Type declaration
BEGIN %COMMON%
IF NAMDEF (ARRYDEF,.T1) LSS 0
%1155% THEN BLDSTATUS = .VREG;
%1155% !Check COMMON declarations
%1155% IF CHKCOMMON(.T1) LSS 0
%1155% THEN BLDSTATUS = .VREG
END %COMMON%
TES;
IF .T1[OPERSP] EQL VARIABLE
THEN T1[OPERSP] = ARRAYNAME
ELSE T1[OPERSP] = FORMLARRAY;
SAVSTK = .STK[2]; !SAVING COMMON LIST POINTERS IF PROCESSING COMMON LISTS
%1575% IF (T2 = BLDDIM(.SPNT[ELMNT])) LSS 0
%1155% THEN BLDSTATUS = .VREG
ELSE
BEGIN
FARRY[IDDIM] = .T2;
%2327% ! Set psect fields for the new array
%2327% SETPSECTS(.FARRY);
IF .FLGREG<BOUNDS> !IF SS BOUNDS CHECKING IS TO BE PERFORMED
! ON ALL ARRAYS (USER "BOUNDS" SWITCH)
OR .FLGREG<DBGDIMN> !OR THE "DEBUG" SWITCH WAS SPECIFIED
THEN T2[ARADLBL] = GENLAB(); !GENERATE A LABEL TO GO ON THE BLOCK
! THAT WILL BE OUTPUT DESCRIBING THE DIMENSION
! INFORMATION FOR THIS ARRAY
END;
STK[2] = .SAVSTK;
END; !OPTION 1 - ARRAY NAMES AND SUBSCRIPTS
SAVSPACE(.R1<LEFT>,@R1);
END; !Loop through list
SAVSPACE(.LPNT<LEFT>,@LPNT);
%1155% RETURN .BLDSTATUS !Deferred status
END; ! of BLDARRAY
GLOBAL ROUTINE BLKSRCH(BLKNAME)=
!++
!---------------------------------------------------------------------
!THIS ROUTINE FINDS OR CREATES THE COMMON BLOCK "NAME" AND
!RETURNS A POINTER TO IT.
!---------------------------------------------------------------------
!--
BEGIN
REGISTER BASE R1:R2;
R1_.COMBLKPTR<LEFT>;
UNTIL .R1 EQL 0
DO
BEGIN ! For each common block
%4527% IF CMPSYM(.R1[COMNAME], .BLKNAME) THEN RETURN .R1; ! Compare
R1_.R1[NEXCOMBLK]; ! Next block
END; ! For each common block
! Existing common block not found. Make a new one.
ENTRY[0] = .BLKNAME;
NAME = COMTAB;
R2 = NEWENTRY();
RETURN .R2
END; ! of BLKSRCH
GLOBAL ROUTINE BLDVAR(VPNT)=
BEGIN
LOCAL BASE T2;
REGISTER BASE T1;REGISTER BASE R1:R2;
!----------------------------------------------------------------------
!THE PARAMETER VPNT POINTS TO THE LIST:
!
!IDENTIFIER (20^18+LOC) - THE SCALAR OR ARRAY VARIABLE
!OPTION 0 OR OPTION 1 - SUBSCRIPTS FOLLOW
! 1^18+LOC - POINTER TO SUBSCRIPT LIST POINTER
! COUNT^18+LOC - POINTER TO A LIST OF SUBSCRIPT EXPRESSIONS
!----------------------------------------------------------------------
T1_.VPNT;T2_.T1[ELMNT];!T2_LOC(IDENTIFIER)
IF .T1[ELMNT1] EQL 0 THEN
BEGIN %SCALAR%
IF .SETUSE EQL SETT
THEN NAMSET(VARYREF, .T2)
ELSE NAMREF(VARYREF,.T2);
IF .VREG LSS 0 THEN T2 _ -1
ELSE T2<LEFT>_IDENTIFIER ! USED BY ASSISTA AND GOTO - EVERYONE ELSE WILL
! ACCEPT AN UNSUBSCRIPTE ARRRAY REF HERE
END
ELSE
BEGIN
IF .SETUSE EQL SETT
THEN NAMSET(ARRAYNM1, .T2)
ELSE NAMREF(ARRAYNM1, .T2);
IF .VREG LSS 0 THEN RETURN .VREG;
R1_.T1[ELMNT2];R2_.R1[ELMNT];SAVSPACE(0,@R1); !CHANGED 1 TO 0
INCR SCR FROM @R2 TO @R2+.R2<LEFT> DO
BEGIN
MAP BASE SCR;MACRO SCRFLGS=0,0,LEFT$,SCRPTR=0,0,RIGHT$;
R1_.SCR[ELMNT]; SCR[SCRPTR]_@R1;SCR[SCRFLGS]_0;
END;
IF (T2_ARRXPND(@T2,@R2)) GTR 0
THEN T2<LEFT>_ARRAYREF;
END;
SAVSPACE(.VPNT<LEFT>,@VPNT);
RETURN .T2!RETURN POINTER TO SCALAR OR ARRAY EXPRESSION
END; ! of BLDVAR
GLOBAL ROUTINE BLDSUBVAR(VPNT)= ! [1416] New
! Like BLDVAR but BLDVAR handles VARIABLESPECs (ID or subscripted ID)
! and BLDSUBVAR handles SUBVARSPECs (ID or subscripted ID or substring of
! either of those). Returns a DATAOPR or ARRAYREF or SUBSTRING node.
BEGIN
!----------------------------------------------------------------------
!THE PARAMETER VPNT POINTS TO THE LIST:
!
!IDENTIFIER (20^18+LOC) - THE SCALAR OR ARRAY VARIABLE
!OPTION: 0 = JUST IDENTIFIER
! 1 = IDENTIFIER FOLLOWED BY LEFT PAREN
! IF OPTION 1, POINTER TO 3-ITEM LIST:
! - FIRST CONSTANT EXPRESSION
! - OPTION: WHICH LEXEME FOLLOWS THE FIRST CONSTANT
! - POINTER TO OTHER STUFF DEPENDING ON THE OPTION
! OPTION 1, COLON A(1:2)
! OTHER STUFF IS A 2-ITEM LIST
! - COLON LEXEME
! - POINTER TO UPPER BOUND CONSTANT EXPRESSION
! OPTION 2, COMMA A(1,2) A(1,2)(3:4) A(1,2,3)
! OTHER STUFF IS A 2 OR 3-ITEM LIST
! - POINTER TO LIST OF SUBSCRIPT EXPRESSIONS
! - OPTION. 0 = NO SUBSTRING EXPRESSIONS, 1 = SUBSTRING
! - PTR TO LIST OF SUBSTRING EXPRESSIONS IF OPTION 1
! OPTION 3, RPAREN A(1) A(1)(2:3)
! OTHER STUFF IS A 1 OR 2-ITEM LIST
! - OPTION. 0 = NO SUBSTRING EXPRESSIONS, 1 = SUBSTRING
! - PTR TO LIST OF SUBSTRING EXPRESSIONS IF OPTION 1
! SUBSTRING EXPRESSIONS, IF PRESENT, ARE A 3-ITEM LIST:
! - PTR TO LOWER BOUND CONSTANT EXPRESSION
! - COLON LEXEME
! - PTR TO UPPER BOUND CONSTANT EXPRESSION
!----------------------------------------------------------------------
MAP BASE R1:R2;
REGISTER BASE R3:IDPTR;
R1 _ .VPNT;
IDPTR _ .R1[ELMNT]; ! Get pointer to identifier
IF .R1[ELMNT1] EQL 0 ! Check option word
THEN ! ID is not followed by (
BEGIN ! Scalar
IF .SETUSE EQL SETT
THEN NAMSET(VARYREF,.IDPTR)
ELSE NAMREF(VARYREF,.IDPTR);
IF .VREG LSS 0 THEN IDPTR _ -1
ELSE IDPTR<LEFT> _ IDENTIFIER;
END ! Scalar
ELSE ! ID is followed by (
BEGIN ! Arrayref or substring
R1 _ .R1[ELMNT2]; ! point to list of stuff after (
CASE .R1[ELMNT1]-1 OF ! see what follows first constant
SET
BEGIN ! option 1, colon - substring
IF .SETUSE EQL SETT ! define and check the variable name
THEN NAMSET(VARIABL1,.IDPTR)
ELSE NAMREF(VARIABL1,.IDPTR);
IF .VREG LSS 0 THEN RETURN .VREG;
STK[.SP+1] _ .R1[ELMNT]; ! put lower bound expression onto STK
R2 _ .R1[ELMNT2];
STK[.SP+2] _ .R2[ELMNT1]; ! put upper bound expression onto STK
IDPTR _ MAKESUBSTR(.IDPTR); ! make substring node
END; ! option 1, colon - substring
BEGIN ! option 2, comma - subscript list
IF .SETUSE EQL SETT ! define and check the name
THEN NAMSET(ARRAYNM1,.IDPTR)
ELSE NAMREF(ARRAYNM1,.IDPTR);
IF .VREG LSS 0 THEN RETURN .VREG;
R2 _ .R1[ELMNT2]; ! get pointer to rest of subscripts
R2 _ .R2[ELMNT];
NAME<LEFT> _ .R2<LEFT> + 2; ! get space for all subscripts
R3 _ CORMAN();
R3<LEFT> _ .R2<LEFT> + 1; ! set up a pointer to all subscripts
(.R3)<FULL> _ .R1[ELMNT]; ! copy first subscript
INCR I FROM 0 TO .R2<LEFT> ! copy rest of subscripts
DO (.R3+1)[.I] _ .(.R2)[.I];
IDPTR _ ARRXPND(.IDPTR,.R3); ! build ARRAYREF node,
! also discard subscript list
R2 _ .R1[ELMNT2]; ! get pointer to other stuff again
IF .R2[ELMNT1] NEQ 0 ! check if substring is present
THEN
BEGIN ! substring of arrayref
R3 _ .R2[ELMNT2];
STK[.SP+1] _ .R3[ELMNT]; ! put lower bound on STK
STK[.SP+2] _ .R3[ELMNT2]; ! put upper bound on STK
IDPTR _ MAKESUBSTR(.IDPTR); ! make substring node
SAVSPACE(.R3<LEFT>,.R3); ! discard substring bounds
END; ! substring of arrayref
END; ! option 2, comma - subscript list
BEGIN ! option 3, right paren - single subscript
IF .SETUSE EQL SETT ! define and check the name
THEN NAMSET(ARRAYNM1,.IDPTR)
ELSE NAMREF(ARRAYNM1,.IDPTR);
IF .VREG LSS 0 THEN RETURN .VREG;
NAME<LEFT> _ 1; ! Get a 1-word block for the subscript
R3 _ CORMAN();
(.R3)<FULL> _ .R1[ELMNT]; ! copy the subscript
IDPTR _ ARRXPND(.IDPTR,.R3); ! build ARRAYREF node,
! also discard subscript block
R2 _ .R1[ELMNT2]; ! check if substring is present
IF .R2[ELMNT] NEQ 0
THEN
BEGIN ! substring of arrayref
R3 _ .R2[ELMNT1];
STK[.SP+1] _ .R3[ELMNT]; ! put lower bound on STK
STK[.SP+2] _ .R3[ELMNT2]; ! put upper bound on STK
IDPTR _ MAKESUBSTR(.IDPTR); ! make substring node
SAVSPACE(.R3<LEFT>,.R3); ! discard substring bounds
END; ! substring of arrayref
END ! option 3, right paren - single subscript
TES;
SAVSPACE(.R2<LEFT>,.R2);
SAVSPACE(.R1<LEFT>,.R1);
END; ! Arrayref or substring
SAVSPACE(.VPNT<LEFT>,.VPNT);
RETURN .IDPTR;
END; ! of BLDSUBVAR
GLOBAL ROUTINE CCONST(C1PTR,C2PTR)=
BEGIN
!**;[1202] THIS ENTIRE ROUTINE (CCONST) ADDED BY EDIT 1202
!**;[1203] AND GREATLY CHANGED BY EDIT 1203
! THIS ROUTINE ACCEPTS A POINTER TO A TWO-WORD LIST, AND DETERMINES
! WHETHER IT IS ACTUALLY A COMPLEX CONSTANT IN DISGUISE. IF SO, THEN
! IT CREATES THE ACTUAL COMPLEX CONSTANT NODE, AND RETURNS A POINTER
! TO IT AS THE RESULTING VALUE. IF NOT, THEN A ZERO IS RETURNED.
! OBSERVE THAT THE ONLY COMPONENTS CURRENTLY ALLOWED ARE OCTAL, INTEGER,
! REAL, AND DOUBLE PRECISION CONSTANTS - OTHERS (LIKE DOUBLE OCTAL)
! COULD POSSIBLY BE ADDED IF DESIRABLE (QUITE UGLY, HOWEVER!).
MAP BASE C1PTR:C2PTR; ! POINTERS TO THE TWO CONSTANT NODES
LOCAL REALPART,IMAGPART; ! ACTUAL ONE-WORD CONSTANT REPRESENTATIONS
! MAKE SURE THAT WE HAVE TWO CONSTANTS...
IF .C1PTR EQL 0 THEN RETURN 0;
IF .C2PTR EQL 0 THEN RETURN 0;
IF .C1PTR[OPRCLS] NEQ DATAOPR THEN RETURN 0;
IF .C1PTR[OPERSP] NEQ CONSTANT THEN RETURN 0;
IF .C2PTR[OPRCLS] NEQ DATAOPR THEN RETURN 0;
IF .C2PTR[OPERSP] NEQ CONSTANT THEN RETURN 0;
! SET UP THE FIRST CONSTANT INTO REALPART
SELECT .C1PTR[VALTYPE] OF
NSET
OCTAL: REALPART_.C1PTR[CONST2];
INTEGER: BEGIN
C1H_0; C1L_.C1PTR[CONST2];
COPRIX_KKTPCNVIX(COMPLEX2,FROMINT);
CNSTCM();
REALPART_.C2H
END;
REAL: BEGIN
C1H_.C1PTR[CONST1]; C1L_.C1PTR[CONST2];
COPRIX_KKTPCNVIX(COMPLEX2,FROMREAL);
CNSTCM();
REALPART_.C2H
END;
DOUBLPREC: BEGIN
C1H_.C1PTR[CONST1]; C1L_.C1PTR[CONST2];
COPRIX_KKTPCNVIX(COMPLEX2,FROMDBLPRC);
CNSTCM();
REALPART_.C2H
END;
OTHERWISE: RETURN 0;
TESN;
! SET UP THE SECOND CONSTANT INTO IMAGPART
SELECT .C2PTR[VALTYPE] OF
NSET
OCTAL: IMAGPART_.C2PTR[CONST2];
INTEGER: BEGIN
C1H_0; C1L_.C2PTR[CONST2];
COPRIX_KKTPCNVIX(COMPLEX2,FROMINT);
CNSTCM();
IMAGPART_.C2H
END;
REAL: BEGIN
C1H_.C2PTR[CONST1]; C1L_.C2PTR[CONST2];
COPRIX_KKTPCNVIX(COMPLEX2,FROMREAL);
CNSTCM();
IMAGPART_.C2H
END;
DOUBLPREC: BEGIN
C1H_.C2PTR[CONST1]; C1L_.C2PTR[CONST2];
COPRIX_KKTPCNVIX(COMPLEX2,FROMDBLPRC);
CNSTCM();
IMAGPART_.C2H
END;
OTHERWISE: RETURN 0;
TESN;
RETURN MAKECNST(COMPLEX,.REALPART,.IMAGPART);
END; ! of CCONST
GLOBAL ROUTINE SETPSECTS(XSTE) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine sets the IDPSECT and IDPSCHARS fields in the
! symbol table entry parameter. The fields are set based on the
! size of the variable or array represented by the symbol table
! entry, the variable's type, and whether or not the variable is
! in COMMON. EQUIVALENCE associations are not taken into account
! by this routine.
!
! Be aware that the psect fields of a variable may change several
! times as new information about a variable is discovered. For
! example:
!
! 1. A type declaration statement changes a variable's type from
! its implicit type set when the variable was first seen in
! the lexical analyzer to the new type specified.
!
! 2. A DIMENSION statement converts a scalar to an array.
!
! 3. A type declaration following a DIMENSION statement can
! change the size of an array.
!
! 4. An ENTRY statement can cause a variable to become a formal
! after all type specification statements have been seen.
!
! Thus, when any of the above changes occurs, the psect fields
! must be reset by either calling this routine or by handling the
! situation locally.
!
! This routine treats any variable that does not have
! IDATTRIBUTE(DUMMY) set as non-formal variables. Thus length
! star character variables, adjustably dimensioned arrays, and
! assumed size arrays that have not yet been seen in a FUNCTION,
! SUBROUTINE, or ENTRY statement are treated as non-formals by
! this routine. This is harmless because their psect fields are
! correctly set later in FUNCGEN. Furthermore, the manipulation
! of the IDCHLEN and ARASIZ of these variables by this routine
! cannot cause address checks, underflows, or other side effects.
!
! See the file PSECT-TABLE.MEM for the design for the values of
! the psect fields.
!
! FORMAL PARAMETERS:
!
! XSTE Pointer to the symbol table entry
!
! IMPLICIT INPUTS:
!
! BIGARY The minimum size in words of a .LARG. object.
! XSTE[IDDIM] The pointer to the dimension table entry for the
! symbol, if the symbol is an array.
!
! IMPLICIT OUTPUTS:
!
! The IDPSECT and IDPSCHARS fields in the symbol table entry.
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN ![2327] New Routine
REGISTER BASE STE, DIMENTRY DIMTBL, BASE COMBLK; ![2343]
! Put pointer into a register for speed
STE = .XSTE;
! Only DATAOPR's need allocation
IF .STE[OPRCLS] NEQ DATAOPR THEN CGERR();
! Constants have no psect fields
IF .STE[OPERSP] EQL CONSTANT THEN CGERR();
! All formals are in .DATA.
IF .STE[IDATTRIBUTE(DUMMY)]
THEN
BEGIN
STE[IDPSECT] = PSDATA;
STE[IDPSCHARS] = PSOOPS;
RETURN
END;
%2343% ! COMMON variables are another special case
%2343% IF .STE[IDATTRIBUTE(INCOM)]
%2343% THEN
%2343% BEGIN !COMMON variable
%2343% ! Get COMMON block of variable
%2343% COMBLK = .STE[IDCOMMON];
%2343% ! If the COMMON block of this variable isn't set yet, then
%2343% ! we must be in the middle of COMMON statement semantic
%2343% ! processing, and COMMSTA can take care of things.
%2343% IF .COMBLK EQL 0 THEN RETURN;
%2343% !Put variable in same psect as its COMMON block
%2343% IF .STE[VALTYPE] EQL CHARACTER
%2343% THEN
%2343% BEGIN !Character
%2343% STE[IDPSECT] = PSCODE;
%2343% STE[IDPSCHARS] = .COMBLK[COMPSECT];
%2343% END !Character
%2343% ELSE
%2343% BEGIN !Non-Character
%2343% STE[IDPSECT] = .COMBLK[COMPSECT];
%2343% STE[IDPSCHARS] = PSOOPS;
%2343% END; !Non-Character
%2343% !All Done
%2343% RETURN;
%2343% END; !COMMON variable
!Set the psect fields for non-formal scalars and arrays. See
!definition of non-formal given in header.
IF .STE[VALTYPE] EQL CHARACTER
THEN
BEGIN !Character variable
STE[IDPSECT] = PSCODE; !This is definitely correct
STE[IDPSCHARS] = PSDATA; !Assume this for now
IF .STE[OPERSP] EQL ARRAYNAME
THEN
BEGIN !Character array
DIMTBL = .STE[IDDIM];
IF EXTENDED
THEN IF CHWORDLEN(.DIMTBL[ARASIZ]) GEQ .BIGARY
THEN STE[IDPSCHARS] = PSLARGE
END !Character array
ELSE
BEGIN !Character scalar
IF EXTENDED
THEN IF CHWORDLEN(.STE[IDCHLEN]) GEQ .BIGARY
THEN STE[IDPSCHARS] = PSLARGE
END !Character scalar
END !Character variable
ELSE
BEGIN !Numeric variable
STE[IDPSECT] = PSDATA; !Assume this for now
STE[IDPSCHARS] = PSOOPS; !This is definitely correct
IF .STE[OPERSP] EQL ARRAYNAME
THEN
BEGIN !Numeric Array
DIMTBL = .STE[IDDIM];
IF EXTENDED
THEN IF .DIMTBL[ARASIZ] GEQ .BIGARY
THEN STE[IDPSECT] = PSLARGE
END !Numeric Array
END; !Numeric variable
END; ! of SETPSECTS
GLOBAL ROUTINE SIZOFARRAY(ARRAY)= ! [1471] Rewritten by RVM
BEGIN
!***********************************************************************
! This routine returns an expression to calculate the number of
! entries in an array. If the size of the array can be determined
! at compile time, then this expression will be a constant table
! entry or an expression that will be evaluated to a constant by
! the skeleton optimizer. Otherwise, it will be a expression to
! be evaluated at runtime.
!
! Note that assumed size arrays cause this routine to give an ICE.
!
!***********************************************************************
MAP BASE ARRAY;
REGISTER BASE DIMTBL;
DIMTBL = .ARRAY[IDDIM]; ! Pointer to dimension table entry
%1510% ! Impossible to determine size of an assumed size array.
%1510% IF .DIMTBL[ASSUMESIZFLG] THEN CGERR();
IF .ARRAY[VALTYPE] EQL CHARACTER
THEN
BEGIN ! Character array.
! Check for adjustably dimensioned array.
IF NOT .DIMTBL[ADJDIMFLG]
THEN RETURN MAKECNST(INTEGER,0,.DIMTBL[ARASIZ]/.ARRAY[IDCHLEN]);
! Adjustably dimensioned character array.
IF .ARRAY[IDCHLEN] NEQ LENSTAR
THEN RETURN MAKPR1(0,ARITHMETIC,DIVOP,INTEGER,
.DIMTBL[ARASIZ],MAKECNST(INTEGER,0,.ARRAY[IDCHLEN]));
RETURN MAKPR1(0,ARITHMETIC,DIVOP,INTEGER,.DIMTBL[ARASIZ],.DIMTBL[DFACTOR(0)]);
END; ! of character array.
! Non-character array.
IF NOT .ARRAY[DBLFLG]
THEN
BEGIN ! Non-character array with one word per element.
! Check for adjustably dimensioned array.
IF .DIMTBL[ADJDIMFLG] THEN RETURN .DIMTBL[ARASIZ];
! Non-Character, non-adjustably dimensioned array
! with one word per element.
RETURN MAKECNST(INTEGER, 0, .DIMTBL[ARASIZ]);
END; ! of non-character array with one word per element.
! The array must be a non-character array with 2 words per element.
! Check for adjustably dimensioned case.
IF NOT .DIMTBL[ADJDIMFLG]
THEN RETURN MAKECNST(INTEGER,0,.DIMTBL[ARASIZ]/2);
! Non-Character, non-adjustably dim'ed array with 2 words per element.
RETURN MAKPR1(0,ARITHMETIC,DIVOP,INTEGER,.DIMTBL[ARASIZ],MAKECNST(INTEGER,0,2));
END; ! of SIZOFARRAY
ROUTINE BLDIOLSCLS(NODE)=
BEGIN
!***************************************************************
! This routine is passed an expression node, and it creates an
! IOLSCLS node pointing to the data contained in the expression
! node. If successful, a pointer is returned to the IOLSCLS
! node.
!***************************************************************
%1202% ! This entire routine is added by edit 1202
MAP BASE NODE; ! An expression node in an iolist
REGISTER BASE IONODE, ! The created IOLSCLS node
%1510% BASE DIMTBL; ! Dimension table of node (if it has one!)
%1743% LOCAL BASE TEMP; ! Temporary variable
MACRO ERR146=(RETURN FATLEX(E146<0,0>))$;
%1510% MACRO ERR191=(RETURN FATLEX(UPLIT 'in an I/O list?0',E191<0,0>)) $;
! A few validity checks . . .
! If NODE is the bare name of an array or formal array
%1510% IF .NODE[OPR2] EQL OPR2C(DATAOPR, ARRAYNAME) ! If array or formal Array
%1510% THEN
%1510% BEGIN
%1510% DIMTBL = .NODE[IDDIM]; ! Get Dimension Table Entry
%1510% IF .DIMTBL[ASSUMESIZFLG] ! Don't allow Assumed Size Arrays
%1510% THEN ERR191
%1510% END;
%2531% ! Check for subroutine name! Function references (with paren's)
%2531% ! are fine, but subroutine names or function names without paren's
%2531% ! are definitely not allowable in I/O lists.
%2531% IF .NODE[OPRCLS] EQL DATAOPR ! Symbol name
%2531% THEN IF .NODE[IDATTRIBUT(INEXTERN)] ! User-callable
%4516% THEN FATLEX (VAORAY, .NODE[IDSYMBOL], E15<0,0> );
! And more validity check if we have an input statement...
IF .TYPE EQL READD THEN ! MUST HAVE VARIABLE OR ARRAY NAME
IF .NODE[OPRCLS] EQL DATAOPR
THEN
(IF .NODE[OPRSP1] EQL VARIABL1 OR
.NODE[OPRSP1] EQL ARRAYNM1 THEN ! WE ARE OK !
ELSE ERR146)
ELSE
IF .NODE[OPRCLS] EQL ARRAYREF THEN ! WE ARE OK !
%1444% ELSE IF .NODE[OPRCLS] EQL SUBSTRING THEN ! OK !
ELSE ERR146;
! Build the IOLSCLS node
NAME = IOLTAB; ! Iolist table
IF .TYPE EQL READD
THEN SETUSE = SETT ! Variables are set
ELSE SETUSE = USE; ! variables are referenced
IF .NODE[OPRCLS] EQL DATAOPR AND .NODE[IDDIM] NEQ 0
%1407% AND .NODE[OPERSP] NEQ CONSTANT
THEN
BEGIN
%1530% NAME<LEFT> = SLCSIZ;
IDOFSTATEMENT = SLISTCALL;
END
ELSE IDOFSTATEMENT = DATACALL;
IONODE = NEWENTRY(); ! Create the IOLSCLS node
IONODE[OPERSP] = .IDOFSTATEMENT; ! DATACALL or SLISTCALL
IONODE[OPRCLS] = IOLSCLS;
IONODE[DCALLELEM] = .NODE; ! Insert pointer to the expression
IF .IONODE[OPERSP] EQL SLISTCALL
THEN
BEGIN
! Fix up OPERSP because newentry has set SRCID
IONODE[SRCID] = 0; ! Clears OPERSP
IONODE[OPERSP] = SLISTCALL;
! Setup pointer to the number of elements in array
%1743% IONODE[SCALLCT] = TEMP = SIZOFARRAY(.NODE);
! Set the parent pointer unless it isn't an expression.
%1767% IF .TEMP[OPRCLS] NEQ DATAOPR
%1743% THEN TEMP[PARENT] = .IONODE;
END;
RETURN .IONODE
END; ! of BLDIOLSCLS
GLOBAL ROUTINE LISTIO(LPNT)=
BEGIN
!***************************************************************
! This routine is used to build iolists for input and output
! statements, i.e., TYPE, WRITE, READ, etc.. It is called with
! LPNT pointing to a list of iolist items; each item consists
! of:
!
! choice-1
! iolist item - either an expression (including constants
! and variables) or an array name.
!
! choice-2
! list of iolist items - including implied DO loops
!
! An iolist chain is created, and a pointer to the chain is
! returned as the value. Notice that the routine is called
! recursively in order to build larger and larger chains!
!***************************************************************
%1202% ! This entire routine is added by edit 1202
MACRO ADDCONTNODE (X) =
BEGIN
T1 = .IOLBL [SNHDR]; ! GET NODE FROM IOCONTNODE
X [CLINK] = .T1; ! LINK IN CONT NODE AT END OF LOOP
X<RIGHT> = .T1; ! POINT TO NEW END OF DATALIST
END$;
MACRO ADDOLAB (X,Y) = ! PUT INDEX ON ACTIVE DO LIST
BEGIN
LOCAL DINODE TEMP;
NAME<LEFT> = DISIZE; ! MAKE NEW DO NODE
TEMP = CORMAN ();
TEMP[DITYPE] = DIDOTYPE; ! SET NODE TYPE TO DO
TEMP[DISTMT] = 0; ! NO DO STMT NODE TO POINT TO
TEMP[LASTDOLBL] = X; ! SET LABEL OF TERMINAL STATEMENT
TEMP[CURDONDX] = Y; ! SET LOOP INDEX
LASDOLABEL = X;
CURDOINDEX = Y;
TEMP[DILINK] = .DOIFSTK; ! LINK NEW NODE INTO DOIFSTK
TEMP[DIBLINK] = 0;
IF .DOIFSTK NEQ 0 THEN DOIFSTK[DIBLINK] = .TEMP;
DOIFSTK = .TEMP;
END$;
MACRO ERR38=(RETURN FATLEX(E38<0,0>))$; !INDEX VARIABLE NOT VARIABLE
%4516% MACRO ERR44=(RETURN FATLEX(.TDOSYM[IDSYMBOL],E44<0,0>))$; !NON-INTEGER LOOP PARAMETER
MACRO IODONODE(X)=
BEGIN
IDOFSTATEMENT = NAME = DODATA;
NAME<RIGHT> = IOLTAB;
T1 = NEWENTRY();
T1[CLINK] = .X<LEFT>;
X<LEFT> = .T1;
T1[OPRCLS] = STATEMENT;
T1[DOLBL] = .IOLBL; !PSEUDO LABEL MADE BY IOCONTNODE
T2 = .IOLBL[SNDOLNK];
IOLBL[SNDOLVL] = .IOLBL[SNDOLVL]+1;
NAME<LEFT> = 1; IOLBL[SNDOLNK] = CORMAN();
(.VREG)<LEFT>=.T1; (.VREG)<RIGHT>=.T2; !LINKING IN ENDING LBL TO DO NODE AND LABEL TABLE
END$;
MACRO IOCONTNODE =
BEGIN !CREATE A CONTINUE NODE IN THE LIST...
IDOFSTATEMENT=NAME=CONTDATA; !NODE IDENTIFICATION AND SIZE
NAME<RIGHT> = IOLTAB;
T1=NEWENTRY(); ! CREATE THE NODE
T1[OPRCLS]=STATEMENT; !IDENTIFY IT
IOLBL=T1[SRCLBL]=GENLAB();
IOLBL[SNREFNO]=2; !REFERENCE COUNT OF 2
IOLBL[SNHDR]=.T1 !PTR TO CONTINUE IN LABEL TABLE NODE
END$;
REGISTER BASE R1:R2:T1; !ALL THE FAST TEMPORARIES!
LOCAL BASE T2;
LOCAL BASE LISTLINK; ! PTR TO FIRST<LEFT> AND LAST<RIGHT> NODES IN THIS IOLIST CHAIN.
LISTLINK=0; !INITIALIZE THE LIST POINTER
INCR DATLST FROM @LPNT TO @LPNT+.LPNT<LEFT> BY 2 DO
BEGIN !TREAT EACH ELEMENT IN THE LIST...
MAP BASE DATLST;
IF .DATLST[ELMNT] EQL 1 THEN ! AN EXPRESSION
BEGIN
R1=.DATLST[ELMNT1]; ! GET PTR TO EXPRESSION
R1=BLDIOLSCLS(.R1); ! BUILD THE IOLSCLS NODE
IF .R1 LSS 0 THEN RETURN .R1; ! SOMETHING FAILED
IF .LISTLINK EQL 0
THEN LISTLINK<LEFT>=LISTLINK<RIGHT>=.R1
ELSE (LISTLINK[CLINK] = .R1; ! TIE IN AT THE
LISTLINK<RIGHT> = .R1); ! END OF THE LIST
END
ELSE ! A LIST OF ELEMENTS OR LIST WITH LOOPPART
BEGIN
LOCAL BASE IOLBL; ! LABEL OF CONTINUE ENDING DO LOOP
LOCAL BASE LNKLST; ! KEEP SEPARATE LIST TEMPORARILY
LOCAL BASE DONOD; ! PTR TO CREATED DO LOOP NODE
LOCAL BASE TDOSYM; ! DO INDEX SYMBOL TABLE PTR
LNKLST=0;
R1=.DATLST[ELMNT1]; ! PTR TO (LIST PTR, LOOP PTR) PAIR
R2=.R1[ELMNT]; ! PTR TO LIST ITSELF
! THERE ARE TWO CHOICES HERE - A LIST WITH A DO LOOP, AND ONE
! WITHOUT A DO LOOP. THE PROCESSING MUST HAPPEN IN STAGES -
! IF THERE IS A DO LOOP, THEN THE LOOP VARIABLE IS ACTUALLY THE
! LAST ELEMENT OF THE LIST, SO WE MUST REMOVE IT AND HANDLE IT
! FIRST. THEN WE HANDLE THE ELEMENTS OF THE LIST. FINALLY WE
! HAVE A BUNCH OF CLEANUP WORK TO DO IN THE CASE THAT THERE WAS
! A LOOP - THIS WORK MUST OCCUR AFTER PROCESSING THE LIST.
IF .R1[ELMNT1] NEQ 0
THEN ! IMPLIED DO LOOP - R2 POINTS TO LIST
BEGIN
IF .R2<LEFT> EQL 1
THEN RETURN FATLEX(E128<0,0>); !NO ELEMENTS FOR LIST!
T1=@R2+.R2<LEFT>; ! PTR TO LAST LIST ELMNT (LOOP INDEX)
T2=TDOSYM=.T1[ELMNT]; ! GET THE DO INDEX VARIABLE
IOCONTNODE; ! GET A CONTINUE NODE
!CHECK OUT IMPLICIT DO INDICES...
!I.E., A(I), I+1=2,10 OR A(I,J),B(I)=1,10
IF .T2[OPRCLS] NEQ DATAOPR THEN ERR38;
IF .T2[OPRSP1] NEQ VARIABL1 THEN ERR38; !VARIABLE OR FORMAL VARIABLE
%1741% ! Implied DO index can NOT be character
%1741% IF .T2[VALTYPE] EQL CHARACTER
%1741% THEN RETURN FATLERR(.T2[IDSYMBOL], .ISN,
%1741% E160<0,0>); ! Complain
IF NAMSET(VARIABL1,.T2) LSS 0
THEN RETURN .VREG; ! THIS CREFS THE VARIABLE, ETC.
IF CKDOINDEX(.T2) THEN ! DO INDEX ALREADY ACTIVE
%4516% RETURN FATLEX(.T2[IDSYMBOL],E21<0,0>);
ADDOLAB(.IOLBL,.T2); ! THIS INDEX CURRENTLY MOST ACTIVE
R2<LEFT>=.R2<LEFT>-2; ! REMOVE THE DO VARIABLE FROM
! LIST OF ELEMENTS SO IT DOESN'T
! GET PROCESSED AS IOLISTNODE
%1550% SAVSPACE(1,.R2+.R2<LEFT>+1); ! SAVE THE 2 WORDS
END;
! HERE IS THE RECURSIVE CALL TO GET THE LIST
! THIS IS THE ONLY RECURSIVE CALL IN THE ROUTINE
IF(LNKLST = LISTIO(.R2)) LSS 0 THEN !ERROR IN LIST
BEGIN
T2=.VREG;
IF .R1[ELMNT1] NEQ 0 !IMPLIED DO LOOP
THEN DOCHECK(.IOLBL); !REMOVE LABEL FROM ACTIVE DO LIST
RETURN .T2
END;
! DONE WITH THE LIST, NOW TIME TO CLEAN UP THE LOOP,
! IN THE CASE THAT THERE INDEED WAS A LOOP...
IF .R1[ELMNT1] NEQ 0 THEN ! IMPLIED DO LOOP
BEGIN
DOCHECK(.IOLBL); !REMOVE LABEL FROM ACTIVE DO LIST
ADDCONTNODE(LNKLST); !LINK IN CONTINUE NODE
IODONODE(LNKLST); !GENERATE A DO LOOP NODE
DONOD=.LNKLST<LEFT>; !SET UP BY IODONODE
! NOW IT IS TIME TO FILL IN ALL THE VALUES FOR THE
! DO LOOP NODE - INITIAL, FINAL, AND INCREMENT,
! CHECKING EACH FOR REASONABLENESS AS WE GO.
DONOD[DOSYM]=.TDOSYM;
R2=.R1[ELMNT2]; !PTR TO BLOCK OR PTRS FOR
!INITIAL, FINAL, AND INCREMENT
SAVSPACE(.R1<LEFT>,.R1);! PTRS TO LIST, INCREMENT BLOCK
DONOD[DOM1]=.R2[ELMNT]; ! INITIAL LOOP VALUE
DONOD[DOM2]=.R2[ELMNT1]; ! FINAL LOOP VALUE
IF .R2[ELMNT2] EQL 0 THEN ! IMPLIED INCREMENT OF ONE
DONOD[DOM3]=.ONEPLIT
ELSE DONOD[DOM3]=.R2[ELMNT2]; ! LOOP INCREMENT
SAVSPACE(.R2<LEFT>,.R2);! PTRS TO LOOP VALUES
END
%1550% ELSE
%1550% BEGIN
%1550% SAVSPACE(.R1<LEFT>,.R1);
%1550% END;
IF .LISTLINK EQL 0 THEN LISTLINK=.LNKLST
ELSE (LISTLINK[CLINK]=.LNKLST<LEFT>;
LISTLINK<RIGHT>= .LNKLST<RIGHT>);
END;
END;
%1550% SAVSPACE(.LPNT<LEFT>,.LPNT);
RETURN .LISTLINK
END; ! of LISTIO
GLOBAL ROUTINE DATALIST(LPNT)=
BEGIN
LOCAL BASE T2;
REGISTER BASE T1;REGISTER BASE R1:R2;
MACRO ADDOLAB (X,Y) =
BEGIN
LOCAL DINODE TEMP;
NAME<LEFT> _ DISIZE; ! MAKE NEW DO NODE
TEMP _ CORMAN ();
TEMP[DITYPE] _ DIDOTYPE; ! SET NODE TYPE TO DO
TEMP[DISTMT] _ 0; ! NO DO STMT NODE TO POINT TO
TEMP[LASTDOLBL] _ X; ! SET LABEL OF TERMINAL STATEMENT
TEMP[CURDONDX] _ Y; ! SET LOOP INDEX
LASDOLABEL _ X;
CURDOINDEX _ Y;
TEMP[DILINK] _ .DOIFSTK; ! LINK NEW NODE INTO DOIFSTK
TEMP[DIBLINK] _ 0;
IF .DOIFSTK NEQ 0 THEN DOIFSTK[DIBLINK] _ .TEMP;
DOIFSTK _ .TEMP;
END$;
LOCAL SAVEBOUNDSFLG; ! TO SAVE THE VALUE OF THE "BOUNDS"
! SWITCH WHILE PROCESSING THE DATA
! LIST FOR A DATA STMNT
MACRO
ERR38=(RETURN FATLEX(E38<0,0>))$, !INDEX VARIABLE NOT VARIABLE
%4516% ERR44=RETURN FATLEX(.TDOSYM[IDSYMBOL],E44<0,0>)$;
!
!MACROS FOR DATALIST NODE GENERATION FOR IOLISTS,DATA LISTS
!
MACRO IODATANODE(X)=
%[635]% BEGIN
NAME _ IOLTAB; !IOLIST TABLE
R1_X;
T2 _ .R1[ELMNT];
SETUSE _ SETT;
! Check the variable to see if it's already been in a DATA
! statement. If so, warn the user that he's initializing the
! same variable twice. Don't do this check for arrays (which
! can be initialized element by element) or character variables
! (which can be initialized char by char with substrings).
IF .T2[IDATTRIBUT(INDATA)] EQL 1 !SEE IF IT'S
%1416% THEN IF .T2[VALTYPE] NEQ CHARACTER !NOT CHARACTER AND
THEN IF .T2[IDDIM] EQL 0 !NOT AN ARRAY BUT
THEN !ALREADY IN A DATA STATEMENT
%4516% FATLEX(.T2[IDSYMBOL],E139<0,0>); !WARN HIM
T2[IDATTRIBUT(INDATA)] _ 1;
%1423% IF .T2[IDATTRIBUTE(FENTRYNAME)] ! Check for function name
%1423% THEN IF .T2[VALTYPE] EQL CHARACTER ! of type character
%1773% THEN IF .FLGREG<PROGTYP> EQL FNPROG ! with FNPROG set
%4516% THEN RETURN FATLEX(.T2[IDSYMBOL],E174<0,0>); ! Yes, error,
! "Can't initialize character function name"
%635% IF .T2[IDATTRIBUT(DUMMY)]
%4516% THEN RETURN FATLEX(.T2[IDSYMBOL],E66<0,0>);
IDOFSTATEMENT _ IF .R1[ELMNT1] NEQ 0 THEN DATACALL
ELSE (R1_.R1[ELMNT]; !PTR TO SYMBOL
%1530% IF .R1[IDDIM] NEQ 0 THEN (NAME<LEFT>_ SLCSIZ;SLISTCALL) ELSE DATACALL
);
R1_NEWENTRY();
R1[OPERSP] _ .IDOFSTATEMENT; !DATACALL OR SLISTCALL
IF .LISTLINK EQL 0
THEN (LISTLINK<LEFT>_LISTLINK<RIGHT>_.R1)
ELSE (LISTLINK[CLINK] _ .R1; LISTLINK<RIGHT>_.R1);
R1[OPRCLS] _ IOLSCLS; !IOLIST CLASS
%1416% R1[DCALLELEM] _ BLDSUBVAR(X);
IF .VREG LSS 0 THEN (R1[DCALLELEM] _ 0; RETURN .VREG); !VREG IS -1 IF BLDVAR FOUND AN ERROR
IF .R1[OPERSP] EQL SLISTCALL
THEN
BEGIN
%1743% LOCAL BASE TEMP;
!FIX UP OPERSP BECAUSE NEWENTRY
!HAS SET SRCID
R1[SRCID]_0;
R1[OPERSP]_SLISTCALL;
%1743% !Ptr to node containing num of elements in array
%1767% R1[SCALLCT] = TEMP = SIZOFARRAY(.R1[DCALLELEM]);
%1743% ! Fix parent ptr if neccesarry.
%1767% IF .TEMP[OPRCLS] NEQ DATAOPR
%1743% THEN TEMP[PARENT] = .R1;
END;
END$;
MACRO IODONODE(X)=
BEGIN
IDOFSTATEMENT_NAME_DODATA;
NAME<RIGHT> _ IOLTAB;
T1_NEWENTRY();
T1[CLINK]_ .X<LEFT>; X<LEFT>_ .T1;
T1[OPRCLS]_STATEMENT;
T1[DOLBL] _ .IOLBL; !PSEUDO LABEL MADE BY IOCONTNODE
T2_.IOLBL[SNDOLNK];
IOLBL[SNDOLVL] _ .IOLBL[SNDOLVL]+1;
NAME<LEFT> _ 1; IOLBL[SNDOLNK] _ CORMAN();
(.VREG)<LEFT>_.T1; (.VREG)<RIGHT>_.T2; !LINKING IN ENDING LBL TO DO NODE AND LABEL TABLE
END$;
MACRO IOCONTNODE =
BEGIN
IDOFSTATEMENT_NAME_CONTDATA; !NODE IDENTIFICATION AND SIZE
NAME<RIGHT> _ IOLTAB;
T1_NEWENTRY();
T1[OPRCLS]_STATEMENT;
IOLBL _ T1[SRCLBL]_ GENLAB();
IOLBL[SNREFNO]_2; !REFERENCE COUNT OF 2
IOLBL[SNHDR] _ .T1 !PTR TO CONTINUE IN LABEL TABLE NODE
END$;
MACRO ADDCONTNODE (X) =
BEGIN
T1 _ .IOLBL [SNHDR]; ! GET NODE FROM IOCONTNODE
X [CLINK] _ .T1; ! LINK IN CONT NODE AT END OF LOOP
X<RIGHT> _ .T1; ! POINT TO NEW END OF DATALIST
END$;
LOCAL BASE LISTLINK; !PTR TO FIRST<LEFT> AND LAST<RIGHT> NODES IN DATALIST CHAIN
!---------------------------------------------------------------------
!THIS ROUTINE IS CALLED WITH LPNT POINTING TO A LIST OF
!DATAITEMS. EACH DATAITEM CONSISTS OF:
!
!CHOICE-1
! DATAITEM-(LOC)
!CHOICE-2
! LIST-(COUNT^18+LOC)
! DATAITEM
! OPTION-0 OR
! OPTION-1
! LOOPPART
!---------------------------------------------------------------------
SAVEBOUNDSFLG_.FLGREG<BOUNDS>; !PRESERVE THE VALUE OF THE "BOUNDS"
! SWITCH (USED BY THE USER TO REQUEST ARRAY BOUNDS CHECKING)
FLGREG<BOUNDS>_0; !TURN OFF THE BOUNDS FLAG UNTIL ARE THROUGH WITH THIS STMNT
! (ELSE THE ARRAY SS CALC WILL BE TURNED INTO A CALL TO
! A RUN-TIME FUNCTION)
LISTLINK_0; !INITIALIZING FOR LIST INPARENS
INCR DATLST FROM @LPNT TO @ LPNT+.LPNT<LEFT> BY 2 DO
BEGIN
MAP BASE DATLST;
IF .DATLST[ELMNT] EQL 1 THEN !A DATAITEM
BEGIN
IODATANODE(.DATLST[ELMNT1]);
END
ELSE !AN IMPLIED DO LOOP OR LIST ENCLOSED IN PARENS
BEGIN
LOCAL BASE LNKLST; !TEMPORARY HOLDER OF LINKLIST
LOCAL BASE TDOSYM; !TEMPORARY HOLDER OF DO INDEX SYMBOL PTR
LOCAL BASE DONOD:IOLBL; !LABEL OF CONTINUE ENDING IMPLIED DO LOOP
LNKLST _ 0; !INIT LOCAL
R1_.DATLST[ELMNT1];R2_.R1[ELMNT]; !R2_LOC(DATAITEM LIST)
IF .R1[ELMNT1] NEQ 0
THEN (!IMPLIED DO LOOP COMING UP ; R2 HAS PTR TO IMPLIED DO LIST
%FIRST CHECK TO SEE THAT THERE HAVE BEEN
SOME VARIABLES FOR THIS DO SPEC %
IF .R2<LEFT> EQL 1
THEN RETURN FATLEX (E128<0,0>);
T1_@R2+.R2<LEFT>;
T2 _ .T1[ELMNT];
IOCONTNODE ; ! GEN A CONTINUE NODE
%DON'T LET SUBSCRIPTED IMPLICIT DO INDECES GO UNDETECTED%
IF .T2[ELMNT1] NEQ 0 THEN RETURN FATLEX(E115<0,0>);
T2 _ TDOSYM _ .T2[ELMNT];
IF .T2[OPRCLS] NEQ DATAOPR THEN ERR38
ELSE IF .T2[OPRSP1] NEQ VARIABL1 THEN ERR38;
IF .T2[VALTYPE] NEQ INTEGER THEN RETURN FATLEX(E104<0,0>);
STK[SP_.SP+1] _.T2; !SAV PTR TO INDEX SYMBOL ON STACK
IF CKDOINDEX (.T2)
%4516% THEN RETURN FATLEX (.T2[IDSYMBOL], E21<0,0>); ! DO INDEX ALREADY ACTIVE
ADDOLAB (.IOLBL, .T2); ! THIS INDEX IS CURRENTLY MOST ACTIVE
R2<LEFT>_.R2<LEFT>-2; !RESET LIST PTR SO THAT LAST ITEM (INDEX PTR)
!DOESN'T GET PROCESSED AS AN IODATANODE
);
IF (LNKLST _ DATALIST (.R2)) LSS 0
THEN BEGIN
T2 _ .VREG;
IF .R1 [ELMNT1] NEQ 0 ! IMPLIED DO LOOP
THEN DOCHECK (.IOLBL); ! REMOVE LABEL FROM ACTIVE DO LIST
RETURN .T2;
END;
IF .R1[ELMNT1] NEQ 0 THEN !IMPLIED DO LOOP
BEGIN
DOCHECK (.IOLBL); ! REMOVE LABEL FROM ACTIVE DO LIST
ADDCONTNODE (LNKLST); ! LINK IN CONT NODE
IODONODE(LNKLST); !GEN A DO LOOP NODE
DONOD_.LNKLST<LEFT>; !SET UP BY IODONODE
DONOD[DOSYM]_.TDOSYM; !STK[2]_LOC(INDEX VARIABLE)
R2_.R1[ELMNT2]; SAVSPACE(.R1<LEFT>,.R1); !R2_LOC(LOOPPART)
R1_.R2[ELMNT];
!R1 POINTS TO INITIAL VALUE
IF .R1[OPR1] NEQ CONSTFL THEN ERR44;
IF .R1[VALTYPE] NEQ INTEGER THEN ERR44;
DONOD[DOM1]_@R1;R1_.R2[ELMNT1]; !_LOC(INITIAL VALUE)
!R1 POINTS TO FINAL VALUE
IF .R1[OPR1] NEQ CONSTFL THEN ERR44;
IF .R1[VALTYPE] NEQ INTEGER THEN ERR44;
DONOD[DOM2]_@R1; !_LOC(FINAL VALUE)
IF .R2[ELMNT2] EQL 0 THEN !INPLIED INCREMENT OF 1
DONOD[DOM3]_.ONEPLIT
ELSE !INCREMENT SPECIFIED
BEGIN
T1_.R2[ELMNT3];R1_.T1[ELMNT];SAVSPACE(0,.T1);
IF .R1[OPR1] NEQ CONSTFL THEN ERR44;
IF .R1[VALTYPE] NEQ INTEGER THEN ERR44;
DONOD[DOM3]_.R1<RIGHT>;
END;
IF .SP GTR 0
THEN ( DATASUBCHK(.DONOD[CLINK],.SP,STK[1]<0,0>);
SP _ .SP-1;
);
SAVSPACE(.R2<LEFT>,.R2);
END;
IF .LISTLINK EQL 0
THEN LISTLINK_.LNKLST
ELSE (LISTLINK[CLINK]_.LNKLST<LEFT>;
LISTLINK<RIGHT> _ .LNKLST<RIGHT>
);
END;
END;
FLGREG<BOUNDS>_.SAVEBOUNDSFLG; !RESTORE THE "BOUNDS" FLAG TO ITS ORIGINAL VAL
RETURN .LISTLINK !POINTS TO FIRST ELEMENT IN LIST
END; ! of DATALIST