Google
 

Trailing-Edge - PDP-10 Archives - FORTRAN-10_V7wLink_Feb83 - sta0.bli
There are 26 other files named sta0.bli in the archive. Click here to see a list.
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
!  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1973, 1983
!AUTHOR: F.J. INFANTE/HPW/ D. B. TOLMAN/DCE/TFV/CKS/CDM/AHM/RVM

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



GLOBAL BIND STA0V = 7^24 + 0^18 + #1715;	! Version Date: 12-Jan-83


%(

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

)%

SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE META72.BLI;
REQUIRE ASHELP.BLI;
SWITCHES LIST;

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

FORWARD
	MULTIASGN,
	ASSIGNMENT,	! ASSIGNMENT
%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
	CNVNODE,
	E102,
	E184,
	E188,
	E191,
	E192,		! "Illegal in SAVE statement"
	E200,
	E201,
%1652%	E209,		! "RETURN illegal in main routine"
%1652%	FATLERR,
	IODOXPN,
	BASE LABLOFSTATEMENT,
	LEXNAME,
	LISTIO,
	NAMLSTOK,
	NAMSET,
	NEWENTRY,
	SAVSPACE,
	STMNDESC;

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$;

%1455%	BIND ISNOTSFN = 0;	! Flag for  CHASGN. for  this is  not  a
				! statement function.   Calls to  CHASN.
				! and CONCA. 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
	!   CALL CHASN. (LHS,RHS)		! for CH1 = CH2
	! or
	!   CALL CONCA. (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
%1455%	! character assignments to calls to CHASN. or CONCA.  It  also
%1455%	! converts a character statement  function into either a  call
%1455%	! to CHSFN.  (the subroutine  form of  CHASN.)  or  a call  to
%1455%	! CHSFC. (the subroutine form of  CONCA.).  CHSFC. is used  if
%1455%	! the character  expression  has  concatenations  at  its  top
%1455%	! level, CHSFN. is used for all 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

%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
				! CHASN., CONCA., 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
%1455%		THEN ENTRY = SIXBIT 'CONCA.'
%1455%		ELSE ENTRY = SIXBIT 'CHASN.'

%1455% 	END;	! Character assignment

	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;
		 R2[IDLIBFNFLG] = 1
	END;

	! If top node of RHS expression is concatenation, turn it into
	! a CONCA. call, otherwise call CHASN.

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

		MAP ARGUMENTLIST R2;
		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;

		! 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
			LOCAL BASE ARGH;
			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%	! If LHS is a substring of a scalar, call NAMSET to set STORD for it

%1661%	VAR = .LHS[ARG4PTR];
%1661%	IF .VAR[OPRCLS] EQL DATAOPR
%1661%	THEN IF NAMSET(VARIABL1,.VAR) LSS 0
%1661%	     THEN RETURN .VREG;

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

		IF .T2[VALTYPE] NEQ INTEGER THEN  STK[1] _ CNVNODE(.T2,INTEGER,0);
		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.

	REGISTER T2=2;
%[745]%	REGISTER BASE T1; 
	MAP BASE T2;
%[745]%	LOCAL BASE R1:SYMTAB;
%1413%	LOCAL ARGUMENTLIST ARGNODE;	!Argument list node for subroutine
%1413%	LOCAL CNT;			!Count for increment loop.
	EXTERNAL E121;
	EXTERNAL STK,
		SAVSPACE %(SIZE,LOC)%,
		CORMAN %()%,
		NEWENTRY %()%,
		TBLSEARCH %()%,
		NAMSET,NAMREF,NAMDEF;
	MACRO
		CARGPTR=0,0,RIGHT$,
		CAFLGFLD=0,0,LEFT$,
		ERR15(X) = RETURN FATLEX(X,SYMTAB[IDSYMBOL],E15<0,0>)  $;
	MACHOP BLT=#251;
	LOCAL BASE CALLNODE;

	!SEMANTIC ANALYSIS BEGINS

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


	R1_.STK[0];
	SYMTAB_.R1[ELMNT];	!SYMTAB_LOC(SUBROUTINE NAME)
	% DEFINE AND CHECK THE FUNCTION 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.   Do also if  /DEBUG:ARGUMENTS  is
%1466%		! specified and the number of arguments is zero.

%[1217]%	IF .TOTELMNTS NEQ 0
%1613%		   OR  .FLGREG<DBGARGMNTS>
%1466%		THEN
%[1217]%	BEGIN	! Arg list is to be made

%[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]%
%[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
%1413%				CNT _ 0;
				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		!EXPRESSION
					BEGIN
						IF .T2[OPRCLS] EQL DATAOPR 
%1413%						THEN
						BEGIN
							ARGNODE[.CNT,AVALFLG] _ 1;
							IF .T2[OPRSP1] EQL  ARRAYNM1
								OR  .T2[OPRSP1]  EQL  VARIABL1
							THEN	NAMSET(VARYREF, .T2 )
						END
						ELSE
						BEGIN
							 T2[PARENT] _ .CALLNODE;
							 IF .T2[OPRCLS] EQL  ARRAYREF
							 THEN  NAMSET( ARRAYNM1, .T2[ARG1PTR])
						END;

					END
					ELSE	!STATEMENT NUMBER
					BEGIN
%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;

%1466%			IF .TOTELMNTS NEQ 0 THEN
%[745]%			!CLEAN UP ALL PTRS TO ARGLISTS
%[745]%			SAVSPACE(.LISTPTR<LEFT>,.R1[ELMNT2]);
!**;[1217], CALLSTA, DCE, 28-May-81
%[1217]%	END	! Arg list is to be made

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

%[745]%	ELSE	! No parenthisis on subroutine reference
%1466%	BEGIN
%1613%		IF .FLGREG<DBGARGMNTS>
%1466%		THEN	! /DEBUG:ARGUMENTS specified
%1466%		BEGIN	! Create arg list for arg checking

%1466%			NAME<LEFT> _ ARGLSTSIZE(0);
%1466%			CALLNODE[CALLIST] _ ARGNODE _ CORMAN();
%1466%			ARGNODE[ARGCOUNT] _ 0;		!Arg count
%1466%			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
%1466%			ARGNODE[ARGCHBLOCK] _ 1;	!Want arg check block
%1466%		END;

%1466%	END;	! No parenthisis 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	(IF .T1[OPRCLS] NEQ DATAOPR THEN T1[PARENT] _ .R2;
		IF .T1[VALTYPE] NEQ INTEGER THEN R2[RETEXPR] _ CNVNODE(.T1,INTEGER,0);
		);
	.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
!	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>;

	MACRO ILLSPECIFIER (NAME) =
		RETURN FATLEX (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
	THEN QUNIT = MAKECNST(INTEGER,0,.DEFUNIT)
	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
		IF .QUNIT[OPRCLS] EQL DATAOPR 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);

		IF .QUNIT[VALTYPE] NEQ INTEGER ! Convert to integer if
		THEN QUNIT = CNVNODE(.QUNIT,INTEGER,0);	! necessary

	END;	! UNIT = numeric


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

	IF .QFMT EQL 0
	THEN  OK		! FMT not specified

	ELSE IF .QFMT^(-18) EQL ASTERISK
	THEN  OK		! FMT = *

	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)]
	THEN  OK		! FMT = namelist name

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

	ELSE IF .QFMT[VALTYPE] EQL INTEGER
	THEN  OK		! FMT = (assigned) integer variable

	ELSE ILLSPECIFIER(FMT);



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

	IF .QREC NEQ 0
	THEN IF .QREC[VALTYPE] NEQ INTEGER
	THEN QREC = CNVNODE(.QREC,INTEGER,0);

	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.


	! IOSTAT must be an integer variable name.

	IF .QIOSTAT NEQ 0
	THEN
	BEGIN
		IF .QIOSTAT[VALTYPE] NEQ INTEGER
		THEN ILLSPECIFIER(IOSTAT);
	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%
