Trailing-Edge
-
PDP-10 Archives
-
BB-D480F-SB_FORTRAN10_V10
-
sta3.bli
There are 12 other files named sta3.bli in the archive. Click here to see a list.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
!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: F.J. INFANTE, D. B. TOLMAN/MD/DCE/EGM/CKS/AHM/CDM/TFV/RVM/MRB/AlB
MODULE STA3(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4)=
BEGIN
GLOBAL BIND STA3V = #10^24 + 0^18 + #2412; ! Version Date: 2-Jul-84
%(
***** Begin Revision History *****
43 ----- ----- IN "EQUISTA", WITHIN THE LOCAL ROUTINE
"GEQITEM", BEFORE CALLING "BLDVAR" FOR AN
ARRAY REF IN AN EQUIVALENCE STMNT, TEMPORARILY TURN OFF THE "BOUNDS"
FLAG, SO WONT TRY TO DO SS CHECKING
46 ----- ----- HAVE STATEMENT FUNCTIONS RESTORE THE SYMBOL
TABLE WHICH WAS MESSED UP TO CREATE THE TEMPROARY
DUMMIES
47 ----- ----- MAKE THE SFNEXPR FIELD OF THE STATEMENT
FUNCTION NODE POINT TO AN ASSIGNMENT OF THE
FUNCTION NAME TO THE EXPRESSION RATHER THAN JUST
POINTING TO THE EXPRESSION
48 ----- ----- FIX EXTESTA SO IT DOESN'T SAVSPAC THE SAME THING TWICE
49 ----- ----- FENTRYNAME IS NO LONGER SET ON STATEMENT FUNCTION
NAMES
50 ----- ----- EQUIVALENCE - PUT THE VARIABLE WHICH IS IN
COMMON AT THE TOP OF THE LIST SO THAT IF THE
CALCULATION OF ITS DISPLACEMENT IS DELAYED UNTIL
OUTMOD, ITS DISPLACEMENT WILL BE CALCULATED BEFORE
THE OTHER VARIABLES WHICH REFERENCE ITS DISPLACEMENT
ARE SHOVED INTO COMMON. WHAT FUN
51 ----- ----- CHECK BOTH NEGATIVE AND POSITIVE LIMITS OF
EQUIVALENCE SUBSCRIPTS
52 ----- ----- FIX DUMYIDMOD SO THAT IT DOES NOT CHANGE THE
TYPE OF FUNCTION NAMES EXPLICITLY TYPED IN
THE FUNCTION STATEMENT
HAVE THE IMPLICIT STATEMENT SET VALTYPE FOR
SUBROUTINE AND PROGRAM NAMES ALSO
JUST IN CASE THE ARE USED FOR SOMETHING ELSE
LATER
53 ----- ----- DOLOOP - WHEN ALREADY DEFINED TERMINAL IS DETECTED
PROCESS THE STATEMENT ANYWAY SO THE UNDEFINED
DO TERMINAL LISTING WON'T GET MESSED UP
54 ----- ----- FIX UP ACTIVE DO INDEX CHECKING SO THAT IT CHECKS
ALL ACTIVE INDICES NOT JUST THE LAST
NAMSET WILL NOW MAKE A CHECK FOR INDEX MODIFICATION
55 ----- ----- IN LOGICALIF - RESTORE LABLOFSTATEMENT AND
STMNDESC ON ANY ERROR RETURNS SO THAT IF THIS
STATEMENT TERMINATES A DO LOOP THE DOCHECK
CALL AFTER SEMANTICS WILL HAVE THE RIGHT INFO
***** Begin Version 4A *****
56 235 ----- IN NAMESTA , DEFINE ITEM AS NAMELIST ITEM, (DT/MD)
57 255 15432 IN DOLOOP, CHECK IF CURRENT STATEMENT # IS SAME AS
ENDING STATEMENT #., (JNT)
***** Begin Version 4B *****
57 324 16750 IF PROCESSING OF STATEMENT FUNCTION FAILS,
SYMBOL TABLE NEEDED FIXING UP BEFORE CONTINUING.
58 417 QAR WITH 57 IN, A(1)=1 WILL DIE IF NOT DIMENSIONED
MUST CHECK FOR CONSTANTS AS PARAMS ON LEFT, (DCE)
59 420 QAR AFTER BOGUS STATEMENT FN SEEN, REMOVE
THE INFO THAT IT WAS A ST FN. THIS PREVENTS
LATER STATEMENTS FROM RELYING ON THIS INFO., (DCE)
***** Begin Version 5A *****
60 534 QAR/21817 VARIOUS PROBLEMS WITH EDIT 59, ESPECIALLY
WITH QUOTED STRINGS IN VARIABLE LIST (BAD
FORMAT STATEMENT, ETC.), (DCE)
61 570 22703 FN(2,3) CAUSES ILL MEM REF UNDER SOME CIRCUMSTANCES,
(DCE)
***** Begin Version 5B *****
62 727 13247 TWO-WAY LOGICAL IF STMNT NEEDS TO KEEP LABEL
COUNT CORRECT FOR SECOND LABEL, (DCE)
***** Begin version 6 *****
63 771 EGM 29-May-80 14108
Make STK validity checks implemented by edit 534 more reliable.
***** Begin Version 7 *****
64 1213 TFV 20-May-81 ------
Pick up datatype and character count from TYPTABle
65 1214 CKS 8-May-81
Add BLOCKIF, ELSESTA, ENDISTA for IF-THEN-ELSE
66 1260 CKS 14-Sep-81
Don't allow character expressions as condition in IF statements or
induction variable in DO statements.
67 1261 CKS 17-Sep-81
Remove calculation of equivalence class offsets and sizes from GEQITEM
since that code is already done in PROCEQUIV. Moreover, the code in
PROCEQUIV works.
70 1262 CKS 22-Sep-81
Parse character substrings in EQUIVALENCE
71 1263 TFV 22-Sep-81 ------
Fix edit 1260 to allow the degenerate case IF('ccc')....
It's silly but legal in Version 6.
72 1267 AHM 6-Oct-81 ------
Define a stub routine INTRSTA for the INTRINSIC statement so we don't
get undefined symbols when linking.
73 1271 CKS 9-Oct-81
Modify DOLOOP to handle modified tree produced by optional comma in
DO statement
74 1402 CKS 23-Oct-81
Allow statement function definitions to be labeled
75 1413 CDM/AHM 4-Nov-81
Use ARGUMENTLIST structure in BLDSFN for storing argument nodes.
Also DUMYIDMOD.
76 1421 CKS 11-Nov-81
Modify BLDSFN for new tree format. Statement functions can now
have zero parameters.
77 1425 CDM 28-Nov-81
Add @ to reference of .T1[ELMENT1] to get address of arguments from
STK.
78 1434 TFV 14-Dec-81 ------
Fix DUMYIDMOD to handle IMPLICIT CHARACTER functions. They have
an extra argument. It is the first and is the character
descriptor of the result.
79 1455 TFV 5-Jan-82 ------
Modify BLDSFN to handle character statement functions.
Character statement functions have an extra argument. It is the
first and is the descriptor for the result. The character
statement function is turned into either a call to CHSFN. (the
subroutine form of CHASN.) or a call to CHSFC. (the subroutine
form of CONCA.). CHSFC. is used if the character expression
has concatenations at its top level, CHSFN. is used for all
other character expressions.
80 1464 RVM 26-Jan-82
Write the routine INTRSTA to do semantic processing for the INTRINSIC
statement. Modify the routine EXTESTA to conform to the FORTRAN 77
Standard: If /F77 is specified, all names in the EXTERNAL statement
name user subroutines.
81 1466 CDM 1-Feb-82
Save pointer in BLDSFN to statement function statement node.
(needed for argument checking.)
82 1476 RVM 8-Feb-82
Change the name of INEXTSGN to USERFUNCTION.
83 1501 RVM 16-Feb-82
Due to a change in the meaning of the INEXTERN and USERFUNCTION
attributes, always lite the INEXTERN bit for any name that has
appeared in an EXTERNAL or INTRINSIC function.
1511 CDM 18-Mar-82
Give errors for EXTERNAL variables in SAVE statements.
1514 RVM 22-Mar-82
Use the mask INTRSCDEF instead of EXTDEF in INTRSTA to check for
conflicts in processing INTRINSIC statement names. The new mask
does not allow an intrinsic function and a dummy argument by the
same name.
1515 RVM 23-Mar-82
Make it illegal to declare a generic name intrinsic, if there
is not a specific intrinsic function of the same name. For
example, INTRINSIC LOG is illegal, because there is no function
named LOG. But, INTRINSIC REAL is OK, because although REAL is
a generic function, there is a function named REAL.
1531 CDM 4-May-82
Results of SAVE stmnt code review.
1573 CKS 25-Jun-82
Modify DOLOOP to allow the statement label to be omitted. Add
WHILSTA for DO WHILE and ENDDSTA for END DO.
1616 CDM 24-Aug-82 Q10-00148
Change DUMYIDMOD so that an IMPLICIT statement won't be able to
give a subroutine an extra variable for a return value when it
tries to make the name character.
1647 CDM 18-Oct-82
Map DINODE onto register R2 in ENDDSTA.
***** End V7 Development *****
1740 CDM 7-Apr-83
Make integer constant expressions work in EQUIVALENCE statements.
1750 MRB 6-May-83
Clarified error message "statement out of order" to include the
possibility of an undimensioned array.
***** Begin Version 10 *********
2240 AlB 28-Nov-83
Force EQVPSECT to be equal to COMPSECT when a common item is
added to the EQUIVALENCE list in routine EQUISTA.
2247 AlB 22-Dec-83
Put in compatibility flagging for old I/O statements.
Routines:
SKIPSTA, UNLOSTA
2252 AlB 27-Dec-83
Change error line number used in edit 2247 from LEXLINE to ISN.
Add compatibility flagging for:
1) DO without label
2) DO WHILE
3) END DO
4) NAMELIST
5) EXTERNAL with & or * on name
6) Two-branch logical if
Routines:
ARITHIF, DOLOOP, ENDDSTA, EXTESTA, NAMESTA, WHILSTA
2270 AlB 13-Jan-84
The NAMELIST statement now sets the INNAM bit in the IDATTRIBUT
field of the symbol table entry for each item in a namelist.
Previously, there was a loop in module PH3G whose sole purpose
was to set this bit, but that was done too late to help the
compatibility flagger.
Routine:
NAMESTA
2327 RVM 23-Mar-84
Put formals into the proper psects.
2412 TFV 2-Jul-84
Split LEXICA into two modules. The classifier is in the new
module LEXCLA. The lexeme scanner is in LEXICA. LEXCLA is
called to initialize each program unit, to classify each
statement, to classify the consequent statement of a logical IF,
and to do the standard end of program and missing end of program
actions.
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.
***** End V10 Development *****
***** End Revision History *****
)%
SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE META72.BLI;
REQUIRE ASHELP.BLI;
SWITCHES LIST;
FORWARD
%1740% CKEQVEXPR, ! Check an expression for EQUIVALENCE statements to
%1740% ! see if it is an integer constant or can be reduced.
GEQITEM(1), ! Generate an equivalence item entry
EQUISTA, ! EQUIVALENCE statement
EXTESTA, ! EXTERNAL statement
INTRSTA, ! INTRINSIC statement
DUMYIDMOD, ! Fixup dummy arguments after an implicit statement
IMPLSTA, ! IMPLICIT statement
NAMESTA, ! NAMELIST statement
SKIPSTA, ! SKIPRECORD OR SKIPFILE statements
UNLOSTA, ! UNLOAD statement
DOLOOP, ! DO LOOP
%1573% WHILSTA, ! WHILE statement
%1573% ENDDSTA, ! END DO statement
ENDWHILE,
LOGICALIF, ! LOGICAL IF statement
ARITHIF, ! ARITHMETIC IF statement
%1214% BLOCKIF, ! BLOCK IF statement
%1214% ELSESTA, ! ELSE AND ELSEIF statements
%1214% ENDISTA, ! ENDIF statement
IFNOTGEN,
CGOTOGEN,
GOTOGEN,
CONTGEN,
BLDSFN,
STATEFUNC; ! STATEMENT FUNCTION
EXTERNAL
ADDLOOP, ! Routine to make do tree structure for optimizer
ARRXPND, ! ARRXPND(ARRAYNAME, SUBSCRIPTLIST)
! SUBSCRIPTLIST= LOC(COUNT,SUBSCRIPT1,SUBSCRIPT2,...)
ASGNTYPER,
BASE ASTATFUN,
BLDARRAY,
BLDUTILITY,
BLDVAR,
%2252% CFLAGB, ! Put out flagger warning outside syntax
%1434% CHARGLIST, ! Routine to make a character function argument list
%1455% CHASGN, ! Routine to convert character statement functions to
%1455% ! calls to CHSFC. or CHSFN.
CKDOINDEX,
CORMAN, ! ALLOCATES MEMORY
CURDOINDEX, ! Pointer to current do index variable
DINODE DOIFSTK, ! Nested IFs and DOs containing current statement
DONESTLEVEL, ! Current level of do nesting
DOXPN, ! Makes do initialization tree
DSCASGNMT,
DSCSTFN,
%1464% E15, ! The "is not" error message
E152,
E153,
E154,
E155,
E163,
E164,
%1511% E192, ! "Illegal for SAVE statement"
%1573% E204,
%1750% E216, ! "Statement funct. out of order or undim array"
%2252% E227, ! 'Extension to Fortran-77: DO WHILE'
%2252% E230, ! 'Extension to Fortran-77: DO without label'
%2252% E231, ! 'Extension to Fortran-77: END DO'
%2252% E254, ! 'Extension to Fortran-77: NAMELIST'
%2247% E268, ! 'Extension to Fortran-77: xxxxx statement'
%2252% E280, ! 'Extension to Fortran-77: Two-branch IF'
%2252% E286, ! 'Extension to Fortran-77: &(or *) used with EXTERNAL'
ENDOFILE, ! Return from lexical
ENTRY,
EQVPTR,
%1740% EVAL, ! Tries to simplify constant expressions into
%1740% ! simple constants.
GENLAB, ! Gets compiler-generated (nM) label
GSTIFCLASIF, ! Classifier state
IDOFSTATMENT,
ISN, ! Current internal statement number
LABDEF,
LABLOFSTATEMENT, ! Label field of current statement
LASDOLABEL, ! Label pointer to last label seen in do statement
%2412% LEXCLA, ! Lexical classifier routine
LIBATTRIBUTES, ! Library function attribute table
LIBFUNTAB, ! Library function table
LOOK4LABEL,
MULTIASGN, ! Routine to process multiple assignment statements
NAME,
NAMDEF,
NAMREF,
NAMSET,
NEWENTRY,
ONEPLIT,
PROGNAME,
PSTATE,
PSTEXECU,
SAVSPACE,
SORCPTR,
SP,
%1464% SRCHLIB, ! Routine that searches table of INTRINSIC functions
STALABL, ! Current statement label
STMNDESC, ! Statement description block
STK,
TBLSEARCH,
TPCDMY,
TYPE,
TYPTAB,
WARNOUT;
ROUTINE CKEQVEXPR(EXPR)= ![1740] New
BEGIN
! Check if the passed EQUIVALENCE EXPR is an integer constant or
! can be reduced to one.
! Either an integer constant is returned, or the passed illegal
! expression (so that operations off an illegal returned
! structure won't be attempted) and an error message given.
MAP BASE EXPR; ! Expression which is not an integer const
MACRO ERR53 = ( FATLEX(E53<0,0>))$;
IF .EXPR[OPERATOR] NEQ INTCONST
THEN
BEGIN ! Not integer constant
EXPR = EVAL(.EXPR); ! EVALuate and reduce to a constant
! if possible
IF .EXPR[OPERATOR] NEQ INTCONST
THEN ERR53; ! Error: this must be an int constant
END;
RETURN .EXPR; ! Return the correct int const or erroneous expression
END; ! of CKEQVEXPR
ROUTINE GEQITEM(PTR)=
BEGIN
! Generate an equivalence item entry
MACRO ERR52 = ( FATLEX(E52<0,0>))$;
REGISTER BASE T1:T2;
MAP BASE R1:R2,
BASE PTR;
LOCAL BASE EPTR; ! Equivalence list pointer
NAME = EQLTAB;
EPTR = NEWENTRY(); !Make an equiv item node
EPTR[EQLID] = R1 = .PTR[ELMNT]; !Ptr to symbol in EQUIVALENCE
R1[IDATTRIBUT(INEQV)] = 1;
IF .R1[IDATTRIBUT(DUMMY)] THEN ERR52; !If dummy symbol then error
IF .PTR[ELMNT1] NEQ 0
THEN
BEGIN !Subscript or substring
%1262% NAMSET(VARYREF,.R1);
%1262% R2 = .PTR[ELMNT2];
%1262%
%1262% ! R2 POINTS TO A 3-ITEM LIST
%1262% ! - PTR TO FIRST CONSTANT
%1262% ! - OPTION: LEXEME AFTER THE FIRST CONSTANT
%1262% ! - PTR TO LIST OF STUFF AFTER LEXEME
%1262% ! OPTION 1, COLON A(1:2)
%1262% ! STUFF IS A 2-ITEM LIST
%1262% ! - COLON LEXEME
%1262% ! - PTR TO UPPER BOUND CONSTANT
%1262% ! OPTION 2, COMMA A(1,2) A(1,2)(3:4) A(1,2,3)
%1262% ! STUFF IS A 2 OR 3-ITEM LIST
%1262% ! - PTR TO LIST OF SUBSCRIPT EXPRESSIONS
%1262% ! - OPTION. 0 = NO SUBSTRING EXPRESSIONS, 1 = SUBSTRING
%1262% ! - PTR TO 3-ITEM LIST OF SUBSTRING EXPRESSIONS IF OPTION 1
%1262% ! OPTION 3, RPAREN A(1) A(1)(2:3)
%1262% ! STUFF IS A 1 OR 2-ITEM LIST
%1262% ! - OPTION. 0 = NO SUBSTRING EXPRESSIONS, 1 = SUBSTRING
%1262% ! - PTR TO 3-ITEM LIST OF SUBSTRING EXPRESSIONS IF OPTION 1
%1262% ! SUBSTRING EXPRESSIONS, IF PRESENT
%1262% ! - PTR TO LOWER BOUND CONSTANT
%1262% ! - COLON LEXEME
%1262% ! - PTR TO UPPER BOUND CONSTANT
%1262%
%1262% CASE .R2[ELMNT1]-1 OF SET
%1262%
%1262% BEGIN ! OPTION 1, COLON
%1262% T1 = .R2[ELMNT]; ! FIRST EXPR IS LOWER BOUND
%1262% IF .T1 EQL 0 THEN T1 = .ONEPLIT; ! IF OMITTED, USE 1
%1262% EPTR[EQLSSTRING] = 1; ! SET FLAG, SUBSTRING PRESENT
%1262%
%1740% ! Lower bound must be integer constant. If
%1740% ! not, see if it is a constant expression that
%1740% ! can be simplified.
%1740% T1 = CKEQVEXPR(.T1);
%1262%
%1262% EPTR[EQLLOWER] = .T1[CONST2] - 1; ! Lower bound
%1262%
%1262% ! Upper bound must be integer constant. This is
%1262% ! not used by later processing; don't keep it.
%1262% T1 = .R2[ELMNT2];
%1740% IF .T1[ELMNT1] NEQ 0
%1740% THEN CKEQVEXPR(.T1[ELMNT1]); ! Check it
%1262%
%1262% END; ! OPTION 1, COLON
%1262%
%1262% BEGIN ! OPTION 2, COMMA
%1262% T1 = .R2[ELMNT2]; ! GET PTR TO REST OF SUBSCRIPTS
%1262% T1 = .T1[ELMNT];
%1262% NAME<LEFT> = .T1<LEFT> + 2; ! ALLOCATE SPACE FOR FIRST
%1262% ! + REST
%1262% T2 = CORMAN();
%1262% T2<LEFT> = .T1<LEFT> + 1; ! SET SUBSCRIPT COUNT
%1262% EPTR[EQLLIST] = .T2; ! SAVE POINTER TO SUBSCRIPT LIST
%1262% EPTR[EQLINDIC]= 1; ! SET FLAG, SUBSCRIPT IS PRESENT
%1262%
%1262% ! Copy each subscript
%1262%
%1740% ! Copy first subscript - must be integer constant
%1740% (.T2)<FULL> = CKEQVEXPR(.R2[ELMNT]);
%1262%
%1262% INCR I FROM .T2+1 TO .T2+.T2<LEFT> DO
%1262% BEGIN ! Copy rest of subscripts
%1740%
%1740% ! Must be integer constant
%1740% (.I)<FULL> = CKEQVEXPR(.T1[ELMNT]);
%1740%
%1262% T1 = .T1 + 1; ! Next subscript
%1262%
%1262% END; ! Copy rest of subscripts
%1262%
%1262% T1 = .R2[ELMNT2]; ! GET POINTER TO OPTION WORD
%1262% IF .T1[ELMNT1] NEQ 0 ! IF SUBSTRING BOUNDS PRESENT
%1262% THEN
%1262% BEGIN ! Substring
%1262%
%1262% T1 = .T1[ELMNT2]; ! Get ptr to expressions
%1262%
%1262% ! Get lower bound
%1262% T2 = .T1[ELMNT];
%1262% IF .T2 EQL 0 THEN T2 = .ONEPLIT;
%1262%
%1740% ! Lower bound must be integer
%1740% ! constant. If not, see if it is a
%1740% ! constant expression that can be
%1740% ! simplified.
%1740% T2 = CKEQVEXPR(.T2); ! New const
%1262%
%1262% EPTR[EQLLOWER] = .T2[CONST2] - 1; ! SAVE LOWER BOUND
%1262% EPTR[EQLSSTRING] = 1; ! SET FLAG, SUBSTRING PRESENT
%1262%
%1740% ! Check upper bound, it must be an
%1740% ! integer constant. Upper bound not used
%1740% ! anywhere else.
%1740% IF .T1[ELMNT2] NEQ 0
%1740% THEN CKEQVEXPR(.T1[ELMNT2]);
%1262%
%1262% END; ! SUBSTRING
%1262% END; ! OPTION 2, COMMA
%1262%
%1262% BEGIN ! OPTION 3, RIGHT PAREN
%1262% EPTR[EQLLIST] = .PTR[CW2R]; ! SAVE PTR TO SUBSCRIPT LIST
%1262% EPTR[EQLINDIC]= 1; ! SET FLAG, SUBSCRIPT IS PRESENT
%1262%
%1740% ! Array ref subscript must be integer constant.
%1740% ! If not, try to simplify.
%1740% R2[ELMNT] = CKEQVEXPR(.R2[ELMNT]); ! Check
%1262%
%1262% T1 = .R2[ELMNT2]; ! GET POINTER TO OPTION WORD
%1262% IF .T1[ELMNT] NEQ 0 ! IF SUBSTRING BOUNDS PRESENT
%1262% THEN
%1262% BEGIN ! SUBSTRING
%1262% T1 = .T1[ELMNT1]; ! GET PTR TO EXPRESSIONS
%1262% T2 = .T1[ELMNT]; ! GET LOWER BOUND
%1262% IF .T2 EQL 0 THEN T2 = .ONEPLIT;
%1262%
%1740% ! Lower bound must be integer
%1740% ! constant. If not, see if it is a
%1740% ! constant expression that can be
%1740% ! simplified.
%1740% T2 = CKEQVEXPR(.T2);
%1262%
%1262% EPTR[EQLLOWER] = .T2[CONST2] - 1; ! Lower bound
%1262% EPTR[EQLSSTRING] = 1; ! Flag: substring present
%1262%
%1262% ! Check upper bound. It must be a
%1262% ! constant. Not used in later
%1262% ! equivalence processing.
%1262%
%1740% IF .T1[ELMNT2] NEQ 0
%1740% THEN CKEQVEXPR(.T1[ELMNT2]);
%1262%
%1262% END; ! SUBSTRING
%1262%
%1262% END ! OPTION 3, RIGHT PAREN
%1262%
%1262% TES;
END ! Item is subscript or substring
ELSE
BEGIN ! Item not subscripted
IF NAMSET(VARYREF,.R1) LSS 0 THEN RETURN .VREG; !NAME CONFLICT
EPTR[EQLDISPL] = 0;
END;
RETURN .EPTR
END; ! of GEQITEM
GLOBAL ROUTINE EQUISTA=
BEGIN
LOCAL BASE T1;
REGISTER BASE R1 :R2;
MACRO ERR52 = ( FATLEX(E52<0,0>))$,
ERR53 = ( FATLEX(E53<0,0>))$;
!MACRO GENERATES AN EQUIVALENCE GROUP ENTRY
!ENTRIES ARE LINKED BY NEWENTRY()
!
MACRO GEQGROUP(EPTR)=
BEGIN
NAME = EQVTAB; ENTRY = R1 = EPTR;
R2 = NEWENTRY();
R1 = EPTR[EQLID];
IF .R1[IDATTRIBUT(INCOM)] THEN (R2[EQVINCOM]=1;
R2[EQVHEAD] = EPTR;
);
R2[EQVISN] = .ISN; !LINE NUMBER FOR POSSIBLE ERROR MESSAGES
.R2
END$;
!
LOCAL BASE GRUPHD;
LOCAL BASE ELISTPTR :EGROUP; !PTR TO LAST EQUIV ITEM ENTRY
%2240% LOCAL BASE COMPTR; !Ptr to Common Block Entry
!SEMANTIC ANALYSIS BEGINS
T1 = @.STK[0]; !LIST PTR TO LIST OF EQV GROUPS
INCR GROUP FROM .T1 TO .T1+.T1<LEFT> DO
BEGIN MAP BASE GROUP;
!EACH EQUIV GROUP IS COMPOSED OF 2 PARTS:
!1. APTR TO THE FIRST EQUIV ITEM AND A LIST PTR TO A LIST
! OF EQUIV ITEM PTRS
!EACH EQUIV ITEM IS A PTR TO A LIST
! .IDENTIFIER
! .OPTION (0 OR 1)
! .PTR TO SUBSCRIPT OR SUBSTRING EXPRESSION LISTS PTR
! (IF OPTION 1)
!
GRUPHD = .GROUP[ELMNT];
IF (ELISTPTR = GEQITEM(.GRUPHD[ELMNT])) LSS 0 THEN RETURN -1; !GENERATE AN EQUIVALENCE ITEM NODE
EGROUP = GEQGROUP(.ELISTPTR); !MACRO GENERATES AN EQUIVALENCE GROUP ENTRY
R1 = .GRUPHD[ELMNT1]; !PTR TO LIST EQUIVALENCED TO "GRUPHD"
INCR LST FROM .R1 TO .R1+.R1<LEFT> DO
BEGIN !PROCESS LIST OF ITEMS EQUIVALENCE TO GROUP HEAD
MAP BASE LST;
ELISTPTR = .EGROUP[EQVLAST]; !PTR TO LAST ITEM IN GROUP
IF (R2 = GEQITEM(.LST[ELMNT])) LSS 0 THEN RETURN -1;
R1 = .R2[EQLID]; !PTR TO SYMBOL NODE
IF .R1[IDATTRIBUT(INCOM)]
THEN IF .EGROUP[EQVINCOM] THEN FATLEX(E48<0,0>) !TWO ITEMS IN COMMON
ELSE (EGROUP[EQVINCOM] = 1;
%2240% COMPTR = .R1[IDCOMMON];
%2240% EGROUP[EQVPSECT] = .COMPTR[COMPSECT];
% MOVE THE ONE IN COMMON TO THE HEAD OF THE LIST
SO THAT THE CALCULATION OF ITS DISPLACEMENT WILL
BE ASSURED WHEN THINGS ARE MOVED INTO COMMON %
R2[EQLLINK] = .EGROUP[EQVFIRST];
EGROUP[EQVFIRST] = EGROUP[EQVHEAD] = .R2
)
ELSE
BEGIN
% LINK IT TO THE END OF THE LIST%
ELISTPTR[EQLLINK] = EGROUP[EQVLAST] = .R2
END;
END; !END OF INCR LST...
END; !END OF INCR GROUP
[email protected][0];
SAVSPACE(.T1<LEFT>,.T1); SAVSPACE(0,.STK[0]);
.VREG
END; ! of EQUISTA
GLOBAL ROUTINE EXTESTA=
BEGIN
! This routine performs semantic analysis of the EXTERNAL statement.
%1464% REGISTER BASE T1:T2, ERROR;
%1464% LOCAL STMTERROR;
%1464% STMTERROR = FALSE; ! Assume no error in the EXTERNAL statement
INCR EXLST FROM .(@STK[0])<RIGHT> TO .(@STK[0])<RIGHT>+.(@STK[0])<LEFT>
DO
BEGIN ! Process a list of externals
MAP BASE EXLST;
%1464% ERROR = FALSE; ! Assume that there is no error for this name
T1 = .EXLST[ELMNT]; ! Pointer to option - ID BLOCK
IF .T1[ELMNT] EQL 0
THEN
BEGIN ! No ampersand or asterisk
T2 = .T1[ELMNT1];
! Test the /F77 switch.
%1464% IF F77
%1464% THEN
%1464% BEGIN ! Compiled /F77
! All names in the external statement name
! user routines. Use NAMDEF to make sure
! there are no conflict in attributes. Note
! the EXTDEFS mask does not allow COMMON blocks
! to have that same name as the routine.
IF NAMDEF(EXTDEFS,.T2) LSS 0
%1464% THEN STMTERROR = ERROR = TRUE
%1476% ELSE
%1501% BEGIN
%1501% T2[IDATTRIBUTE(INEXTERN)] = 1;
%1476% T2[IDATTRIBUTE(USERFUNCTION)] = 1
%1501% END
%1464% END ! of compiled /F77
%1464% ELSE
%1464% BEGIN ! Compiled /NOF77
! The names in the statement name either user
! routines or intrinsic routines. Use NAMDEF
! to make sure there are no conflicts in the
! attributes. Note the mask EXTDEF does allow
! a common block to have the same name as the
! routine.
IF NAMDEF(EXTDEF,.T2) LSS 0
%1464% THEN STMTERROR = ERROR = TRUE
%1464% ELSE T2[IDATTRIBUT(INEXTERN)] = 1;
%1464% END; ! of compiled /NOF77
END ! No ampersand or asterisk
ELSE
BEGIN ! Ampersand of asterisk before name
! Since there is an ampersand or asterisk before the
! name, the name names a user routine.
! Skip past the ampersand or asterisk to get name.
IF .T1[ELMNT] EQL 2
%2252% THEN ! Asterisk
%2252% BEGIN
%2252% IF FLAGEITHER ! Compatibility flagger
%2252% THEN CFLAGB(UPLIT '*?0',E286<0,0>);
%2252% T2 = .T1[ELMNT2] !SKIP *
%2252% END
%2252% ELSE ! Ampersand
%2252% BEGIN
%2252% IF FLAGEITHER ! Compatibility flagger
%2252% THEN CFLAGB(UPLIT '&?0',E286<0,0>);
%2252% T2 = .T1[ELMNT1] !SKIP &
%2252% END;
! Make sure there are no conflicts in the names
! attributes. EXTDEFS does not allow a common
! block to have the same name as the user routine.
IF NAMDEF( EXTDEFS, .T2 ) LSS 0
%1464% THEN STMTERROR = ERROR = TRUE
%1464% ELSE
%1501% BEGIN
%1501% T2[IDATTRIBUTE(INEXTERN)] = 1;
%1464% T2[IDATTRIBUT(USERFUNCTION)] = 1
%1501% END
END; ! of ampersand of asterisk before name
%1464% IF NOT .ERROR
%1464% THEN
%1464% BEGIN ! Set name's OPERSP field
T2[OPERSP] = IF .T2[IDATTRIBUT(DUMMY)]
THEN FORMLFN
ELSE FNNAME;
%1511% ! Check for error conflict with SAVE statements
%1511% ! variable can't be in both
%1511% IF .T2[IDSAVVARIABLE]
%1511% THEN FATLERR(.T2[IDSYMBOL],
%1531% UPLIT(ASCIZ'EXTERNAL name'),
%1511% .ISN,E192<0,0>);
%1464% END; ! of set name's OPERSP field.
SAVSPACE(.T1<LEFT>,@T1<RIGHT>)
END; ! of process a list of externals
SAVSPACE( .(@STK[0])<LEFT>, .(@STK[0])<RIGHT> );
SAVSPACE( 0, .STK[0]<RIGHT> );
%1464% RETURN (IF .STMTERROR THEN -1 ELSE 0)
END; ! of EXTESTA
GLOBAL ROUTINE INTRSTA=
BEGIN
! [1464] Written by RVM, 26-Jan-82
! This routine performs semantic analysis of the INTRINSIC
! statement.
REGISTER BASE IDENTIFIER, STMTERROR, FNINDEX;
MAP LIBATTSTR LIBATTRIBUTES;
%1515% MACRO ERR15(S) = FATLEX(UPLIT ASCIZ S,IDENTIFIER[IDSYMBOL], E15<0,0>)$;
STMTERROR = FALSE; ! Assume no errors in the INTRINSIC statement
INCR LST FROM .(@STK[0])<RIGHT> TO .(@STK[0])<RIGHT> + .(@STK[0])<LEFT>
DO
BEGIN ! Process list of identifiers
MAP BASE LST;
! Get the STE for this identifier.
IDENTIFIER = .LST[ELMNT];
! Use NAMDEF to check the attributes of this identifier.
%1514% ! Note that the INTRSCDEF mask allows an intrinsic routine
%1514% ! to have the same name as a common block, but not to have
%1514% ! have the same name as a formal argument.
%1514% IF NAMDEF(INTRSCDEF,.IDENTIFIER) LSS 0
THEN STMTERROR = TRUE
ELSE
BEGIN ! No conflicts in attributes
! Use SRCHLIB to make sure that this identifier
! is indeed the name of an INTRINSIC routine.
IF (FNINDEX = SRCHLIB(.IDENTIFIER)) EQL -1
THEN
BEGIN ! Identifier is not an INTRINSIC routine
STMTERROR = TRUE;
%1515% ERR15('the name of an intrinsic function')
END ! of identifier is not an INTRINSIC routine
ELSE
%1515% IF .LIBATTRIBUTES[.FNINDEX-LIBFUNTAB<0,0>, ATTSPGEN]
%1515% THEN
%1515% BEGIN ! Non-specific, generic name is illegal
%1515% STMTERROR = TRUE;
%1515% ERR15('the name of a non-generic function')
%1515% END ! of non-specific, generic name is illegal
%1515% ELSE
BEGIN ! Set up the attributes of this identifier.
IDENTIFIER[IDATTRIBUT(INEXTERN)] = 1;
%1511% ! Can't also be in SAVE statement
%1511% IF .IDENTIFIER[IDSAVVARIABLE]
%1511% THEN FATLERR(.IDENTIFIER[IDSYMBOL],
%1531% UPLIT(ASCIZ'INTRINSIC name'),
%1511% .ISN,E192<0,0>);
IDENTIFIER[OPERSP] =
IF .IDENTIFIER[IDATTRIBUT(DUMMY)]
THEN FORMLFN
ELSE FNNAME;
END; ! of set up the attributes of this identifier.
END; ! of no conflicts in attributes
END; ! of Process list of identifiers
SAVSPACE( .(@STK[0])<LEFT>, .(@STK[0])<RIGHT> );
SAVSPACE( 0, .STK[0]<RIGHT> );
RETURN (IF .STMTERROR THEN -1 ELSE 0)
END; ! of INTRSTA
GLOBAL ROUTINE DUMYIDMOD=
BEGIN
! Fixes up the valtype of dummy variables after an IMPLICIT
! statement was processed.
REGISTER BASE R1:R2:T2;
%1413% LOCAL ARGUMENTLIST ARGLST;
! Do the function name if present
R1 = .SORCPTR<RIGHT>; ! FUNCTION statement
R2 = .R1[ENTSYM]; ! Symbol table entry for the function/entry
%1434% ARGLST = .R1[ENTLIST]; ! Pointer to the argument list
IF NOT .R2[IDATTRIBUT(INTYPE)]
THEN
BEGIN
T2 = .R2[IDSYMBOL]<30,6>; ! First character of symbol
%1213% ! Pick up datatype and character count from TYPTABle
%1213% R2[VALTYPE] = .TYPTAB[2 * (.T2 - SIXBIT"A")]<RIGHT>;
%1213% IF .R2[VALTYPE] EQL CHARACTER
%1616% AND .FLGREG<PROGTYP> EQL FNPROG
%1434% THEN
%1434% BEGIN ! Character function
%1434%
%1434% ! Make a character function argument list for
%1434% ! the return value of the funtion.
%1434%
%1434% R1[ENTLIST] = ARGLST = CHARGLIST(.ARGLST);
%1434%
%1434% ARGLST[1,ARGFULL] = .R2; ! Point first argument
%1434% ! to the function name
%1434%
%1434% R2[IDATTRIBUT(DUMMY)] = 1; ! Mark it as dummy arg
%2327% ! Set the psect fields. All formals (even character)
%2327% ! are in .DATA.. (IDPSCHARS should be ignored for all
%2327% ! formals.)
%2327% R2[IDPSECT] = PSDATA;
%2327% R2[IDPSCHARS] = PSOOPS;
%1434% ! Fill in the character length field
%1434%
%1434% R2[IDCHLEN] = .TYPTAB[2 * (.T2 - SIXBIT"A") + 1];
%1434%
%1434% END; ! Character function
END;
! Now the dummy arguments
%1413% IF .ARGLST NEQ 0 ! ARGLST points to argument list
THEN
%1413% DECR I FROM .ARGLST[ARGCOUNT] TO 1 DO
BEGIN
%1413% R2 = .ARGLST[.I,ARGNPTR]; ! Pointer to arg
T2 = .R2[IDSYMBOL]<30,6>;
%1434% IF NOT .R2[IDATTRIBUT(INTYPE)]
%1434% THEN
%1434% BEGIN ! Variable has not been declared
%1213% ! Pick up datatype and character count from TYPTABle
%1213% R2[VALTYPE] = .TYPTAB[2 * (.T2 - SIXBIT"A")]<RIGHT>;
%1213% IF .R2[VALTYPE] EQL CHARACTER
%1213% THEN R2[IDCHLEN] = .TYPTAB[2 * (.T2 - SIXBIT"A") + 1];
%1434% END; ! Variable has not been declared
END;
END; ! of DUMYIDMOD
GLOBAL ROUTINE IMPLSTA=
BEGIN
! IMPLICIT statement proccessing
REGISTER BASE R1;
! Semantic analysis begins
IF (R1 = .SORCPTR<RIGHT>) NEQ 0
THEN ( IF .R1[SRCID] EQL ENTRID
THEN DUMYIDMOD(); )
ELSE ( %SET TYPE OF PROGRAM OR BLOCK DATA NAMES JUST INCASE %
REGISTER BASE T2;
IF .PROGNAME NEQ SIXBIT'MAIN.' AND
.PROGNAME NEQ SIXBIT'.BLOCK'
THEN
BEGIN
ENTRY = .PROGNAME;
NAME = IDTAB;
R1 = TBLSEARCH();
T2 = .R1[IDSYMBOL]<30,6>; !FIRST CHARACTER
%1213% ! Pick up datatype and character count from TYPTABle
%1213% R1[VALTYPE] = .TYPTAB[2 * (.T2 - SIXBIT"A")]<RIGHT>;
%1213% IF .R1[VALTYPE] EQL CHARACTER
%1213% THEN R1[IDCHLEN] = .TYPTAB[2 * (.T2 - SIXBIT"A") + 1];
END
);
.VREG
END; ! of IMPLSTA
!GLOBAL ROUTINE GLOBSTA=
!BEGIN
!!
!! ROUTINE COMMENTED IN 1(41)-116
!!
!! EXTERNAL STK,BLDARRAY %(ONEARRAY LIST)%,SAVSPACE %(SIZE,LOC)%,TYPE;
!! MAP BASE T1;MACRO ELMNT=0,0,FULL$;
! BIND GLOBPLIT= PLIT'GLOBAL';
!%1(41)-117% ENTRY[1]=GLOBPLIT;
!%1(41)-117% ERROUT(73);!STATEMENT NOT YET SUPPORTED
!!
!! COMMENT REST OF ROUTINE IN EDIT 1(41)-114
!!
!! IF SCAN(PLIT'AL') LSS 0 THEN (ENTRY[1]=GLOBPLIT;ERROUT(E12));
!! IF SYNTAX(GLOBALSPEC) LSS 0 THEN RETURN -1;
!!SEMANTIC ANALYSIS BEGINS
!! IDTYPE=-1;TYPE=1;T1=.STK[0];
!! BLDARRAY(.T1[ELMNT]);SAVSPACE(0,@STK[0]);
!! .VREG
!%1(41)-117% RETURN -1
!END;
GLOBAL ROUTINE NAMESTA=
BEGIN
%
ROUTINE EXPECTS STK[0] TO CONTAIN A POINTER TO ALIST POINTER
OF THE FORM (COUNT,,PTR). THE LIST PTR POINTS TO A LIST OF
COUNT+1 POINTERS THAT EACH POINT TO A 4 WORD BLOCK OF THE FORM:
0. /
1. NAMELIST NAME PTR
2. /
3. LIST POINTER (COUNT,,LISTPTR)
WHERE THE LIST POINTER IN 3. POINTS TO ALIST OF IDENTIFIER PTRS
THAT ARE THE ITEMS IN THE NAMELIST
%
MACRO ERR58(X)=FATLEX(X,E58<0,0>)$;
REGISTER BASE R1:R2;
LOCAL BASE T1:T2;
!SEMANTIC ANALYSIS BEGINS
%2252% IF FLAGANSI THEN WARNERR(.ISN,E254<0,0>); !Compatibility flagger
T1 = @.STK[0]; !GET PTR TO NAMELIST BLOCK
INCR NLST FROM .T1 TO .T1+.T1<LEFT> DO
BEGIN
MAP BASE NLST;
T1 = .NLST[ELMNT]; !PTR TO BLOCKLIST NAME
R1 = .T1[ELMNT1]; !PTR TO NAMELIST NAME
IF NAMDEF(NMLSTDEF, .R1) LSS 0 THEN RETURN .VREG;
R1[IDATTRIBUT(NAMNAM)] = 1;
R2 = .T1[ELMNT3]; !PTR TO LIST OF NAMELST ANME PTRS
SAVSPACE(.T1<LEFT>,.T1);
INCR ILST FROM .R2 TO .R2+.R2<LEFT> DO
BEGIN
MAP BASE ILST;
T2 = .ILST[ELMNT]; !GET PTR TO NAMELIST ITEM
!CHECK FOR ILLEGAL NAMES
%2270% ! Remove this test
%2270% ! (What was it doing? -- NAMDEF doesn't return positive value)
%2270% ! IF NAMDEF(NMLSTITM,.T2) GTR 0 !CHECK FOR NAMELIST ITEM
%2270% ! THEN ILST[ELMNT]<LEFT> = 0;
%2270% IF NAMDEF(NMLSTITM,.T2) EQL 0 ! If item is ok,
%2270% THEN T2[IDATTRIBUTE(INNAM)]=1; ! set 'in NAMELIST'
END; !END OF INCR ILST
NAME = NAMTAB; T2 = NEWENTRY();
T2[NAMLIST] = .R2<RIGHT>;
T2[NAMCNT] = .R2<LEFT>+1;
T2[NAMLID] = .R1; !NAMLIST NAME
R1[IDCOLINK]=.T2; !SET POINTER IN NAMELIST NAME ENTRY
END; !OF INCR NLST
T1 = @.STK[0]; SAVSPACE(.T1<LEFT>,.T1); SAVSPACE(0,.STK[0]);
.VREG
END; ! of NAMESTA
GLOBAL ROUTINE SKIPSTA=
BEGIN
REGISTER R;
BIND DUM = PLIT( REC NAMES 'RECORD?0', FIL NAMES 'FILE?0' );
R = SKIPDATA;
LOOK4CHAR = REC<36,7>;
DECR I FROM 1 TO 0
DO
BEGIN
IF LEXICAL(.GSTSSCAN) NEQ 0
THEN
BEGIN % GOT ONE %
%2247% IF FLAGEITHER
%2247% THEN !Compatibility check
%2247% BEGIN
%2247% IF .R EQL SKIPFDATA
%2252% THEN CFLAGB((PLIT 'SKIPFILE?0')<0,0>,E268<0,0>)
%2252% ELSE CFLAGB((PLIT 'SKIPRECORD?0')<0,0>,E268<0,0>)
%2247% END;
IF SYNTAX(UTILSPEC) LSS 0 THEN RETURN .VREG;
RETURN BLDUTILITY(.R)
END;
R = SKIPFDATA; ! TRY FILE
LOOK4CHAR = FIL<36,7>
END;
RETURN FATLEX(E12<0,0>); !MISSPELLED
END; ! of SKIPSTA
GLOBAL ROUTINE UNLOSTA=
BEGIN
!SEMANTIC ANALYSIS BEGINS
%2247% IF FLAGEITHER !Compatibility check
%2252% THEN CFLAGB((PLIT 'UNLOAD')<0,0>,E268<0,0>);
BLDUTILITY(UNLODATA);
.VREG
END; ! of UNLOSTA
GLOBAL ROUTINE DOLOOP=
BEGIN
REGISTER BASE T1:T2;
REGISTER BASE R1:R2;
LOCAL BEFOREDO; !HOLDS DO PREDECESSOR
LOCAL DOSTMTPTR; !POINTS TO CREATED DO STMT NODE
MACRO
LBLPTR=0,0,RIGHT$,
INDX=0,1,FULL$,
INITIAL=0,2,FULL$,
FINAL=0,3,FULL$,
INCROPT=0,4,FULL$,
INCREMENT=0,5,FULL$;
!------------------------------------------------------------------------------------------------------------------
! THE SYNTAX ROUTINE RETURNS A POINTER IN STK[0] WHICH POINTS TO THE LIST
!
![1573] OPTION 0 - LABEL ABSENT, OR OPTION 1 - LABEL PRESENT
![1573] POINTER TO:
! LABEL(21^18+LOC) - LABEL OF DO TERMINAL STATEMENT
![1271] OPTION 0 - COMMA ABSENT, OR OPTION 1 - COMMA PRESENT
! IDENTIFIER(20^18+LOC) - DO INDEX
! EXPRESSION(1^18+LOC) - POINTER TO POINTER TO INITIAL VALUE OF DO INDEX
! EXPRESSION(1^18+LOC) - POINTER TO POINTER TO FINAL VALUE OF DO INDEX
! OPTION 0 - INCREMENT OF DO INDEX IS ONE
! OPTION 1 - INCREMENT OF DO INDEX IS EXPRESSION FOLLOWING
! LIST(1^18+LOC) - POINTER TO POINTER TO POINTER TO INCREMENT OF DO INDEX
!------------------------------------------------------------------------------------------------------------------
T1=.STK[0]; !T1=LOC(LIST)
%1573% IF .T1[ELMNT] NEQ 0 ! if optional label is present
%1573% THEN
%1573% BEGIN ! label specified
%1573% T1 = .T1+1; ! advance over option word
R2=.T1[LBLPTR]; ! get pointer to label
R1 = .R2[ELMNT]; ! get label table entry
%1573% SAVSPACE(.R2<LEFT>,.R2) ! free up pointer word
%1573% END ! label specified
%1573% ELSE
%1573% BEGIN ! label omitted
%2252% IF FLAGANSI THEN WARNERR(.ISN,E230<0,0>); !Compatibility flagger
%1573% R1 = GENLAB(); ! use created (nM) label
%1573% R1[SNREF] = .R1[SNREF] + 1; ! count this reference to it
%1573% END; ! label omitted
R2=.T1[INDX];
IF (T2=.R1[SNHDR]) NEQ 0 THEN !ERROR DO TERMINAL ALREADY SEEN
FATLEX(.T2[SRCISN],.R1[SNUMBER],E20<0,0>); !DON'T RETURN
IF .R1[SNUMBER] EQL .STALABL THEN !IF IT'S THE NUMBER ON THIS STATEMENT
FATLEX(.ISN,.R1[SNUMBER],E20<0,0>); !FATAL ERROR
%1260% IF .R2[VALTYPE] EQL CHARACTER ! CAN'T HAVE INDEX OF TYPE CHAR
%1260% THEN RETURN FATLEX(E163<0,0>); ! "Ill comb of char and numeric"
IF CKDOINDEX(.R2<RIGHT>)
THEN RETURN FATLEX( R2[IDSYMBOL], E21<0,0>); !DO INDEX ALREADY ACTIVE
IF NAMSET(VARIABL1, .R2) LSS 0 THEN RETURN .VREG;
BEFOREDO = .SORCPTR<RIGHT>; !PTR TO STATEMENT NODE PRECEDING DO
NAME=IDOFSTATEMENT=DODATA;NAME<RIGHT>=SORTAB;
DOSTMTPTR = T2 = NEWENTRY();
BEGIN ![1214] PUSH NODE ON DOIFSTK FOR THIS DO
MAP DINODE T2;
NAME<LEFT> = DISIZE; ! MAKE NEW DO NODE
T2 = CORMAN();
T2[DITYPE] = DIDOTYPE; ! SET NODE TYPE TO DO
T2[DISTMT] = .DOSTMTPTR; ! SET STMT PTR TO STATEMENT NODE
T2[LASTDOLBL] = .R1; !SET LABEL OF TERMINAL STATEMENT
T2[CURDONDX] = .R2; !SET LOOP INDEX
LASDOLABEL = .R1;
CURDOINDEX = .R2;
T2[DILINK] = .DOIFSTK; ! LINK NEW NODE INTO DOIFSTK
T2[DIBLINK] = 0; ! SET FWD AND BACK LINKS OF NEW NODE
IF .DOIFSTK NEQ 0 THEN DOIFSTK[DIBLINK] = .T2; ! BACK LINK OF OLD TOP NODE
DOIFSTK = .T2; ! POINT DOIFSTK TO NEW INNERMOST NODE
END;
T2 = .DOSTMTPTR; ! RESTORE PTR TO DO STMT NODE
T2[DOPRED] = IF .BEFOREDO EQL 0 THEN .SORCPTR<LEFT> ELSE .BEFOREDO; !LINK IN PREVIOUS STATEMENT NODE
DONESTLEVEL = .DONESTLEVEL+1;
T2[DOSYM]=.R2;T2[DOLBL]=.R1;
R2=.R1[SNDOLNK];R1[SNDOLVL]=.R1[SNDOLVL]+1;NAME<LEFT>=1;R1[SNDOLNK]=CORMAN();
(@VREG)<LEFT>=@T2;(@VREG)<RIGHT>=@R2;
R1=.T1[INITIAL];R2=.T1[FINAL];T2[DOM1]=.R1%[ELMNT]%;T2[DOM2]=.R2%[ELMNT]%;
! SAVSPACE(.R1<LEFT>,@R1);SAVSPACE(.R2<LEFT>,@R2);
IF .T1[INCROPT] NEQ 0 THEN
BEGIN
R1=.T1[INCREMENT];T2[DOM3]=.R1[ELMNT];
SAVSPACE(.R1<LEFT>,.R1);
END ELSE T2[DOM3]=.ONEPLIT;
SAVSPACE(.STK[0]<LEFT>,.STK[0]);
ADDLOOP(.DONESTLEVEL); !FOR OPTIMIZER
DOXPN(.T2<RIGHT>); !CREATE THE NODE FOR THE DO INITIALIZATION CODE
.VREG
END; ! of DOLOOP
GLOBAL ROUTINE WHILSTA= ! [1573] New
! Semantic routine for DO WHILE statement
!
! STK points to a 2-word block containing
! statement label of terminal statement or 0
! while expression
!
! This routine generates an IF NOT to test the condition and pushes a
! WHILE node onto DOIFSTK with the labels of the IF NOT statement and the
! (not yet generated) CONTINUE statement at the end.
BEGIN
REGISTER DINODE R1;
REGISTER BASE T1:T2;
MAP BASE LABLOFSTATEMENT;
%2252% IF FLAGANSI THEN WARNERR(.ISN,E227<0,0>); !Compatibility flagger
! If the DO WHILE is labeled, generate a CONTINUE to hang the label on
IF .LABLOFSTATEMENT NEQ 0
THEN CONTGEN(.LABLOFSTATEMENT);
! Generate a logical IF. Push a pointer to it on DOIFSTK.
NAME<LEFT> = DISIZE; ! Create DINODE
R1 = CORMAN();
R1[DILINK] = .DOIFSTK; ! Link it into DOIFSTK
R1[DIBLINK] = 0;
IF .DOIFSTK NEQ 0 THEN DOIFSTK[DIBLINK] = .R1;
DOIFSTK = .R1;
R1[DITYPE] = DIWHILETYPE; ! Set type = WHILE
R1[TOPLBL] = GENLAB(); ! Generate label for top of loop
R1[BOTLBL] = GENLAB(); ! Generate label for bottom of loop
T1 = .STK[0]; ! Get pointer to semantic info
R1[BOTSTMT] = T2 = .T1[ELMNT]; ! Statement label of terminal stmt
STK[0] = T1[ELMNT1]; ! Set expr pointer for IFNOTGEN
! Label in DO 10 WHILE has been counted and shouldn't be, adjust count
IF .T2 NEQ 0 THEN
BEGIN
T2[SNREF] = .T2[SNREF] - 1; ! Adjust count
T2[SNWHILE] = 1; ! Mark stmt label as terminating a
! DO WHILE
%2252% END
%2252% ELSE ! No terminating label, so flag the extension
%2252% IF FLAGANSI THEN WARNERR(.ISN,E230<0,0>);
! Label the IF (.NOT. ) with TOPLBL, jumped to from the bottom
! of the loop.
LABLOFSTATEMENT = .R1[TOPLBL];
STALABL = .LABLOFSTATEMENT[SNUMBER];
R1[DISTMT] = IFNOTGEN(.R1[BOTLBL]);
! Generate IF (.NOT. EXPR) GOTO BOTLBL
END; ! WHILSTA
GLOBAL ROUTINE ENDDSTA= ! [1573] New
! Semantic routine for END DO statement.
!
! END DO terminates the innermost enclosing DO, found by looking at DOIFSTK.
! The top entry must be a DO, otherwise we have a nesting error. If the DO
! is controlled by a statement label, the label must match the END DO,
! otherwise we have a nesting error.
!
! If the END DO is labeled but the DO isn't, change the unlabeled DO to a
! labeled DO. Otherwise both DO and END DO must be unlabeled or both must be
! labeled and the labels must match. In either case, turn the END DO into a
! CONTINUE.
!
! After creating a CONTINUE node, we can just return and let the code in
! DRIVER (in routine DOCHECK) do the work of popping the DO stack and
! matching up the CONTINUE with all appropriate DOs.
BEGIN
REGISTER BASE DOSTMT;
REGISTER DINODE DI;
REGISTER BASE R1:R2; ! Temporaries that get reused
MAP BASE LABLOFSTATEMENT;
%2252% IF FLAGANSI THEN WARNERR(.ISN,E231<0,0>); !Compatibility flagger
! END DO must be followed by LINEND
IF LEXEMEGEN() NEQ EOSLEX^18 THEN RETURN NOEOSERRV;
! Last DO or IF statement in source
DI = .DOIFSTK;
! Find closest enclosing DO or IF. Error if it's not a DO.
IF .DI EQL 0 THEN RETURN FATLEX(E204<0,0>); ! "No matching DO"
IF .DI[DITYPE] EQL DIIFTYPE ! If top of stack isn't a DO,
THEN ! improper nesting
BEGIN ! Error processing
R2 = .DI[DISTMT]; ! "IF at line <n> has not terminated"
FATLEX (.R2[SRCISN], E153<0,0>);
! Find the innermost DO, if any, and unlink it from the stack,
! thus matching the END DO with the closest preceding DO.
! Leave the IF where it is so the ENDIF, when seen, will
! terminate the IF properly.
DO DI = .DI[DILINK]
UNTIL (.DI[DITYPE] NEQ DIIFTYPE) OR (.DI EQL 0);
! DI points to closest enclosing DO, if any
IF .DI NEQ 0
THEN
BEGIN ! Found a DO to remove
%1647% MAP DINODE R2; ! ReMAP R2 for another purpose
IF (R2 = .DI[DIBLINK]) NEQ 0 ! Backwards link
THEN R2[DILINK] = .DI[DILINK]
ELSE DOIFSTK = .DI[DILINK];
IF (R2 = .DI[DILINK]) NEQ 0 ! Forwards link
THEN R2[DIBLINK] = .DI[DIBLINK];
SAVSPACE(DISIZE-1,.DI);
END; ! Found a DO to remove
RETURN -1; ! error
END; ! Error processing
! END DO matches a DO.
! Check consistency of statement labels.
DOSTMT = .DI[DISTMT]; ! Get pointer back to DO statement
R2 = IF .DI[DITYPE] EQL DIDOTYPE
THEN .DOSTMT[DOLBL]
ELSE .DI[BOTSTMT];
IF .R2[SNUMBER] GEQ 100000 THEN R2 = 0;
IF .R2 NEQ 0 ! If DO <label> form
THEN IF .R2 NEQ .LABLOFSTATEMENT ! and this isn't that label
THEN ! we have bad nesting
BEGIN ! bad nesting
FATLEX (.DOSTMT[SRCISN], E152<0,0>);
! "DO at line <n> has not terminated"
! Pop one DO off the stack, even though it doesn't match,
! in an attempt to keep the rest of the DOs and END DOs
! straight.
DOIFSTK = .DOIFSTK[DILINK];
SAVSPACE(DISIZE-1,.DI);
END; ! bad nesting
! Here we have a normal, legal END DO.
! If END DO is labeled, generate a CONTINUE with that label and let
! DOCHECK (in DRIVER) do the work. This is convenient because a
! labeled END DO could be terminating more than one loop.
IF .LABLOFSTATEMENT NEQ 0
THEN
BEGIN
IF .DI[DITYPE] EQL DIWHILETYPE
THEN
BEGIN
IF .DI[BOTSTMT] EQL 0
THEN
BEGIN
DI[BOTSTMT] = .LABLOFSTATEMENT;
LABLOFSTATEMENT[SNWHILE] = 1;
END;
END
ELSE
! If the END DO is labeled and the DO isn't, change the label
! on the DO to match the END DO.
IF .R2 EQL 0
THEN
BEGIN
R2 = .DOSTMT[DOLBL];
R2[SNDOLVL] = .R2[SNDOLVL] - 1;
R2[SNREF] = .R2[SNREF] - 1;
R1 = .R2[SNDOLNK];
R2[SNDOLNK] = .R1[RIGHTP];
DOSTMT[DOLBL] = .LABLOFSTATEMENT;
LABLOFSTATEMENT[SNDOLVL] = .LABLOFSTATEMENT[SNDOLVL] + 1;
LABLOFSTATEMENT[SNREF] = .LABLOFSTATEMENT[SNREF] + 1;
R1[RIGHTP] = .LABLOFSTATEMENT[SNDOLNK];
LABLOFSTATEMENT[SNDOLNK] = .R1;
DI[LASTDOLBL] = .LABLOFSTATEMENT;
END;
END
ELSE
BEGIN
IF .DI[DITYPE] EQL DIWHILETYPE
THEN
BEGIN
RETURN ENDWHILE(.DOIFSTK);
END
ELSE
BEGIN
LABLOFSTATEMENT = R2 = .DOSTMT[DOLBL];
STALABL = .R2[SNUMBER];
END;
END;
RETURN CONTGEN(.LABLOFSTATEMENT);
END; ! ENDDSTA
GLOBAL ROUTINE ENDWHILE (DI) = ! [1573] New
! Routine to generate GOTO at the bottom of DO WHILE loop.
! Removes node DI from DOIFSTK. DI must be a WHILE node.
BEGIN
MAP DINODE DI;
REGISTER DINODE Q, BASE R;
MAP BASE LABLOFSTATEMENT;
! Remove node DI from doubly linked stack
IF (Q = .DI[DIBLINK]) NEQ 0 ! link predecessor node to successor
THEN Q[DILINK] = .DI[DILINK]
ELSE DOIFSTK = .DI[DILINK];
IF (Q = .DI[DILINK]) NEQ 0 ! link successor node to predecessor
THEN Q[DIBLINK] = .DI[DIBLINK];
! Generate GOTO and CONTINUE
GOTOGEN(.DI[TOPLBL]);
R = CONTGEN(.DI[BOTLBL]);
R[SRCISN] = 0;
! Set LABLOFSTATEMENT and STALABL to the label of the generated
! CONTINUE statement so DRIVER doesn't get confused and wreck
! things
LABLOFSTATEMENT = .DI[BOTLBL];
STALABL = .LABLOFSTATEMENT[SNUMBER];
END; ! ENDWHILE
GLOBAL ROUTINE LOGICALIF=
BEGIN
LOCAL BASE IFEXPR,LASTTRUESRC,SAVLABEL,SAVDESC;
REGISTER BASE T1:T2;
IFEXPR = .STK[0]; !SAVING PTR TO EXPR PTR
!SEMANTIC ANALYSIS BEGINS
SAVDESC = @STMNDESC; ! SAVE THE STATMENT DESCRIPTION POINTER
%2412% IF LEXCLA( .GSTIFCLASIF ) EQL ENDOFILE<0,0> THEN ( STMNDESC = .SAVDESC; RETURN -1); ! UNRECOGNIZED STATEMENT
IF .BADIFOBJ ( @STMNDESC ) THEN ( STMNDESC=.SAVDESC; RETURN FATLEX(E23<0,0>)); ! ILLEGAL LOGICAL IF OBJECT
!
!STK[0] CONTAINS A PTR TO PTR TO PTR TO EXPRESSION NODE
!
STK[0] = .IFEXPR; !RESTORING THE PTR
T2=.STK[0];IFEXPR=.T2[ELMNT];SAVSPACE(.T2<LEFT>,.T2);LASTTRUESRC=.LASTSRC;
LOOK4LABEL = 0; !CLEAR LABEL FLAG
SP=-1; !RESET STK PTR FOR PARSE
SAVLABEL = .LABLOFSTATEMENT; LABLOFSTATEMENT = STALABL = 0;
%EXECUTE THE SYNTAX IF NECESSARY %
IF( T1 = .SYNOW(@STMNDESC)) NEQ 0
THEN IF SYNTAX(.T1) LSS 0
THEN (STMNDESC=.SAVDESC;LABLOFSTATEMENT=.SAVLABEL; RETURN -1);
IF (.STMNROUTINE(@STMNDESC))() LSS 0
THEN (LABLOFSTATEMENT=.SAVLABEL;STMNDESC=.SAVDESC; RETURN -1); !STATEMENT HAD AN ERROR
!------------------------------------------------------------------------------------------------------------------
! REMOVE THE FALSE SOURCE NODE FROM THE LINKED LIST OF SOURCE STATEMENTS
!------------------------------------------------------------------------------------------------------------------
STMNDESC = .SAVDESC; ! RESTORE THE STATEMENT DESCRIPTION POINTER
T1=.LASTSRC; IF .LASTTRUESRC EQL 0 THEN LASTSRC = .SORCPTR<LEFT> ELSE LASTSRC=.LASTTRUESRC;
IF .T1[SRCID] EQL SFNID %STATEMENT FUNCTION% THEN FATLEX(E23<0,0>);
LABLOFSTATEMENT = .SAVLABEL;
%1260% ! Don't allow character expression in condition.
%1263% ! Allow character constant and make it hollerith.
%1263% IF .IFEXPR[OPERATOR] EQL CHARCONST
%1263% THEN IFEXPR[OPERATOR] = HOLLCONST ! Make it hollerith
%1263% ELSE IF .IFEXPR[VALTYPE] EQL CHARACTER
%1260% THEN RETURN FATLEX(E164<0,0>); ! Character variable illegal
NAME=IDOFSTATEMENT=IFLDATA; NAME<RIGHT> = SORTAB;T2=NEWENTRY();
T2[LIFEXPR]=.IFEXPR;T2[LIFSTATE]=.T1;
IF .IFEXPR[OPRCLS]NEQ DATAOPR
THEN IFEXPR[PARENT] = .T2; !EXPR NODE POINTS TO SRC NODE
T1[SRCLBL] = 0; ! REMOVING ANY LABEL THE STATEMENT HAD FROM THE STATEMENT PART
END; ! of LOGICALIF
GLOBAL ROUTINE ARITHIF=
BEGIN
REGISTER BASE T1:T2;REGISTER BASE R1:R2;
MACRO IFEXPR=0,0,FULL$,LTLABEL=0,1,FULL$,EQLABEL=0,2,FULL$,
GTOPT=0,3,FULL$,GTLABEL=0,4,FULL$;
!SEMANTIC ANALYSIS BEGINS
T1=.STK[0]; !T1=LOC(LIST)
R1=.T1[LTLABEL];R2=.T1[EQLABEL];
IF .T1[GTOPT] NEQ 0
%2252% THEN ! Already have a third label
%2252% BEGIN
T2=.T1[GTLABEL];T1=.T2[ELMNT];SAVSPACE(.T2<LEFT>,@T2);
%2252% END
%2252% ELSE ! Generate a third label
%2252% BEGIN
%2252% IF FLAGEITHER THEN CFLAGB(E280<0,0>); !Compatibility flagging
%2252% T1=@R2; T1[SNREFNO]=.T1[SNREFNO]+1
%2252% END;
NAME=IDOFSTATEMENT=IFADATA;NAME<RIGHT>=SORTAB;T2=NEWENTRY();
T2[AIFLESS]=.R1<RIGHT>;
T2[AIFEQL]=.R2<RIGHT>;
T2[AIFGTR]=.T1<RIGHT>;
T1=.STK[0]; R1 = T2[AIFEXPR]=.T1[ELMNT];
%1260% ! Don't allow character expression in condition.
%1263% ! Allow character constant and make it hollerith.
%1263% IF .R1[OPERATOR] EQL CHARCONST
%1263% THEN R1[OPERATOR] = HOLLCONST ! Make it hollerith
%1263% ELSE IF .R1[VALTYPE] EQL CHARACTER
%1260% THEN RETURN FATLEX(E164<0,0>); ! Character variable illegal
!
!CHECK TO POINT BACK TO SRC NODE
!
IF .R1[OPRCLS] NEQ DATAOPR
THEN R1[PARENT] = .T2; !EXPR POINTS BACK TO SRC NODE
%(**CHECK FOR COMPLEX EXPRESSION - THIS IS ILLEGAL**)%
IF .R1[VALTYPE] EQL COMPLEX THEN WARNLEX(E99<0,0>);
SAVSPACE(.T1<LEFT>,@T1);
END; ! of ARITHIF
![1214] ADD ROUTINES BLOCKIF, ELSESTA, ENDISTA
GLOBAL ROUTINE BLOCKIF=
!Translate IF (...) THEN into internal form using logical IF and GOTO
!statements. If the block IF is labeled, attach the label to the logical IF.
!Assign the ISN of the block IF to the the logical IF, set the ISN of the GOTO
!to zero.
!
!Generate two labels, THENLBL and ENDLBL. THENLBL will be defined at the next
!ELSE, ELSEIF, or ENDIF encountered. ENDLBL will be defined at the ENDIF.
!THENLBL is where the IF should go if the condition is false, ENDLBL is where
!all THEN and ELSE branches go at their end.
BEGIN
BIND THENPLIT = UPLIT('THEN?0');
REGISTER DINODE R1;
! Have read IF( <EXPRESSION> )
! Expression node is in .STK[0]
! Statement has been classified block IF, so we must have THEN <EOS> next.
! Check it to make sure
LOOK4CHAR = THENPLIT<36,7>; ! READ THEN
IF LEXICAL(.GSTSSCAN) EQL 0
THEN BEGIN
LEXEMEGEN(); ! NOT THEN, GET WHATEVER IT WAS
RETURN ERR0V(THENPLIT); ! "FOUND <WHATEVER> WHEN EXPECTING THEN"
END;
IF LEXEMEGEN() NEQ EOSLEX^18 THEN RETURN NOEOSERRV; ! READ <EOS>
! "FOUND <WHATEVER> WHEN EXPECING EOS"
!Now generate a logical IF. Push a pointer to it on DOIFSTK so we can find
!the IF when we see its matching ENDIF.
NAME<LEFT> = DISIZE; R1 = CORMAN(); ! PUSH AN IF NODE ONTO DOIFSTK
R1[DILINK] = .DOIFSTK;
R1[DIBLINK] = 0;
IF .DOIFSTK NEQ 0 THEN DOIFSTK[DIBLINK] = .R1;
DOIFSTK = .R1;
R1[DITYPE] = DIIFTYPE; ! SET TYPE = IF
R1[THENLBL] = GENLAB(); ! GENERATE LABEL FOR THEN
R1[ENDLBL] = GENLAB(); ! GENERATE LABEL FOR ENDIF
R1[DISTMT] = IFNOTGEN (.R1[THENLBL]);
! GENERATE IF (.NOT. EXPR) GOTO THENLBL
END; ! of BLOCKIF
GLOBAL ROUTINE ELSESTA=
!Here on ELSE and ELSEIF statements. Classifier has decided this is not an
!assignment, so has weeded out ELSEIF(I) = 3 and all other statements with a
!zero-level equals sign. The classifier has read over the ELSE. Any statement
!starting with ELSE which does not have a zero-level equals sign comes here.
!
!Complete the classification of the statement by checking for <EOS> and IF
!following the ELSE. For ELSEIF, parse the logical expression using the BNF
!specification for logical IF, and check for THEN <EOS>.
BEGIN
REGISTER BASE T1:T2;
REGISTER DINODE R1;
LOCAL BASE SAVTHENLBL;
BIND IFPLIT = UPLIT('IF?0'),
THENPLIT = UPLIT('THEN?0');
LOOK4CHAR = IFPLIT<36,7>; ! CHECK FOR ELSEIF
IF LEXICAL(.GSTSSCAN) NEQ 0
THEN
BEGIN ! FOUND ELSEIF
!ELSE IF statement
!Have read ELSEIF.
!Read ( <EXPRESSION> ) using the BNF-driven parser, return the expression in
!.STK[0]. Then read and check the mandatory THEN <EOS>
IF SYNTAX(LOGICALIFSPEC) LSS 0 THEN RETURN -1; ! GET EXPRESSION
LOOK4CHAR = THENPLIT<36,7>; ! READ THEN
IF LEXICAL(.GSTSSCAN) EQL 0
THEN BEGIN ! NO THEN
LEXEMEGEN(); ! "FOUND <WHATEVER> WHEN EXPECTING THEN"
RETURN ERR0V(THENPLIT);
END;
IF LEXEMEGEN() NEQ EOSLEX^18 THEN RETURN NOEOSERRV; ! READ EOS
R1 = .DOIFSTK; ! FIND CLOSEST ENCLOSING IF OR DO
IF .R1 EQL 0 THEN RETURN FATLEX (E154<0,0>); ! "NO MATCHING IF"
IF .R1[DITYPE] NEQ DIIFTYPE THEN
BEGIN T1 = .R1[DISTMT]; !"DO AT LINE <N> HAS NOT TERMINATED"
RETURN FATLEX (.T1[SRCISN],E152<0,0>);
END;
IF .R1[THENLBL] EQL 0 ! IF THENLBL = 0, WE ARE AFTER AN ELSE
THEN BEGIN ! "IF AT LINE <N> ALREADY HAS ELSE"
T1 = .R1[DISTMT];
RETURN FATLEX(.T1[SRCISN],E155<0,0>);
END;
!Now generate GOTO ENDLBL (if preceding stmt isn't an unconditional jump)
! nnnM: IF (.NOT. EXPR) GOTO THENLBL
! ^ (nnnM is the THENLBL of the corresponding IF or ELSEIF)
! or
! GOTO ENDLBL (if preceding stmt isn't an unconditional jump)
! nnnM: CONTINUE
! nnnP: IF (.NOT. EXPR) GOTO THENLBL
!if the ELSEIF statement is labeled.
!
!The reason for the two forms is that the nnnP label must be attached to the
!last statement generated by this routine. DRIVER will define LABLOFSTATEMENT
!on the last statement generated by this routine, and the end-of-do-loop code
!only examines the last statement.
CGOTOGEN(.R1[ENDLBL]); ! GENERATE GO TO ENDLBL
SAVTHENLBL = .R1[THENLBL]; ! ATTACH THENLBL TO GENERATED IF
IF .LABLOFSTATEMENT NEQ 0
THEN ! GENERATE A CONTINUE TO HOLD THENLBL
BEGIN
CONTGEN(.SAVTHENLBL);
SAVTHENLBL = .LABLOFSTATEMENT; ! ATTACH LABLOFSTATEMENT
! TO GENERATED IF
END;
R1[THENLBL] = GENLAB(); ! GENERATE NEW THEN LABEL TO JUMP TO
T2 = IFNOTGEN(.R1[THENLBL]); ! GENERATE LOGICAL IF AND GOTO
T2[SRCLBL] = .SAVTHENLBL; ! PUT OLD THENLBL ON THE LOGICAL IF
SAVTHENLBL[SNHDR] = .T2; ! POINT LABEL TABLE NODE BACK TO STMT
SAVTHENLBL[SNEXECU] = 1; ! MARK STMT EXECUTABLE
END %ELSEIF%
ELSE
BEGIN
!ELSE statement
!Have read ELSE. Check for <EOS>
IF LEXEMEGEN() NEQ EOSLEX^18 THEN RETURN NOEOSERRV;
! "FOUND <WHATEVER> WHEN EXPECTING EOS"
R1 = .DOIFSTK; ! FIND CLOSEST ENCLOSING IF OR DO
IF .R1 EQL 0 THEN RETURN FATLEX (E154<0,0>); ! "NO MATCHING IF"
IF .R1[DITYPE] NEQ DIIFTYPE
THEN BEGIN
T1 = .R1[DISTMT]; !"DO AT LINE <N> HAS NOT TERMINATED"
RETURN FATLEX (.T1[SRCISN],E152<0,0>);
END;
IF .R1[THENLBL] EQL 0 ! IF THENLBL = 0, WE ARE AFTER AN ELSE
THEN BEGIN ! "IF AT LINE <N> ALREADY HAS ELSE"
T1 = .R1[DISTMT];
RETURN FATLEX(.T1[SRCISN],E155<0,0>);
END;
!Now generate GOTO ENDLBL
! nnnM: CONTINUE
! ^ (nnnM is the THENLBL of the corresponding IF or ELSEIF)
! nnnP: CONTINUE (if ELSE has a label)
CGOTOGEN(.R1[ENDLBL]); ! GO TO ENDLBL
CONTGEN(.R1[THENLBL]); ! THENLBL: CONTINUE
IF .LABLOFSTATEMENT NEQ 0 THEN CONTGEN(.LABLOFSTATEMENT); ! STALABL: CONTINUE
R1[THENLBL] = 0; ! CLEAR THENLBL -- NOW AFTER ELSE
END %ELSE%;
END; ! of ELSESTA
GLOBAL ROUTINE ENDISTA=
!Here on ENDIF. Classifier has read over ENDIF, so we only have to check
!that there is no junk after the keyword.
BEGIN
REGISTER BASE T1;
REGISTER DINODE R1:R2;
IF LEXEMEGEN() NEQ EOSLEX^18 THEN RETURN NOEOSERRV; ! READ EOS
R1 = .DOIFSTK; ! FIND CLOSEST ENCLOSING IF OR DO
IF .R1 EQL 0 THEN RETURN FATLEX (E154<0,0>); ! "NO MATCHING IF"
IF .R1[DITYPE] NEQ DIIFTYPE ! IF TOP OF STACK ISN'T AN IF,
THEN
BEGIN ! Illegal nesting of DOs and IFs
! Error processing
T1 = .R1[DISTMT]; !"DO AT LINE <N> HAS NOT TERMINATED"
FATLEX (.T1[SRCISN], E152<0,0>);
!FIND INNERMOST IF, IF ANY, AND UNLINK IT FROM THE STACK,
!THUS MATCHING THE ENDIF WITH THE CLOSEST PRECEDING IF.
!LEAVE THE DO WHERE IT IS SO THE DO'S TARGET STATEMENT, WHEN
!SEEN, WILL TERMINATE THE DO PROPERLY.
DO
R1 = .R1[DILINK]
UNTIL .R1[DITYPE] EQL DIIFTYPE OR .R1 EQL 0;
!R1 POINTS TO CLOSEST ENCLOSING IF, IF ANY
IF .R1 NEQ 0
THEN
BEGIN ! UNLINK THE IF FROM DOIFSTK AND TOSS IT
IF (R2 = .R1[DIBLINK]) NEQ 0 ! FWD LINK OF PREDECESSOR
THEN R2[DILINK] = .R1[DILINK]
ELSE DOIFSTK = .R1[DILINK];
IF (R2 = .R1[DILINK]) NEQ 0 ! BACK LINK OF SUCCESSOR
THEN R2[DIBLINK] = .R1[DIBLINK];
SAVSPACE(DISIZE-1,.R1);
END;
RETURN -1; ! ERROR
END; ! Error processing
!Here we have a normal, legal ENDIF.
!Generate
! nnnM: CONTINUE (nnnM = label in goto in matching THEN)
! mmmM: CONTINUE (mmmM = label in goto in matching ELSEs)
! (only if there is at least 1 ELSE clause)
! xxxP: CONTINUE (xxxP = label of the ENDIF stmt, if any)
IF .R1[THENLBL] NEQ 0 THEN CONTGEN(.R1[THENLBL]);
T1 = .R1[ENDLBL];
IF .T1[SNREFNO] GTR 1 THEN CONTGEN(.T1);
IF .LABLOFSTATEMENT NEQ 0 THEN CONTGEN(.LABLOFSTATEMENT);
DOIFSTK = .R1[DILINK]; ! POP THE IF NODE FROM DOIFSTK
IF .DOIFSTK NEQ 0 THEN DOIFSTK[DIBLINK] = 0; ! FIX BACK LINK OF NEW TOP
SAVSPACE(DISIZE-1,.R1); ! FREE MEMORY OCCUPIED BY IF NODE
END; ! ENDISTA
ROUTINE IFNOTGEN(LABELNODE)=
!Generate stmt nodes for IF (NOT .STK[0]) GOTO <LABELNODE>
!The generated logical IF is linked into the source list and returned as
!the value of IFNOTGEN. STK has been set up by EXPRESS.
BEGIN
REGISTER BASE T1:T2;
LOCAL BASE IFEXPR;
LOCAL SAVLASTSRC,SAVLABL;
T2 = .STK[0]; ! GET IF EXPRESSION OFF STK
IFEXPR = .T2[ELMNT];
SAVSPACE(.T2<LEFT>,.T2);
%1260% ! Don't allow character expression in condition.
%1263% ! Allow character constant and make it hollerith.
%1263% IF .IFEXPR[OPERATOR] EQL CHARCONST
%1263% THEN IFEXPR[OPERATOR] = HOLLCONST ! Make it hollerith
%1263% ELSE IF .IFEXPR[VALTYPE] EQL CHARACTER
%1260% THEN RETURN FATLEX(E164<0,0>); ! Character variable illegal
NAME = EXPTAB; ! MAKE EXPRESSION NODE TO HOLD .NOT. IFEXPR
T1 = NEWENTRY();
T1[OPRCLS] = NEGNOT; T1[OPERSP] = NOTOP; ! OPERATOR = .NOT.
T1[VALTYPE] = LOGICAL; ! TYPE LOGICAL
T1[ARG1PTR] = 0; T1[ARG2PTR] = T2 = .IFEXPR; ! OPERAND IS IFEXPR
IF .T2[OPRCLS] EQL DATAOPR ! SET VAL FLAGS AND VARIOUS POINTERS AS EXPRESS DOES
THEN T1[A2VALFLG] = 1
ELSE BEGIN
T2[PARENT] = .T1;
IF .T2[FNCALLSFLG] THEN T1[FNCALLSFLG] = 1;
END;
IF .T2[DBLFLG] THEN T1[ARG2PTR] = TPCDMY(.T1,.T2); ! INSERT TYPECNV NODE IF NECESSARY
IFEXPR = .T1; ! NEW IFEXPR IS .NOT. IFEXPR
NAME = IDOFSTATEMENT = IFLDATA; ! GENERATE LOGICAL IF STATEMENT NODE
NAME<RIGHT> = SORTAB;
T1 = NEWENTRY();
T1[LIFEXPR] = .IFEXPR; ! FILL IN CONDITION OF IF STMT
IFEXPR[PARENT] = .T1; ! POINT EXPR BACK TO STMT
SAVLASTSRC = .LASTSRC; ! SAVE SORCPTR SO WE CAN REMOVE GOTO
SAVLABL = .LABLOFSTATEMENT; ! SAVE STMT LABEL SO IT DOESN'T GET
LABLOFSTATEMENT = STALABL = 0; ! ATTACHED TO THE GOTO
T1[LIFSTATE] = GOTOGEN(.LABELNODE); ! GENERATE GOTO THENLBL
LASTSRC = .SAVLASTSRC; ! UNLINK GOTO FROM STATEMENT CHAIN
LABLOFSTATMEMENT = .SAVLABL; ! RESTORE STMT LABEL
RETURN .T1 ! RETURN GENERATED IF
END; ! IFNOTGEN
ROUTINE CGOTOGEN(LABELNODE)=
! GENERATE GO TO LABEL IF PRECEDING
! STATEMENT IS NOT UNCONDITIONAL GOTO
! OF SOME KIND
BEGIN
REGISTER BASE T1;
T1 = .LASTSRC; T1 = .T1[SRCID]; ! GET ID OF LAST STMT IN SOURCE LIST
IF .T1 NEQ GOTOID AND .T1 NEQ IFAID AND
.T1 NEQ RETUID AND .T1 NEQ STOPID
THEN ! NOT AN UNCONDITIONAL JUMP, SO
BEGIN ! GENERATE GOTO
T1 = GOTOGEN(.LABELNODE);
T1[SRCISN] = 0;
END;
END; ! CGOTOGEN
ROUTINE GOTOGEN(LABELNODE)= ! GENERATE GO TO LABEL;
BEGIN
REGISTER BASE T1;
LOCAL BASE SAVLABLOFSTMT;
MAP BASE LABELNODE;
SAVLABLOFSTMT = .LABLOFSTATEMENT;
LABLOFSTATEMENT = 0;
NAME = IDOFSTATEMENT = GOTODATA; ! CREATE GOTO STMT NODE
NAME<RIGHT> = SORTAB;
T1 = NEWENTRY();
T1[GOTOLBL] = .LABELNODE; ! FILL IN DEST LABEL
T1[GOTONUM] = T1[GOTOLIST] = 0;
T1[SRCLBL] = 0; ! NO STMT LABEL ON THIS STMT
LABELNODE[SNREF] = .LABELNODE[SNREF] + 1; ! INCREMENT LABEL'S REF CNT
LABLOFSTATEMENT = .SAVLABLOFSTMT;
RETURN .T1 ! RETURN GENERATED GOTO
END; ! GOTOGEN
GLOBAL ROUTINE CONTGEN(LABELNODE)= ! GENERATE LABEL: CONTINUE
BEGIN
REGISTER BASE T1;
LOCAL BASE SAVLABLOFSTMT;
MAP BASE LABELNODE;
SAVLABLOFSTMT = .LABLOFSTATEMENT;
LABLOFSTATEMENT = .LABELNODE;
NAME = IDOFSTATEMENT = CONTDATA; ! CREATE CONTINUE STMT NODE
NAME<RIGHT> = SORTAB;
T1 = NEWENTRY();
LABELNODE[SNEXECU] = 1; ! LABEL IS THE LABEL OF AN EXECUTABLE STMT
LABLOFSTATEMENT = .SAVLABLOFSTMT;
RETURN .T1
END; ! CONTGEN
ROUTINE BLDSFN=
BEGIN
! Builds a statement function source tree node. STK[0] contains
! a pointer to the output from a statefunction parse.
REGISTER
BASE R1,
BASE R2,
BASE T2;
LOCAL
%1413% ARGUMENTLIST ARGNODE,
BASE ID, ! Symbol table entry for the argument
BASE SAV,
BASE T1,
BASE TMP; ! The temp .Fnnnn name for the argument
%1455% BIND ISSFN = 1; ! Flag to CHASGN for this is a statement
! function. Calls to CHSFN. and CHSFC.
! are generated.
NAME = IDOFSTATEMENT = SFNDATA;
NAME<RIGHT> = SORTAB;
R1 = NEWENTRY();
T1 = .STK[0];
R1[SFNNAME] = .ASTATFUN; ! Pointer put in ASTATFUN by
! STATEFUNC routine
%1466% ASTATFUN[IDSFNODE] = .R1; ! Pointer back to SF definition
! for arg checking.
%1531% ! Statement function names cannot appear in a SAVE statement.
%1531% IF .ASTATFUN[IDSAVVARIABLE]
%1531% THEN FATLERR(.ASTATFUN[IDSYMBOL],UPLIT(ASCIZ'Statement function'),
%1531% .ISN,E192<0,0>);
R1[SFNEXPR] = ! Pointer to expression
%1421% IF .T1[ELMNT] EQL 1
THEN .T1[ELMNT1]
ELSE .T1[ELMNT2];
%1455% IF .ASTATFUN[VALTYPE] NEQ CHARACTER
%1455% THEN
%1455% BEGIN ! Numeric statement function
! Make sfnexpr point to an assignment node
ASGNTYPER(.R1); ! Check for type conversion
R2 = .R1[SFNEXPR]; ! Restore expression pointer
NAME<LEFT> = ASGNSIZ+SRCSIZ;
T2 = CORMAN();
T2[OPRCLS] = STATEMENT;
T2[OPERSP] = ASGNID;
T2[LHEXP] = .ASTATFUN;
T2[A1VALFLG] = 1;
T2[RHEXP] = .R2;
R1[SFNEXPR] = .T2;
%1455% ! Pointer to statement function as parent
%1455% IF .R2[OPRCLS] NEQ DATAOPR
%1455% THEN R2[PARENT] = .R1;
%1455% END ! Numeric statement function
%1455% ELSE
%1455% BEGIN ! Character statement function
%1455% ! Make sfnexpr point to a call to either CHSFN. or CHSFC.
%1455% R2 = .R1[SFNEXPR]; ! Restore expression pointer
%1455% IF .R2[VALTYPE] NEQ CHARACTER
%1455% THEN FATLEX(E163<0,0>); ! "Illegal combination of
%1455% ! character and numeric data"
%1455% R1[SFNEXPR] = CHASGN(.ASTATFUN, .R2, ISSFN);
%1455% END; ! Character statement function
! Build the new argument list block
%1421% IF .T1[ELMNT] EQL 1 ! Get pointer to args in R2
%1421% THEN R2 = 0 ! If zero args, clear R2
%1425% ELSE R2 = @.T1[ELMNT1]; ! Else get len-1,,address of args
%1421% T1 = (IF .R2 EQL 0 THEN 0 ELSE .R2<LEFT>+1); ! Get number of args
%1413% NAME<LEFT> = ARGLSTSIZE(.T1); ! Compute the size of argument block
%1413% ARGNODE = T2 = CORMAN(); ! Get a block for the argument list
%1413% R1[SFNLIST] = .ARGNODE; ! Point Statement to argument list
%1421% ARGNODE[ARGCOUNT] = .T1;
%1421% IF .R2 NEQ 0
THEN
DECR I FROM .R2<LEFT> TO 0 DO
BEGIN
! Restore the symbol table by switching formals and
! .Fnnnn variables
ID = @(.R2)[.I]; ! Symbol
SAV = .ID[IDSYMBOL];
TMP = .ID[CLINK];
ID[IDSYMBOL] = .TMP[IDSYMBOL];
TMP[IDSYMBOL] = .SAV;
%2507% ID[IDIMPLNONE] = .TMP[IDIMPLNONE]; ! Copy if we've warned
! about IMPLICIT NONE
%1413% ARGNODE[.I + 1,ARGFULL] = .TMP; ! Put .Fnnnn variable in
! the argument list
! Check for duplicate dummy arguments
SAV = .I - 1;
UNTIL .SAV LSS 0
DO
BEGIN
TMP = @@(@R2)[.SAV]; ! Next parameter
IF .ID[IDSYMBOL] EQL .TMP[IDSYMBOL]
THEN FATLEX(.ID[IDSYMBOL],E87<0,0>);
SAV = .SAV - 1;
END;
END;
%1455% IF .ASTATFUN[VALTYPE] EQL CHARACTER
%1455% THEN
%1455% BEGIN ! Build a character function argument list
%1455% R1[SFNLIST] = ARGNODE = CHARGLIST(.ARGNODE);
%1455% ARGNODE[ARGCOUNT] = .T1 + 1;
%1455% ARGNODE[1,ARGFULL] = .ASTATFUN; ! Point first argument
%1455% ! to the function name
%1455% ASTATFUN[IDATTRIBUT(DUMMY)] = 1; ! Mark it as dummy arg
%2327% ! Set the psect fields. All formals (even character) are
%2327% ! in .DATA.. (IDPSCHARS should be ignored for all formals.)
%2327% ASTATFUN[IDPSECT] = PSDATA;
%2327% ASTATFUN[IDPSCHARS] = PSOOPS;
%1455% END; ! Build a character function argument list
%1421% IF .R2 NEQ 0 THEN SAVSPACE(.R2<LEFT>,.R2);
SAVSPACE(.STK[0]<LEFT>,.STK[0]);
RETURN .R1
END; ! of BLDSFN
GLOBAL ROUTINE STATEFUNC=
BEGIN
REGISTER
BASE R1,
BASE T1,
BASE T2;
LOCAL
LNAME,
BASE SAV;
MACRO
CNT= 0,0,LEFT$,
SCRFLAGS = 0,0,LEFT$,
SCRCNT = 0,0,LEFT$,
SCRLOC=0,0,RIGHT$;
T2 = LEXEMEGEN();
IF .T2<LEFT> NEQ IDENTIFIER
THEN RETURN FATLEX(.ISN,E10<0,0>); ! Unrecognized statement
LNAME = .T2; ! Saving the array or function name pointer
IF .T2[OPRSP1] NEQ ARRAYNM1
THEN
BEGIN ! Statement function
STMNDESC = DSCSTFN<0,0>; ! Update the statement
! description
! Check statement ordering for out of order or
! undimensioned array
IF .PSTATE EQL PSTEXECU<0,0>
%1750% THEN WARNLEX(E216<0,0>);
! Check for label on statement
IF .STALABL NEQ 0
%1402% THEN LABDEF();
! Record the definiton of the statement function
IF (SAV = NAMDEF(STFNDEF,.T2)) LSS 0 THEN RETURN .SAV;
T2[IDATTRIBUT(SFN)] = 1; ! It is a statment function
T2[OPERSP] = FNNAME;
ASTATFUN = .T2<RIGHT>; ! Pointer used in BLDSFN
IF SYNTAX(STATEFUNCSPEC) LSS 0
THEN
BEGIN ! Out of order or undimensioned array
ASTATFUN = 0;
! Remove bogus statement function definition to
! prevent later confusion, e. g. A(1)=1; A(1)=1
! without dimension statement gives ugly errors!
T1 = .LNAME;
T1[OPRSP1] = VARIABL1;
T1[IDATTRIBUTE(SFN)] = 0;
%771% ! Check for both an invalid syntax stack pointer
%771% ! and the absence of the expected list of
%771% ! identifiers
%771% IF (R1 = .STK<RIGHT>) EQL 0 THEN RETURN -1;
%771% IF .R1[0]<LEFT> NEQ IDENTIFIER THEN RETURN -1;
%771% ! The stack appears intact. Step through the
%771% ! list of identifier pointers and replace the
%771% ! function formals with the actual identifiers
DECR I FROM .STK<LEFT> TO 0 DO
BEGIN
T2 = @(.R1)[.I];
! Be sure that we are not inadvertently
! in the constant table rather than the
! symbol table, e.g. FN(3,2)
IF .T2[OPERSP] EQL CONSTANT
THEN RETURN -1;
SAV = .T2[IDSYMBOL];
T1 = .T2[CLINK];
IF .T2 NEQ 0
THEN
BEGIN
T2[IDSYMBOL] = .T1[IDSYMBOL];
T1[IDSYMBOL] = .SAV;
END;
END; ! Decr loop
RETURN -1
END; ! Out of order or undimensioned array
BLDSFN(); ! Build a statefunction node
ASTATFUN = 0; ! Reset since parse is finished
RETURN
END;
! An array assignment with possible multiple assignments
STMNDESC = DSCASGNMT<0,0>; ! Update the statement description
PSTATE = PSTEXECU<0,0>; ! Set ordering
IF .STALABL NEQ 0 THEN LABDEF(); ! Enter the label in the
! label table
NAMSET(ARRAYNM1,.T2); ! Record the update
IF SYNTAX(ARRAYASSIGNSPEC) LSS 0 THEN RETURN -1;
T1 = .STK[0]; ! T1 is the subscript list base
T2 = .T1[ELMNT];
INCR SCR FROM @T2 TO @T2+.T2<LEFT> DO
BEGIN
MAP BASE SCR;
R1 = .SCR[ELMNT];
SCR[SCRFLAGS] = 0;
SCR[SCRLOC] = .R1; ! Pointer to subscript expression
IF .R1[OPRCLS] EQL DATAOPR
THEN SCR[P1AVALFLG] = 1
ELSE IF .R1[OPRCLS] EQL ARRAYREF THEN SCR[P1AVALFLG] = 1;
END;
IF (T2 = ARRXPND(@LNAME,@T2)) LSS 0 THEN RETURN -1;
RETURN MULTIASGN(.T2) ! Give it the left hand side
END; ! of STATEFUNC
END
ELUDOM