Google
 

Trailing-Edge - PDP-10 Archives - FORTRAN-10_Alpha_31-jul-86 - sta0.bli
There are 26 other files named sta0.bli in the archive. Click here to see a list.
!COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1973, 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/HPW/ D. B. TOLMAN/DCE/TFV/CKS/CDM/AHM/RVM/RJD/TJK/AlB/MEM

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

GLOBAL BIND STA0V = #11^24 + 0^18 + #4543;	! Version Date: 9-Jul-86


%(

***** Begin Revision History *****

44	-----	-----	CATCH ILLEGAL LIST DIRECTED RANDOM ACCESS

45	-----	-----	MOVE DO INDEX MODIFICATION CHECK TO NAMSET SO THAT
			IT WILL GET ALL CASES OF MODIFICATION
46	336	17259	CHECK FOR ILLEGAL I/O LIST WITH NAMELIST

***** Begin Version 5B *****

47	742	-----	STOP/PAUSE STATEMENTS NOW TAKE DIGIT STRINGS
			INSTEAD OF OCTAL STRINGS
48	745	-----	ARGUMENT LIST COULD NOT BE .GTR. 124 - FIX IT, (DCE)

***** Begin Version 6 *****

49	760	TFV	1-Oct-79	------
	Rewrite RWBLD to accept either positional (old style) or keyword
	(new style) control information lists

50	766	DCE	14-May-80	-----
	Give error messages for the following:
	1. GO TO A where A is dimensioned
	2. GO TO A(I) where A is dimensioned
	3. ASSIGN 10 TO A(I) where A is dimensioned

54	1076	TFV	8-Jun-81	------
	Allow list-directed I/O without an iolist.

55	1114	CKS	22-Jun-81	-----
	Fix check in RWBLD for namelist IO without IO list.  It was using
	R2 as if it contained a format statement pointer; make it be true.

70	1150	DCE	7-Apr-82	20-17292
	For an ASSIGN statement, flag the label as having been ASSIGNed.
	This prevents the optimizer from getting illegal jumps into loops
	when not warranted.

***** Begin Version 7 *****

51	1202	DCE	1-Jul-80	-----
	Change calls to DATALIST to be calls to LISTIO so that we can do
	expressions on output lists.

52	1203	DCE	24-Nov-80	-----
	Modify 1202 to accomodate the new I/O list processing

53	1217	DCE	28-May-81	-----
	Allow empty argument lists for CALL stmnts.
	R2 as if it contained a format statement pointer; make it be true.

56      1233	CKS	25-Jun-81
%!	Make "READ (1), X" work.  The problem is complex.  The BNF for
!	IO statements contains [ [ COMMA ] +OUTPLIST ] where OUTPLIST is
!	an output list.  OUTPLIST is %NOTEOL% %GIOLIST% where NOTEOL checks
!	for an end of line since GIOLIST can't be called on a null expression.
!	When these productions are folded together you get
!		( COMMA %NOTEOL% ...   |   %NOTEOL% ... )
!	which is not LL(1).  That is, one-token lookahead cannot distinguish
!	which alternative to use when the input starts with ",".  Comma
!	matches both alternatives.  As it happens, SYNTAX always chooses the
!	action routine alternative, which is wrong in this case.  To get
!	around this, replace [ COMMA ] with an action routine %OPTCOMMA%
!	which acts like the optional syntax in the BNF, but doesn't require
!	the parser to decide between two alternatives.  One additional
!	complication is present:  the whole IO list, optional comma and all,
!	is optional.  Therefore, OPTCOMMA fails on end of line, so that
!	SYNTAX will decide that the optional IO list is not present and
%	proceed accordingly.

57	1247	CKS	6-Aug-81
	Add SUBASSIGN semantic routine to parse substring assignment statements

58	1254	CKS	14-Aug-81
	Modify MULTIASGN to generate a CALL node for character assignments.
	Call CONCA. if the RHS of the assignment is a concatenation expression,
	CHASN. otherwise.

59	1257	TFV	10-Sep-81	------
	Fix LITOR6DIGIT to convert character constant args to hollerith.
	This fixes STOP/PAUSE 'foo'.

60	1260	CKS	14-Sep-81
	Don't allow character variables in ASSIGN and GOTO statements

61	1263	TFV	22-Sep-81	------
	Fix edit 1260 to allow the degenerate case GOTO (100,200),'ccc'.
	It's silly but legal in Version 6.

62	1277	CKS	20-Oct-81
	Fix assigned GOTO to support the syntax GOTO I (10,20,30).
	That is, allow the optional comma to be absent.  This means that it is
	no longer possible to use array elements in assigned GOTO.  Remove the
	V6 warning against using array elements.

63	1413	CDM/AHM	4-Nov-81
	Edited CALLSTA to  use structure ARGUMENTLIST  for assigning  argument
	nodes.  Made MULTIASGN know about larger arg block nodes for character
	assignments.  Also assign parent pointer to get at name of  subroutine
	being called for LINK hollerith/string argument coercion support.

64	1446	AHM	22-Dec-81
	Made MULTIASGN return the address of the created statement  node
	so that calling  routines that  punt on  negative return  values
	always get something positive when things went OK.  This bug was
	detected when  character assignment  statements in  logical  IFs
	returned 1B0  in  VREG causing  LOGICALIF  to not  link  the  IF
	statement into the statement list.  Also, MULTIASGN was  cleaned
	up slightly.

65	1455	TFV	5-Jan-81	------
	Change MULTIASGN for character statement functions.  The code to
	convert character assignments to calls to CHASN. or CONCA.   has
	been made into the routine  CHASGN. It will convert a  character
	statement function 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.

66	1465	CKS	22-Jan-82
	Rewrite RWBLD to read the new tree shape produced by action routine
	KEYSCAN.  READ and WRITE statement keyword lists are now parsed by
	that action routine instead of by SYNTAX.

67	1466	CDM	1-Feb-82
	Create zero block argument lists in CALLSTA if  /DEBUG:ARGUMENTS
	is specified.

68	1471	RVM	5-Feb-82
	Put checks into RWBLD to give error messages if illegal internal
	file I/O is specified.  If an internal file is an array, put its
	total size in characters into the IORECORD field of the I/O
	statement node.  This causes no problems as random access I/O to
	internal files is illegal.

69	1477	CKS	10-Feb-82
	Fix RWBLD to check first for arrayname as unit specifier, then
	convert it to integer.  Converting first leaves you looking at
	a type conversion node, which isn't an array name.

1505	AHM	13-Mar-82
	Make CHASGN set the psect index of the symbol table entries it
	creates for the  various character  assignment subroutines  to
	PSCODE so that routines references are relocated by .CODE.

1510	RVM	14-Mar-82
	Put checks in RWBLD to make it illegal to use an assumed-size array
	as either a unit or format in an I/O statement.

1517	CKS	24-Mar-82
	Fix SUBASSIGN so that the RHS expression must be followed by LINEND.

1531	CDM	4-May-82
	SAVE stmt changes after code review.

1546	CKS	31-May-82
	Modify RWBLD to be IOBLD, which does TYPE/ACCEPT type statements as
	well as READ and WRITE.  Eliminate the FORMATID half of RWBLD, which
	is not necessary since action routine KSPEC builds identical semantic
	info for the two syntaxes.  Move TYPESTA and its friends here so all
	the relevant routines are in this module.

1551	AHM	4-Jun-82
	Remove edit 1505  because external references  no longer  have
	their psect index set.

1613	CDM	13-Aug-82
	Change /DEBUG:PARAMETERS to /DEBUG:ARGUMENTS

1652	CDM	20-Oct-82
	Give warning for RETURN in main program.

1661	CKS	2-Nov-82
	Substring assignments aren't setting STORD for the variable being
	assigned to.  Call NAMSET to do this for scalar assignments.  For
	assignments to arrays, it seems that STORD is meaningless -- at
	least, routine STATEFUNC does not worry about it for numeric array
	assignments -- so don't worry for character assignments either.

1665	CKS	8-Nov-82
	Allow computed GOTO as the last statement in a DO loop.

1677	CKS/CDM	20-Nov-82
	Use action routine KEYSCAN to parse FIND, ENCODE, REWIND.
	Check that an argument list really exists before lighting the
	ARGCHBLOCK bit saying arg checking is necessary.

1715	RVM	12-Jan-83
	The compiler did not realize that character variables were
	stored into when they were used	as internal files by WRITE
	statements.  To remedy this, set the STORD attribute when
	doing the semantic checks on internal file specifiers used
	in WRITE statements.

***** End V7 Development *****

1737	RJD	4-Mar-83
	When the /DEBUG:ARGUMENTS switch is on but no arguments are
	being passed, the loop which assigns arguments should not be
	executed.  Also, the CNT should be initialized to zero outside
	of the loop.

1776	TFV	9-Sep-83
	Namelist I/O is illegal for ENCODE and DECODE.  Check for it in
	IOBLD.

2003	TJK	27-Sep-83
	Add check to IOBLD to allow a format specifier to be
	a REAL or LOGICAL variable (instead of just INTEGER).

2063	TFV	29-Jun-84
	Give an error for NAMELIST I/O with REREAD, ENCODE, and DECODE.

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

2245	CDM	15-Dec-83
	Improve argument checking.  Subroutine  calls with no  arguments
	would not output  argument checking (1120)  rel blocks for  Link
	unless /DEBUG:ARGUMENTS was  given.  Now always  output the  the
	rel block, and change the call to the subroutine not to have its
	own unique  argument block  of  0, but  instead use  the  shared
	ZERBLK which  everyone  else  with no  arguments  shares.   This
	simplifies code in several places.
	This deleted  uneeded checkes  of /DEBUG:ARGUMENTS  in  CALLSTA.
	Also delete  unused  macros  CARGPTR,  CAFLGFLD,  ERR15(X),  and
	machop BLT.

2247	AlB	22-Dec-83
	Add compatibility flagging for old-type I/O statements
	Routines:
		ACCESTA, PUNCSTA, RERESTA, TYPESTA

2252	AlB	27-Dec-83
	Added Compatibility flagging for:
	1) ENCODE/DECODE
	2) Non-integer used with REC=
	3) Non-integer used with UNIT=
	4) Non-integer used as index to RETURN
	5) Non-integer used as index to computed GOTO
	6) Assigned GOTO with label list
	Routines:
		BLDUTILITY, DECOSTA, ENCOSTA, GOTOSTA, IOBLD, RETUSTA

2261	AlB	5-Jan-84
	More compatibility flagger checks:
		PRINT (specifiers) iolist	! "(specifiers)" is neither ANSI nor VAX
		WRITE f, iolist			! WRITE with default unit is
		WRITE (FMT=f, ...) iolist	!     neither ANSI nor VAX
		Concantenation with length (*)	! ANSI extension

	Routines:
		CHASGN, PRINSTA, WRITSTA

2276	AlB	26-Jan-84
	Compatibility flagging for intrinsic functions and Fortran-supplied
	subroutines:

	1) Added routine CFSRCLIB to search a list of functions/subroutines
	   which might cause incompatibilities.

	2) Modified CALL statement to put out flagger warning if we detect
		a) A reference to a subroutine supplied by us but not by
		   the VAX and/or Fortran-77.
		b) A reference to a subroutine supplied by both VAX and us
		   which may produce a different result, or has different
		   arguments.

	Routines:
		CALLSTA	CFSRCLIB

2277	AlB	26-Jan-84
	Removed some entries from the Function Compatibility tables
	(CFTABLEN and CFTABLEV).  Those entries removed were the bit
	manipulation functions and subroutines that the VAX has always
	had, and which Randy Meyers is adding to Fortran-10/20.
	Routine:
		CFSRCLIB

2300	AlB	27-Jan-84
	Corrected spelling of entries in CFTABLEN & CFTABLEV.
	Routine:
		CFSRCLIB

