Google
 

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

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

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

GLOBAL BIND ACT0V = 7^24 + 0^18 + #1702;	! Version Date: 9-Dec-82

%(

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

47	----	-----	ADD ROUTINE TO GENERATE TEMPORARIES FOR
			STATEMENT FUNCTION DUMMIES

48	-----	-----	ADD THE CODE TO PNAMSET TO HANDLE THE *N
			CONSTRUCT AFTER FUNCTION NAMES

49	-----	-----	FIX RECORDMARK TO SIMULATE VARIBLESPEC PRORERLY
			ITS ALL IBMS FAULT!!!!!!

50	-----	-----	FIX ERROR RETURN IN EXPRLIST TO RETURN -1 AND
			THUS SUPRESS AN EXTRANEOUS ERROR MESSAGE

51	-----	-----	SET ACTLDATYPE IN TYPEID FOR ASTER()

***** Begin Version 4B *****

52	325	17044	CHECK FOR STACK OVERFLOW IN LONG ARG LISTS.

***** Begin Version 5A *****

53	603	23442	ALLOW * AS NEW STATEMENT LABEL CONSTANT
			BEGINNING CHARACTER, (DCE)

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

54	716	26409	MARK LABELS WHICH CAN BE REACHED ON RETURN
			FROM SUBROUTINES DIRECTLY, (DCE)

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

55	760	TFV	1-Oct-79	------
	Recordmark is optional in FIND statement since REC= expression
	is now legal

56	777	EGM	27-Jun-80	-----
	In RECORDMARK, when parsing an array reference for a unit specification,
	set LSAVE to indicate that we have used the right paren lexeme.

57	1061	DCE	9-Apr-81	-----
	Give warning for # used in a random I/O statement

61	1132	AHM	22-Sep-81	Q10-06347
	Reword message E150 defined by edit 1061 to refer to REC= as well as '

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

58	1213	TFV	20-May-81	------
	Modify ASTERTYPE to handle CHARACTER*n. Clean up use of .VREG
	Fix IMPLICIT handling; TYPTABle now has two word entries; second
	word is character count for character data.

59	1217	DCE	28-May-81	-----
	Allow CALL stmnt with null arg list, i. e., CALL FOO()

60	1232	TFV	16-Jul-81	------
	TYPEID sets CHDECL flag if a character declaration is seen. Used
	in MRP3R and MRP3G to test if we have to scan the symbol table to
	generate high seg character descriptors.

62	1410	CKS	28-Oct-81
	Add action routine CMNCOMMA to analyze commas in COMMON statements.
	A comma is a list terminator if followed by /, otherwise a separator.

63	1421	CKS	11-Nov-81
	Add action routine NULLCHECK to check for null parameter lists in
	statement function definitions.  In a definition of the form F() = ...
	we can't use +SUBLOCAL to read a list of parameters, since SUBLOCAL
	will complain when it sees the right paren.  NULLCHECK is called before
	SUBLOCAL to detect the right paren and cause SYNTAX to take the other
	alternative, which must match right paren.

64	1434	TFV	7-Dec-81	------
	Add a routine CHARGLIST  to convert non-character function  argument
	blocks to character  function argument  blocks. They  have an  extra
	argument.  It is the  first argument and is  the descriptor for  the
	result.  This fixes the cases where a function statement is followed
	by a character or implicit character statement that changes the type
	of the function.

65	1465	CKS	20-Jan-82
	Add KEYSCAN routine to parse the keyword list in READ and WRITE
	statements.

66	1470	CKS	2-Feb-81
	Make KEYSCAN parse READ (unit ' record).

1505	AHM	9-Mar-82
	Make SUBLOCAL  set  the  psect  index  of  statement  function
	formals to PSDATA for extended addressing support.

1527	CKS	29-Apr-82
	Add new routines CONSTEXPR, EVAL, and MAKELIT to parse
	constant expressions.  Add ASTEREXPR to parse length specifications
	in declarations of the form *const, *(expression), or *(*).

1535	CDM	17-May-82
	Fixes to optimize CHAR(constant) and ICHAR(constant) into constants.

1546	CKS	31-May-82
	Allow expressions in TYPE, ACCEPT, et al.  Unify the handling of
	"READ f, list" vs. "READ (cilist) list" forms.

1573	CKS	1-Jul-82
	Add LABELANDWHILE action routine to help parse DO WHILE statement.
	It parses an optional statement label, optional comma, and the
	word WHILE.

1575	TFV	7-Jul-82
	Fix type declarations to allow 'var *len (subs) * len'.

1656	CKS	25-Oct-82
	Add routine PARMASSIGN, action routine to parse IDENTIFIER = CONSTEXPR
	for parameter statements.

1670	CKS	10-Nov-82
	Allow arbitrary expressions (not just constant expressions) as array
	bounds.  BLDDIM will check that such expressions are only used with
	formal arrays.

1677	CKS	20-Nov-82
	Use action routine KEYSCAN to parse FIND, ENCODE, REWIND.

1702	CKS	9-Dec-82
	Improve error message when turkey incorrectly uses FMT= keyword
	to specify format in ENCODE/DECODE.

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

)%

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

FORWARD
	ASTERTYPE,
	PNAMSET,
	TMPGN,
	SUBLOCAL,
	NULLCHECK,
	FUNCTIONSCAN,
	LABELS,
	NOLABELS,
	TYPEID,
	IMPLICITSPEC,
	TOQUOTE,
	KSPEC,
	KUSPEC,
	KEYSCAN,
	UNITSCAN,
	FMTSCAN,
	EXPRLIST,
	CHARGLIST(1),	! Generate a character  function argument list.   It
			! has an extra argument.   It is the first  argument
			! and is the descriptor for the result.
	CONSTEXPR,
	EVAL,
	NTHARG,
	CNVCONST,
	ASTEREXPR,
	CONSTP;

EXTERNAL
	ACTLDATYPE,
	BASE ASTATFUN,
	BLDVAR,
	ASTER,
	C1H,
	C1L,
	C2H,
	C2L,
	CGERR,
%1213%	CHDECL,		! Flag for character declaration seen
%1213%	CHDLEN,		! Default character count for character data
%1213%	CHLEN,		! Character count for character data
	CNSTCM,
	COPRIX,
	COPYLIST,
	CORMAN,		! Routine to get space from free memory
	DATASTA,
	E9,
%1061%	E150,
	E160,
	E182,
	E183,
	E195,
	E198,
	E199,
	E211,
	ENTRSTA,
	ENTRY,
	EXPRESS,
	FINDSTA,
	FNTMP,		! Counter for .Fnnnn temporaries
	GSTCSCAN,
	GSTKSCAN,
	GSTLEXEME,
	GSTSSCAN,
	GTYPCOD,
	IDTYPE,
	KARIIB,
	KARIGB,
	KBOOLBASE,
	KSPECB,
	KSPECG,
	KTYPCB,
	KTYPCG,
	LEXEMEGEN,
	LEXICAL,
	LEXOPGEN,
	LEXL,
	LOOK4CHAR,
	LOOK4LABEL,
	LSAVE,
%1535%	MAKLIT,		! Make empty literal table node
	NAME,		! Global argument to CORMAN
	NAMDEF,
	NAMREF,
	NAMSET,
	NEWENTRY,
	NONIOINIO,
	PROGNAME,
	SAVSPACE,	! Routine to free space
	SETUSE,
	SP,
	STK,
	STMNDESC,
	SYNTAX,
	TYPE,
	TYPTAB,
	WARNERR;

OWN
%1656%	PARMCNV;		! Set iff parameter list enclosed in parens

GLOBAL ROUTINE ASTERTYPE=
BEGIN	
	!***************************************************************
	! Action routine to parse *size modifiers in type declaractions.
	! Invoked by  ONEARRAY  BNF.   Calls ASTER  to  parse  the  size
	! modifier and determine the datatype.   Three words are put  on
	! STK:
	!	length for character data or 0
	!	flag = 1 if *size was specified
	!	datatype returned by ASTER
	!***************************************************************

%1575%	! Rewritten by TFV on 7-Jul-82

%1213%	REGISTER VAL;	! Use VAL instead of VREG

	! Return if not type declaration

	IF .ORDERCODE(@STMNDESC) NEQ GTYPCOD<0,0> THEN RETURN 0;

%1213%	! Call ASTER to process the *n, *(n), and *(*) constructs

	! ASTER leaves two words on STK:
	!	length for character data or 0
	!	flag = 1 if *size was specified

%1213%	IF (VAL = ASTER(.IDTYPE)) LSS 0
%1213%	THEN	RETURN .VAL
%1213%	ELSE	STK[SP = .SP + 1] = .VAL;	! Put datatype on stack

	RETURN 0

END;	! of ASTERTYPE

GLOBAL ROUTINE PNAMSET=
BEGIN
	! Set progname so it will come out on the heading

	REGISTER BASE ID;

	IF .STMNROUTINE(@STMNDESC) NEQ ENTRSTA<0,0>
	THEN  
	BEGIN
		ID = .STK[.SP]<RIGHT>;
		PROGNAME = .ID[IDSYMBOL];

		! Pick up any *n after function names if a type was specified

		IF .ORDERCODE(@STMNDESC) EQL GTYPCOD<0,0>
		THEN
		BEGIN

%1575%			! ASTER leaves two words on STK:
%1575%			!	length for character data or 0
%1575%			!	flag = 1 if *size was specified

			IF (IDTYPE = ASTER(.IDTYPE)) LSS 0
			THEN RETURN .IDTYPE;

			! Discard the flag word setup by ASTER

%1575%			SP = .SP - 1;
		END;
	END;
	RETURN 0

END;	! of PNAMSET

GLOBAL ROUTINE TMPGN=
BEGIN
	! Generates a .Fnnnn temporary , returns its name but does not
	! enter it in the symbol table.

	REGISTER VAL;

	VAL = SIXBIT'.F0000' +
		(.FNTMP<9,3>)^18 +
		(.FNTMP<6,3>)^12 +
		(.FNTMP<3,3>)^6 +
		(.FNTMP<0,3>);

	FNTMP = .FNTMP + 1;
	RETURN .VAL

END;	! of TMPGN

GLOBAL ROUTINE SUBLOCAL=
BEGIN
	! This routine  is called  to generate  a special  non-confilcting
	! variable for  statement  function formal  arguments.   A  .Fnnnn
	! variable  is  generated  and  inserted  into  the  symbol  table
	! directly after  the  actual  identifier.   The  names  are  then
	! interchanged so that EXPRESS will  get the .Fnnnn variable  when
	! looking up  the  formal  argument.  The  semantic  routine  will
	! reinterchange the names for the rest of the program.  The .Fnnnn
	! variable gets the  type of  the formal  argument, the  character
	! length if it is a character variable,and have dummy and formlvar
	! set in the IDATTRIBUT field.

	REGISTER BASE ID:SAV:TMP;

	! ID - formal argument
	! SAV - used to switch names
	! TMP - .Fnnnn variable

	! Get a variable

	STK[SP = .SP + 1] = LEXL = LEXICAL(.GSTLEXEME);

	IF .LEXL<LEFT> NEQ IDENTIFIER
	THEN	IF .LEXL<LEFT> EQL CONSTLEX
		THEN RETURN FATLEX(PLIT'dimensioned',ASTATFUN[IDSYMBOL],E15<0,0>)
		ELSE RETURN ERR0L(IDENPLIT);

	ID = .LEXL<RIGHT>;

	! Generate a new .Fnnnn symbol, insert it in the symbol table after
	! the formal argument and swap the names

	SAV = .ID[CLINK];
	NAME = IDTAB;
	TMP = ID[CLINK] = NEWENTRY();
	TMP[CLINK] = .SAV;
	TMP[IDSYMBOL] = .ID[IDSYMBOL];	! Name of the formal argument
	ID[IDSYMBOL] = TMPGN();		! .Fnnnn variable name

	TMP[IDATTRIBUT(DUMMY)] = -1;	! Mark it as a dummy argument
	TMP[OPERSP] = FORMLVAR;		! It's a formal variable
	TMP[VALTYPE] = .ID[VALTYPE];	! The valtype is the same as the formal
					! argument.
%1434%	TMP[IDCHLEN] = .ID[IDCHLEN];	! The character length is the same also
%1505%	TMP[IDPSECT] = PSDATA;		! The variable is in the .DATA. psect
	RETURN 0	! Return success

END;	! of SUBLOCAL

GLOBAL ROUTINE NULLCHECK=	![1421] New
BEGIN
	! Action routine called to detect null parameter list in statement
	! function definition.   This  routine succeeds  if  the  upcoming
	! lexeme is not ')'.  Otherwise, it fails without typing an  error
	! message.  SYNTAX will then try the other alternative, which must
	! match ')'.   This  routine never  reads  any lexemes.   It  just
	! serves to choose between two  alternatives, one of which  starts
	! with ')'.

	LOOK4CHAR = ")";
	IF LEXICAL(.GSTCSCAN) NEQ 0
	THEN				! Right paren coming up, fail
	BEGIN
		LSAVE = -1;		! Reread the right paren
		LEXL = RPAREN^18;
		RETURN -1;		! Fail to make syntax try another
					! alternative
	END;

	RETURN 0;			! Else succeed

END; ! of NULLCHECK

GLOBAL ROUTINE FUNCTIONSCAN =
BEGIN
	! Scan for the string "FUNCTION".  If it is found then call this a
	! function.  We will invoke the rule that identifiers must be less
	! than or equal to 6 characters in making this decision.

	LOOK4CHAR = FNPLIT<29,7>;	! Skip the blank

	IF LEXICAL(.GSTSSCAN) EQL 0
	THEN	RETURN -1	! Not function
	ELSE	RETURN 0	! Got one

END;	! of FUNCTIONSCAN

GLOBAL ROUTINE LABELS=
BEGIN
	! This routine sets a flag that indicates to the lexical  analyzer
	! that what one really wants here is a label and not a constant.

	LOOK4LABEL = 1;
	RETURN 0

END;	! of LABELS

GLOBAL ROUTINE NOLABELS=
BEGIN
	! This routine sets a flag that indicates to the lexical  analyzer
	! that what one really wants here is a constant and not a label.

	LOOK4LABEL = 0;
	RETURN 0

END;	! of NOLABELS

GLOBAL ROUTINE TYPEID =
BEGIN
	!*****************************************************************
	! This routine  will  pick up  the  data type  words  in  IMPLICIT
	! statements.  It then calls ASTER to pick up the *size  construct
	! if  any  and  then  sets  the  type  for  use  in  the   routine
	! IMPLICITSPEC and returns.
	!*****************************************************************

	REGISTER R1,R2;

	LOOK4CHAR _ "?L";	! Any letter

	SELECT LEXICAL(.GSTCSCAN) OF NSET
	"I": EXITSELECT (R1 = INTEGER; R2 = INTGPLIT<22,7>);
	"R": EXITSELECT (R1 = REAL; R2 = REALPLIT<22,7>);
	"D": EXITSELECT (R1 = DOUBLPREC; R2 = DOUBPLIT<22,7>);
	"C": EXITSELECT (R1 = COMPLEX; R2 = COMPLIT<22,7>);
	"L": EXITSELECT (R1 = LOGICAL; R2 = LOGIPLIT<22,7>);
	OTHERWISE: RETURN FATLEX(E17<0,0>)
	TESN;

	LOOK4CHAR = .R2;
%1213%	IF LEXICAL(.GSTSSCAN) EQL 0
%1213%	THEN
%1213%	BEGIN	! May be CHARACTER instead of COMPLEX

%1213%		IF .R1 EQL COMPLEX
%1213%		THEN
%1213%		BEGIN	! Try CHARACTER

%1213%			R1 = CHARACTER;
%1213%			LOOK4CHAR = R2 = CHARPLIT<22,7>;
%1213%			IF LEXICAL(.GSTSSCAN) EQL 0 THEN RETURN FATLEX(E17<0,0>);
%1213%			CHDLEN = 1;	! Default character count is 1

%1232%			! Set flag for  character declaration  seen used  in
%1232%			! MRP3R and MRP3G  to test  if we have  to scan  the
%1232%			! symbol  table  to  generate  high  seg   character
%1232%			! descriptors.

%1232%			CHDECL = -1;
%1213%		END
%1213%		ELSE
%1213%			RETURN FATLEX(E17<0,0>);
%1213%	END;

	ACTLDATYPE = .R1;

%1213%	TYPE = ASTER(.R1);

	! ASTER leaves two words on STK:
	!	length for character data or 0
	!	flag = 1 if *size was specified

%1213%	IF .TYPE EQL CHARACTER
%1575%	THEN	CHLEN = .STK[.SP - 1] 	! Fetch character length from stack
%1575%	ELSE	CHLEN = 0;		! No character length

%1575%	SP = .SP - 2;		! Discard the two words ASTER put on STK

%1213%	RETURN .TYPE

END;	! of TYPEID

GLOBAL ROUTINE IMPLICITSPEC=
BEGIN
	! This  routine  will  pick   up  the  letter  and   letter-letter
	! constructs in  implicit statements.   It  will then  adjust  the
	! basic type table appropriately.

	LOCAL L1,L2;
	
	LOOK4CHAR = "?L";	! Any letter
	IF (L1 = LEXICAL(.GSTCSCAN)) EQL 0 THEN RETURN FATLEX(E18<0,0>);
	L1 = .L1 - "A";

	! We have a letter in L1.  Lets look for the "-"

	LOOK4CHAR = "-";
	IF LEXICAL(.GSTCSCAN) EQL 0
	THEN
	BEGIN	! Just single letter

%1213%		! Give warning if already specifiedd in IMPLICIT statement

%1213%		IF .TYPTAB[2 * .L1]<LEFT> EQL #777777
%1213%		THEN	WARNLEX(E88<0,0>)
%1213%		ELSE	TYPTAB[2 * .L1]<LEFT> = #777777;

%1213%		! Set implicit type for identifiers

%1213%		TYPTAB[2 * .L1]<RIGHT> = .TYPE;

%1213%		! Set character count for character data

%1213%		IF .TYPE EQL CHARACTER THEN TYPTAB[2 * .L1 + 1] = .CHLEN;

		RETURN 0
	END
	ELSE
	BEGIN	! Look for the second letter

		LOOK4CHAR = "?L";
		IF (L2 = LEXICAL(.GSTCSCAN)) EQL 0
		THEN RETURN FATLEX(E18<0,0>);

		! Got one so check to see if they are in ascending order

		L2 = .L2 - "A";

		IF .L1  LEQ .L2
		THEN
		BEGIN	! OK - Set implicit type for range of letters
			DO	
%1213%			BEGIN
%1213%				! Give warning if already specified in
%1213%				! IMPLICIT statement

%1213%				IF .TYPTAB[2 * .L1]<LEFT> EQL #777777
%1213%				THEN WARNLEX(E88<0,0>)
%1213%				ELSE TYPTAB[2 * .L1]<LEFT> = #777777;

%1213%				! Set implicit type for identifiers

%1213%				TYPTAB[2 * .L1]<RIGHT> = .TYPE;

%1213%				! Set character count for character data
%1213%				IF .TYPE EQL CHARACTER
%1213%				THEN TYPTAB[2 * .L1 + 1] = .CHLEN;
%1213%			END
%1213%			WHILE (L1 = .L1 + 1) LEQ .L2;

			RETURN 0
		END
		ELSE	RETURN FATLEX(E18<0,0>);
	END;

END;	! of IMPLICITSPEC

GLOBAL ROUTINE TOQUOTE=
BEGIN
	! Picks up the "TO" for assign statements

	LOOK4CHAR = (UPLIT ASCIZ 'TO')<36,7>;
	IF LEXICAL(.GSTSSCAN) EQL 0
	THEN	RETURN FATLEX(E10<0,0>)
	ELSE	RETURN 0

END;	! of TOQUOTE

GLOBAL ROUTINE LABELANDWHILE=		! [1573] New

! Parses the optional label and WHILE part of a DO WHILE statement.
! The equivalent BNF is
!
! 	[ LABELEX [ COMMA ] ]  %WHILEQUOTE%
!
! where WHILEQUOTE reads "WHILE" with GSTSSCAN.  This BNF isn't usable
! because when SYNTAX checks for the an optional LABELEX and it isn't
! found, it sees "WHILE" as an identifier and there's no way to back up.
!
! This routine does not attempt to mimic the tree shape that SYNTAX
! would produce with the above BNF.  It returns a LABELEX or 0 on STK,
! and returns success (0) or failure (-1) as its value.

BEGIN
	BIND WHILEPLIT = (UPLIT ASCIZ 'WHILE')<36,7>;

	! Check for WHILE

	LOOK4CHAR = WHILEPLIT;
	IF LEXICAL(.GSTSSCAN) NEQ 0
	THEN
	BEGIN	! WHILE
		STK[SP=.SP+1] = 0;	! no label
		RETURN 0;		! succeed
	END;	! WHILE

	! Not WHILE, must be label

	LABELS();			! integers here are labels
	LEXL = LEXEMEGEN();		! read lexeme
	NOLABELS();			! back to integers as integers
	IF .LEXL<LEFT> EQL LABELEX	! must have label
	THEN STK[SP=.SP+1] = .LEXL	! we do, return it on STK
	ELSE RETURN ERR0L(LABLPLIT);	! "found ... when expecting label"

	! Check for and skip optional comma

	LOOK4CHAR = ",";		! comma
	LEXICAL(.GSTCSCAN);		! read it if it's there

	! Now we must see WHILE

	LOOK4CHAR = WHILEPLIT;		! while
	IF LEXICAL(.GSTSSCAN) NEQ 0	! read it if it's there
	THEN RETURN 0			! it was, succeed
	ELSE RETURN FATLEX(E10<0,0>);	! "Statement not recognized"

END;	! LABELANDWHILE

GLOBAL ROUTINE KEY1SPEC = KSPEC(1,2);	! [1546] New

GLOBAL ROUTINE KEY4SPEC = KSPEC(4,4);	! [1546] New

GLOBAL ROUTINE ENCDECSPEC = KEYSCAN(1,3); ! [1677] New

GLOBAL ROUTINE REWSPEC = KUSPEC(1,2);	! [1677] New

GLOBAL ROUTINE FINDSPEC = KEYSCAN(1,2);	! [1677] New

ROUTINE KSPEC (STARTPOS,MAXPOS)=	! [1546] New

! Routine to parse the keyword list or format specifier in READ, WRITE,
! TYPE, ACCEPT, PRINT, PUNCH, and REREAD statements.  The specification
! can be either a parenthesized keyword list (as described below in routine
! KEYSCAN) or a format specifier followed by comma.
!
! This routine returns a pointer on STK to a 7-word block.  The block 
! contains pointers to the UNIT, FMT, variable, REC, END, ERR, IOSTAT
! specifiers, in that order.

BEGIN
	REGISTER QFMT,LSP;

	! Check for parenthesized keyword list
	LOOK4CHAR = "(";		
	IF LEXICAL(.GSTCSCAN) NEQ 0	! check for left paren
	THEN				! found left paren
	BEGIN	! keyword list
		! Parse keyword list
		KEYSCAN(.STARTPOS,.MAXPOS);

		! Read closing right paren
		IF .LSAVE NEQ 0 THEN LSAVE = 0 ELSE LEXL = LEXEMEGEN();

		IF .LEXL<LEFT> NEQ RPAREN 
		THEN RETURN ERR0L(RPARPLIT); ! "found ... when expecting ')'"
	END	! keyword list
	ELSE
	BEGIN	! plain format specifier

		QFMT = FMTSCAN();	! read format specifier
		IF .QFMT LSS 0 THEN RETURN .QFMT; ! if error, pass it on

		! The format specifier must be followed by comma or EOL.
		! This routine does not read the comma or EOL, just checks
		! that it's there.

		IF .LSAVE EQL 0 THEN (LEXL = LEXEMEGEN(); LSAVE = -1);
						! peek at next lexeme

		IF .LEXL<LEFT> NEQ LINEND	! LINEND is OK
		THEN IF .LEXL<LEFT> NEQ COMMA	! COMMA is OK
		     THEN RETURN ERR0L(.LEXNAM[COMMA]);	! anything else, not OK

		LSP = .SP;		! make semantic node
		SP = .SP + 7;		! 7 words long
		STK[.LSP+1] = 0;	! unit
		STK[.LSP+2] = .QFMT;	! fmt
		STK[.LSP+3] = 0;	! var
		STK[.LSP+4] = 0;	! rec
		STK[.LSP+5] = 0;	! end
		STK[.LSP+6] = 0;	! err
		STK[.LSP+7] = 0;	! iostat

		COPYLIST(.LSP);		! copy into 7-word block, leave pointer
					! on top of STK
	END;

END;	! KSPEC

ROUTINE KUSPEC (STARTPOS,MAXPOS)=	! [1677] New

! Routine to parse the keyword list in REWIND and friends.  The specification
! can be either a parenthesized keyword list (as described below in routine
! KEYSCAN) or a unit specifier.
!
! This routine returns a pointer on STK to a 7-word block.  The block 
! contains pointers to the UNIT, FMT, variable, REC, END, ERR, IOSTAT
! specifiers, in that order.

BEGIN
	REGISTER QUNIT,LSP;

	! Check for parenthesized keyword list
	LOOK4CHAR = "(";		
	IF LEXICAL(.GSTCSCAN) NEQ 0	! check for left paren
	THEN				! found left paren
	BEGIN	! keyword list
		! Parse keyword list
		KEYSCAN(.STARTPOS,.MAXPOS);

		! Read closing right paren
		IF .LSAVE NEQ 0 THEN LSAVE = 0 ELSE LEXL = LEXEMEGEN();

		IF .LEXL<LEFT> NEQ RPAREN 
		THEN RETURN ERR0L(RPARPLIT); ! "found ... when expecting ')'"
	END	! keyword list
	ELSE
	BEGIN	! plain unit specifier

		QUNIT = UNITSCAN();	! read unit specifier
		IF .QUNIT LSS 0 THEN RETURN .QUNIT; ! if error, pass it on

		! The unit specifier must be followed by EOL.
		! This routine does not read the EOL, just checks
		! that it's there.

		IF .LSAVE EQL 0 THEN (LEXL = LEXEMEGEN(); LSAVE = -1);
						! peek at next lexeme

		IF .LEXL<LEFT> NEQ LINEND	! LINEND is OK
		THEN RETURN ERR0L(.LEXNAM[LINEND]); ! anything else, not OK

		LSP = .SP;		! make semantic node
		SP = .SP + 7;		! 7 words long
		STK[.LSP+1] = .QUNIT;	! unit
		STK[.LSP+2] = 0;	! fmt
		STK[.LSP+3] = 0;	! var
		STK[.LSP+4] = 0;	! rec
		STK[.LSP+5] = 0;	! end
		STK[.LSP+6] = 0;	! err
		STK[.LSP+7] = 0;	! iostat

		COPYLIST(.LSP);		! copy into 7-word block, leave pointer
					! on top of STK
	END;

END;	! KUSPEC

ROUTINE KEYSCAN (STARTPOS,MAXPOS)=		! [1465] New

! Routine to look at the control information list (cilist) in READ and WRITE
! and friends.  The list can have the following forms:
!
!	(u,f,keys)	(u'r,f,keys)
!	(u,keys)	(u'r,keys)
!	(keys)
!	(u,f)		(u'r,f)
!	(u)		(u'r)
!	(u,f,v)
!	(u,f,v,keys)
!
! where keys is one or more of
!
! 	UNIT=u		u = integer expression, char variable, char array, *
!	FMT=f		f = integer variable, numeric array, char expression,
!			    label, *
!	REC=r		r = integer expression
!	END=s		s = label
!	ERR=s		s = label
!	IOSTAT=v	v = integer variable
!
! The argument STARTPOS is 1 to read a list that may start with unit, or 4
! to read a list that must be all keywords.
! The argument MAXPOS is 2 to allow positional specification of UNIT and FMT,
! or 3 to allow UNIT, FMT, and an encode/decode variable.
!
! [1702] Crock: if MAXPOS is 3, specifying that a 3-element positional arg list
! is legal (for ENCODE and DECODE), do not allow FMT= keyword.

BEGIN

	REGISTER POS;			! Position we're currently at in
					!  positional arg list.
					! position 1: unit expression
					! position 2: format expression
					! position 3: encode/decode variable
					! position 4: keyword list

	LOCAL K,			! keyword in sixbit
	      QUNIT,QFMT,QREC,		! keyword values
	      QERR,QEND,QIOSTAT,
	      QVAR,
	      LSP;			! local SP


	QUNIT = QFMT = QREC = QERR = QEND = QIOSTAT = QVAR = 0;

	POS = .STARTPOS;		! Start at unit (1) or keywords (4)

	DO				! Loop through cilist
	BEGIN

		K = LEXICAL(.GSTKSCAN);	! Look for "KEYWORD="

		IF .K EQL 0		! If keyword not found, we have a
		THEN			!   positional argument
		BEGIN	! positional arg

			CASE .POS OF SET
			CGERR();	! 0

			BEGIN		! 1 - u or u'r
				POS = 2; 

				QUNIT = UNITSCAN(); ! read unit expression
				IF .QUNIT LSS 0 THEN RETURN .QUNIT;

				IF .LSAVE EQL 0	    ! peek at following lexeme
				THEN (LSAVE = -1; LEXL = LEXOPGEN());

				IF .LEXL<LEFT> EQL TICLEX   ! If unit was
				THEN			! delimited by '
				BEGIN	! u'r
					LSAVE = 0;  ! Read the '

					FLGREG<FELFLG> = 0;
						    ! bare array names illegal
					IF EXPRESS() LSS 0 THEN RETURN .VREG;
						    ! read rec expression
					QREC = .STK[.SP];
					SP = .SP - 1;
				END;	! u'r
			END;		! 1 - u or u'r

			BEGIN		! 2 - f
				POS = 3;
				IF .POS GTR .MAXPOS THEN POS = 4;
				QFMT = FMTSCAN(); ! read format expression
				IF .QFMT LSS 0 THEN RETURN .QFMT;
			END;		! 2 - f

			BEGIN		! 3 - variable
				POS = 4;
				LSP = .SP;	! Save SP for COPYLIST
				IF SYNTAX(VARIABLESPEC) LSS 0 ! Parse variable
				THEN RETURN .VREG; ! if error, pass it on
				COPYLIST(.LSP);	! Copy variable spec off STK
				QVAR = .STK[.SP]; ! Get pointer to variable
				SP = .LSP;	! Restore SP
				SETUSE = IF NOT .IOINPT(@STMNDESC)
				         THEN SETT ELSE USE;
						! ENCODE, the output statement
						! of the pair, modifies the
						! variable in the cilist
				QVAR = BLDVAR(@.QVAR);
						! Build DATAOPR or ARRAYREF
				IF .QVAR LSS 0 THEN RETURN .QVAR;
			END;		! 3 - variable

			BEGIN		! 4 - keys
				! After unit & format, the only legal thing is
				! a list of keywords. If we see more positional
				! args, it's an error.

				IF .LSAVE EQL 0
				THEN (LEXL = LEXEMEGEN(); LSAVE = -1);
					! read a lexeme for the error message
					! to use
				RETURN ERR0L (UPLIT ASCIZ 'keyword');
			END		! 4 - keys
			TES
		END	! positional arg
		ELSE
		BEGIN	! keyword arg

			POS = 4;	! Only keywords legal from now on

			IF .K EQL SIXBIT 'UNIT'
			THEN
			BEGIN	! UNIT=
				IF .QUNIT NEQ 0 THEN FATLEX(.K,E182<0,0>);
					! "UNIT= may only be specified once"
				QUNIT = UNITSCAN();
				IF .QUNIT LSS 0 THEN RETURN .QUNIT;
			END	! UNIT=

			ELSE IF .K EQL SIXBIT 'FMT'
			THEN
			BEGIN	! FMT=
				IF .QFMT NEQ 0 THEN FATLEX(.K,E182<0,0>);
					! "FMT= may only be specified once"
				QFMT = FMTSCAN();
				IF .QFMT LSS 0 THEN RETURN .QFMT;
%1702%				IF .MAXPOS EQL 3     ! If in ENCODE/DECODE,
%1702%						     ! don't allow FMT to be
%1702%						     ! specified this way
%1702%				THEN RETURN FATLEX(E211<0,0>); 
			END	! FMT=

			ELSE IF .K EQL SIXBIT 'REC'
			THEN
			BEGIN	! REC=
				IF .QREC NEQ 0 THEN FATLEX(.K,E182<0,0>);
					! "REC= may only be specified once"
				FLGREG<FELFLG> = 0;
				IF  EXPRESS() LSS 0 THEN RETURN .VREG;
				QREC = .STK[.SP];
				SP = .SP - 1;
			END	! REC=

			ELSE IF .K EQL SIXBIT 'END'
			THEN
			BEGIN	! END=
				IF .QEND NEQ 0 THEN FATLEX(.K,E182<0,0>);
					! "END= may only be specified once"
				LABELS();      ! Read number as statement label
				NONIOINIO = 1; ! Label must be executable,
					       ! not format
				QEND = LEXL = LEXEMEGEN(); ! Read label
				NOLABELS();    ! Reset numbers to be integer
					       ! constants
				NONIOINIO = 0; ! Reset flag (LABREF does, but
					       ! if we didn't get a label, we
					       ! didn't go through LABREF)
				IF .QEND<LEFT> NEQ LABELEX    ! Must be a
				THEN ERR0L(.LEXNAM[LABELEX]); ! statement label
			END	! END=

			ELSE IF .K EQL SIXBIT 'ERR'
			THEN
			BEGIN	! ERR=
				IF .QERR NEQ 0 THEN FATLEX(.K,E182<0,0>);
					! "ERR= may only be specified once"
				LABELS();      ! Read number as statement label
				NONIOINIO = 1; ! Executable, not format
				QERR = LEXL = LEXEMEGEN(); ! Read label
				NOLABELS();    ! Reset numbers to be integers
				NONIOINIO = 0; ! Reset flag (LABREF does, but
					       ! if we didn't get a label, we
					       ! didn't go through LABREF)
				IF .QERR<LEFT> NEQ LABELEX    ! Must be a
				THEN ERR0L(.LEXNAM[LABELEX]); ! statement label
			END	! ERR=

			ELSE IF .K EQL SIXBIT 'IOSTAT'
			THEN
			BEGIN	! IOSTAT=
				IF .QIOSTAT NEQ 0 THEN FATLEX(.K,E182<0,0>);
					! "IOSTAT= may only be specified once"

				LSP = .SP;		! Save SP for COPYLIST
				IF SYNTAX(VARIABLESPEC) LSS 0 ! Parse variable
				THEN RETURN .VREG;	! If error, pass it on
				COPYLIST(.LSP);		! Copy semantic info
				QIOSTAT = .STK[.SP];	! Get pointer to info
				SP = .LSP;		! Restore SP

				SETUSE = SETT;		! Variable is modified
				IF (QIOSTAT=BLDVAR(@.QIOSTAT)) LSS 0
							! Build DATAOPR or
							!  ARRAYREF node
				THEN RETURN .VREG;	! If error, pass it on
			END	! IOSTAT=

			ELSE RETURN FATLEX(.K,E183<0,0>);
					! "unrecognized keyword K"
		END;

		! Read next lexeme.  If it is comma, go do next argument.
		! If it is right paren, we have found the end of the list;
		! return without reading past the right paren.  Otherwise
		! it's an error.

		IF .LSAVE EQL 0 THEN (LEXL = LEXEMEGEN(); LSAVE = -1);
		IF .LEXL<LEFT> EQL COMMA 
		THEN LSAVE = 0;
	END
	WHILE .LEXL<LEFT> EQL COMMA;

	IF .LEXL<LEFT> EQL RPAREN 
	THEN LSAVE = -1
	ELSE RETURN ERR0L (UPLIT ASCIZ '"," or ")"');

	! Put args into a block of information on the semantic stack

	LSP = .SP;
	SP = .SP + 7;
	STK[.LSP+1] = .QUNIT;
	STK[.LSP+2] = .QFMT;
	STK[.LSP+3] = .QVAR;
	STK[.LSP+4] = .QREC;
	STK[.LSP+5] = .QEND;
	STK[.LSP+6] = .QERR;
	STK[.LSP+7] = .QIOSTAT;
	COPYLIST(.LSP);

END;   ! KEYSCAN

ROUTINE UNITSCAN=			! [1465] New

! Parses unit specifier.  Legal syntaxes are *, array name, expression.
! Semantic checks will impose further restrictions.

BEGIN
	REGISTER U;

	LOOK4CHAR = "*";		! Check for UNIT=*
	IF LEXICAL(.GSTCSCAN) NEQ 0
	THEN U = ASTERISK^18		! Store asterisk lexeme for UNIT=*
	ELSE
	BEGIN
		FLGREG<FELFLG> = 1;	! Allow bare array names
		IF EXPRESS() LSS 0 THEN RETURN .VREG; ! Read an expression
		U = .STK[.SP];
		SP = .SP - 1;		! Remove it from the semantic stack
	END;

	RETURN .U;

END;	! UNITSCAN

ROUTINE FMTSCAN=			! [1465] New

! Parses format specifier.  Legal syntaxes are *, label, array name,
! namelist name, expression.  Semantic checks will impose further 
! restrictions.

BEGIN
	REGISTER BASE F;
	REGISTER BASE ID:NAMCOM;
	LOCAL NAMROUT;
	MAP BASE LEXL;

	LOOK4CHAR = "*";		! Check for FMT=*
	IF LEXICAL(.GSTCSCAN) NEQ 0
	THEN F = ASTERISK^18		! Store asterisk lexeme for FMT=*
	ELSE
	BEGIN
					! Check for FMT=label
		LABELS();		! Read numbers as statement labels
		LEXL = LEXEMEGEN();	! Get a lexeme
		NOLABELS();		! Read numbers as integer constants

		IF .LEXL<LEFT> EQL LABELEX ! If we got a statement label,
		THEN F = .LEXL		! it is the format specifier

		ELSE
		BEGIN
			IF .LEXL<LEFT> EQL IDENTIFIER ! If we got a namelist 
			  AND .LEXL[IDATTRIBUT(NAMNAM)]	! name, 
			THEN
			BEGIN	! namelist
				F = .LEXL;	! set format specifier to
						! namelist name

				IF NAMREF(NMLSTREF,.F) LSS 0 THEN RETURN .VREG;

				! Call NAMREF or NAMSET for the variables
				! in the namelist

				NAMROUT = IF .TYPE EQL READD
				          THEN NAMSET ELSE NAMREF;
				NAMCOM = .F[IDCOLINK];
				INCR NMLST FROM .NAMCOM[NAMLIST] 
					   TO .NAMCOM[NAMLIST]
						+.NAMCOM[NAMCNT] - 1
				DO
				BEGIN
					ID = @.NMLST;
					(.NAMROUT)(.ID[OPRSP1],.ID); 
				END;
			END	! namelist
			ELSE
			BEGIN	! not label, not namelist
				LSAVE = -1;	! Otherwise back up over the
						! lexeme we just read
				FLGREG<FELFLG> = 1; ! Allow bare array names
				IF EXPRESS() LSS 0 THEN RETURN .VREG;
						! Read FMT expression
				F = .STK[.SP];
				SP = .SP - 1;	! Remove it from the stack
			END	! not label, not namelist
		END
	END;

	RETURN .F;
END;	! FMTSCAN

GLOBAL ROUTINE EXPRLIST=
BEGIN
	! PROCESS THE ARGUMENT LIST OF A CALL STATEMENT

	LOCAL LSP;
	MACRO STKSIZE=250$;	! For checking stack overflow
	REGISTER BASE T1,VAL;

	T1 = .STK[.SP - 1];	! T1 is loc(identifier)

	IF (VAL = NAMREF(FNNAME1, .T1)) LSS 0
	THEN RETURN .VAL;	! Name conflict

	T1[OPERSP] = IF .T1[IDATTRIBUT(DUMMY)] THEN FORMLFN ELSE FNNAME;

	! Now scan the list of expressions (zero or more separated by commas)
	! which must follow.

	LSP = .SP;
	LSAVE = -1;

%1217%	LEXL = LEXEMEGEN();

%1217%	IF .LEXL<LEFT> EQL RPAREN	! As in CALL FOO() - empty list
%1217%	THEN STK[SP = .SP + 1] = 0	! Empty list set up
%1217%	ELSE
	WHILE 1 DO
	BEGIN
		FLGREG<FELFLG> = 1;

		! Allow * as initial character for label too.

		IF (.LEXL<LEFT> NEQ DOLLAR)
		AND (.LEXL<LEFT> NEQ ANDSGN)
		AND (.LEXL<LEFT> NEQ ASTERISK)
		THEN
		BEGIN
			STK[SP = .SP + 1] = 1;	! Expression
			IF (VAL =  EXPRESS()) LSS 0 THEN RETURN .VAL;

			! Express puts its result on STK[SP = .SP + 1] and
			! returns next lexeme in lexl
		END
		ELSE
		BEGIN
			STK[SP = .SP + 1] = 2;	! Label arg
			LOOK4LABEL  = 1;
			STK[SP = .SP + 1] = LEXL = LEXEMEGEN();

			IF .LEXL<LEFT> NEQ LABELEX
			THEN	RETURN FATLEX(LABLPLIT,LEXPLITV,E0<0,0>);

%716%			T1 = .LEXL<RIGHT>;	! Get label address
%716%			T1[SNRFS] = 1;		! Mark label as being jumped to
%716%						! by a return from a subroutine
%716%						! call
			LEXL = LEXEMEGEN();
		END;
		IF .LEXL<LEFT> NEQ COMMA
		THEN  EXITLOOP
%1217%		ELSE LEXL = LEXEMEGEN();

		! Make sure that a super long list of arguments will not
		! overflow stk

		IF .SP GTR STKSIZE - 3
		THEN
		BEGIN
			COPYLIST(.LSP);
			LSP = .SP; 
		END;
	END;
	LSAVE _ -1;
	COPYLIST(.LSP);
	RETURN 0

END;	! of EXPRLIST


GLOBAL ROUTINE CMNCOMMA=                ! [1410] New
BEGIN
	! This routine is responsible for parsing the optional comma in
	!
	! 	COMMON A,/B/C
	!
	! This is problematical because the thing preceding the comma is a
	! list of ONEARRAYs separated by commas.  The comma gets read as a
	! list separator, not as an  optional comma terminating the  list.
	! The solution is to check for  ",/" before allowing the comma  to
	! be seen as a list separator.
	!
	! This routine always succeeds.  It leaves things  alone if called
	! before a comma which is a list separator.  It reads and discards
	! a comma which is followed by / or  //.  The / or // is not  read
	! by this routine.

				
	IF .LSAVE NEQ 0
	THEN
	BEGIN	! If a lexeme  is already  saved then that  lexeme is  the
		! first char of the string we're looking for.

		IF .LEXL<LEFT> NEQ COMMA THEN RETURN 0;	! Not comma, no match

		LOOK4CHAR = (UPLIT '//')<36,7>;		! Comma followed by //?
		IF LEXICAL(.GSTSSCAN) NEQ 0
		THEN
		BEGIN
			LEXL<LEFT> = CONCAT; 	! Yes, delete comma, return //
			RETURN 0;
		END;

		LOOK4CHAR = (UPLIT '/')<36,7>;	! Comma followed by /?
		IF LEXICAL(.GSTSSCAN) NEQ 0
		THEN
		BEGIN
			LEXL<LEFT> = SLASH;	! Yes, delete comma, return /
			RETURN 0;
		END;
		RETURN 0;		! Comma followed by other stuff,
					! return the other stuff
	END;

	! Else no saved lexeme

	LOOK4CHAR = (UPLIT ',//')<36,7>; ! Comma followed by //?
	IF LEXICAL(.GSTSSCAN) NEQ 0
	THEN
	BEGIN
		LSAVE = -1;		! Ignore the comma, return the //
		LEXL<LEFT> = CONCAT;
		RETURN 0;
	END;

	LOOK4CHAR = (UPLIT ',/')<36,7>;	! Comma followed by ?
	IF LEXICAL(.GSTSSCAN) NEQ 0
	THEN
	BEGIN
		LSAVE = -1;		! Ignore the comma, return the /
		LEXL<LEFT> = SLASH;
		RETURN 0;
	END;

	RETURN 0;		! Otherwise comma, if present, is a list
				! separator
END;	! of CMNCOMMA

GLOBAL ROUTINE CHARGLIST(OLDARGLIST)=
BEGIN

%1434%	! Written by TFV on 7-Dec-81

	! Generate the argument list for a character function.  It has an
	! extra argument.  It is the first argument and is the descriptor
	! for the result.  The space for the old  argument list is freed;
	! the new argument list is returned.

	MAP ARGUMENTLIST OLDARGLIST;

	REGISTER
		ARGUMENTLIST ARGLIST,
		NUMARGS;

	IF .OLDARGLIST EQL 0
	THEN	NUMARGS = 1		! New argument list has one element
	ELSE	NUMARGS = .OLDARGLIST[ARGCOUNT] + 1;	! New argument list is
							! 1 larger

	NAME<LEFT> = ARGLSTSIZE(.NUMARGS);	! Compute size of block needed
	ARGLIST = CORMAN();			! Get the space

	IF .OLDARGLIST NEQ 0
	THEN
	BEGIN	! An old argument list exists

		! Copy the header words to the new argument list

		DECR I FROM ARGHDRSIZ - 1 TO 0
		DO (.ARGLIST)[.I] = .(.OLDARGLIST)[.I];

		! Copy the argument pointers

		DECR I FROM .NUMARGS - 1 TO 1
		DO ARGLIST[.I + 1, ARGFULL] = .OLDARGLIST[.I, ARGFULL];

		! Return the space for the old argument list

		SAVSPACE(ARGLSTSIZE(.OLDARGLIST[ARGCOUNT]) - 1, .OLDARGLIST);

	END;	! An old argument list exists

	ARGLIST[ARGCOUNT] = .NUMARGS;		! Setup number of arguments

	RETURN .ARGLIST;	! Return the new argument list

END;	! of CHARGLIST

GLOBAL ROUTINE PARMASSIGN =		! [1656] New

! Action routine to do parameter definition
! Parses
!	IDENTIFIER = %CONSTEXPR%
! and assigns the value of the constant expression to the identifier,
! type-converting it if appropriate.  A warning is given if:
!	- /F77
!	- the parens around the parameter list are omitted
!	- the parameter variable and the expression differ in type

BEGIN
	REGISTER BASE ID:EXPR;

	! Read identifier lexeme

	IF .LSAVE NEQ 0 THEN LSAVE = 0 ELSE LEXL = LEXEMEGEN();

	IF .LEXL<LEFT> NEQ IDENTIFIER THEN RETURN ERR0L(IDENPLIT);
	ID = .LEXL;

	! Read EQUAL

	IF LEXEMEGEN() NEQ EQUAL^18 THEN RETURN ERR0V(.LEXNAM[EQUAL]);

	! Read CONSTEXPR

	IF CONSTEXPR() LSS 0 THEN RETURN .VREG;
	EXPR = .STK[.SP];   SP = .SP - 1;

	! Define the identifier with the value of the expression.
	! Convert the expression to match the type of the parameter if
	! the parameter list was enclosed in parentheses.  If no parens,
	! we have a /F66 style parameter statement.  Do not convert, but
	! give a warning if a conversion would have occurred.

	IF NAMDEF (PARADEF, .ID) LSS 0 THEN RETURN .VREG;
	ID[IDATTRIBUT(PARAMT)] = 1;

	ID[IDPARAVAL] = .EXPR;
	IF .ID[VALTYPE] NEQ .EXPR[VALTYPE] OR .ID[VALTYPE] EQL CHARACTER
	THEN IF .PARMCNV NEQ 0
	     THEN ID[IDPARAVAL]=CNVCONST(.EXPR,.ID,.EXPR[VALTYPE],.ID[VALTYPE])
	     ELSE IF F77 THEN WARNLEX(.ID[IDSYMBOL],E198<0,0>);
				! "Parameter X will not be type converted"
				! Suppress warning if /F66

END;	! PARMASSIGN

GLOBAL ROUTINE PARMLPAREN =		! [1656] New

! Action routine to read optional left paren for parameter statement.
! Sets PARMCNV if left paren seen, clears it otherwise.

BEGIN
	LEXL = LEXEMEGEN();

	IF .LEXL<LEFT> EQL LPAREN
	THEN PARMCNV = -1
	ELSE (PARMCNV = 0; LSAVE = -1);

END;	! PARMLPAREN



GLOBAL ROUTINE PARMRPAREN =		! [1656] New

! Checks for and reads right paren in PARAMETER statement

BEGIN
	LOCAL RFLAG;

	IF .LSAVE NEQ 0 THEN LSAVE = 0 ELSE LEXL = LEXEMEGEN();

	IF .LEXL<LEFT> EQL RPAREN
	THEN RFLAG = -1
	ELSE (RFLAG = 0;  LSAVE = -1);

	IF .RFLAG NEQ .PARMCNV THEN RETURN FATLEX (E9<0,0>);
					! "Unmatched parentheses"

END;	! PARMRPAREN

GLOBAL ROUTINE CONSTEXPR=		! [1527] New

! Action routine to parse and evaluate a constant expression.
! Returns -1 if an error is encountered, or 0 if no error.
! If no error is encountered, also returns a constant lexeme on STK.

BEGIN
	REGISTER BASE CONST;

	IF EXPRESS() LSS 0 THEN RETURN .VREG; ! Read an expression.
					      ! If error, pass it on

	CONST = EVAL(.STK[.SP]);	! Evaluate expression
	IF .CONST LSS 0			! Check if error
	THEN
	BEGIN
		SP = .SP - 1;		! If error, clean up STK
		RETURN .CONST;		! Pass the error on
	END
	ELSE
	BEGIN
		STK[.SP] = .CONST;	! No error, put the constant on STK
		STK[.SP]<LEFT> = IF .CONST[VALTYPE] EQL CHARACTER
				 THEN LITSTRING ELSE CONSTLEX;
					! Put lexeme name on STK
		RETURN 0;		! Return success
	END;

END;	! CONSTEXPR

ROUTINE EVAL (EXPR) =			! [1527] New

! Routine to evaluate a constant expression.
! (At present, works on expressions produced by EXPRESS.  Certain nodes,
! viz. SPECOP, INLINFN, and CMNSUB, which cannot occur this early, are not
! handled.)
!
! Returns constant lexeme on success, -1 on error.
! SAVSPACEs the expression tree.

BEGIN
	MAP BASE EXPR;
	REGISTER BASE ARG1:ARG2;
	LOCAL BASE ARGPTR:RESULTPTR:RESULT:ARG;
	LOCAL ARGUMENTLIST ARGL;
	LOCAL LEN;

	CASE .EXPR[OPRCLS] OF SET

	BEGIN				! BOOLEAN
		! Evaluate args
		IF (ARG1 = EVAL(.EXPR[ARG1PTR])) LSS 0 THEN RETURN .VREG;
		IF (ARG2 = EVAL(.EXPR[ARG2PTR])) LSS 0 THEN RETURN .VREG;

		! Set opcode and operands for CNSTCM
		COPRIX = KBOOLOPIX(EXPR);
		C1L = IF .ARG1[VALTP1] EQL INTEG1
			THEN .ARG1[CONST2]
			ELSE .ARG1[CONST1];
		C2L = IF .ARG2[VALTP1] EQL INTEG1
			THEN .ARG2[CONST2]
			ELSE .ARG2[CONST1];

		! Do the operation and return
		CNSTCM();
		SAVSPACE(EXSIZ-1,.EXPR);

		RETURN MAKECNST(LOGICAL,0,.C2L);
	END;				! BOOLEAN

	BEGIN				! DATAOPR
		! Leaf: check that it's a constant
		IF .EXPR[OPERSP] EQL CONSTANT
		THEN RETURN .EXPR
		ELSE RETURN FATLEX(E195<0,0>); ! "Constant required"
	END;				! DATAOPR

	BEGIN				! RELATIONAL
		BIND VECTOR TRAN = UPLIT (0,1,2,3,0,6,5,4);
		REGISTER COND;

		! Evaluate args
		COND = 0;
		IF (ARG1 = EVAL(.EXPR[ARG1PTR])) LSS 0 THEN RETURN .VREG;
		IF (ARG2 = EVAL(.EXPR[ARG2PTR])) LSS 0 THEN RETURN .VREG;

		! Set COND to .LT. (1), .EQ. (2), or .GT. (4)
		IF .ARG1[CONST1] LSS .ARG2[CONST1]
		THEN COND = .COND OR 1;

		IF .ARG1[CONST1] EQL .ARG2[CONST1]
		THEN
		BEGIN
			IF .ARG1[CONST2] LSS .ARG2[CONST2]
			THEN COND = .COND OR 1;

			IF .ARG1[CONST2] EQL .ARG2[CONST2]
			THEN COND = .COND OR 2;

			IF .ARG1[CONST2] GTR .ARG2[CONST2]
			THEN COND = .COND OR 4;
		END;

		IF .ARG1[CONST1] GTR .ARG2[CONST1]
		THEN COND = .COND OR 4;

		! Now COND encodes whether ARG1 is greater than, equal to,
		! or less than ARG2.  The TRAN table tells for each relational
		! operator which COND values satisfy the operator.

		! Compute whether the relation is satisfied or not.
		COND = .COND AND .TRAN[.EXPR[OPERSP]];

		SAVSPACE(EXSIZ-1,.EXPR);

		! Return an appropriate logical constant
		IF .COND NEQ 0
		THEN RETURN MAKECNST(LOGICAL,0,TRUE)
		ELSE RETURN MAKECNST(LOGICAL,0,FALSE);
	END;				! RELATIONAL

	BEGIN				! FNCALL
		! Check first arg; must be CHAR or ICHAR
		ARG1 = .EXPR[ARG1PTR];
		
		IF .ARG1[IDSYMBOL] EQL SIXBIT 'CHAR.'
		THEN
		BEGIN	! CHAR.
			IF (ARG2 = EVAL(NTHARG(2,.EXPR))) LSS 0 
			THEN RETURN .VREG;
			ARG1 = MAKLIT(1);
			ARG1[LIT1] = .ARG2[CONST2]^29 + "    "^1;
			SAVSPACE(EXSIZ-1,.EXPR);
			RETURN .ARG1;
		END	! CHAR.

		ELSE IF .ARG1[IDSYMBOL] EQL SIXBIT 'ICHAR.'
		THEN
		BEGIN	! ICHAR.
			IF (ARG2 = EVAL(NTHARG(1,.EXPR))) LSS 0 
			THEN RETURN .VREG;
			SAVSPACE(EXSIZ-1,.EXPR);
			RETURN MAKECNST (INTEGER,0, .ARG2[LITC2]);
		END	! ICHAR.

		ELSE RETURN FATLEX(E195<0,0>); ! "Constant required"
	END;				! FNCALL

	BEGIN				! ARITHMETIC
		! Evaluate args
		IF (ARG1 = EVAL(.EXPR[ARG1PTR])) LSS 0 THEN RETURN .VREG;
		IF (ARG2 = EVAL(.EXPR[ARG2PTR])) LSS 0 THEN RETURN .VREG;

		! Check for exponentiation
		IF .EXPR[OPERSP] EQL EXPONOP
		THEN
		BEGIN	! exponentiation
			! Make sure exponent is integer
			IF .ARG2[VALTYPE] NEQ INTEGER
			THEN FATLEX(E199<0,0>);

			COPRIX = KEXPIX(.ARG1[VALTP1]);
		END	! exponentiation
		ELSE
		BEGIN	! mundane
			COPRIX = KARITHOPIX(EXPR);
		END;	! mundane

		C1H = .ARG1[CONST1];   C1L = .ARG1[CONST2];
		C2H = .ARG2[CONST1];   C2L = .ARG2[CONST2];
		
		! Do the operation and return
		CNSTCM();
		SAVSPACE(EXSIZ-1,.EXPR);

		RETURN MAKECNST(.EXPR[VALTYPE], .C2H, .C2L);

	END;				! ARITHMETIC

	BEGIN				! TYPECNV
		! Evaluate the operand
		IF (ARG2 = EVAL(.EXPR[ARG2PTR])) LSS 0 THEN RETURN .VREG;

		! Call CNSTCM to do the conversion
		C1H = .ARG2[CONST1];
		C1L = .ARG2[CONST2];
		COPRIX = KTPCNVIX(EXPR);
		CNSTCM();
		SAVSPACE(EXSIZ-1,.EXPR);

		RETURN MAKECNST(.EXPR[VALTYPE],.C2H,.C2L);
	END;				! TYPECNV

	BEGIN				! ARRAYREF
		RETURN FATLEX(E195<0,0>); ! "not constant"
	END;				! ARRAYREF

	BEGIN				! CMNSUB
		CGERR();
	END;				! CMNSUB

	BEGIN				! NEGNOT
		IF (ARG2 = EVAL(.EXPR[ARG2PTR])) LSS 0 THEN RETURN .VREG;

		IF .EXPR[OPERSP] EQL NEGOP
		THEN RETURN NEGCNST(.ARG2)
		ELSE RETURN NOTCNST(.ARG2);
	END;				! NEGNOT

	BEGIN				! SPECOP
		CGERR();
	END;				! SPECOP

	BEGIN				! FIELDREF
		CGERR();
	END;				! FIELDREF

	BEGIN				! STORECLS
		CGERR();
	END;				! STORECLS

	BEGIN				! REGCONTENTS
		CGERR();
	END;				! REGCONTENTS

	BEGIN				! LABOP
		CGERR();
	END;				! LABOP

	BEGIN				! STATEMENT
		CGERR();
	END;				! STATEMENT

	BEGIN				! IOLSCLS
		CGERR();
	END;				! IOLSCLS

	BEGIN				! INLINFN
		CGERR();
	END;				! INLINFN

	BEGIN				! SUBSTRING
		RETURN FATLEX(E195<0,0>); ! "not constant"
	END;				! SUBSTRING

	BEGIN				! CONCATENATION
		ARGL = .EXPR[ARG2PTR];

		! Look through argument list EVALing the args and accumulating
		! the result string length.

		LEN = 0;
		INCR N FROM 2 TO .ARGL[ARGCOUNT] DO
		BEGIN
			IF (ARGL[.N,ARGNPTR] = ARGPTR = EVAL(.ARGL[.N,ARGNPTR])) LSS 0
			THEN RETURN .VREG; ! If error, pass it on
			LEN = .LEN + .ARGPTR[LITLEN];
		END;

		! Allocate literal table node for result string

		RESULT = MAKLIT(.LEN);

		! Copy strings into result

		RESULTPTR = RESULT[LITC1];

		INCR N FROM 2 TO .ARGL[ARGCOUNT] DO
		BEGIN
			ARG = .ARGL[.N,ARGNPTR];
			ARGPTR = ARG[LITC1];
			DECR I FROM .ARG[LITLEN] TO 1 DO
			COPYII(ARGPTR,RESULTPTR);
		END;

		! Insert trailing spaces to bring string up to
		! word boundary

		WHILE .RESULTPTR<31,5> NEQ 0
		DO REPLACEI(RESULTPTR," ");

		! Clean up

		!SAVSPACE(ARG LIST);
		!SAVSPACE(CONCAT NODE);

		RETURN .RESULT;
	END				! CONCATENATION

	TES;

END;	! EVAL

ROUTINE NTHARG (N,CNODE) =

! Returns Nth argument of function call node CNODE.
! The argument list has already been validated by MAKLIBFUN.

BEGIN
	MAP BASE CNODE;
	REGISTER ARGUMENTLIST ARGL;

	ARGL = .CNODE[ARG2PTR];		! Get pointer to arg list
	RETURN .ARGL[.N,ARGNPTR];	! Return Nth arg

END;	! NTHARG
GLOBAL ROUTINE CNVCONST (CNODE, TONODE, FROMTYPE, TOTYPE) = ! [1527] New

! Routine to convert constant to desired type.  Used to convert F77 parameters
! to match the type declared for the parameter.  Under /F66, parameters have
! the type of the expression, not the parameter name.
!
! Args:	CNODE = constant node to be converted
!	TONODE = identifier node (gives character length to convert to)
!	FROMTYPE = valtype of constant
!	TOTYPE = desired valtype

BEGIN
	MAP BASE TONODE:CNODE;
	REGISTER BASE FROMPTR:TOPTR:RESULT;

	IF .FROMTYPE EQL .TOTYPE
	THEN
	BEGIN	! types match
		IF .TOTYPE NEQ CHARACTER ! converting numeric to numeric?
		THEN RETURN .CNODE;	! yes, done

		IF .TONODE[IDCHLEN] EQL LENSTAR	! converting to length *?
		THEN RETURN .CNODE;	! yes, result length is length of RHS

		IF .CNODE[LITLEN] EQL .TONODE[IDCHLEN]	! lengths match?
		THEN RETURN .CNODE;	! yes, return RHS

		! copy string to literal node of correct length

		RESULT = MAKLIT(.TONODE[IDCHLEN]);
		FROMPTR = CNODE[LITC1];
		TOPTR = RESULT[LITC1];

		DECR I FROM .TONODE[IDCHLEN] TO 1 DO
		COPYII(FROMPTR,TOPTR);

		WHILE .TOPTR<31,5> NEQ 0 ! put 0-4 trailing spaces at end
		DO REPLACEI(TOPTR," ");

		RETURN .RESULT + LITSTRING^18;
					! return copied string as string lexeme
	END;	! types match

	IF .TOTYPE EQL CHARACTER	! converting numeric to character?
	THEN RETURN FATLEX(E160<0,0>);	! yes, error, can't be done

	! Numeric to numeric conversion, call CNSTCM to do the work

	C1H = .CNODE[CONST1];
	C1L = .CNODE[CONST2];
	COPRIX = (VTP2(.FROMTYPE))^3 + VTP2(.TOTYPE)
		  + (IF .GFLOAT THEN KTYPCG ELSE KTYPCB);
	CNSTCM();
	RETURN MAKECNST (.TOTYPE, .C2H, .C2L) + CONSTLEX^18;

END;	! CNVCONST

GLOBAL ROUTINE ASTEREXPR =		! [1527] New

! Action routine to read array declarator bounds.  Allows asterisk, expression,
! or constant expression.  Returns (on STK) a constant, expression, or asterisk.
! Returns -1 on error, 0 on success.

BEGIN
	LOCAL BASE CONST;

	IF .LSAVE NEQ 0 THEN LSAVE = 0 ELSE LEXL = LEXEMEGEN();

	IF .LEXL<LEFT> EQL ASTERISK THEN STK[SP=.SP+1] = .LEXL
	ELSE
	BEGIN	! Constant or expression
		LSAVE = -1;
%1670%		IF EXPRESS() LSS 0 THEN RETURN .VREG;
%1670%					! Read an expression
%1670%		IF CONSTP(.STK[.SP])	! Check if expression is constant
%1670%		THEN
%1670%		BEGIN
%1670%			CONST = STK[.SP] = EVAL(.STK[.SP]);
%1670%					! Evaluate constant expression
%1670%			IF .CONST LSS 0 THEN RETURN .CONST;
%1670%			STK[.SP]<LEFT> = IF .CONST[VALTYPE] EQL CHARACTER
%1670%					 THEN LITSTRING ELSE CONSTLEX;
%1670%			RETURN 0;
%1670%		END;
	END;	! Constant or expression

	RETURN 0;			! succeed

END;	! ASTEREXPR
ROUTINE CONSTP (EXPR) =			! [1670] New

! Return true iff EXPR is a constant expression

BEGIN
	MAP BASE EXPR;

	SELECT .EXPR[OPRCLS] OF NSET

	DATAOPR:
		RETURN .EXPR[OPERSP] EQL CONSTANT;

	FNCALL:		RETURN 0;
	ARRAYREF:	RETURN 0;
	SUBSTRING:	RETURN 0;
	CONCATENATION:	RETURN 0;

	TYPECNV:	RETURN CONSTP(.EXPR[ARG2PTR]);
	NEGNOT:		RETURN CONSTP(.EXPR[ARG2PTR]);

	OTHERWISE:			! binary
		RETURN
		IF CONSTP(.EXPR[ARG1PTR]) THEN CONSTP(.EXPR[ARG2PTR]) ELSE 0;

	TESN;

END;	! CONSTP

END
ELUDOM