%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;


	! Check for namelist directed IO with an IO list

	IF .QFMT NEQ 0
	THEN IF .QFMT[OPRCLS] EQL DATAOPR
	THEN IF .QFMT[IDATTRIBUT(NAMNAM)]
	THEN IF .IOL NEQ 0
	THEN RETURN FATLEX(E102<0,0>);


%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>);

%1471%		! Make sure the format is not asterisk.

%1471%		IF .QFMT^(-18) EQL ASTERISK
%1471%		THEN RETURN FATLEX(UPLIT 'List directed I/O?0',E188<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;

%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>;

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

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

	MACRO ILLSPECIFIER (NAME) =
		RETURN FATLEX (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);

		IF .QUNIT[VALTYPE] NEQ INTEGER ! Convert to integer if
		THEN QUNIT = CNVNODE(.QUNIT,INTEGER,0);	! necessary

	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
	THEN IF .QREC[VALTYPE] NEQ INTEGER
	THEN QREC = CNVNODE(.QREC,INTEGER,0);


	! 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;

	! 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 READSTA=
%1546% IOBLD(READDATA,-5,TRUE);

GLOBAL ROUTINE WRITSTA=
%1546% IOBLD(WRITDATA,-3,TRUE);

GLOBAL ROUTINE TYPESTA=
%1546%	IOBLD(WRITDATA,-1,FALSE);

GLOBAL ROUTINE PUNCSTA=
%1546%	IOBLD(WRITDATA,-2,FALSE);

GLOBAL ROUTINE PRINSTA=
%1546%	IOBLD(WRITDATA,-3,FALSE);

GLOBAL ROUTINE ACCESTA=
%1546%	IOBLD(READDATA,-4,FALSE);

GLOBAL ROUTINE RERESTA=
%1546%	IOBLD(READDATA,-6,FALSE);

GLOBAL ROUTINE ENCOSTA=
%1677%	IOBLD(ENCODATA,0,TRUE);

GLOBAL ROUTINE DECOSTA=
%1677%	IOBLD(DECODATA,0,TRUE);

END
ELUDOM