2302	TJK	2-Feb-84
	Add new flag IDCLOBB to the IDFNATTRIB field of a symbol table
	entry.  This flag is set for certain library routines  (called
	as subroutines).  It indicates that  ACs are not preserved  by
	the call.

	Have CHASGN generate calls to  CASNM.  instead of CHASN.   for
	single-source character  assignments,  and CNCAM.  instead  of
	CONCA. for character concatenation assignments.  Also have  it
	set IDCLOBB for these routines, which don't preserve ACs.

	Replace a check for CONCA. with a check for CNCAM. in  SKCALL.

	Have ALCCALL mark registers 2-15 (octal) as being clobbered if
	IDCLOBB is set.

2303	AlB	3-Feb-84
	Remove the CFFSNAME variable, and instead reference the symbol table
	to get name to stick into warning messages; WARNLEX will now print
	the correct name (or at least the 'dotted' version of that name).
	This edit touched some WARNLEX calls, and caused changed to routine
	CFSRCLIB.

	Made some cosmetic changes to better conform to programming
	conventions.

2340	AlB	13-Apr-84
	Remove flagger checking of Fortran-supplied subprograms.  The fact
	that these routines are not present (or differ) on VAX and/or ANSI
	is checked at run-time, and need not be checked in the compiler.

2455	MEM	30-Aug-84
	Replace all occurrences of VAX with VMS.

2473	CDM	26-Oct-84
	Add IMPLICIT NONE for the Military Standard MIL-STD-1753.

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

2534	MEM	13-Jun-85
	In SUBASSIGN set the STORD bit in the left hand expression of the
	assignment and delete the call to NAMSET.

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

4501	MEM	22-Jan-85
	Modified IOBLD for indexed read.

4503	MEM	22-Jan-85
	Created REWRSTA to flag ANSI compatibility and to perform keyword
	processing for the REWRITE statement.

4514	MEM	13-Sep-85
	Fillin in blank fields SRCID, OPRCLS, and SRCLBL in the node (character
	assignment) under a character statement function node.
	
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.

4526	MEM	27-Nov-85
	Give error message on TOPS10 if RMS specifiers are given in a READ
	statement and for all REWRITE statements.

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.

4543	JB	9-Jul-86
	Allow list-directed I/O with internal files, but flag it as
	non-standard.
ENDV11
)%

SWITCHES NOLIST;
REQUIRE FTTENX.REQ;	![4526]
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE META72.BLI;
REQUIRE ASHELP.BLI;
SWITCHES LIST;

! Below is for RUNOFF in generating .PLM files
!++
!.LITERAL
!--

!THE NUMBER IN COMMENT'S IS THE STATEMENTS LOCATION
!IN THE HASH TABLE .

FORWARD
	MULTIASGN,
	ASSIGNMENT,	! ASSIGNMENT
%2276%	CFSRCLIB(1),	! Search table of incompatible functions/subroutines
%1455%	CHASGN,		! Character assignment
%  1%	PUNCSTA,	!PUNCH 
% 38%	CALLSTA,	!CALL 
% 49%	GOTOSTA,	!GOTO 
% 53%	PAUSSTA,	!PAUSE 
% 57%	RETUSTA,	!RETURN 
% 73%	ACCESTA,	!ACCEPT 
% 78%	READSTA,	!READ 
% 90%	WRITSTA,	!WRITE 
% 98%	CONTSTA,	!CONTINUE 
%109%	ASSISTA,	!ASSIGN 
%114%	STOPSTA;	!STOP

FORWARD
	IOBLD;

EXTERNAL
%2252%	CFLAGB,		! Put out certain flagger warnings
	CNVNODE,
%2534%	CREFIT,
	E102,
	E184,
	E188,
	E191,
	E192,		! "Illegal in SAVE statement"
	E200,
	E201,
%1652%	E209,		! "RETURN illegal in main routine"
%1776%	E217,		! NAMELIST is not allowed in ENCODE and DECODE
%2261%	E221,		! 'Extension to Fortran-77: Concantenation with length (*)'
%2252%	E232,		! 'Extension to Fortran-77: ENCODE statement'
%2252%	E233,		! 'Extension to Fortran-77: DECODE statement'
%2455%	E250,		! 'VMS incompatibility: Label list with assigned GOTO'
%2252%	E258,		! 'Extension to Fortran-77: Non-integer with computed GOTO'
%2252%	E259,		! 'Extension to Fortran-77: Non-integer with (Keyword)
%2252%	E261,		! 'Extension to Fortran-77: Non-integer RETURN index'
%2247%	E267,		! 'Extension to Fortran-77: xxxx statement'
%2455%	E268,		! 'Fortran-77 or VMS: xxxx statement'
%2455%	E269,		! 'Fortran-77 or VMS: PRINT with specifiers'
%2455%	E285,		! 'Fortran-77 or VMS: WRITE default unit'
%4501%	E307,		! a key relation specifier must be specified with KEYID
%4501%	E308,		! illegal specifier in indexed read
%4501%	E309,		! indexed read is not ANSI compatible
%4501%	E310,		! key relation specifiers can only be used in READ stmt
%4503%	E311,		! format can not be asterisk or namelist in indexed read
%4503%	E314,		! UNIT must be specified
%4526%	E322,		! TOPS20 ONLY: xxx
%4543%	E324,		! list directed I/O used with internal files is non-standard

%1652%	FATLERR,
%2557%	INTRCHK,
	IODOXPN,
%2261%	IOSPEC,		! True if "(keywords)" used in I/O, false otherwise
	BASE LABLOFSTATEMENT,
	LEXNAME,
	LISTIO,
%4527%	ONEWPTR,	! Returns [1,,pointer] to Sixbit argument
	NAMLSTOK,
	NAMSET,
	NEWENTRY,
	SAVSPACE,
	STMNDESC;

%2247%	MACRO		!To aid in compatibility flagging
%2247%		ANSICHECK(STAT,ERR) =
%2247%		    IF FLAGANSI THEN WARNERR ((PLIT ASCIZ STAT)<0,0>,.ISN,ERR<0,0>)$,
%2247%		FLAGCHECK(STAT,ERR) =
%2247%		    IF FLAGEITHER THEN CFLAGB ((PLIT ASCIZ STAT)<0,0>,ERR<0,0>)$;
GLOBAL ROUTINE MULTIASGN(LEFTSIDE)=
BEGIN
	MAP BASE R1:R2;
%1455%	REGISTER BASE LHS;
%1455%	REGISTER BASE RHS;
	EXTERNAL NEWENTRY %()%,SAVSPACE %(SIZE,LOC)%;
	EXTERNAL STK,ASGNTYPER,LABLOFSTATEMENT;
	EXTERNAL WARNLEX;

	MACRO EXPRBASE=1,0,FULL$;

%2302%	BIND ISNOTSFN = 0;	! Flag for  CHASGN for  this  is  not  a
%2302%				! statement function.   Calls to  CASNM.
%2302%				! and CNCAM. are generated

%1254%	MAP BASE LEFTSIDE;

%1254%	IF .LEFTSIDE[VALTYPE] NEQ CHARACTER
%1254%	THEN
	BEGIN	! Numeric assignment

		NAME_IDOFSTATEMENT_ASGNDATA;
		NAME<RIGHT>_SORTAB;
		R1_NEWENTRY();
		R2_.STK[0];
		R1[RHEXP]_.R2[ELMNT1] % EXPRESSION POINTER %;
		R1[LHEXP]_R2_.LEFTSIDE;
		ASGNTYPER(.R1);	!CHECKING FOR ASSIGNMENT CONVERSION
		R2 _ .R1[LHEXP]; !RESTORING EXP PTR INCASE OF TYPE CONVERSION NODE INSERTED
		IF .R2[OPRCLS] EQL DATAOPR
		THEN R1[A1VALFLG]_1
		ELSE R2[PARENT] _ .R1;

		R2 _ .R1[RHEXP]; !RESTORE RH EXP PTR

		IF .R2[OPRCLS] EQL DATAOPR
		THEN R1[A2VALFLG]_1
		ELSE
		BEGIN
			R2[PARENT] _ .R1;
			IF .R2[FNCALLSFLG]
			THEN R1[FNCALLSFLG] _1
		END;
	END	! Numeric assignment
%1254%	ELSE
	BEGIN	! [1254] Character assignment

	! Turn the node into a
%2302%	!   CALL CASNM. (LHS,RHS)		! for CH1 = CH2
	! or
%2302%	!   CALL CNCAM. (LHS,RHS1,...,RHSn)	! for CH = CH1 // ... // CHn

		LHS _ .LEFTSIDE;	! Get pointer to LHS expressnion
		RHS _ @(.STK+1);	! Get pointer to RHS expression

%1455%		R1 = CHASGN(.LHS, .RHS, ISNOTSFN);

	END;  	! [1254] Character assignment

	SAVSPACE(.STK[0]<LEFT>,@STK[0]);

%1446%	RETURN .R1;	! Finally, return the created statement
			! so that our callers know we succeeded
END;

GLOBAL ROUTINE CHASGN(LHS, RHS, ISSFN)=
BEGIN

%1455%	! Moved out of MULTIASGN since it  is also used by BLDSFN  for
%1455%	! character  statement  functions.    This  routine   converts
%2302%	! character assignments to calls to CASNM. or CNCAM.  It  also
%1455%	! converts a character statement  function into either a  call
%2302%	! to CHSFN.  (the  statement function  form of  CASNM.)  or  a
%2302%	! call to  CHSFC. (the  statement  function form  of  CNCAM.).
%1455%	! CHSFC.   is   used   if   the   character   expression   has
%1455%	! concatenations at  its top  level, CHSFN.  is used  for  all
%1455%	! other character expressions.

%1455%	MAP BASE LHS;
%1455%	MAP BASE RHS;
%1455%	MAP BASE R1;
%1455%	MAP BASE R2;

	EXTERNAL TBLSEARCH,CORMAN;
	EXTERNAL E163;

	IF .RHS[VALTYPE] NEQ CHARACTER  ! If RHS is numeric 
	THEN FATLEX(E163<0,0>);		! "Illegal combination of
					! character and numeric data"

	NAME = IDOFSTATEMENT = CALLDATA; ! Make a CALL node

%1455%	IF .ISSFN EQL 1
%1455%	THEN
%1455%	BEGIN	! Character statement function

		R1 = CORMAN();		! Get space for the node,  don't
					! link it into the source tree
%4514%		R1[SRCID] = .IDOFSTATEMENT;
%4514%		R1[OPRCLS] = STATEMENT;
%4514%		IF (R1[SRCLBL] = .LABLOFSTATEMENT) NEQ 0	! If any
%4514%		THEN LABLOFSTATEMENT[SNHDR] = .R1;

%1455%	END	! Character statement function
%1455%	ELSE
%1455%	BEGIN	! Character assignment

		NAME<RIGHT> = SORTAB;
		R1 = NEWENTRY();	! Get space for the node, and
					! link it into the source tree

%1455%	END;	! Character assignment

	NAME = IDTAB;		! Get symbol table pointer for
%2302%				! CASNM., CNCAM., CHSFN., or CHSFC.

%1455%	IF .ISSFN EQL 1
%1455%	THEN
%1455%	BEGIN	! Character statement function

%1455%		IF .RHS[OPRCLS] EQL CONCATENATION
%1455%		THEN ENTRY = SIXBIT 'CHSFC.'
%1455%		ELSE ENTRY = SIXBIT 'CHSFN.'

%1455%	END	! Character statement function
%1455%	ELSE
%1455%	BEGIN	! Character assignment

%1455%		IF .RHS[OPRCLS] EQL CONCATENATION
%2302%		THEN ENTRY = SIXBIT 'CNCAM.'
%2302%		ELSE ENTRY = SIXBIT 'CASNM.'

%1455% 	END;	! Character assignment

%4527%	ENTRY = ONEWPTR(.ENTRY);	![1,,pointer]

	R1[CALSYM] = R2 = TBLSEARCH();
	IF NOT .FLAG		! If this was the first reference,
	THEN			! set up the symbol table entry as a
	BEGIN			! library function
		R2[OPERSP] = FNNAME;
