Trailing-Edge
-
PDP-10 Archives
-
BB-4157F-BM_1983
-
fortran/compiler/act1.bli
There are 26 other files named act1.bli in the archive. Click here to see a list.
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
! OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1983
!AUTHOR: T.E. OSTEN/FJI/MD/SJW/JNG/DCE/TFV/CKS/AHM/CDM/RVM/SRM
MODULE ACT1(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4)=
BEGIN
GLOBAL BIND ACT1V = 7^24 + 0^18 + #1715; ! Version Date: 12-Jan-83
%(
***** Begin Revision History *****
69 ----- ----- MAKE USE COUNT FOR IMPLIESD 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 Revision History *****
)%
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),
TMPGEN(1),
BLDDIM(1),
AJDIMSTK(1),
CHKCOMMON(1),
CHKTYPE(1),
BLDARRAY(1),
BLKSRCH(1),
BLDVAR(1),
BLDSUBVAR(1),
CCONST(2),
SIZOFARRAY(1),
BLDIOLSCLS(1),
LISTIO(1),
DATALIST(1);
GLOBAL SETUSE; !SET TO INDICATE WHETHER VARIABLE IS BEING
!SET (ASSIGNED TO) OR USED (REFERENCED)
EXTERNAL
ARRXPND,
C1H,
C1L,
C2H,
C2L,
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
CNSTCM,
CNVNODE,
COPRIX,
COMBLKPTR,
CORMAN,
CREFIT,
CURDOINDEX, ! PTR to current DO index variable
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
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
BASE ENTPREVIOUS, ! Address of the previous entry statement or 0.
FARRY,
FATLEX,
GENLAB, ! Make a label table entry for a compiler generated label
IDTYPE,
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
NAME,
NAMLSTOK,
NEWENTRY,
NONIOINIO,
ONEPLIT,
PROGNAME,
SAVSPACE,
SORCPTR, ! Pointer to the first program statement
SP,
STK,
STMNDESC,
TBLSEARCH,
TYPE,
TMPCNT[4];
% 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',
%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'
);
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,
EQVIN = 1^27, ! Equivalence
COMIN = 1^26, ! in common block
DATAIN = 1^24, ! in DATA
DUMIEE = 1^22; ! dummy parameter
! 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.
BIND DEFMASK = PLIT (
%ARRYDEF% NAMLST + STFN + ENTPNT + EXTBTH,
%ARRYDEFT% NAMLST + STFN + ENTPNT + EXTBTH + TYPED,
%STFNDEF% NAMLST + STFN + ENTPNT + EXTBTH + EQVIN + COMIN + DATAIN + DUMIEE,
%EXTDEF% NAMLST + STFN + ENTPNT + EXTBTH + DATAIN + COMIN + EQVIN,
%NMLSTDEF% NAMLST + STFN + ENTPNT + EXTBTH + DUMIEE + DATAIN + COMIN + EQVIN,
%VARARY% NAMLST + STFN + EXTBTH + COMIN + DUMIEE,
%IDDEFT% NAMLST + TYPED,
%IDDEFINE% NAMLST + STFN + ENTPNT + EQVIN + COMIN + DATAIN, %DUMMY PARAMETERS%
%ENTRYDEF% NAMLST + STFN + ENTPNT + EXTBTH + CMNBLK + DUMIEE,
%EXTDEFS% NAMLST + STFN + ENTPNT + EXTBTH + CMNBLK + DATAIN + COMIN + EQVIN,
%CMNBLK% ENTPNT + EXTRSGN,
%1527% %PARADEF% NAMLST + CMNBLK + STFN + ENTPNT + EXTBTH + EQVIN + COMIN + DATAIN + DUMIEE,
%NMLSTITM% NAMLST + STFN + EXTBTH + DUMIEE,
%1514% %INTRSCDEF% NAMLST + STFN + ENTPNT + EXTBTH + DATAIN + COMIN + EQVIN + 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)
! 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 ;
BIND PDEFAS = PLIT (
R18,R19,0,0,R22,R23,R24,0,R26,R27,R28,0,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
RETURN FATLEX( .PDEFAS[35-FIRSTONE(.R)], ID[IDSYMBOL], E34 );
! We must do just a bit more checking. If we find an error,
! assign VREG a non-zero value from the CASE statement and give
! an error message below.
VREG _ 0;
VREG _ CASE .TYPE OF SET
%ARRYDEF% BEGIN
IF .ID[OPRSP1] NEQ VARIABL1 THEN AYORFN
END;
%ARRYDEFT% BEGIN
IF .ID[OPRSP1] NEQ VARIABL1 THEN AYORFN
END;
%STFNDEF% BEGIN
IF .ID[OPRSP1] NEQ VARIABL1 THEN AYORFN
END;
%EXTDEFS% BEGIN
IF .ID[OPRSP1] EQL ARRAYNM1 THEN AY
END;
%NMLSTDEF% BEGIN
IF .ID[OPRSP1] NEQ VARIABL1 THEN AYORFN
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>)
END;
%ENTRYDEF% BEGIN
IF .ID[OPRSP1] EQL FNNAME1 AND NOT .ID[IDATTRIBUT(NOALLOC)] THEN FNN
END;
%EXTDEF% BEGIN
IF .ID[OPRSP1] EQL ARRAYNM1 THEN AY
END;
%CMNBLK% BEGIN
IF .ID[OPRSP1] EQL FNNAME1 AND NOT .ID[IDATTRIBUT(NOALLOC)] THEN FNN
END;
%PARADEF% BEGIN
IF NOT .ID[IDATTRIBUT(NOALLOC)]
THEN IDENPLIT
![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;
%NMLSTITM% BEGIN
IF .ID[OPRSP1] EQL FNNAME1 THEN FNN
END
TES;
! If error was found above, then give error message now.
IF .VREG NEQ 0
THEN RETURN FATLEX ( .VREG, ID[IDSYMBOL], E34 );
END; ! of NAMDEF
GLOBAL ROUTINE NAMSET(TYPE, ID)=
BEGIN % THE SYMBOL POINTED TO BY ID AND DEFINED BY TYPE IS
BEING SET %
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)=
BEGIN % CHECK TO SEE IF WE HAVE WHAT WE THINK WE HAVE AND IF NOT
OUTPUT AN ERROR MESSAGE %
% 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;
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' );
MAP BASE ID;
VREG _ 0;
VREG _ CASE .TYPE OF SET
%VARYREF% BEGIN
IF .ID[OPRSP1] EQL FNNAME1
OR .ID[IDATTRIBUT(NAMNAM)]
THEN VAORAY
END;
%VARIABL1% BEGIN
IF .ID[OPRSP1] NEQ VARIABL1
OR .ID[IDATTRIBUT(NAMNAM)]
THEN VARIB
END;
%ARRAYNM1% BEGIN
IF .ID[OPRSP1] NEQ ARRAYNM1
THEN AAY
END;
%FNNAME1% BEGIN
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)]
%1412% THEN FATLEX(R34,ID[IDSYMBOL],E34<0,0>);
%1412% IF .ID[IDATTRIBUT(FENTRYNAME)]
%1412% 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;
%NMLSTREF% BEGIN
%NO CONFLICTS HERE%
0
END;
%PARAREF% BEGIN
RETURN .ID[IDPARAVAL]
END
TES;
IF .VREG NEQ 0
THEN RETURN FATLEX (.VREG, ID[IDSYMBOL],E15<0,0> );
% INDICATE THAT WE ARE USING THIS NAME %
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)
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
%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
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
THEN ALST_.ALST+1; !IF ARG IS NOT A $ THE SKIP BY 1
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;
%1422% END;
%1213% ! If this function has a type, set valtype and character count
%1213% IF .IDTYPE GEQ 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
%1213% ! Optional valuelist is a VAX 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
GLOBAL ROUTINE TMPGEN(TYPE)=
BEGIN
BIND TMPNAM=PLIT(
%0% SIXBIT 'TM.000',
%1% SIXBIT 'MF.000',
%2% SIXBIT 'OF.000',
%3% SIXBIT 'SZ.000');
REGISTER BASE R3,R2,R1;MACHOP IDIVI=#231,LSHC=#246;
R1_.TMPCNT[.TYPE]_.TMPCNT[.TYPE]+1;
DECR I FROM 2 TO 0 DO (IDIVI(R1,10);LSHC(R2,-6));
ENTRY[0]_.TMPNAM[.TYPE]+.R3<LEFT>;
NAME_IDTAB;R3_TBLSEARCH();
%1505% R3[IDPSECT] = PSDATA; ! Temps go in the .DATA. psect
IF .TYPE EQL 0 THEN R3[OPR1]_VARFL;
RETURN .R3
END; ! of TMPGEN
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
GLOBAL ROUTINE BLDDIM(SSLST)= ![1510] Do a lot of cleanup
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 "fake" dimension table while the
! option list is scanned. Used for different
! things during second part of this routine.
%1510% LOCAL
%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;
%1510% MACRO ERR31 = FATLEX( FARRY[IDSYMBOL], E31<0,0> ) $,
%1510% ERR74 = FATLEX( FARRY[IDSYMBOL], E74<0,0> ) $,
%1510% ERR141 = FATLEX(.FARRY[IDSYMBOL], E141<0,0>) $,
%1510% 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;
!-----------------------------------------------------------------------------
!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
!
!
!Since the knowledge of whether or not the dimensions are adjustable or
!in error is not known until the list has been scanned, a pseudo
!dimension node is created on the unused portion of the stack
! (STK[2] - STK[100]).
!------------------------------------------------------------------------------
BIND ADJUSTABLE=STK[2], AOFF=STK[4];
BIND DLBL = STK [5] <LEFT>, ! TEMP ARADLBL
ALINK = STK [5] <RIGHT>, ! TEMP ARALINK
%[1245]% ASIZE = STK [6] <FULL>, ! TEMP ARASIZ
A0F = STK [8] <RIGHT>; ! TEMP DFACTOR (0)
!------------------------------------------------------------------------------
!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.
!------------------------------------------------------------------------------
T2 = STK[3]<0,0>;
! Initially clear some flags and stuff.
ADJUSTABLE = AOFF = 0;
%1510% ASSUMEDSIZE = FALSE;
! Clear the adjustable dimensioned and assumed-size flags
! in the fake dimension table entry.
%1510% STK[3] = 0;
%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, and store in the fake dimension
! table as well as DNUM.
%1510% T2[DIMNUM] = DNUM = .SSLST<LEFT> + 1;
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);
AOFF = .AOFF - .ASIZE;
%1510% IF NOT .ASSUMEDSIZE
%1510% THEN
%1510% BEGIN ! Calculate Array Size
%1560% ASIZE = .ASIZE*.BOUND[CONST2];
! Don't let the array size get too
! large without reporting the error.
%1560% IF .IDTYPE EQL CHARACTER
%1560% THEN
%1560% BEGIN ! Character array
%1560% IF .ASIZE GEQ CHARSPERWORD^18
%1560% THEN ERR141;
%1560% END ! Character array
%1560% ELSE ! Numeric array
%1560% IF .ASIZE GEQ 1^18 THEN ERR141;
%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);
AOFF = .AOFF-.ASIZE*.LOBOUND[CONST2];
%1510% IF NOT .ASSUMEDSIZE
%1510% THEN
%1510% BEGIN ! Calculate array size
ASIZE = .ASIZE*(.UPBOUND[CONST2]-.LOBOUND[CONST2]+1);
! Check for total space needed for this
! array.
%1560% IF .IDTYPE EQL CHARACTER
%1560% THEN
%1560% BEGIN ! Character array
%1560% IF .ASIZE GEQ CHARSPERWORD^18
%1560% THEN ERR141;
%1560% END ! Character array
%1560% ELSE ! Numeric array
%1560% IF .ASIZE GEQ 1^18 THEN ERR141;
%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);
T2 = .T2+2;
END; ! of loop through list of dimension bounds
!--------------------------------------------------------------------
! STK[2] THRU STK[(.DNUM+1)*2] NOW CONTAINS A DIMENSION NODE. USE THE
! CORMAN ROUTINE TO CREATE A REAL DIMENSION NODE AND COPY THE NODE
! FROM THE STACK.
!--------------------------------------------------------------------
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;
!CHECK FOR ADJUSTABLE ARRAY NOT A DUMMY
IF NOT .FARRY[IDATTRIBUT(DUMMY)] THEN AJDIMSTK(.FARRY);
ASIZE = INITLTEMP(INTEGER);
AOFF<LEFT> = 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;
DECR I FROM .DNUM - 1 TO 1 DO
LDECR: BEGIN
T2 = .T2 - 2; ! DIMSUBENTRY (I)
IF .T2 [DFACTOR (0)] NEQ 0
THEN LEAVE LDECR;
IF NOT .T2 [DVARUBFLG (0)] OR
.T2 [DIMENL (0)] NEQ .ONEPLIT OR
.I NEQ 1
%[1250]% OR .IDTYPE EQL CHARACTER
THEN BEGIN
T2 [DFACTOR (0)] = INITLTEMP (INTEGER);
LEAVE LDECR;
END;
!I == 1 => T2 [...(0)] IS FOR 2ND DIM
PTR = .DTABPTR <RIGHT>;
WHILE .PTR NEQ 0
DO BEGIN
E = .PTR;
CHECKTHIS: BEGIN
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;
!IF DIM1 SAME THEN SHARE FACTOR FOR DIM2
IF .E [DIMENU (0)] EQL .T2 [DIMENU (-1)] AND
.E [DIMENL (0)] EQL .ONEPLIT
THEN BEGIN
PTR = .E [DFACTOR (1)];
T2 [DFACTOR (0)] = .PTR;
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
PTR = INITLTEMP (INTEGER); ! NO MATCH FOUND
T2 [DFACTOR (0)] = .PTR;
PTR [IDUSECNT] = 1; ! 1ST USAGE: NO SHARING
END; ! OF LDECR
T2 = .T2 - 2; ! 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;
T2 [ADJDIMFLG] = 1;
END !ADJUSTABLE
ELSE AOFF<LEFT> = 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% ! Point T2 back at the start of the "fake" dimension table.
%1510% T2 = STK[3]<0,0>;
%1510%
%1510% ! Set the Assumed Size Array flag.
%1510% T2[ASSUMESIZFLG] = 1
%1510% END; ! End of check if assumed-size arrays are legal
SAVSPACE(.SSLST<LEFT>,.SSLST);
!
!NOW MAKE A REAL DIMENSION NODE TRANSFERING THE INFORMATION ON THE
!TEMPORARY STACK (STK) TO THE DIMENSION NODE OF SIZE (.DNUM+1)*2
!
NAME<LEFT> = T2 = DIMSIZ+.DNUM*DIMSUBSIZE;
T2 = .T2-1; !ONE LESS FOR UPCOMING BLT
T2 = .T2+(T1 = (NAME<RIGHT> = DIMTAB; NEWENTRY()));
!ADD THE PTR TO THE NEW DIMENSION NODE TO T2 (THE NUMBER OF WORDS IN THE BLOCK MINUS 1)
DLBL = 0; ! FOR SAFETY
ALINK = .DTABPTR <RIGHT>; ! LINK THIS ENTRY INTO LIST
DTABPTR <RIGHT> = .T1; ! NEW LIST HEAD
T1<LEFT> = STK[3]<0,0>;
SAVET1 = .T1; !SAVING T1 INCASE OF BLT INTERRUPT
BLT(T1,0,T2); !MOVE THE BLOCK TO NEW LOCATION
T1 = .SAVET1;
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;
T1[ARADDRVAR] = .PTRVAR; !PTR VARIABLE TO DIMENSION NODE
END;
) ELSE T1[ARADDRVAR] = 0;
RETURN .T1 !PTR TO DIMENSION NODE
END; ! of BLDDIM
ROUTINE CHKCOMMON(T1)=
BEGIN
! Checks common declarations
MACRO
ERR42=RETURN FATLEX(T1[IDSYMBOL], E42<0,0>)$,
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'),
%1511% 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
ERR4=(RETURN FATLEX(T1[IDSYMBOL], PLIT'VARIABLE', E4<0,0>))$,
ERR41=(RETURN FATLEX(T1[IDSYMBOL], FARRY[IDSYMBOL],E41<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
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)];
T2 [IDUSECNT] = .T2 [IDUSECNT] - 1;
IF .T2 [IDUSECNT] EQL 0
THEN T2 [IDATTRIBUT (NOALLOC)] = 1; ! NOT SHARED NOW: DON'T ALLOC
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;
PTR [IDUSECNT] = .PTR [IDUSECNT] + 1; ! UPDATE SHARING COUNT
LEAVE OUT;
END; ! OF CHECKTHIS
PTR = .E [ARALINK]; ! NEXT ENTRY
END; ! OF WHILE .PTR NEQ 0
IF .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
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;
BEGIN
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
THEN
%1155% BLDSTATUS = .VREG
%1155% ELSE
%1155% BEGIN ! NAMDEF didnt find error
T1[IDATTRIBUT(INTYPE)] = 1;
T1[VALTYPE] = .IDTYPE;
%1213% ! Put length for CHARACTER variables into symbol table
%1213% IF .IDTYPE EQL CHARACTER THEN T1[IDCHLEN] = .CHLEN;
%1155% END; ! NAMDEF didnt find error
END; ! Type declaration
BEGIN %COMMON%
IF NAMDEF (ARRYDEF,.T1) LSS 0
%1155% THEN
%1155% BLDSTATUS = .VREG;
%1155% !Check COMMON declarations
%1155% IF CHKCOMMON(.T1) LSS 0
%1155% THEN
%1155% BLDSTATUS = .VREG
END %COMMON%
TES;
IF .T1[OPERSP] EQL VARIABLE THEN T1[OPERSP] = ARRAYNAME
ELSE T1[OPERSP] = FORMLARRAY;
END;
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;
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;
SAVSPACE(.R1<LEFT>,@R1);
END;
SAVSPACE(.LPNT<LEFT>,@LPNT);
%1155% RETURN .BLDSTATUS !Deferred status
END; ! of BLDARRAY
GLOBAL ROUTINE BLKSRCH(BLKNAME)=
BEGIN
REGISTER BASE R1:R2;
!---------------------------------------------------------------------
!THIS ROUTINE FINDS OR CREATES THE COMMON BLOCK "NAME" AND
!RETURNS A POINTER TO IT.
!---------------------------------------------------------------------
R1_.COMBLKPTR<LEFT>;
UNTIL .R1 EQL 0 DO
BEGIN
IF .R1[COMNAME] EQL .BLKNAME THEN RETURN .R1;
R1_.R1[NEXCOMBLK];
END;
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 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!)
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;
![rvm] There is an error here.There needs to be check for external name
! 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
IONODE[SCALLCT] = SIZOFARRAY(.NODE);
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
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
IF NAMSET(VARIABL1,.T2) LSS 0
THEN RETURN .VREG; ! THIS CREFS THE VARIABLE, ETC.
IF CKDOINDEX(.T2) THEN ! DO INDEX ALREADY ACTIVE
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
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
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
%1423% THEN RETURN FATLEX(T2[IDSYMBOL],E174<0,0>); ! Yes, error,
! "Can't initialize character function name"
%[635]% IF .T2[IDATTRIBUT(DUMMY)] 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
LOCAL BASE SYMBL;
!FIX UP OPERSP BECAUSE NEWENTRY
!HAS SET SRCID
R1[SRCID]_0;
R1[OPERSP]_SLISTCALL;
SYMBL _ .R1[DCALLELEM];
R1[SCALLCT] _ SIZOFARRAY(.SYMBL); !PTR TO NODE CONTAINING NUM OF ELEMENTS IN ARRAY
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)
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