Google
 

Trailing-Edge - PDP-10 Archives - FORTRAN-10_Alpha_31-jul-86 - 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, 1986
!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/JB

MODULE STA3(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4)=
BEGIN

GLOBAL BIND STA3V = #11^24 + 0^18 + #4527;	! Version Date:	1-Jan-86

%(

***** 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.

***** End Revision History *****

***** 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 *****

2546	MEM	5-Sep-85
	In WHILSTA when we push the conditional expression onto STK, we should
	push a bytepointer to the expression instead of the expression itself
	because this is what IFNOTGEN is expecting.

2557	JB	6-Nov-85
	Check for the use of specific function names in argument lists
	instead of in INTRINSIC statements. Call routine INTRCHK to
	perform the check.

***** End Revision History *****

***** Begin Version 11 *****

4504	MEM	22-Jan-85
	Modify UNLOSTA to parse both the UNLOAD and the UNLOCK statement,
	and to perform ANSI flagging on the UNLOCK statement.
	Ripped out GLOBSTA which was commented out in V6.

4516	CDM	2-Oct-85
	Phase I.I for VMS long symbols.  Pass Sixbit to all error message
	routines, do not pass addresses of Sixbit anymore.  In later edits
	this will pass [length,,pointer to symbol] instead of a pointer to
	this to the error message routines.

4527	CDM	1-Jan-86
	VMS Long symbols phase II.  Convert all internal symbols from
	one word of Sixbit to [length,,pointer].  The lengths will be one
	(word) until a later edit, which will store and use long symbols.

ENDV11
)%

SWITCHES NOLIST;
REQUIRE FTTENX.REQ;	![4526]
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'
%4504%	E267,		! 'Extension to Fortran-77: xxxxx statement'
%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'
%4526%	E322,		! TOPS20 ONLY: xxx
	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
	T1=@.STK[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;

%4516%	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
%2557%			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=
!++
! Fixes up the valtype of dummy variables after an IMPLICIT
! statement was processed.
!--
BEGIN
	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
%4527%		T2 = .R2[IDDOT];	! 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	! For each dummy argument

%1413%		R2 = .ARGLST[.I,ARGNPTR];	! Pointer to arg
%4527%		T2 = .R2[IDDOT];		! 1st character
%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;	! For each dummy argument

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
	BEGIN	! Set type of program or BLOCK DATA names just in case

		REGISTER BASE T2;

%4527%		! First word of program name.  It is reasonable to only
%4527%		! compare the first word since users can't have "." in
%4527%		! their names.  Otherwise we'd have to compare word by
%4527%		! word.
%4527%
%4527%		T2 = @@PROGNAME<SYMPOINTER>;		! 1st word of symbol
%4527%		IF .T2 NEQ SIXBIT 'MAIN.' AND		! Unnamed main
%4527%			.T2  NEQ  SIXBIT '.BLOCK'	! BLOCK DATA
		THEN
		BEGIN	! Check program name

			ENTRY = .PROGNAME;
			NAME = IDTAB;
			R1 = TBLSEARCH();
%4527%			T2 = .R1[IDDOT];	!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	! Check program name

	END;	! Set type of program or BLOCK DATA names just in case

	.VREG

END;	! of IMPLSTA

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=

!++
! FUNCTIONAL DESCRIPTION:
!
!	Parsing the UNLOAD and UNLOCK statements.
!
! FORMAL PARAMETERS:
!
!	None
!
! IMPLICIT INPUTS:
!
!	STK	Points to the address of the block of specifiers built 
!		by KEYSCAN
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	UNLOAD statement node or UNLOCK statement node 
!
! SIDE EFFECTS:
!
!	None
!
!--

BEGIN	![4504]	Rewritten
	BIND DUM = PLIT( AD NAMES 'AD?0', CK NAMES 'CK?0'  );

	! try unload
	LOOK4CHAR = AD<36,7>;
	IF LEXICAL(.GSTSSCAN)  NEQ 0
	THEN
	BEGIN	% got unload %
		IF FLAGEITHER	!Compatibility check
		THEN CFLAGB((PLIT 'UNLOAD')<0,0>,E268<0,0>);	

		IF SYNTAX(UTILSPEC)  LSS   0  THEN RETURN .VREG;
		RETURN  BLDUTILITY(UNLODATA)
	END
	ELSE
	BEGIN
		! try unlock
		LOOK4CHAR = CK<36,7>;
		IF LEXICAL(.GSTSSCAN)  NEQ 0
		THEN
		BEGIN	% got unload %
%4526%			IF NOT FTTENEX
%4526%			THEN FATLEX (UPLIT ASCIZ 'UNLOCK statement',E322<0,0>);
			IF FLAGANSI		!Compatibility check
			THEN WARNERR((PLIT ASCIZ 'UNLOCK')<0,0>,.ISN,E267<0,0>);	
	
			IF SYNTAX(UTILSPEC)  LSS   0  THEN RETURN .VREG;
			RETURN  BLDUTILITY(UNLCKDATA)
		END
		ELSE RETURN FATLEX(E12<0,0>);	!MISSPELLED
	END;
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>)
%4516%	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
%2546%	STK[0] = T1[ELMNT1]<0,0>;	! 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