%2302%		R2[IDLIBFNFLG] = 1;	! Set library function/subroutine flag
%2302%		IF .ISSFN NEQ 1		! Character assignment?
%2302%		THEN R2[IDCLOBB] = 1;	! Yes, set flag saying ACs are smashed
	END;

	! If top node of RHS expression is concatenation, turn it into
%2302%	! a CNCAM. call, otherwise call CASNM.

	IF .RHS[OPRCLS] EQL CONCATENATION
	THEN
	BEGIN	! Concatenation

		MAP ARGUMENTLIST R2;
%2261%		LOCAL BASE ARGH;	! Address of argument operand

		R1[CALLIST] = R2 = .RHS[ARG2PTR];

		! ARG2 of a CONCATENATION node
		! is an arg list suitable for CALL

		R2[1,ARGNPTR] = .LHS;  ! Fill in first argument
		IF .LHS[OPRCLS] EQL DATAOPR
		THEN R2[1,AVALFLG] = 1
		ELSE LHS[PARENT] = .R1;

		! Check for character arguments with length of (*).
		! The Fortran-77 specification does not allow them,
		! but both Fortran-10/20 and VMS do.

%2261%		IF FLAGANSI
%2261%		THEN
%2261%		    INCR I FROM 2 TO .R2[ARGCOUNT]
%2261%		    DO  BEGIN
%2261%			ARGH=.R2[.I,ARGNPTR];
%2261%		    	IF .ARGH[OPRCLS] EQL DATAOPR	! Is it data?
%2261%		    	THEN	IF SYMBOL(ARGH)		! Is it pointing to symbol?
%2261%				THEN	IF .ARGH[IDCHLEN] LSS 0
%2261%					THEN EXITLOOP (WARNERR(.ISN,E221<0,0>))
%2261%		    END;

		! Fix parent pointers of args 2-N.  They currently
		! point to the CONCATENATION node, change them to
		! point to the CALL node.

		INCR I FROM 2 TO .R2[ARGCOUNT]
		DO
		IF NOT .R2[.I,AVALFLG]
		THEN
		BEGIN
			ARGH = .R2[.I,ARGNPTR];
			ARGH[PARENT] = .R1;
		END;

		SAVSPACE(EXSIZ-1,.RHS);	! Toss the CONCATENATION node

	END	! Concatenation
	ELSE
	BEGIN	! Non-concatenation

		MAP ARGUMENTLIST R2;

%1413%		NAME<LEFT> = ARGLSTSIZE(2); 	! Allocate space for
						! arg list with 2 args
		R1[CALLIST] = R2 = CORMAN();

		R2[ARGCOUNT] = 2;	 ! Set arg count to 2

		R2[1,ARGNPTR] = .LHS;    ! first arg is LHS
		IF .LHS[OPRCLS] EQL DATAOPR 
		THEN R2[1,AVALFLG] = 1
		ELSE LHS[PARENT] = .R1;

		R2[2,ARGNPTR] = .RHS;    ! second arg is RHS
		IF .RHS[OPRCLS] EQL DATAOPR 
		THEN R2[2,AVALFLG] = 1
		ELSE RHS[PARENT] = .R1;

	END;	! Non-concatenation

	BTTMSTFNFLG = 0;	! This isn't a bottommost function
				! (ie, we destroy AC 16)

	RETURN .R1;
END;

GLOBAL ROUTINE ASSIGNMENT=
BEGIN
	EXTERNAL NAMSET,NAMDEF;
	REGISTER BASE T1:T2;
	EXTERNAL STK,SP,NEWENTRY %()%,SAVSPACE %(SIZE,LOC)%,MULTIASGN %()%,PROGNAME;
!------------------------------------------------------------------------------------------------------------------
!	SYNTAX RETURNS A LIST POINTER (COUNT^18+LOC) IN STK[0]. THIS LIST CONTAINS:
!
!	IDENTIFIER(20^18+LOC) - TO BE ASSIGNED
!	POINTER TO LOGICAL EXPRESSION - (COUNT^18+LOC)
!
!------------------------------------------------------------------------------------------------------------------
	T1_.STK[0];	!T1_LIST POINTER (COUNT^18+LOC)
	T2_.T1[ELMNT];	!T2_LOC(IDENTIFIER)
	% CHECK TO SEE IF ITS REALLY A VARIABLE  %
	IF  NAMSET( VARIABL1, .T2 )  LSS 0  THEN RETURN .VREG;
	% GENERATE THE ASSIGNMENT NODE %
	MULTIASGN(.T2)	! GIVE IT THE LEFT HAND SIDE
END;


GLOBAL ROUTINE SUBASSIGN=	! [1247] New

! Substring assignment

BEGIN
	EXTERNAL LEXEMEGEN,REFERENCE,EXPRESSION,COPYLIST;
	REGISTER BASE LHS:RHS:VAR;

	LEXL _ LEXEMEGEN();
	IF (LHS _ REFERENCE()) LSS 0 THEN RETURN .VREG;
	IF .LEXL<LEFT> NEQ EQUAL THEN RETURN ERR0L(.LEXNAM[EQUAL]);
	IF (RHS _ EXPRESSION()) LSS 0 THEN RETURN .VREG;

%1517%	IF .LEXL<LEFT> NEQ LINEND
%1517%	THEN RETURN ERR0L(.LEXNAM[LINEND])
%1517%	ELSE LSAVE _ 0;

%1661%	VAR = .LHS[ARG4PTR];
%2534%	VAR[IDATTRIBUT(STORD)] = 1;	
%2534%	IF  .FLGREG<CROSSREF>  THEN  CREFIT( .VAR, SETT );

	STK[0] _ .LHS;
	STK[1] _ .RHS;
	SP _ 1;
	COPYLIST(-1);
	RETURN MULTIASGN(.LHS);

END %SUBASSIGN%;



GLOBAL ROUTINE ASSISTA=
BEGIN
	EXTERNAL SAVSPACE %(SIZE,LOC)%,BLDVAR %(VPNT)%,NEWENTRY %()%, ASIPTR,TBLSEARCH %()%,STK,TYPE,SETUSE,NAMSET;
	EXTERNAL E147,E164;
	MAP BASE ASIPTR;REGISTER BASE R1:R2;
!SEMANTIC ANALYSIS BEGINS
	!--------------------------------------------------------------------------------
	!THE CALL TO SYNTAX LEAVES A LIST POINTER ON THE STACK (STK[0]).
	!THE POINTER POINTS TO THE LIST:
	!
	!LABEL (LABELEX^18+LOC) - THE LABEL TO BE ASSIGNED
	!VARIABLESPEC - POINTER TO SCALAR OR ARRAY ELEMENT
	!--------------------------------------------------------------------------------
	R1_.STK[0];	!R1_LIST POINTER
	% SET SETUSE FLAG FOR BLDVAR %
	SETUSE _ SETT;
	IF(STK[2]_R2_BLDVAR(.R1[ELMNT1])) LSS 0 THEN RETURN .VREG;

%1260%	% DON'T ALLOW ASSIGN TO CHARACTER VARIABLE %
%1260%	IF .R2[VALTYPE] EQL CHARACTER
%1260%	THEN RETURN FATLEX(E164<0,0>);

	% BLDVAR ALLOWS ARRAYS WITHOUT SUBSCRIPTS SO DON'T LET THEM THROUGH HERE %
	IF .R2<LEFT> EQL IDENTIFIER
	THEN	IF .R2[OPRSP1] EQL ARRAYNM1
%4516%		THEN	RETURN FATLEX (.R2[IDSYMBOL], ARPLIT<0,0>, E4<0,0> );

%766%	! GIVE WARNING FOR ASSIGN INTO SUBSCRIPTED VARIABLE
%766%	IF .R2<LEFT> EQL ARRAYREF
%766%	THEN WARNLEX(E147<0,0>);

	R2[IDATTRIBUT(INASSI)]_1;
	NAME_IDOFSTATEMENT_ASSIDATA;NAME<RIGHT>_SORTAB;R2_NEWENTRY();
	R2[ASILBL]_.R1[ELMNT];R2[ASISYM]_@STK[2];SAVSPACE(.R1<LEFT>,@R1);
![1150] Mark this label as having been ASSIGNed.
%[1150]% R1_.R2[ASILBL]; R1[SNASSIGNED]_1;
	IF .ASIPTR<LEFT> EQL 0 THEN ASIPTR<LEFT>_ASIPTR<RIGHT>_@R2
		ELSE
		BEGIN
			ASIPTR[ASILINK]_@R2;ASIPTR<RIGHT>_@R2
		END;
	.VREG
END;
GLOBAL ROUTINE GOTOSTA=
BEGIN
	EXTERNAL SAVSPACE %(SIZE,LOC)%,TBLSEARCH %()%,NEWENTRY %()%,STK,NAMREF;
	EXTERNAL EXPRTYPER,CNVNODE; !DOES TYPE CONVERSION IF NECESSARY
	EXTERNAL E147,E164;
	MACRO GETLAB =
		INCR LLST FROM @STK[2] TO @STK[2]+.STK[2]<LEFT> DO
		BEGIN
			MAP BASE LLST;
			LLST[ELMNT] _ .(@LLST[ELMNT])<RIGHT>
		END
	$;
	LOCAL BASE T1;  REGISTER BASE R1:T2:R2;
!SEMANTIC ANALYSIS BEGINS
	!---------------------------------------------------------------------------------
	!THE SYNTAX ROUTINE RETURNS A POINTER IN STK[0] TO THE LIST:
	!
	!CHOICE 1 - SIMPLE GOTO
	!	LABEL (LABELEX^18+LOC) 
	!CHOICE 2 - ASSIGNED OR COMPUTED GOTO
	!	CHOICE 1 - ASSIGNED GOTO
	!	COUNT^18+LOC - POINTER TO ASSIGNED VARIABLE AND LABEL LIST
	!	CHOICE 2 - COMPUTED GOTO
	!	COUNT^18+LOC - POINTER TO LABEL LIST AND CONTROL EXPRESSION
	!
	!SEE EXPANSION OF METASYMBOL GOTO FOR COMPLETE EXPANSION
	!---------------------------------------------------------------------------------
	R1_.STK[0];					!R1_LIST POINTER
	IF .R1[ELMNT] EQL  1 THEN			!CHOICE 1 - SIMPLE GOTO
	BEGIN
%1665%		! Don't allow simple GOTO as last statement of a DO loop

%1665%		IF .LABLOFSTATEMENT NEQ 0
%1665%		THEN IF .LABLOFSTATEMENT[SNDOLVL] NEQ 0
%1665%		     THEN RETURN FATLEX(E67<0,0>); ! "Illegal DO object"

		NAME_IDOFSTATEMENT_GOTODATA;NAME<RIGHT>_SORTAB;T1_NEWENTRY();
		T1[GOTOLBL]_.R1[ELMNT1];T1[GOTONUM]_T1[GOTOLIST]_0;
		RETURN
	END;
	!------------------------------------------------------------------------------
	!AT THIS POINT WE HAVE EITHER A COMPUTED OR ASSIGNED GOTO.
	!R1[ELMNT1] TELLS US WHICH.  CHOICE 1 = ASSIGNED GOTO, 
	!CHOICE 2 = COMPUTED GOTO.
	!------------------------------------------------------------------------------
	R2_.R1[ELMNT2];					!R2_LOC (ASSIGNED OR COMPUTED GOTO COMPONENTS)
	IF .R1[ELMNT1] EQL 1 THEN			!ASSIGNED GOTO
	BEGIN
%1665%		! Don't allow assigned GOTO as last statement of a DO loop

%1665%		IF .LABLOFSTATEMENT NEQ 0
%1665%		THEN IF .LABLOFSTATEMENT[SNDOLVL] NEQ 0
%1665%		     THEN RETURN FATLEX(E67<0,0>); ! "Illegal DO object"

%1277%		T1 _ .R2[ELMNT]; 	! GET POINTER TO ID TABLE ENTRY
%1277%		IF NAMREF(VARIABL1,.T1) LSS 0 THEN RETURN .VREG;
%1277%					! THIS STMT REFERENCES THE IDENTIFIER
%1277%		STK[1] _ .T1;

%1260%		% DON'T ALLOW GOTO CHARACTER VARIABLE %
%1260%		IF .T1[VALTYPE] EQL CHARACTER
%1260%		THEN RETURN FATLEX(E164<0,0>);

		IF .R2[ELMNT1] NEQ 0 THEN		!ASSIGNED GOTO WITH LABEL LIST
		BEGIN
%2455%			IF FLAGVMS THEN WARNERR(.ISN,E250<0,0>); !Comp Flagging
			T1_.R2[ELMNT2];STK[2]_.T1[ELMNT1];  !SKIP OPTIONAL COMMA
			GETLAB;
			SAVSPACE(.R2[ELMNT2]<LEFT>,.R2[ELMNT2]);
			STK[2]<LEFT> _ .STK[2]<LEFT>+1;  !INCREMENT COUNT OF LABELS
		END
		ELSE STK[2]_0;NAME_IDOFSTATEMENT_AGODATA;
	END
	ELSE
	BEGIN					!COMPUTED GOTO
		STK[2]_.R2[ELMNT];
		GETLAB;
		T2 _ STK[1] _.R2[ELMNT2];			!SKIP OPTIONAL COMMA
		STK[2]<LEFT> _ .STK[2]<LEFT>+1;  !INCREMENT COUNT OF LABELS

%1260%		! Don't allow GOTO character variable.
%1263%		! Allow character constant and make it hollerith.

%1263%		IF .T2[OPERATOR] EQL CHARCONST
%1263%		THEN	T2[OPERATOR] _ HOLLCONST	! Make it hollerith
%1263%		ELSE	IF .T2[VALTYPE] EQL CHARACTER
%1260%			THEN RETURN FATLEX(E164<0,0>);	! Character variable illegal

%2252%		IF .T2[VALTYPE] NEQ INTEGER
%2252%		THEN
%2252%			BEGIN
%2252%			IF FLAGANSI THEN WARNERR(.ISN,E258<0,0>); !Comp Flagging
%2252%			STK[1] _ CNVNODE(.T2,INTEGER,0)	! Convert to integer
%2252%			END;
		NAME_IDOFSTATEMENT_CGODATA;
	END;
	SAVSPACE(.R1<LEFT>,@R1);
	NAME<RIGHT>_SORTAB;T1_NEWENTRY();
	!PTR TO LABEL		NUM OF LABELS INLIST	 PTR TO LIST
	T1[GOTOLBL]_.STK[1];T1[GOTONUM]_.STK[2]<LEFT>;T1[GOTOLIST]_.STK[2]<RIGHT>;
	T2_.T1[GOTOLBL]; IF .T2[OPRCLS] NEQ DATAOPR THEN T2[PARENT] _ .T1;
	.VREG
END;
GLOBAL ROUTINE CALLSTA=
BEGIN
!++
! Builds a  CALL  statement node.   This  routine expects  to  return  a
! pointer in  STK[0] to  a  subroutine name  optionally followed  by  an
! argument list.  See expansion of metasymbol call for details.
!--

	REGISTER
		BASE T2=2,
%[745]%		BASE T1; 

	LOCAL
%1413%		ARGUMENTLIST ARGNODE,	! Argument list node for subroutine
		BASE CALLNODE,		! Call statement node.
%1413%		CNT,			! Count for increment loop.
%[745]%	 	BASE R1,		! Loaded from STK
%[745]%		BASE SYMTAB;		! STE for subroutine name.

	EXTERNAL E121;
	EXTERNAL STK,
		SAVSPACE %(SIZE,LOC)%,
		CORMAN %()%,
		NEWENTRY %()%,
		TBLSEARCH %()%,
		NAMSET,NAMREF,NAMDEF;


	!SEMANTIC ANALYSIS BEGINS


	R1_.STK[0];
	SYMTAB_.R1[ELMNT];	!SYMTAB_LOC(SUBROUTINE NAME)

	! Define and check the function name 

%2507%	SYMTAB[IDSUBROUTINE] = 1;	! This is a subroutine name
	IF NAMREF( FNNAME1 , .SYMTAB )  LSS 0
	THEN RETURN .VREG;

	IF .SYMTAB[IDATTRIBUT(SFN)]   THEN RETURN  FATLERR(.ISN,E121<0,0>);

%1531%	! Subroutine names can't appear in SAVE statements.
%1531%	IF .SYMTAB[IDSAVVARIABLE]
%1531%	THEN	FATLERR(.SYMTAB[IDSYMBOL],UPLIT(ASCIZ'Subroutine name'),
%1531%		.ISN,E192<0,0>);

	STK[1]_.SYMTAB;

!
!MAKE A CALL STATEMENT NODE
!
	NAME_IDOFSTATEMENT_CALLDATA;
	NAME<RIGHT>_SORTAB;
	CALLNODE _ NEWENTRY();

	IF .R1[ELMNT1] NEQ 0
	THEN	!ARGUMENT LIST
	BEGIN
![745] REWRITE WHOLE ROUTINE TO HANDLE REAL LONG ARGUMENT LISTS
%[745]%		LOCAL LISTPTR, TOTELMNTS;
%[745]%		LISTPTR _ .R1[ELMNT2];
%[745]%		TOTELMNTS _ 0;
%[745]%		!CALCULATE TOTAL NUMBER OF PARAMETERS IN LIST
%[745]%		INCR LISTNUM FROM 0 TO .LISTPTR<LEFT> DO
%[745]%		  TOTELMNTS_.TOTELMNTS+.(.LISTPTR<RIGHT>+.LISTNUM)<LEFT>+1;
%[745]%		TOTELMNTS_.TOTELMNTS  /   2;  !GET REAL COUNT

%1466%		! Make an argument node.

%[745]%		!Get free space for arg list
%[745]%		NAME<LEFT> _ ARGLSTSIZE(.TOTELMNTS);
%1413%		CALLNODE[CALLIST] _ ARGNODE _ CORMAN();
		ARGNODE[ARGCOUNT] _ .TOTELMNTS;	!Arg count
%1413%		ARGNODE[ARGPARENT] _ .CALLNODE;	!Pointer to call node

%1413%		! Arg checking  is  not  possible  for  a  dummy
%1413%		! routine name, LINK must  know the name of  the
%1413%		! subroutine at link-time.
%1677%		IF NOT .SYMTAB[IDATTRIBUT(DUMMY)] THEN
%1413%		ARGNODE[ARGCHBLOCK] _ 1;	!Want arg check block
%[745]%
%1737%		!Jump out of the routine here if number of arguments
%1737%		!is zero.  
%1737%		!LISTPTR points to number of sets of arguments.

%1737%		IF .TOTELMNTS NEQ 0
%1737%		THEN
%1737%		BEGIN	! Arguments exist.
%1737%			! Copy the arguments.
%1737%
%1737%			CNT = 0;

%[745]%			!Walk each of the potential lists of arguments

%[745]%			INCR LISTNUM FROM 0 TO .LISTPTR<LEFT> DO
%[745]%			BEGIN
%[745]%				T1_@(.LISTPTR<RIGHT>+.LISTNUM);
%[745]%
%[745]%				!LOOK AT EACH ELEMENT IN EACH LIST
				INCR ARG FROM @T1 TO @T1+.T1<LEFT> BY 2  DO
				BEGIN
					MAP BASE ARG;

%1413%					CNT _ .CNT+1;	!One more argument
					T2_.ARG[ELMNT1];
%1413%					ARGNODE[.CNT,ARGNPTR] _ .T2;
%1413%					ARGNODE[.CNT,AFLGFLD] _ 0;
					IF .ARG[ELMNT] EQL 1
					THEN
					BEGIN	! Expression

						IF .T2[OPRCLS] EQL DATAOPR 
%1413%						THEN
						BEGIN
							ARGNODE[.CNT,AVALFLG] _ 1;
							IF .T2[OPRSP1] EQL  ARRAYNM1
								OR  .T2[OPRSP1]  EQL  VARIABL1
%2557%							THEN	NAMSET(VARYREF, .T2 );

%2557%							! If the argument is a
%2557%							! function name, call
%2557%							! INTRCHK to check that
%2557%							! it has been declared
%2557%							! INTRINSIC and is a
%2557%							! specific function
%2557%							! name.
%2557%							IF .T2[OPR1] EQL FNNAMFL
%2557%							THEN INTRCHK(.T2);

						END
						ELSE
						BEGIN
							 T2[PARENT] _ .CALLNODE;
							 IF .T2[OPRCLS] EQL  ARRAYREF
							 THEN  NAMSET( ARRAYNM1, .T2[ARG1PTR])
						END;

					END	! Expression
					ELSE
					BEGIN	! Statement number
%1413%						ARGNODE[.CNT,AVALFLG] _ 1;
					END;

![745] CLEAN UP AFTER ALL THE ARGUMENTS ARE DONE, AND RECLAIM FREE SPACE
%[745]%				END;
%[745]%				!FOR EACH PARTIAL ARGUMENT LIST
%[745]%				SAVSPACE(.T1<LEFT>,.T1);
%[745]%				!GO TO NEXT PARTIAL LIST
%[745]%				T1_@(.R1[ELMNT2]+.LISTNUM);
%[745]%			END;

%[745]%			!CLEAN UP ALL PTRS TO ARGLISTS
%[745]%			SAVSPACE(.LISTPTR<LEFT>,.R1[ELMNT2]);
%1737%
%1737%		END;	! Arguments exist.

%[745]%	END	! Parenthesis given on subroutine reference

%[745]%	ELSE
%1466%	BEGIN	! No parenthesis on subroutine reference
%1466%
%1466%		NAME<LEFT> _ ARGLSTSIZE(0);
%1466%		CALLNODE[CALLIST] _ ARGNODE _ CORMAN();
%1466%		ARGNODE[ARGCOUNT] _ 0;		!Arg count
%1466%		ARGNODE[ARGPARENT] _ .CALLNODE;	!Pointer to call node
%1466%
%1413%		! Arg checking  is  not  possible  for  a  dummy
%1413%		! routine name, LINK must  know the name of  the
%1413%		! subroutine at link-time.
%1677%		IF NOT .SYMTAB[IDATTRIBUT(DUMMY)] THEN
%1466%			ARGNODE[ARGCHBLOCK] _ 1;	!Want arg check block
%1466%
%1466%	END;	! No parenthesis on subroutine reference

%[745]%	CALLNODE[CALSYM]_.STK[1];

	FLGREG<BTTMSTFL>_0;
	SAVSPACE(.R1<LEFT>,@R1);

END;	! of CALLSTA


GLOBAL ROUTINE RETUSTA=
BEGIN

	! Semantics for RETURN statement

	REGISTER BASE T1:R2;
	EXTERNAL STK,EXPRTYPER,SAVSPACE %(size,loc)%,NEWENTRY %()%;
	EXTERNAL LSAVE,LEXL,LEXNAME,EXPRESS,CNVNODE;


%1652%	! RETURN statements are  meaningless in a  main program, give  a
%1652%	! warning.
%1652%
%1652%	IF .FLGREG<PROGTYP> EQL MAPROG THEN FATLERR(.ISN,E209<0,0>);


	LEXL _ LEXEMEGEN();
	LSAVE _ -1;
	IF .LEXL<LEFT> NEQ LINEND 
	THEN
	BEGIN
		IF ( STK[0] _ EXPRESS() ) LSS 0
		THEN  RETURN  .VREG;
		IF .LEXL<LEFT>  NEQ  EOSLEX
		THEN	RETURN NOEOSERRL
	END
	ELSE STK[0] _ 0;

	!SEMANTIC ANALYSIS BEGINS

	!---------------------------------------------------------------
	! THIS ROUTINE  EXPECTS  IN STK[0],  A  POINTER TO  AN  OPTIONAL
	! RETURN EXPRESSION OR 0.
	!---------------------------------------------------------------

	NAME _ IDOFSTATEMENT _ RETUDATA;
	NAME<RIGHT> _ SORTAB;
	R2 _ NEWENTRY();
	R2[RETEXPR] _ T1 _ .STK[0];
	IF .T1 NEQ 0
	THEN
%2252%		BEGIN !Optional RETURN expression
%2252%		IF .T1[OPRCLS] NEQ DATAOPR THEN T1[PARENT] = .R2;
%2252%		IF .T1[VALTYPE] NEQ INTEGER
%2252%		THEN
%2252%			BEGIN ! Non-integer expression
%2252%			IF FLAGANSI THEN WARNERR(.ISN,E261<0,0>); !Comp Flagger
%2252%			R2[RETEXPR] = CNVNODE(.T1,INTEGER,0)	! Convert to integer
%2252%			END !Non-integer expression
%2252%		END; !Optional RETURN expression
	.VREG
END;
GLOBAL ROUTINE CONTSTA=
BEGIN
	EXTERNAL NEWENTRY;
        IF LEXEMEGEN() NEQ LINEND^18 THEN  RETURN  NOEOSERRV;
!SEMANTIC ANALYSIS BEGINS
	NAME _ IDOFSTATEMENT _ CONTDATA; NAME<RIGHT>_SORTAB; NEWENTRY();
	.VREG
END;
%[742]%	GLOBAL ROUTINE LITOR6DIGIT=
BEGIN
!
!PARSES OPTIONAL [LITERAL OR 6-DIGIT STRING ] AFTER STOP OR  PAUSE
!RETURNS LEXEME FOR EITHER
!

%1257%	REGISTER BASE R2;
	EXTERNAL  GSTOPOBJ,STLEXEME,LEXICAL;

	IF ( R2_LEXICAL( .GSTOPOBJ ))  EQL  0 
	THEN
	BEGIN	% ITS NOT A DIGIT OR '  %
		IF  LEXICAL (.GSTLEXEME )  NEQ  EOSLEX^18
		THEN
		BEGIN	% AND ITS NOT ENDOF STATEMENT EITHER %
%[742]%			RETURN FATLEX( PLIT'string or 6-digit integer?0',LEXPLITV,E0<0,0>)
		END
		% ELSE EOS IS OK %
	END
	ELSE
	BEGIN	% MAKE SURE THAT THERE WERE NO ERRORS IN THE OBJECT %
		IF .R2  EQL  EOSLEX^18
		THEN	RETURN -1;	! SOME SORT OF ERROR OCCURED
		%OTHERWISE ITS AN INTEGER OR LITERAL
		  WHICH MUST BE FOLLOWED BY EOS %
		IF LEXICAL(.GSTLEXEME)  NEQ  EOSLEX^18
		THEN	RETURN NOEOSERRV
	END;

%1257%	R2[OPERATOR] _ HOLLCONST;	! Change character constant arg into hollerith
	RETURN .R2
END;	% LITOR6DIGIT %



GLOBAL ROUTINE STOPSTA=
BEGIN
	REGISTER BASE R1:R2;
%[742]%	EXTERNAL STK,SAVSPACE %(SIZE,LOC)%,NEWENTRY %()%,LITOR6DIGIT;
%[742]%	IF (R2 _ LITOR6DIGIT()) LSS 0 THEN RETURN -1;
	NAME_IDOFSTATEMENT_STOPDATA;NAME<RIGHT>_SORTAB;R1_NEWENTRY();
	R1[STOPIDENT]_@R2;
	.VREG
END;
GLOBAL ROUTINE PAUSSTA=
BEGIN
	REGISTER BASE R1:R2;
%[742]%	EXTERNAL STK,SAVSPACE %(SIZE,LOC)%,NEWENTRY %()%,LITOR6DIGIT;
%[742]%	IF (R2 _ LITOR6DIGIT()) LSS 0 THEN RETURN -1;
	NAME_IDOFSTATEMENT_PAUSDATA;NAME<RIGHT>_SORTAB;R1_NEWENTRY();
	R1[PAUSIDENT]_.R2;
	.VREG
END;

GLOBAL ROUTINE IOBLD (NODEDATA,DEFUNIT,UNITFLAG)= ! [1465] New

!----------------------------------------------------------------------
!This routine expects a pointer in STK[0] to:
!	pointer to:
!		unit expression
!		format expression
!		encode/decode variable
!		rec expression
!		err label
!		end label
!		iostat variable
!		key expression	 [4501]
!		keyeq expression [4501]
!		keyge expression [4501]
!		keygt expression [4501]
!		keyid expression [4501]
!	option
!	iolist
!----------------------------------------------------------------------
!
! For ENCODE and DECODE, the action routine that parses the keyword list
! guarantees that unit, format, and variable are all present.

BEGIN
	REGISTER BASE T1;
	REGISTER BASE R1:R2;
	LOCAL IOL,
%1471%	      BASE DIMTBL;

	! Offsets into semantic block built by KEYSCAN

	STRUCTURE RBASE [I,J,K,L] =
		  CASE .I OF SET
   %0%		     (\.RBASE +.J)<.K,.L>;
   %1%		    (@\.RBASE +.J)<.K,.L>
		  TES;

	BIND RBASE QUNIT = 0<FULL,R2>:
		   QFMT = 1<FULL,R2>:
		   QVAR = 2<FULL,R2>:
		   QREC = 3<FULL,R2>:
		   QEND = 4<FULL,R2>:
		   QERR = 5<FULL,R2>:
		   QIOSTAT = 6<FULL,R2>:
%4501%		   QKEYID  = 7<FULL,R2>:
%4501%		   QKEYREL = 8<FULL,R2>:
%4501%		   QIOKEY  = 9<FULL,R2>;

	MACRO ILLSPECIFIER (NAME) =
%4527%		RETURN FATLEX (ONEWPTR(SIXBIT 'NAME'), E184<0,0>)$;

%1510%	MACRO ERR191(S) = 
%1510%		RETURN FATLEX (UPLIT ASCIZ 'S', E191<0,0>)$;

	MACRO OK = .VREG$;



	! Set statement type for LISTIO

	TYPE = IF .NODEDATA EQL READDATA OR .NODEDATA EQL DECODATA
	       THEN READD
	       ELSE WRITEE;

	R1 = .STK[0];			! Get pointer to args
	R2 = .R1[ELMNT];


	! Fill in default UNIT if necessary.  Check if UNIT was
	! specified in a statement like TYPE or ACCEPT, where unit
	! may not be specified.

	IF .QUNIT EQL 0
%4503%	THEN
%4503%	BEGIN
%4503%		IF .NODEDATA EQL REWRDATA 
%4503%		THEN FATLEX(E314<0,0>)	! UNIT must be specified for REWRITE 
%4503%		ELSE QUNIT = MAKECNST(INTEGER,0,.DEFUNIT)
%4503%	END
	ELSE IF NOT .UNITFLAG
	THEN FATLEX(E201<0,0>);	! "UNIT may not be specified"

	! Check UNIT.  Legal forms are *, integer expression,
	! character variable or array element or substring,
	! or character array name.

	IF .QUNIT^(-18) EQL ASTERISK
	THEN
	BEGIN	! UNIT=*
		QUNIT = MAKECNST(INTEGER,0,.DEFUNIT);
	END	! UNIT=*

	ELSE IF .QUNIT[VALTYPE] EQL CHARACTER
	THEN
	BEGIN	! UNIT = character
%4503%		IF .NODEDATA EQL REWRDATA THEN ILLSPECIFIER(UNIT)
%4503%		ELSE IF .QUNIT[OPRCLS] EQL DATAOPR
%4503%		THEN   ! Don't allow bare
		   (IF .QUNIT[OPRSP1] EQL FNNAME1    !   function name
		    THEN ILLSPECIFIER(UNIT)
		    ELSE IF .QUNIT[OPERSP] EQL CONSTANT	! Don't allow
		    THEN ILLSPECIFIER(UNIT)	        ! char constant
%1510%		    ELSE IF .QUNIT[OPRSP1] EQL ARRAYNM1
%1510%		    THEN
%1510%		    BEGIN
%1510%			DIMTBL = .QUNIT[IDDIM];	   ! Get Dimesion Table
%1510%			IF .DIMTBL[ASSUMESIZFLG]   ! Don't allow assume
%1510%			THEN ERR191(as unit specifiers); ! size array
%1510%		    END
		    ELSE OK)
	        ELSE IF .QUNIT[OPRCLS] EQL ARRAYREF THEN  OK
		ELSE IF .QUNIT[OPRCLS] EQL SUBSTRING THEN  OK
		ELSE ILLSPECIFIER(UNIT);
	END	! UNIT = character

	ELSE IF .QUNIT[OPRCLS] EQL RELATIONAL 
				! Don't allow any relational operator
	THEN FATLEX(E200<0,0>)	! including # (was REC= delimiter, now
				! gets parsed by EXPRESS as .NE.)

	ELSE
	BEGIN	! UNIT = numeric

		IF .QUNIT[OPRCLS] EQL DATAOPR  ! Don't allow bare array
		THEN IF .QUNIT[PARENLSTFLG]    !  name or function name
		     THEN ILLSPECIFIER(UNIT);

%2252%		IF .QUNIT[VALTYPE] NEQ INTEGER
%2252%		THEN	!Non-integer UNIT
%2252%			BEGIN
%2252%			ANSICHECK('UNIT',E259);	!Compatibility flagger
%2252%			QUNIT = CNVNODE(.QUNIT,INTEGER,0) !Convert to integer
%2252%			END;

	END;	! UNIT = numeric


	! Check FMT.  Legal forms are *, character expression,
	! character array name, statement label, numeric array name,
%2003%	! or integer, real, or logical variable name.

	IF .QFMT EQL 0
	THEN  OK		! FMT not specified

	ELSE IF .QFMT^(-18) EQL ASTERISK
%4503%	THEN
%4503%	BEGIN
%4503%		IF .NODEDATA EQL REWRDATA 
%4503%		THEN FATLEX (UPLIT ASCIZ 'a rewrite statement',UPLIT ASCIZ 'an asterisk',E311<0,0>)
%4503%	  	ELSE OK		! FMT = *	
%4503%	END

	ELSE IF .QFMT[OPRCLS] EQL LABOP
	THEN  OK		! FMT = label

%1510%	ELSE IF .QFMT[OPR2] EQL OPR2C(DATAOPR,ARRAYNAME)
%1510%	THEN			! FMT = Array or Formal Array
%1510%	BEGIN
%1510%	    DIMTBL = .QFMT[IDDIM];	! Get Dimesion Table
%1510%	    IF .DIMTBL[ASSUMESIZFLG]	! Don't allow assumed-size
%1510%	    THEN ERR191(as format specifiers)	!	array
%1510%	    ELSE OK
%1510%	END

	ELSE IF .QFMT[VALTYPE] EQL CHARACTER
	THEN OK			! FMT = character expression

	ELSE IF .QFMT[OPRCLS] NEQ DATAOPR
	THEN ILLSPECIFIER(FMT)	! expression, but not type character

	ELSE IF .QFMT[IDATTRIBUT(NAMNAM)]
%4503%	THEN
%4503%	BEGIN
%4503%		IF .NODEDATA EQL REWRDATA 
%4503%		THEN FATLEX (UPLIT ASCIZ 'a rewrite statement',UPLIT ASCIZ 'a namelist',E311<0,0>)
%4503%	  	ELSE OK		! FMT = namelist name	
%4503%	END

	ELSE IF .QFMT[OPRSP1] EQL FNNAME1
	THEN ILLSPECIFIER(FMT)	! FMT = function name

%2003%	ELSE IF .QFMT[DATOPS1] NEQ VARIABL1
%2003%	THEN ILLSPECIFIER(FMT)	! FMT not a variable
%2003%
%2003%	ELSE IF .QFMT[VALTYPE] EQL INTEGER
%2003%	THEN OK			! FMT = (assigned) integer variable
%2003%
%2003%	ELSE IF .QFMT[VALTYPE] EQL REAL
%2003%	THEN OK			! FMT = (assigned) real variable
%2003%
%2003%	ELSE IF .QFMT[VALTYPE] EQL LOGICAL
%2003%	THEN OK			! FMT = (assigned) logical variable

	ELSE ILLSPECIFIER(FMT);



	! Check REC.  Convert it to integer if necessary.  Also,
	! cannot be used with FMT=*.

	IF .QREC NEQ 0
%2252%	THEN
%4503%	BEGIN
%4503%		IF .NODEDATA EQL REWRDATA THEN ILLSPECIFIER(REC);
%2252%		IF .QREC[VALTYPE] NEQ INTEGER
%2252%		THEN	!Non-integer REC
%2252%			BEGIN
%2252%			ANSICHECK('REC',E259);	!Compatibility flagger
%2252%			QREC = CNVNODE(.QREC,INTEGER,0) !Convert to integer
%2252%			END;
%4503%	END;
	IF .QFMT^(-18) EQL ASTERISK
	THEN IF .QREC NEQ 0
	THEN RETURN FATLEX (UPLIT 'random access?0', E101<0,0>);
			    ! "List directed random access is illegal"


	! ERR and END must be statement labels.  No
	! check necessary.

	IF (.QEND NEQ 0) AND (.NODEDATA EQL REWRDATA) THEN ILLSPECIFIER(END);

	! IOSTAT must be an integer variable name.

	IF .QIOSTAT NEQ 0
	THEN
	BEGIN
		IF .QIOSTAT[VALTYPE] NEQ INTEGER
		THEN ILLSPECIFIER(IOSTAT);
	END;

%4501%	IF .NODEDATA EQL READDATA
%4501%	THEN 
%4501%	BEGIN
%4501%		! indexed read is not ANSI compatible
%4501%		IF (.QIOKEY NEQ 0) OR (.QKEYID NEQ 0)
%4501%		THEN
%4526% 		BEGIN
%4526%			IF NOT FTTENEX 
%4526%			THEN FATLEX (UPLIT ASCIZ 'key relation/key of reference specifiers',E322<0,0>);
%4501%			IF FLAGANSI THEN WARNLEX(E309<0,0>);
%4526%		END;
%4501%
%4501%		! if KEYID is specified then a key relation specifier must be specified
%4501%
%4501%		IF (.QKEYID NEQ 0) AND (.QKEYREL EQL 0) AND (.QIOKEY EQL 0)
%4501%		THEN FATLEX (E307<0,0>);

%4501%		IF (.QIOKEY NEQ 0)
%4501%		THEN
%4501%		BEGIN
%4501%		! END= and REC= may not be specified in an indexed read
%4501%		IF .QEND NEQ 0 THEN FATLEX (UPLIT ASCIZ 'END',E308<0,0>);
%4501%		IF .QREC NEQ 0 THEN FATLEX (UPLIT ASCIZ 'REC',E308<0,0>);
%4501%
%4501%		! format can not be an asterisk or a namelist in a indexed read
%4501%		IF .QFMT^(-18) EQL ASTERISK
%4501%		THEN FATLEX (UPLIT ASCIZ 'in an indexed read',UPLIT ASCIZ 'an asterisk',E311<0,0>)
%4501%		ELSE IF .QFMT[IDATTRIBUT(NAMNAM)]
%4501%		THEN FATLEX (UPLIT ASCIZ 'in an indexed read',UPLIT ASCIZ 'a namelist',E311<0,0>);
%4501%		END
%4501%	END
%4501%	ELSE
%4501%	BEGIN
%4501%		! key relation specifiers may only be used in read statements
%4501%		IF .QIOKEY NEQ 0 THEN FATLEX(E310<0,0>);
%4501%		IF .QKEYID NEQ 0 THEN ILLSPECIFIER(KEYID);
%4501%	END;

%1677%	! Check ENCODE/DECODE
%1677%
%1677%	IF .QVAR NEQ 0
%1677%	THEN
%1677%	BEGIN	! ENCODE/DECODE
%1677%					! QUNIT is character count
%1677%		IF .QUNIT[VALTYPE] NEQ INTEGER ! must be integer
%1677%		THEN ILLSPECIFIER(UNIT);
%1677%
%1677%		IF .QFMT^(-18) EQL ASTERISK ! FMT=* is illegal
%1677%		THEN RETURN FATLEX (KEYWRD(@STMNDESC),E101<0,0>);

%1677%		IF .QREC NEQ 0		! REC= cannot be specified
%1677%		THEN ILLSPECIFIER(REC);
%1677%
%1677%	END;	! ENCODE/DECODE

	! Do IO list

	IF .R1[ELMNT1] EQL 0
	THEN IOL = 0				! No IO list
	ELSE
	BEGIN
		T1 = .R1[ELMNT2];		! Get pointer to tree
		IOL = LISTIO(@@@.T1);		! Build IO list
		IF .IOL LSS 0 THEN RETURN .IOL;	! If error, pass it on
		SAVSPACE(0,@@.T1);		! Clean up
		SAVSPACE(0,@.T1);
		SAVSPACE(0,.T1);
	END;

%2063%	! Check for illegal namelist directed I/O.  It is not allowed in
%2063%	! REREAD, ENCODE, and  DECODE statements.   Also it  can not  be
%2063%	! used with an iolist.

	IF .QFMT NEQ 0
	THEN IF .QFMT[OPRCLS] EQL DATAOPR
	THEN IF .QFMT[IDATTRIBUT(NAMNAM)]
	THEN
%2063%	BEGIN	! NAMELIST I/O

%2063%		IF .QVAR NEQ 0		! Prohibit it in ENCODE and DECODE
%2063%		THEN RETURN FATLEX(UPLIT ASCIZ 'ENCODE and DECODE',E217);

%2063%		IF .DEFUNIT EQL -6	! Phohibit it in REREAD
%2063%		THEN RETURN FATLEX(UPLIT ASCIZ 'REREAD',E217);

%2063%		IF .IOL NEQ 0		! Prohibit it with an iolist
%2063%		THEN RETURN FATLEX(E102<0,0>);

%2063%	END;	! NAMELIST I/O


%1715%	! Check for proper use of internal files, and note that the
%1715%	! CHARACTER variable has been stored into.

%1471%	IF .QUNIT[VALTYPE] EQL CHARACTER
%1471%	THEN
%1471%	BEGIN	! Check Internal File

%1471%		! Make sure that there is a format.
%1471%		IF .QFMT EQL 0
%1471%		THEN RETURN FATLEX(UPLIT 'Unformatted I/O?0', E188<0,0>);

%1471%		! Make sure the format is not a NAMELIST.

%1471%		IF .QFMT[OPRCLS] EQL DATAOPR
%1471%		THEN IF .QFMT[IDATTRIBUT(NAMNAM)]
%1471%		THEN RETURN FATLEX(UPLIT 'NAMELIST I/O?0', E188<0,0>);

%4543%		! Make sure if list-directed and ansi flagging on, give warning

%4543%		IF .QFMT^(-18) EQL ASTERISK AND FLAGANSI 
%4543%		THEN WARNERR(.ISN,E324<0,0>);

%1471%		! Make sure there is no REC= specifier

%1471%		IF .QREC NEQ 0
%1471%		THEN RETURN FATLEX (UPLIT 'Random access I/O?0', E188<0,0>);

%1715%		IF .TYPE EQL WRITEE THEN QUNIT[IDATTRIBUT(STORD)] = 1;

%4501%		! Make sure NO indexed read key specifiers
%4501%
%4501%		IF (.QIOKEY NEQ 0) OR (.QKEYID NEQ 0)
%4501%		THEN FATLEX (UPLIT 'Indexed read key specifiers?0', E188<0,0>);

%1471%	END;	! of Check Internal File


	! Build statement node and fill it in

	NAME = IDOFSTATEMENT = .NODEDATA;
	NAME<RIGHT> = SORTAB;
	T1 = NEWENTRY();

	T1[IOUNIT] = .QUNIT;
	T1[IORECORD] = .QREC;
	T1[IOEND] = .QEND;
	T1[IOERR] = .QERR;
	T1[IOIOSTAT] = .QIOSTAT;
	T1[IOLIST] = .IOL<LEFT>;	
%4501%	IF .QKEYID NEQ 0 THEN T1[IOKEYID] = .QKEYID;! KEYID field same as REC field
%4501%	T1[IOKEYREL] = .QKEYREL;
%4501%	T1[IOKEY] = .QIOKEY;

	IF .QFMT^(-18) EQL ASTERISK
	THEN T1[IOFORM] = -1
	ELSE T1[IOFORM] = .QFMT;

%1677%	IF .QVAR NEQ 0			! ENCODE/DECODE?
%1677%	THEN				! yes
%1677%	BEGIN
%1677%		T1[IOVAR] = .QVAR;	! set i/o variable
%1677%		T1[IOCNT] = .QUNIT;	! set char count
%1677%	END;

%1471%	! If the unit is a multi-record internal file, we will need
%1471%	! the total size of the array in characters.  Store it in
%1471%	! the IORECORD field of the I/O statement.  (IORECORD is
%1471%	! normally the random access I/O record number.)

%1471%	IF .QUNIT[OPERATOR] EQL OPERC(CHARACTER,DATAOPR,ARRAYNAME)
%1471%	OR .QUNIT[OPERATOR] EQL OPERC(CHARACTER,DATAOPR,FORMLARRAY)
%1471%	THEN
%1471%	BEGIN
%1471%		DIMTBL = .QUNIT[IDDIM];	! Pointer to dimension table
%1471%		! Get the size of the array in characters.
%1471%		IF .DIMTBL[ADJDIMFLG]
%1471%		THEN T1[IORECORD]=.DIMTBL[ARASIZ]
%1471%		ELSE T1[IORECORD]=MAKECNST(INTEGER,0,.DIMTBL[ARASIZ]);
%1471%	END;

	! Set parent pointers of subexpression nodes

	IF .QUNIT NEQ 0
	THEN IF .QUNIT[OPRCLS] NEQ DATAOPR
	     THEN QUNIT[PARENT] = .T1;

	IF .QFMT NEQ 0
%1546%	THEN IF .QFMT^(-18) NEQ ASTERISK
	     THEN IF .QFMT[OPRCLS] NEQ DATAOPR
		  THEN IF .QFMT[OPRCLS] NEQ LABOP
		       THEN QFMT[PARENT] = .T1;

	IF .QREC NEQ 0
	THEN IF .QREC[OPRCLS] NEQ DATAOPR
	     THEN QREC[PARENT] = .T1;

	! Process implicit DOs in the IO list

	IODOXPN(.T1);

	! Clean up

	SAVSPACE(.R1<LEFT>,.R1);
	SAVSPACE(.R2<LEFT>,.R2);

	RETURN .T1;

END;	! IOBLD

GLOBAL ROUTINE BLDUTILITY (NODEDATA)=	! [1677] New

!----------------------------------------------------------------------
!This routine expects a pointer in STK[0] to:
!	pointer to:
!		unit expression
!		format expression
!		encode/decode variable
!		rec expression
!		err label
!		end label
!		iostat variable
!		keyid
!		key relational specifier
!		iokey
!----------------------------------------------------------------------

BEGIN
	REGISTER BASE T1;
	REGISTER BASE R1:R2;
	LOCAL IOL,
%1471%	      BASE DIMTBL;

	! Offsets into semantic block built by KEYSCAN

	STRUCTURE RBASE [I,J,K,L] =
		  CASE .I OF SET
   %0%		     (\.RBASE +.J)<.K,.L>;
   %1%		    (@\.RBASE +.J)<.K,.L>
		  TES;

	BIND RBASE QUNIT = 0<FULL,R2>:
		   QFMT = 1<FULL,R2>:
		   QVAR = 2<FULL,R2>:
		   QREC = 3<FULL,R2>:
		   QEND = 4<FULL,R2>:
		   QERR = 5<FULL,R2>:
		   QIOSTAT = 6<FULL,R2>:
%4501%		   QKEYID = 7<FULL,R2>:
%4501%		   QKEYREL = 8<FULL,R2>:
%4501%		   QIOKEY = 9<FULL,R2>;

	MACRO ILLSPECIFIER (NAME) =
%4527%		RETURN FATLEX (ONEWPTR(SIXBIT 'NAME'), E184<0,0>)$;

	MACRO OK = .VREG$;

	R1 = .STK[0];			! Get pointer to args
	R2 = .R1[ELMNT];


	! UNIT must be specified

	IF .QUNIT EQL 0			
	THEN ILLSPECIFIER(UNIT);

	! Check UNIT.  Must be integer expression.

	IF .QUNIT^(-18) EQL ASTERISK
	THEN ILLSPECIFIER(UNIT)

	ELSE IF .QUNIT[VALTYPE] EQL CHARACTER
	THEN ILLSPECIFIER(UNIT)

	ELSE IF .QUNIT[OPRCLS] EQL RELATIONAL 
				! Don't allow any relational operator
	THEN FATLEX(E200<0,0>)	! including # (was REC= delimiter, now
				! gets parsed by EXPRESS as .NE.)

	ELSE
	BEGIN	! UNIT = numeric

		IF .QUNIT[OPRCLS] EQL DATAOPR  ! Don't allow bare array
		THEN IF .QUNIT[PARENLSTFLG]    !  name or function name
		     THEN ILLSPECIFIER(UNIT);

%2252%		IF .QUNIT[VALTYPE] NEQ INTEGER
%2252%		THEN
%2252%			BEGIN	! Non-integer UNIT
%2252%			ANSICHECK('UNIT',E259);	! Compatibility flagging
%2252%			QUNIT = CNVNODE(.QUNIT,INTEGER,0) !Convert to integer
%2252%			END;	! Non-integer UNIT

	END;	! UNIT = numeric


	! FMT must be omitted

	IF .QFMT NEQ 0
	THEN ILLSPECIFIER(FMT);


	! Check REC.  Convert it to integer if necessary.  

	IF .QREC NEQ 0
%2252%	THEN
%2252%		IF .QREC[VALTYPE] NEQ INTEGER
%2252%		THEN
%2252%			BEGIN	! Non-integer REC
%2252%			ANSICHECK('REC',E259); !Compatibility flagger
%2252%			QREC = CNVNODE(.QREC,INTEGER,0) !Convert to integer
%2252%			END;	! Non-integer REC

	! ERR and END must be statement labels.  No
	! check necessary.


	! IOSTAT must be an integer variable name.

	IF .QIOSTAT NEQ 0
	THEN
	BEGIN
		IF .QIOSTAT[VALTYPE] NEQ INTEGER
		THEN ILLSPECIFIER(IOSTAT);
	END;

%4501%	IF .QKEYID NEQ 0 THEN ILLSPECIFIER(KEYID);
%4501%	IF .QIOKEY NEQ 0 THEN FATLEX(E310<0,0>); ! keys can only be specified in read stm

	! Build statement node and fill it in

	NAME = IDOFSTATEMENT = .NODEDATA;
	NAME<RIGHT> = SORTAB;
	T1 = NEWENTRY();

	T1[IOUNIT] = .QUNIT;
	T1[IORECORD] = .QREC;
	T1[IOEND] = .QEND;
	T1[IOERR] = .QERR;
	T1[IOIOSTAT] = .QIOSTAT;


	! Set parent pointers of subexpression nodes

	IF .QUNIT NEQ 0
	THEN IF .QUNIT[OPRCLS] NEQ DATAOPR
	     THEN QUNIT[PARENT] = .T1;

	IF .QREC NEQ 0
	THEN IF .QREC[OPRCLS] NEQ DATAOPR
	     THEN QREC[PARENT] = .T1;

	! Clean up

	SAVSPACE(.R1<LEFT>,.R1);
	SAVSPACE(.R2<LEFT>,.R2);

	RETURN .T1;

END;	! BLDUTILITY
GLOBAL ROUTINE OPTCOMMA=		![1233] New

! Action routine to check for and skip over the optional comma in
!	READ (1), X
!
! Also returns success if any token except EOL is seen (with or without comma),
! failure if EOL is seen, and failure plus an error message if a comma followed
! by EOL is seen.

BEGIN
	IF .LSAVE EQL 0 THEN (LEXL_LEXEMEGEN(); LSAVE_-1);  ! READ NEXT LEXEME
	IF .LEXL<LEFT> EQL COMMA 
	THEN
	BEGIN					! COMMA IS PRESENT
		LEXL_LEXEMEGEN(); LSAVE_-1;	! READ COMMA
		IF .LEXL<LEFT> NEQ LINEND	! COMMA FOLLOWED BY EOL?
		THEN RETURN 0			! NO, SUCCESS
		ELSE RETURN FATLEX(.LEXNAME[IDENTIFIER],.LEXNAME[.LEXL<LEFT>],E0<0,0>);  ! YES, ERROR
	END;
	IF .LEXL<LEFT> EQL LINEND THEN RETURN -1 ELSE RETURN 0
END;
GLOBAL ROUTINE CFSRCLIB (SYMTAB) = ! New in edit [2276]

!++
! FUNCTIONAL DESCRIPTION:
!
! Search a table of function and subroutine names for those subprograms
! which could cause an incompatibility with the VMS, or are an extension
! to the Fortran-77 standard.
!
! FORMAL PARAMETERS:
!
! 	SYMTAB is the pointer to the symbol table entry containing the name for
! 	which we search.
!
! IMPLICIT INPUTS:
!
!	Symbol table entry
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	If the entry is found, the returned value is the CFTABLEV entry,
!	which contains flags which describe the possible incompatibility.
!	If the entry is not found, the returned value is zero.	
!
! SIDE EFFECTS:
!
!	None
!
!--


BEGIN

! The table of names of subroutines/functions which have some kind of conflict:
!
! This table must match CFTABLEV word for word.
! ****** BEWARE OF SKEWS *********

	BIND CFTABLEN = UPLIT (

		SIXBIT 'ACOSD',
		SIXBIT 'ALG10.',
XALOG   INDEXES	SIXBIT 'ALOG',
		SIXBIT 'ALOG.',
XALOG10 INDEXES	SIXBIT 'ALOG10',
XAMAX1  INDEXES	SIXBIT 'AMAX1',
		SIXBIT 'AMAX1.',
XAMIN1  INDEXES	SIXBIT 'AMIN1',
		SIXBIT 'AMIN1.',
		SIXBIT 'ASIND',
		SIXBIT 'ASSIGN',
		SIXBIT 'ATAN2D',
		SIXBIT 'ATAND',
		SIXBIT 'BITEST',
		SIXBIT 'BJTEST',
		SIXBIT 'CDABS',
		SIXBIT 'CDCOS',
		SIXBIT 'CDEXP',
		SIXBIT 'CDLOG',
		SIXBIT 'CDSIN',
		SIXBIT 'CDSQRT',
		SIXBIT 'CHKDIV',
		SIXBIT 'CLOSE',
		SIXBIT 'CLRFMT',
XCMPLX  INDEXES	SIXBIT 'CMPLX',
		SIXBIT 'CMPLX.',
XCOSD   INDEXES	SIXBIT 'COSD',
		SIXBIT 'COSD.',
XCOTAN  INDEXES	SIXBIT 'COTAN',
		SIXBIT 'COTAN.',
		SIXBIT 'DACOSD',
		SIXBIT 'DASIND',
		SIXBIT 'DATAN2',	! **** This is really DATAN2D *****
		SIXBIT 'DATAND',
		SIXBIT 'DATE',
		SIXBIT 'DBLEQ',
		SIXBIT 'DCMPLX',
		SIXBIT 'DCONJG',
XDCOTAN INDEXES	SIXBIT 'DCOTAN',
		SIXBIT 'DCOTN.',
XDFLOAT INDEXES	SIXBIT 'DFLOAT',
		SIXBIT 'DFLOT.',
		SIXBIT 'DIMAG',
		SIXBIT 'DIVERT',
		SIXBIT 'DREAL',
		SIXBIT 'DTAND',
		SIXBIT 'DTOGA',
		SIXBIT 'DUMP',
		SIXBIT 'ERRSET',
		SIXBIT 'ERRSNS',
		SIXBIT 'ERRTST',
		SIXBIT 'EXIT',
		SIXBIT 'FDBSET',
		SIXBIT 'FFUNIT',
		SIXBIT 'GCOTN.',
		SIXBIT 'GFLOT.',
		SIXBIT 'GTODA',
		SIXBIT 'IDATE',
		SIXBIT 'IIAND',
		SIXBIT 'IIBCLR',
		SIXBIT 'IIBITS',
%2300%		SIXBIT 'IIBSET',
		SIXBIT 'IIEOR',
		SIXBIT 'IIOR',
		SIXBIT 'IISHFT',	!**** IISHFTC must be added later ****
		SIXBIT 'ILL',
		SIXBIT 'INOT',
		SIXBIT 'IRAD50',
		SIXBIT 'IZEXT',
		SIXBIT 'JIAND',
		SIXBIT 'JIBCLR',
		SIXBIT 'JIBITS',
		SIXBIT 'JIBSET',
		SIXBIT 'JIEOR',
		SIXBIT 'JIOR',
		SIXBIT 'JISHFT',	! ***** JISHFTC must be added later *****
		SIXBIT 'JNOT',
		SIXBIT 'JZEXT',
		SIXBIT 'LEGAL',
		SIXBIT 'OVERFL',
		SIXBIT 'PDUMP',
		SIXBIT 'QACOS',
		SIXBIT 'QACOSD',
		SIXBIT 'QASIN',
		SIXBIT 'QASIND',
		SIXBIT 'QATAN',
		SIXBIT 'QATAN2',	! ***** QATAN2D must be added later
		SIXBIT 'QATAND',
		SIXBIT 'QCOS',
		SIXBIT 'QCOSD',
		SIXBIT 'QCOSH',
		SIXBIT 'QDIM',
		SIXBIT 'QEXP',
		SIXBIT 'QEXT',
		SIXBIT 'QEXTD',
		SIXBIT 'QLOG',
		SIXBIT 'QLOG10',
		SIXBIT 'QMAX1',
		SIXBIT 'QMIN1',
		SIXBIT 'QMOD',
		SIXBIT 'QSIGN',
		SIXBIT 'QSIN',
		SIXBIT 'QSIND',
		SIXBIT 'QSINH',
		SIXBIT 'QSQRT',
		SIXBIT 'QTAN',
		SIXBIT 'QTAND',
		SIXBIT 'QTANH',
		SIXBIT 'R50ASC',
		SIXBIT 'RAD50',
		SIXBIT 'RANDU',
		SIXBIT 'SAVFMT',
		SIXBIT 'SAVRAN',
		SIXBIT 'SECNDS',
		SIXBIT 'SETRAN',
XSIND   INDEXES	SIXBIT 'SIND',
		SIXBIT 'SIND.',
		SIXBIT 'SNGLQ',
		SIXBIT 'SORT',
		SIXBIT 'TAND',
		SIXBIT 'TIME',
		SIXBIT 'TRACE',
		SIXBIT 'USEREX',
TNBOT INDEXES	SIXBIT 'ZEXT'

		);

! Table of flag settings corresponding to the subroutines/functions.
! Entries for dotted names have the index to the true entry in left half, and
!	zero in the right half.
! Entries for undotted names have zero in left half, and flags in right half.
!
! This table must match CFTABLEN word for word.
! ******* BEWARE OF SKEWS *********

	BIND CFTABLEV = UPLIT (

%2455%		CFFNVMS,		!ACOSD
		(XALOG10)^18,		!ALG10.
%2455%		CFNOTGNVMS,		!ALOG
		(XALOG)^18,		!ALOG.
%2455%		CFNOTGNVMS,		!ALOG10
%2455%		CFNOTGNVMS,		!AMAX1
		(XAMAX1)^18,		!AMAX1.
%2455%		CFNOTGNVMS,		!AMIN1
		(XAMIN1)^18,		!AMIN1.
%2455%		CFFNVMS,		!ASIND
%2455%		CFSBVMS,		!ASSIGN
%2455%		CFFNVMS,		!ATAN2D
%2455%		CFFNVMS,		!ATAND
%2455%		CFFNVMS,		!BITEST
%2455%		CFFNVMS,		!BJTEST
		CFNOTSBF77,		!CDABS
		CFNOTSBF77,		!CDCOS
%2455%		CFFNVMS+CFNOTSBF77,	!CDEXP
%2455%		CFFNVMS+CFNOTSBF77,	!CDLOG
%2455%		CFFNVMS+CFNOTSBF77,	!CDSIN
%2455%		CFFNVMS+CFNOTSBF77,	!CDSQRT
%2455%		CFNOTSBVMS+CFNOTSBF77,	!CHKDIV
%2455%		CFSBVMS,		!CLOSE
		CFNOTSBVMS+CFNOTSBF77,	!CLRFMT
		CFNOTFNF77,		!CMPLX
		(XCMPLX)^18,		!CMPLX.
		CFNOTFNF77+CFNOTGNUS,	!COSD
		(XCOSD)^18,		!COSD.
%2455%		CFNOTFNF77+CFNOTFNVMS,	!COTAN
		(XCOTAN)^18,		!COTAN.
%2455%		CFFNVMS,		!DACOSD
%2455%		CFFNVMS,		!DASIND
%2455%		CFFNVMS,		!DATAN2D
%2455%		CFFNVMS,		!DATAND
		CFSBDIFF+CFNOTSBF77,	!DATE
%2455%		CFFNVMS,		!DBLEQ
%2455%		CFFNVMS,		!DCMPLX
%2455%		CFFNVMS,		!DCONJG
%2455%		CFNOTFNF77+CFNOTFNVMS,	!DCOTAN
		(XDCOTAN)^18,		!DCOTN.
		CFNOTFNF77,		!DFLOAT
		(XDFLOAT)^18,		!DFLOT.
%2455%		CFFNVMS,		!DIMAG
%2455%		CFNOTSBVMS+CFNOTSBF77,	!DIVERT
%2455%		CFFNVMS,		!DREAL
%2455%		CFFNVMS,		!DTAND
%2455%		CFNOTSBVMS+CFNOTSBF77,	!DTOGA
%2455%		CFNOTSBVMS+CFNOTSBF77,	!DUMP
		CFSBDIFF+CFNOTSBF77,	!ERRSET
		CFSBDIFF+CFNOTSBF77,	!ERRSNS
%2455%		CFSBVMS,		!ERRTST
		CFSBDIFF+CFNOTSBF77,	!EXIT
%2455%		CFSBVMS,		!FDBSET
%2455%		CFNOTSBVMS,		!FFUNIT
		(XDCOTAN)^18,		!GCOTN.
		(XDFLOAT)^18,		!GFLOT.
		CFNOTSBVMS+CFNOTSBF77,	!GTODA
%2455%		CFSBVMS,		!IDATE
%2455%		CFFNVMS,		!IIAND
%2455%		CFFNVMS,		!IIBCLR
%2455%		CFFNVMS,		!IIBITS
%2455%		CFFNVMS,		!IIBSET
%2455%		CFFNVMS,		!IIEOR
%2455%		CFFNVMS,		!IIOR
%2455%		CFFNVMS,		!IISHFT
%2455%		CFNOTSBVMS+CFNOTSBF77,	!ILL
%2455%		CFFNVMS,		!INOT
%2455%		CFSBVMS,		!IRAD50
%2455%		CFFNVMS,		!IZEXT
%2455%		CFFNVMS,		!JIAND
%2455%		CFFNVMS,		!JIBCLR
%2455%		CFFNVMS,		!JIBITS
%2455%		CFFNVMS,		!JIBSET
%2455%		CFFNVMS,		!JIEOR
%2455%		CFFNVMS,		!JIOR
%2455%		CFFNVMS,		!JISHFT
%2455%		CFFNVMS,		!JNOT
%2455%		CFFNVMS,		!JZEXT
%2455%		CFNOTSBVMS+CFNOTSBF77,	!LEGAL
%2455%		CFNOTSBVMS+CFNOTSBF77,	!OVERFL
%2455%		CFNOTSBVMS+CFNOTSBF77,	!PDUMP
%2455%		CFFNVMS,		!QACOS
%2455%		CFFNVMS,		!QACOSD
%2455%		CFFNVMS,		!QASIN
%2455%		CFFNVMS,		!QASIND
%2455%		CFFNVMS,		!QATAN
%2455%		CFFNVMS,		!QATAN2
%2455%		CFFNVMS,		!QATAND
%2455%		CFFNVMS,		!QCOS
%2455%		CFFNVMS,		!QCOSD
%2455%		CFFNVMS,		!QCOSH
%2455%		CFFNVMS,		!QDIM
%2455%		CFFNVMS,		!QEXP
%2455%		CFFNVMS,		!QEXT
%2455%		CFFNVMS,		!QEXTD
%2455%		CFFNVMS,		!QLOG
%2455%		CFFNVMS,		!QLOG10
%2455%		CFFNVMS,		!QMAX1
%2455%		CFFNVMS,		!QMIN1
%2455%		CFFNVMS,		!QMOD
%2455%		CFFNVMS,		!QSIGN
%2455%		CFFNVMS,		!QSIN
%2455%		CFFNVMS,		!QSIND
%2455%		CFFNVMS,		!QSINH
%2455%		CFFNVMS,		!QSQRT
%2455%		CFFNVMS,		!QTAN
%2455%		CFFNVMS,		!QTAND
%2455%		CFFNVMS,		!QTANH
%2455%		CFSBVMS,		!R50ASC
%2455%		CFSBVMS,		!RAD50
%2455%		CFSBVMS,		!RANDU
%2455%		CFNOTSBVMS+CFNOTSBF77,	!SAVFMT
%2455%		CFNOTSBVMS+CFNOTSBF77,	!SAVRAN
%2455%		CFSBVMS,		!SECNDS
%2455%		CFNOTSBVMS+CFNOTSBF77,	!SETRAN
		CFNOTFNF77+CFNOTGNUS,	!SIND
		(XSIND)^18,		!SIND.
%2455%		CFFNVMS,		!SNGLQ
%2455%		CFNOTSBVMS+CFNOTSBF77,	!SORT
%2455%		CFFNVMS,		!TAND
		CFSBDIFF+CFNOTSBF77,	!TIME
%2455%		CFNOTSBVMS+CFNOTSBF77,	!TRACE
%2455%		CFSBVMS,		!USEREX
%2455%		CFFNVMS			!ZEXT

		);

	MAP BASE SYMTAB;	! Symbol Table entry

	LOCAL
		TOP,		! Index to first viable entry
		BOTTOM;		! Index to last viable entry

	REGISTER
		NAME,		! Name for which we search
		CENTER;		! Index to current entry


%4527%	! Our names are only 6 characters (one word) long.  Give up now if
%4527%	! the name if over that length.
%4527%
%4527%	IF .SYMTAB[IDSYMLENGTH] GTR 1 THEN RETURN 0;

%4527%	NAME = .SYMTAB[ID1ST6CHAR]; ! Name from symbol table entry

	TOP = 0;		! Start looking at
	BOTTOM = (TNBOT);	!    the entire table

	! Loop until:
	!	Entry found, in which case return the CFTABLEV entry,
	!    or all entries examined, in which case return zero

%2303%	WHILE .BOTTOM GEQ .TOP
%2303%	DO
%2303%	BEGIN	! Look for entry
		CENTER = (.TOP + .BOTTOM) / 2;	! Look here

		IF .NAME EQL .CFTABLEN[.CENTER]
		THEN
		BEGIN	! Entry matches
			IF (TOP = .CFTABLEV[.CENTER]<LEFT>) NEQ 0
%2303%			THEN CENTER = .TOP;	! Index to undotted name
			RETURN .CFTABLEV[.CENTER]
		END;	! Entry matches

		IF .NAME GTR .CFTABLEN[.CENTER]
		THEN TOP = .CENTER + 1		! Ignore old top thru center
		ELSE BOTTOM = .CENTER -1;	! Ignore center thru old bottom
%2303%	END;	! Look for entry

	RETURN 0		! No match

END;	! of CFSRCLIB
GLOBAL ROUTINE READSTA=
%1546% IOBLD(READDATA,-5,TRUE);

GLOBAL ROUTINE WRITSTA=
%2261%	BEGIN
%2261%	REGISTER BASE R;
%2261%	STRUCTURE RBASE [I,J,K,L] =
%2261%		CASE .I OF SET
%2261%		    (\.RBASE +.J)<.K,.L>;	!0
%2261%		    (@\.RBASE +.J)<.K,.L>	!1
%2261%		TES;
%2261%	BIND RBASE QUNIT = 0<FULL,R>;
%2261%
%2261%	IF FLAGEITHER
%2261%	THEN	! Check for default unit
%2261%		BEGIN
%2261%		R=.STK[0];
%2261%		R=.R[ELMNT];
%2261%		IF .QUNIT EQL 0 THEN CFLAGB(E285<0,0>)
%2261%		END;
%1546%	IOBLD(WRITDATA,-3,TRUE)
%2261%	END; ! of WRITSTA

GLOBAL ROUTINE REWRSTA=

!++
! FUNCTIONAL DESCRIPTION:
!
!	Perform keyword processing for the REWRITE statement 
!
! FORMAL PARAMETERS:
!
!	None
!
! IMPLICIT INPUTS:
!
!	STK	Points to the address of the block of specifiers built 
!		by KEYSCAN
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	Rewrite statement node
!
! SIDE EFFECTS:
!
!	None
!
!--

BEGIN	![4503]	New
%4526%	IF NOT FTTENEX THEN FATLEX (UPLIT ASCIZ 'REWRITE statement',E322<0,0>);
	ANSICHECK('REWRITE',E267);
	IOBLD(REWRDATA,-3,TRUE);
END; ! of REWRSTA

GLOBAL ROUTINE TYPESTA=
%2247%	BEGIN
%2247%	ANSICHECK('TYPE',E267);
%1546%	IOBLD(WRITDATA,-1,FALSE)
%2247%	END; ! of TYPESTA

GLOBAL ROUTINE PUNCSTA=
%2247%	BEGIN
%2247%	FLAGCHECK('PUNCH',E268);
%1546%	IOBLD(WRITDATA,-2,FALSE)
%2247%	END; ! of PUNCSTA

GLOBAL ROUTINE PRINSTA=
%2261%	BEGIN
%2261%	IF FLAGEITHER
%2261%	THEN IF .IOSPEC THEN CFLAGB(E269<0,0>);
%1546%	IOBLD(WRITDATA,-3,FALSE)
%2261%	END; ! of PRINSTA

GLOBAL ROUTINE ACCESTA=
%2247%	BEGIN
%2247%	ANSICHECK('ACCEPT',E267);
%1546%	IOBLD(READDATA,-4,FALSE)
%2247%	END; ! of ACCESTA

GLOBAL ROUTINE RERESTA=
%2247%	BEGIN
%2247%	FLAGCHECK('REREAD',E268);
%1546%	IOBLD(READDATA,-6,FALSE);
%2247%	END; ! of RERESTA

GLOBAL ROUTINE ENCOSTA=
%2252%	BEGIN
%2252%	IF FLAGANSI THEN WARNERR(.ISN,E233<0,0>);	!Compatibility flagger
%1677%	IOBLD(ENCODATA,0,TRUE);
%2252%	END;

GLOBAL ROUTINE DECOSTA=
%2252%	BEGIN
%2252%	IF FLAGANSI THEN WARNERR(.ISN,E232<0,0>);	!Compatibility flagger
%1677%	IOBLD(DECODATA,0,TRUE);
%2252%	END;

! Below is for RUNOFF in generating .PLM files
!++
!.END LITERAL
!--

END
ELUDOM