Google
 

Trailing-Edge - PDP-10 Archives - CFS_TSU04_19910205_1of1 - update/ftncsr/act0.bli
There are 12 other files named act0.bli in the archive. Click here to see a list.
!COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1972, 1987
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR ANY  OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF THE  SOFTWARE  IS  HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT  NOTICE
!AND  SHOULD  NOT  BE  CONSTRUED  AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY  OF  ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.

!AUTHOR: F.J. INFANTE, D. B. TOLMAN/DCE/TFV/EGM/AHM/CKS/CDM/TGS/TJK/AlB/MEM

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

GLOBAL BIND ACT0V = #11^24 + 0^18 + #4530;	! Version Date: 17-Feb-86

%(

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

1732	CDM	10-Mar-83
	Add code to check for the length of a character constant in  a
	PARAMETER statement.  If the word length of the identifier  is
	longer than the constant,  build a new  constant and pad  with
	blanks.

1740	CDM	7-Apr-83
	Make constant expressions work for EQUIVALENCE statements.
	EVAL must be a global routine.

1765	TGS	29-Jun-83
	Fix KEYSCAN to check for ENCODE/DECODE without a third
	positional argument.  Improve error messages for mis-positioned
	optional keyword arguments.

1777	TJK	13-Sep-83
	Make KSPEC and KUSPEC pass errors from KEYSCAN.
	Also add explicit zero return for no error.

2055	CDM	30-May-84
	Edit 1732 did not  check for a PARAMETER  constant not being  of
	type character  so  that  a  illegal  constant  could  make  the
	compiler  get  a   non  informative   compiler  error   (illegal
	instrucion) before the problem can  be properly reported to  the
	user.

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

***** Begin Version 10 *********

2253	AlB	28-Dec-83
	Added code for compatibility flagger.
	Routines:
		EXPRLIST, FMTSCAN, KEYSCAN, PARMLPAREN

2261	AlB	5-Jan-84
	Set global variable IOSPEC to true if I/O specifiers were found
	inside parentheses, and false otherwise.  This helps the compatibility
	flagger detect "PRINT (FMT=f) iolist" which is extension to Fortran-77
	and incompatible with VAX.
	Routine:
		KSPEC

2270	AlB	16-Jan-84
	FMTSCAN, upon encountering 'FMT=namelist', will go through that
	list in order to do NAMSET or NAMREF calls for each of the items in
	the list.  This process caused a redundant, and to some extent confusing,
	VAX compatibility warning;  VAX compatibility flagging is now turned
	off during those calls.

	It should be noted that the incompatibilities are flagged when the
	NAMELIST statement itself is parsed, so nothing falls through a crack.

2341	AlB	17-Apr-84
	Added NML to list of acceptable keywords in KEYSCAN. NML= is
	equivalent to FMT= except that its argument may only be a NAMELIST
	name.

	Added the NMLSCAN routine to handle the NML= keyword.

	Since FMTSCAN and NMLSCAN do identical processing for a namelist
	key value, the NMLIOREF routine was added to be called by both
	FMTSCAN and NMLSCAN.

	If VAX compatibility flagging is being done, then a warning will
	be issued if 'FMT=namelist' is used (VAX wants 'NML=namelist').

2370	MEM	14-Jun-84
	Calls to FATLEX with E182 or E183 were changed to pass the address
	of the specifier to be printed in the error message instead of
	passing the specifier itself.

2424	MEM	13-Jul-84
	Check for IOSTAT in read/write statements instead of only
	checking the first five characters and ignoring the rest.

2436	MEM	31-Jul-84
        Replace K, in calls to FATLEX in KEYSCAN, with KEYBUFFER

2455	MEM	30-Aug-84
	Replace all references to VAX with VMS.

2461	CDM	28-Sept-84
	Add octal and  hexadecimal constants for  the Military  Standard
	MIL-STD-1753 to DATA statements.
	Add routines OCTHEX and GETDIGIT.
	Fix error message  in CNVCONST.   It was not  giving a  variable
	name to an error message that  expects it.

2473	CDM	29-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.

2510	CDM	4-Jan-85
	Enhancements to edit 2461 for octal and hexadecimal constants in
	DATA statements.  Better error messages and significant leading
	zeroes to match the already existing octal constants.

***** End V10 Development *****

2537	CDM	16-JUL-85
	When no FMT= or NML= is given in a format expression,
	FMT= is default.  FMTSCAN is called, but doesn't
	know if it is FMT= has really been given or not.
	Add argument to indicate this.

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

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

4501	MEM	22-Jan-85
	Modified KEYSCAN to scan for the new indexed read specifiers.

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

4527	CDM	1-Jan-86
	VMS Long symbols phase II.  Convert all internal symbols from
	one word of Sixbit to [length,,pointer].

4530	MEM	17-Feb-86
	Add support for long symbols. Handle conflict of INTEGER FUNCTION x
	which can be either function declaration of X or declaration of
	identifier FUNCTIONX.

4534	CDM	12-May-86
	Correct error message.  KEYBUFFER was being overwritten before
	error message was displayed.

ENDV11
)%

!++
! These are the action routines for the BNF.
!
! To return a value to the BNF, return:
!
!	-1	Didn't find what I wanted.
!
!	0	Success, I found what I wanted.
!--

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,		! Parse for data type or NONE on IMPLICIT
%2473%	IMPCHK,		! Check if IMPLICIT NONE was parsed by TYPEID
	IMPLICITSPEC,
	TOQUOTE,
	KSPEC,
	KUSPEC,
	KEYSCAN,
	UNITSCAN,
	FMTSCAN,
%2341%	NMLSCAN,	! Handle NML= keyword
%2341%	NMLIOREF(1),	! Handle namelist for both FMTSCAN and NMLSCAN
	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,
%2461%	OCTHEX,		! Action routine to read an octal/hex constant
%2461%	GETDIGIT;	! Gets a digit, called by OCTHEX.

EXTERNAL
	ACTLDATYPE,
%2473%	ANSIPLIT,	! 'Extension to Fortran 77:'
	BASE ASTATFUN,
	BLDVAR,
	ASTER,
	C1H,		! Arguments to CNSTM
	C1L,		! Arguments to CNSTM
	C2H,		! Arguments to CNSTM
	C2L,		! Arguments to CNSTM
%2253%	CFLEXB,		! Put out compatibility warning
	CGERR,
%1213%	CHDECL,		! Flag for character declaration seen
%1213%	CHDLEN,		! Default character count for character data
%1213%	CHLEN,		! Character count for character data
	CNSTCM,		! Constant combine routine
	COPRIX,		! Arguments to CNSTM
	COPYLIST,
	CORMAN,		! Routine to get space from free memory
%4527%	CPYSYM,		! Copies [length,,pointer] to unique memory
	E9,
%2461%	E64,		! Constant underflow or overflow
%1061%	E150,
	E160,
%2461%	E163,		! Illegal combination of character and numeric data
	E182,
	E183,
	E195,
	E198,
	E199,
	E211,
%2253%	E218,		! Extension to Fortran-77: Apostrophe in I/O keyword
%2253%	E237,		! Extension to Fortran-77: Format in numeric array
%2455%	E240,		! VMS incompatibility: FMT= used instead of NML=
%2341%	E262,		! Extension to Fortran-77: Use of NAMELIST
%2253%	E264,		! Extension to Fortran-77: Missing parens around PARAMETER
%2253%	E270,		! Extension to Fortran-77: & used as return label
%2253%	E271,		! Fortran-77 or VMS: $ used as return label
%2341%	E298,		! NML= must have only namelist name
%2461%	E302,		! Octal & hex constants are extensions
%2473%	E303,		! IMPLICIT NONE
%4501%	E306,		! only 1 of KEY,KEYEQ,KEYGE,KEYGT can be specified
%4501%	E312,		! Illegal valtype of expression
	ENTRSTA,
	ENTRY,
	EXPRESS,
	FINDSTA,
	FNTMP,		! Counter for .Fnnnn temporaries
	GSTCSCAN,
	GSTKSCAN,
	GSTLEXEME,
	GSTSSCAN,
	GTYPCOD,
	IDTYPE,
%2473%	IMPNONE,	! Flag for IMPLICIT NONE
	KARIIB,
	KARIGB,
	KBOOLBASE,
%2461%	KDNEGB,		! Negate double word
%2424%	KEYBUFFER,	! 4 word buffer containing keyword found in LEXICA
	KSPECB,
	KSPECG,
	KTYPCB,
	KTYPCG,
	LEXEMEGEN,
	LEXICAL,
%2473%	LEXLINE,	! Line number that we're parsing
	LEXOPGEN,
	LEXL,
%1732%	LITPOINTER,	! Pointer to first,,last linked literals
	LOOK4CHAR,
	LOOK4LABEL,
	LSAVE,
%1535%	MAKLIT,		! Make empty literal table node
	NAME,		! Global argument to CORMAN
	NAMDEF,
	NAMREF,
	NAMSET,
	NEWENTRY,
	NONIOINIO,
%4527%	ONEWPTR,	! Returns [1,,pointer] to Sixbit argument passed
%1732%	PRVLIT,		! Previous literal in the linked list
	PROGNAME,
	SAVSPACE,	! Routine to free space
	SETUSE,
	SP,
	STK,
	STMNDESC,
	SYNTAX,
	TYPE,
%2473%	TYPIMP,		! Flag for whether variables are typed IMPLICITly
	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
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;

%4527%	RETURN CPYSYM( ONEWPTR(.VAL) );		![length,,pointer]

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,	! formal argument
	BASE SAV,	! used to switch names
	BASE TMP;	! .Fnnnn variable


	! Get a variable

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

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

	ID = .LEXL<RIGHT>;

	! Generate a new formal variable, insert it in the symbol  table
	! after the existing  argument and  swap the names  so that  the
	! previously existing argument becomes a .Fnnnn variable.

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

	! Copy/create the info needed for this new variable

	TMP[IDATTRIBUT(DUMMY)] = -1;	! Mark it as a dummy argument
%2473%	TMP[IDATTRIBUT(INTYPE)] = .ID[IDATTRIBUT(INTYPE)];	! Declared?
	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
%4530%	!PROGNAME = MAIN. by default if no program/function/subroutine name was specified
%4530%	!If a program/function/subroutine name was specified then 
%4530%	!    ddd FUNCTION nnn
%4530%	!is declaration of identifier FUNCTIONnnn of data type ddd
%4530%	!since it is not a function declaration so exit this routine
%4530%
%4530%	!where ddd is a datatype (INTEGER,REAL,CHARACTER...) and
%4530%	!      nnn is an symbol/number
%4530%	
%4530%	IF @(.PROGNAME<SYMPOINTER>) NEQ SIXBIT 'MAIN.'	
%4530%	THEN RETURN -1;		

	! Scan for the string "FUNCTION".  If it is found then call this a
	! function.  

	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 =

!++
! FUNCTIONAL DESCRIPTION:
!
!	This  action  routine  parses  the  valid  characters  following
!	"IMPLICIT".  They are either a data  type or "NONE".  If a  data
!	type, 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.
!
! FORMAL PARAMETERS:
!
!	None
!
! IMPLICIT INPUTS:
!
!	ANSIPLIT	Characters for error message about ansi-F77 standard
!
!	E17, E303	Error messages for IMPLICIT
!
!	LEXLINE		line number of statement being processed
!
! IMPLICIT OUTPUTS:
!
!	CHLEN		Character length passed to <>
!
!	GSTSSCAN	"Scan for character string" passed to LEXICA
!
!	IMPNONE		Flag for IMPLICIT NONE was seen
!
!	LOOK4CHAR	Pointer to character string to look for
!
!	SP		Pointer into STK
!
!	STK		Results of the parsed BNF stack
!
!	TYPIMP		Flag indicating that IMPLICIT statements have
!			been scanned (other than IMPLICIT NONE).
!
! ROUTINE VALUE:
!
!	.LT. 0 if parsing a data type or NONE fails.
!
!	.EQ. 0 if parsing NONE succeeds.
!
!	.GT. 0 if a data type is found (the data type itself is returned).
!
! SIDE EFFECTS:
!
!	Parsing is done on the input source file.
!
!--


![2473] Rewritten

BEGIN

REGISTER R1;	! VALTYPE of the data type read in

	! This is  a table  of  the valid  data types/"NONE" characters to  
	! follow IMPLICIT.  This  table  mus be  kept  in order  with  TYPENUM.
	! For the global externals, start at the second character, the
	! first character is " ".

BIND	TYPECHAR = PLIT(
		INTGPLIT<29,7>,
		REALPLIT<29,7>,
		DOUBPLIT<29,7>,
		COMPLIT<29,7>,
		LOGIPLIT<29,7>,
		CHARPLIT<29,7>,
		UPLIT(ASCIZ 'NONE')<36,7>);

BIND	TYPNONE = -1;	! Invalid VALTYPE, for IMPLICIT NONE

	! This is the table of VALTYPEs corresponding to the  characters
	! parsed in TYPECHAR. It must be kept in order with TYPECHAR.

BIND	TYPENUM = PLIT(
		INTEGER,
		REAL,
		DOUBLPREC,
		COMPLEX,
		LOGICAL,
		CHARACTER,
		TYPNONE);

LABEL	LOOP;

LOCAL	FNDONE;		! "Found one!"  (a dataype or a NONE)

MACRO	ERR303 = (FATLEX(UPLIT(ASCIZ'Other IMPLICIT specifications are illegal with'),
			E303<0,0>))$;


	! Try each valid string of characters following IMPLICIT, one by
	! one.

	FNDONE = FALSE;		! Haven't found any yet!

	INCR CNT FROM 0 TO .(TYPECHAR - 1) -1
	DO
LOOP:	BEGIN	! Scan for each datatype

		LOOK4CHAR = .TYPECHAR[.CNT];	! Characters to look for
		IF LEXICAL(.GSTSSCAN) NEQ 0	! Look for them
		THEN
		BEGIN	! Found a data type

			FNDONE = TRUE;		! We FOUND it!
			R1 = .TYPENUM[.CNT];	! VALTYPE of this type
			LEAVE LOOP;		! Don't look any further

		END;	! Found a data type

	END;	! Scan for each datatype

	! Didn't find a data type?  We tried all the valid possiblities, so
	! if we didn't find one complain!

	IF NOT .FNDONE 
	THEN RETURN FATLEX(E17<0,0>);	! Invalid data type


	IF .R1 EQL TYPNONE
	THEN
	BEGIN	! IMPLICIT NONE

		STK[SP = .SP+1] = 'NONE';	! Tell IMPCHK we have one
!		If we have already seen an IMPLICIT NONE, then tell the
!		user they're verbose. This is the catch the "IMPLICIT
!		NONE, NONE" case which the BNF allows

%2506%		IF .IMPNONE
%2506%		THEN FATLEX(UPLIT(ASCIZ'Muliple'), E303<0,0>)	! Warning
%2506%		ELSE IMPNONE = TRUE;		! IMPLICIT NONE

		! IMPLICIT NONE is not ANSI standard, give a warning

		IF FLAGANSI THEN FATLERR(ANSIPLIT, .LEXLINE, E303<0,0>);

		! Other  IMPLICIT  statements   are  not  allowed   with
		! IMPLICIT NONE.

		IF .TYPIMP THEN ERR303;

		RETURN 0;	! "Found something valid after IMPLICIT"

	END;	! IMPLICIT NONE


	! Not IMPLICIT NONE.
	! Has IMPLICIT NONE been seen already? No other IMPLICIT 
	! statements are allowed wit it.

	IF .IMPNONE THEN ERR303;


	TYPIMP = TRUE;		! IMPLICIT used for typeing variables


	IF .R1 EQL CHARACTER
	THEN
	BEGIN	! Type is character

%1213%		CHDLEN = 1;	! Default character count is 1

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

%1232%		CHDECL = -1;

	END;	! Type is character

	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 IMPCHK=	![2473] New

!++
! FUNCTIONAL DESCRIPTION:
!
!	Action routine to check for  IMPLICIT NONE.  If TYPEID  (another
!	action routine) puts 'NONE' on STK, then we've seen it.  This is
!	to decide if  the part  of the  BNF, "("  <implicitspec> ")"  is
!	optional or not.  It's not allowed with NONE, and is required without NONE.
!
! FORMAL PARAMETERS:
!
!	None
!
! IMPLICIT INPUTS:
!
!	SP		Current position in STK.
!
!	STK		Parse stack for BNF.
!
! IMPLICIT OUTPUTS:
!
!	SP		Current position in STK.
!
! ROUTINE VALUE:
!
!	-1 	If IMPLICIT NONE was parsed by TYPEID (routine "fails")
!
!	0 	Otherwise (routine "succeeds")
!
! SIDE EFFECTS:
!
!	None
!
!--


BEGIN
	! Have we seen IMPLICIT NONE in TYPEID? If so, 'NONE' was
	! pushed on the top of the stack.

	IF .STK[.SP] EQL 'NONE'
	THEN
	BEGIN	! IMPLICIT NONE

		SP = .SP - 1;	! Set pointer to not look at 'NONE'
		RETURN -1;	! Don't parse optional (<implicitspec>)

	END	! IMPLICIT NONE
	ELSE RETURN 0;		! Must continue parsing (<implicitspec>)

END;	! of IMPCHK
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 10-word block.  The block 
! contains pointers to the UNIT, FMT, variable, REC, END, ERR, IOSTAT
! specifiers, in that order, plus 3 words for RMS key specifiers.

BEGIN
	REGISTER QFMT,LSP;
%1777%	LOCAL SCANERR;
%2261%	GLOBAL IOSPEC;

	! 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
%2261%		IOSPEC=TRUE;		! So PRINT can be flagged
%1777%		SCANERR = 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 ')'"

%1777%		IF .SCANERR LSS 0	! KEYSCAN error
%1777%		THEN RETURN .SCANERR;

	END	! keyword list
	ELSE
	BEGIN	! plain format specifier

%2261%		IOSPEC=FALSE;		! So WRITE can be flagged

%2537%		QFMT = FMTSCAN(TRUE);	! 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
%4501%		SP = .SP + 10;		! 10 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
%4501%		STK[.LSP+8] = 0;	! keyid
%4501%		STK[.LSP+9] = 0;	! keyrel
%4501%		STK[.LSP+10] = 0;	! key

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

%1777%	RETURN 0;	! no error

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 10-word block.  The block 
! contains pointers to the UNIT, FMT, variable, REC, END, ERR, IOSTAT
! specifiers, in that order, plus 3 words for RMS key specifiers.

BEGIN
	REGISTER QUNIT,LSP;
%1777%	LOCAL SCANERR;

	! 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
%1777%		SCANERR = 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 ')'"

%1777%		IF .SCANERR LSS 0	! KEYSCAN error
%1777%		THEN RETURN .SCANERR;

	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
%4501%		SP = .SP + 10;		! 10 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
%4501%		STK[.LSP+8] = 0;	! keyid
%4501%		STK[.LSP+9] = 0;	! keyrel
%4501%		STK[.LSP+10] = 0;	! key

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

%1777%	RETURN 0;	! no error

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
![4501]	KEY=k		k = integer expression or char expression		
![4501]	KEYEQ=k		k = integer expression or char expression		
![4501]	KEYGE=k		k = integer expression or char expression	
![4501]	KEYGT=k		k = integer expression or char expression	
![4501]	KEYID=r		r = integer expression	
!
! 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
%4501%	BIND
%4501%		CIEXP = UPLIT ASCIZ 'a character or integer expression',
%4501%		IEXP = UPLIT ASCIZ 'an integer expression';

%2370%	LOCAL K,			! pointer to keyword in asciz
	      QUNIT,QFMT,QREC,		! keyword values
	      QERR,QEND,QIOSTAT,QVAR,	      
	      LSP;			! local SP
%4501%	LOCAL BASE QKEYREL: QIOKEY: QKEYID;! more keyword values
%4501%	LOCAL MULTIFLG;	! we have seen multiple key relation specifiers

%1765%	! Return a fatal error if parsing ENCODE/DECODE 
%1765%	! and no variable has yet been parsed

%1765%	MACRO CHKENCDEC =
%1765%	BEGIN
%1765%	IF .MAXPOS EQL 3
%1765%	THEN IF .QVAR EQL 0
%1765%	THEN RETURN FATLEX(.LEXNAM[IDENTIFIER],PLIT 'keyword',E0<0,0>);
%1765%	END$;

	QUNIT = QFMT = QREC = QERR = QEND = QIOSTAT = QVAR = 0;
%4501%	QKEYID = QKEYREL = QIOKEY = 0;
%4501%	MULTIFLG = FALSE;		! we have not seen multiple key relation specifiers

	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
%2253%					IF FLAGANSI	!Compatibility flagger
%2253%					THEN WARNLEX(E218<0,0>);
					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;
%2537%				QFMT = FMTSCAN(FALSE); ! 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

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

%2424%			ELSE IF .KEYBUFFER EQL 'FMT'
			THEN
			BEGIN	! FMT=
%2436%				IF .QFMT NEQ 0 THEN FATLEX(KEYBUFFER,E182<0,0>);
					! "FMT= may only be specified once"
%2537%				QFMT = FMTSCAN(TRUE);
				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=

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

%2424%			ELSE IF .KEYBUFFER EQL 'REC'
			THEN
			BEGIN	! REC=
%2436%				IF .QREC NEQ 0 THEN FATLEX(KEYBUFFER,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=

%2424%			ELSE IF .KEYBUFFER EQL 'END'
			THEN
			BEGIN	! END=
%2436%				IF .QEND NEQ 0 THEN FATLEX(KEYBUFFER,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=

%2424%			ELSE IF .KEYBUFFER EQL 'ERR'
			THEN
			BEGIN	! ERR=
%2436%				IF .QERR NEQ 0 THEN FATLEX(KEYBUFFER,E182<0,0>);
					! "ERR= may only be specified once"
%1765%				CHKENCDEC;     ! Check for ENC/DEC misordering
				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=

%2424%			ELSE IF (.KEYBUFFER EQL 'IOSTA') AND
%2424%				(.(KEYBUFFER+1) EQL 'T')
			THEN
			BEGIN	! IOSTAT=
%2436%				IF .QIOSTAT NEQ 0 THEN FATLEX(KEYBUFFER,E182<0,0>);
					! "IOSTAT= may only be specified once"
%1765%				CHKENCDEC;		! Check ENC/DEC 
				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=

%4501%			ELSE IF .KEYBUFFER EQL 'KEY'
%4501%			THEN
%4501%			BEGIN	! KEY=
%4501%				! we have already seen a key relational specifier
%4501%				IF .QIOKEY NEQ 0 THEN MULTIFLG = TRUE;
%4501%	
%4501%				QKEYREL = KEYREL0;
%4501%	
%4501%				IF  EXPRESS() LSS 0 THEN RETURN .VREG;
%4501%				QIOKEY = .STK[.SP];
%4501%				SP = .SP - 1;
%4501%				IF (.QIOKEY[VALTYPE] NEQ INTEGER) AND
%4501%				   (.QIOKEY[VALTYPE] NEQ CHARACTER)
%4501%				THEN FATLEX (CIEXP,UPLIT ASCIZ 'KEY=',E312<0,0>);
%4501%			END
%4501%			ELSE IF .KEYBUFFER EQL 'KEYEQ'
%4501%			THEN
%4501%			BEGIN	! KEYEQ=
%4501%				! we have already seen a key relational specifier
%4501%				IF .QIOKEY NEQ 0 THEN MULTIFLG = TRUE;
%4501%	
%4501%				QKEYREL = KEYRELEQ;
%4501%	
%4501%				IF  EXPRESS() LSS 0 THEN RETURN .VREG;
%4501%				QIOKEY = .STK[.SP];
%4501%				SP = .SP - 1;
%4501%				IF (.QIOKEY[VALTYPE] NEQ INTEGER) AND
%4501%				   (.QIOKEY[VALTYPE] NEQ CHARACTER)
%4501%				THEN FATLEX (CIEXP,UPLIT ASCIZ 'KEYEQ=',E312<0,0>);
%4501%			END
%4501%			ELSE IF .KEYBUFFER EQL 'KEYGE'
%4501%			THEN
%4501%			BEGIN	! KEYGE=
%4501%				! we have already seen a key relational specifier
%4501%				IF .QIOKEY NEQ 0 THEN MULTIFLG = TRUE;
%4501%	
%4501%				QKEYREL = KEYRELGE;

%4501%				IF  EXPRESS() LSS 0 THEN RETURN .VREG;
%4501%				QIOKEY = .STK[.SP];
%4501%				SP = .SP - 1;
%4501%				IF (.QIOKEY[VALTYPE] NEQ INTEGER) AND
%4501%				   (.QIOKEY[VALTYPE] NEQ CHARACTER)
%4501%				THEN FATLEX (CIEXP,UPLIT ASCIZ 'KEYGE=',E312<0,0>);
%4501%			END
%4501%			ELSE IF .KEYBUFFER EQL 'KEYGT'
%4501%			THEN
%4501%			BEGIN	! KEYGT=
%4501%				! we have already seen a key relational specifier
%4501%				IF .QIOKEY NEQ 0 THEN MULTIFLG = TRUE;
%4501%	
%4501%				QKEYREL = KEYRELGT;
%4501%	
%4501%				IF  EXPRESS() LSS 0 THEN RETURN .VREG;
%4501%				QIOKEY = .STK[.SP];
%4501%				SP = .SP - 1;
%4501%				IF (.QIOKEY[VALTYPE] NEQ INTEGER) AND
%4501%				   (.QIOKEY[VALTYPE] NEQ CHARACTER)
%4501%				THEN FATLEX (CIEXP,UPLIT ASCIZ 'KEYGT=',E312<0,0>);
%4501%			END
%4501%			ELSE IF .KEYBUFFER EQL 'KEYID'
%4501%			THEN
%4501%			BEGIN	! KEYID=
%4501%				IF .QKEYID NEQ 0 THEN FATLEX(KEYBUFFER,E182<0,0>);
%4501%					! "KEYID= may only be specified once"
%4501%	
%4501%				IF  EXPRESS() LSS 0 THEN RETURN .VREG;
%4501%				QKEYID = .STK[.SP];
%4501%				SP = .SP - 1;
%4501%				IF (.QKEYID[VALTYPE] NEQ INTEGER) 
%4501%				THEN FATLEX (IEXP,UPLIT ASCIZ 'KEYID=',E312<0,0>);
%4501%			END

%2436%			ELSE
%2436%			BEGIN	! "unrecognized keyword K"

%4534%				OWN SAVEKEY[MAXSYMWORDS];	! Where to save
%4534%
%4534%				! Bad keyword.  Must save it away, since
%4534%				! someone may overwrite KEYBUFFER before
%4534%				! the error message is output.
%4534%
%4534%				INCR CNT FROM 0 TO MAXSYMWORDS
%4534%				DO SAVEKEY[.CNT] = .KEYBUFFER[.CNT];
%4534%				RETURN FATLEX(SAVEKEY<0,0>,E183<0,0>);

%2436%			END;	! "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 ")"');

%1765%	IF .MAXPOS EQL 3			! ENC/DEC without 
%1765%	THEN IF .QVAR EQL 0			! a variable
%1765%		THEN RETURN ERR0L (UPLIT ASCIZ '","');	! is an error

%4501%	! if we have seen multiple key relational specifiers, say so
%4501%	IF .MULTIFLG EQL TRUE THEN WARNLEX(E306<0,0>);
				
	! Put args into a block of information on the semantic stack

	LSP = .SP;
%4501%	SP = .SP + 10;
	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;
%4501%	STK[.LSP+8] = .QKEYID;
%4501%	STK[.LSP+9] = .QKEYREL;
%4501%	STK[.LSP+10] = .QIOKEY;

	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(FMTGIVEN)=			! [2537] argument added

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

! FMTGIVEN	TRUE or FALSE depending on whether "FMT=" was really
!		seen in the user's program.


BEGIN
	REGISTER BASE F;
	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

%2341%				IF NMLIOREF(.F) LSS 0 THEN RETURN .VREG;
%2341%
%2455%				! Should use NML if flagging for VMS
%2537%				IF .FMTGIVEN EQL TRUE THEN
%2455%				IF FLAGVMS THEN WARNLEX(E240<0,0>)
			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

%2253%				! If numeric array, flag the extension to ANSI
%2253%				IF FLAGANSI
%2253%				THEN
%2253%					IF .F[OPRCLS] EQL DATAOPR AND
%2253%						.F[VALTYPE] NEQ CHARACTER
%2253%					THEN
%2253%						IF .F[OPERSP] EQL ARRAYNAME OR
%2253%							.F[OPERSP] EQL FORMLARRAY
%2253%						THEN WARNLEX(E237<0,0>)
			END	! not label, not namelist
		END
	END;

	RETURN .F;
END;	! FMTSCAN
ROUTINE NMLSCAN=

!++
! FUNCTIONAL DESCRIPTION:		[Added in edit 2341]
!
!	Parses NML specifier.
!
!	The only legal syntax is namelist name.
!
! FORMAL PARAMETERS:
!
!	None
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	LEXL contains the next lexeme.
!
! ROUTINE VALUE:
!
!	If the next lexeme is a namelist name, that lexeme is returned.
!	Otherwise, a negative number is returned.
!
! SIDE EFFECTS:
!
!	Fatal error message if lexeme is not a NAMELIST name.
!
!--


BEGIN
	MAP BASE LEXL;

	LEXL=LEXEMEGEN();	! Get the lexeme for the keyword value
	IF .LEXL<LEFT> EQL IDENTIFIER AND .LEXL[IDATTRIBUTE(NAMNAM)]
	THEN
		IF NMLIOREF(.LEXL) LSS 0 ! Set references to NAMELIST items
		THEN RETURN .VREG	 ! Trouble
		ELSE RETURN .LEXL	 ! All is well
	ELSE RETURN FATLEX(E298<0,0>)	 ! Must be namelist name		

END; ! of NMLSCAN
		
ROUTINE NMLIOREF(LEX)=

!++
! FUNCTIONAL DESCRIPTION:		[Added in edit 2341]
!
!	Handles the namelist keyword value for FMT= and NML=.
!
!	The reference to the namelist name is noted via NAMREF.
!	The references to the namelist elements are noted via
!	NAMREF (for output) or via NAMSET (for input).
!
! FORMAL PARAMETERS:
!
!	LEX is the lexeme for the namelist name.
!
! IMPLICIT INPUTS:
!
!	TYPE contains READD if this is for an input statement,
!	otherwise the statement is assumed to be output.
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	If NAMREF likes the namelist name, return a 0.
!	Otherwise, return a negative error number.
!
! SIDE EFFECTS:
!
!	Fatal error message if .LEX cannot be a NAMELIST name.
!	Flagger warning if ANSI flagging is being done.
!
!--


BEGIN
	REGISTER BASE
		ID:		! Index into Symbol Table
		NAMCOM;		! Link to the entry in Namelist table
	MAP BASE LEX;		! The lexeme
%2455%	LOCAL SAVEFLAG;		! To save setting of CFLGVMS

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

	! Call NAMREF or NAMSET for the variables in the namelist

%2455%	SAVEFLAG=.F2<CFLGVMS>;	! Remember the VMS setting
%2455%	F2<CFLGVMS>=0;		! Turn off flagging temporarily

	NAMCOM = .LEX[IDCOLINK];
	INCR NMLST FROM .NAMCOM[NAMLIST] 
		   TO .NAMCOM[NAMLIST]+.NAMCOM[NAMCNT] - 1
	DO
	BEGIN
		ID = @.NMLST;
		IF .TYPE EQL READD
		THEN NAMSET (.ID[OPRSP1],.ID)
		ELSE NAMREF (.ID[OPRSP1],.ID)
	END;

%2455%	F2<CFLGVMS>=.SAVEFLAG;	! Restore any VMS flagging

	IF FLAGANSI THEN WARNLEX(E262<0,0>); !NAMELIST is ANSI extension

	RETURN 0
END; ! of NMLIOREF
GLOBAL ROUTINE EXPRLIST=
BEGIN
!++
!	Process the argument list of a CALL statement.
!--

	LOCAL LSP;
	REGISTER BASE T1,VAL;

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

%2507%	T1[IDSUBROUTINE] = 1;	! Mark as a subroutine name
	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
%2253%			BEGIN	! Return label
%2253%			IF FLAGEITHER AND (T1 = .LEXL<LEFT>) NEQ ASTERISK
%2253%			THEN
%2253%				BEGIN	! Compatibility checks
%2253%				IF .T1 EQL DOLLAR
%2253%				THEN
%2253%					CFLEXB(E271<0,0>)	! Flag the $
%2253%				ELSE
%2253%					IF FLAGANSI
%2253%					THEN WARNLEX(E270<0,0>)	! Flag the &
%2253%				END;	! Compatibility checks

			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();
%2253%			END;	! Return label
		IF .LEXL<LEFT> NEQ COMMA
		THEN  EXITLOOP
%1217%		ELSE LEXL = LEXEMEGEN();

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

%2507%		IF .SP GTR STKSIZ - 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;

%1732%	LOCAL
%1732%		BASE EXPLEN,	! Length of constant expression in words
%1732%		BASE IDLEN,	! Length of ID in words
%1732%		BASE NEWLIT,	! Make a new constant
%1732%		BASE SAVPRVLIT;	! Saved value of PRVLIT

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

%1732%	! Check if the length of the constant is long enough.  If  the
%1732%	! word length of the identifier  is longer than the  constant,
%1732%	! then me must make a new constant that is long enough (padded
%1732%	! with blanks).
%1732%
%1732%	IF .ID[VALTYPE] EQL CHARACTER 		! symbol character?
%2055%	THEN IF .EXPR[VALTYPE] EQL CHARACTER	! constant character?
%1732%	THEN
%1732%	BEGIN	! Character parameter
%1732%
%1732%		IDLEN = CHWORDLEN( .ID[IDCHLEN] );	! Len of identifier
%1732%		EXPLEN = CHWORDLEN( .EXPR[LITLEN] );	! Len of constant
%1732%
%1732%		IF .IDLEN GTR .EXPLEN
%1732%		THEN
%1732%		BEGIN	! Make a new longer character constant
%1732%
%1732%			! Save the  node  that  points  to  the  lit  to
%1732%			! replace.  After the MAKLIT call, PRVLIT is  no
%1732%			! longer that node.
%1732%			SAVPRVLIT = .PRVLIT;
%1732%
%1732%			NEWLIT = MAKLIT(.ID[IDCHLEN]);
%1732%
%1732%			! Copy over each  word of the  old to the  new
%1732%			! consant.
%1732%			INCR CNT FROM 1 TO .EXPLEN
%1732%			DO 	NEWLIT[LITWD(.CNT)] = .EXPR[LITWD(.CNT)];
%1732%
%1732%			! Pad with  blanks from  the  end of  the  old
%1732%			! constant to the end of the new one.
%1732%			INCR CNT FROM ( .EXPLEN + 1 ) TO .IDLEN
%1732%			DO	NEWLIT[LITWD(.CNT)] = '     ';
%1732%
%1732%			! Delete the old literal,  we don't need it
%1732%			SAVSPACE(.EXPLEN-1 + LTLSIZ - 1, .EXPR<RIGHT>);
%1732%
%1732%			! Remove it from the linked list too.
%1732%			IF .LITPOINTER<LEFT> EQL .EXPR<RIGHT>	! 1st literal?
%1732%			THEN	LITPOINTER<LEFT> = .NEWLIT	! Yes
%1732%			ELSE	SAVPRVLIT[LITLINK] = .NEWLIT;
%1732%
%1732%			! Assign a  new  constant  expression  of  the
%1732%			! correct size.  Assign only to the right hand
%1732%			! side,  since  the  left  must  contain   the
%1732%			! lexeme.
%1732%			EXPR<RIGHT> = .NEWLIT;
%1732%
%1732%		END;	! Make a new longer character constant
%1732%
%1732%	END;	! Character parameter

	ID[IDPARAVAL] = .EXPR;		! Parameter value

	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
%2253%	ELSE
%2253%		BEGIN
%2253%		IF FLAGANSI THEN WARNLEX(E264<0,0>);	!Compatibility flagger
%2253%		PARMCNV = 0; LSAVE = -1
%2253%		END;

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
GLOBAL ROUTINE EVAL (EXPR) =		! [1527] New [1740] Make global

! Evaluates a constant expression, trying  to simplify it into a  single
! constant.

! (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];
		
%4527%		IF .ARG1[ID1ST6CHAR] 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.

%4527%		ELSE IF .ARG1[ID1ST6CHAR] 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

	! Converting numeric to character is illegal.

	IF .TOTYPE EQL CHARACTER
%2461%	THEN RETURN FATLEX(E163<0,0>);

	! 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
GLOBAL ROUTINE OCTHEX=	![2461] New

!++
! FUNCTIONAL DESCRIPTION:
!
!	Action routine to  process octal/hexadecimal  constants in  DATA
!	statements.  Parse to see if one is present, and if so, put  the
!	necessary information pointing to an  octal constant on STK  for
!	later processing.
!
! FORMAL PARAMETERS:
!
!	None
!
! IMPLICIT INPUTS:
!
!	GSTCSCAN	Want LEXICA to scan a character
!
!	GSTSSCAN	Want LEXICA to scan a string
!
!	SP		Top location in STK
!
! IMPLICIT OUTPUTS:
!
!	LOOK4CHAR	Trashed, argument to LEXICA
!
!	SP		Top location in STK
!
!	STK		Syntax parsing stack
!
! ROUTINE VALUE:
!
!	Returns:
!
!		 0	If we found a valid octal or hexidecimal constant
!
!		-1	If we failed
!
! SIDE EFFECTS:
!
!	The input file will be parsed and characters may be "eaten".
!
!--


BEGIN
	REGISTER
		DIG,		! Octal/hex digit
		LOWWORD,	! Low order word of constant
		HIWORD;		! Hi order word of constant

	LOCAL
%2510%		ISDOUBLE,	! TRUE = Double precision constant
%2510%				! FALSE = Single precision constant
		ISNEG,		! TRUE = negate the constant
				! FALSE = keep constant as read in
		ISOCTAL,	! TRUE = octal constant
				! FALSE = hex constant
		NUMDIGITS;	! Number of digits read so far


	! Look for "O'<octal constant>'" or "Z'<hex constant>'"

	! Look for >O'<  (Note we're reading in TWO CHARACTERS!)

	LOOK4CHAR = UPLIT(ASCIZ 'O''')<36,7>;

	IF LEXICAL(.GSTSSCAN) NEQ 0
%2510%	THEN ISOCTAL = TRUE		! Parsing octal constant
	ELSE
	BEGIN	! Not O'

		! Look for >Z'<  (Note we're reading in TWO CHARACTERS!)

		LOOK4CHAR = UPLIT(ASCIZ 'Z''')<36,7>;

		IF LEXICAL(.GSTSSCAN) EQL 0
		THEN RETURN -1		! Found no octal/hexadecimal constant
		ELSE ISOCTAL = FALSE;	! Parsing hex constant, Z'

	END;	! Not O'


	! Found "O'" or "Z'".  Look for the digits or +/- following.

	! Look for +/-.  Plus is simply read over, minus must be remembered
	! so that the constant can be negated after we've read it in.  This
	! is not in the Mil Standard, merely an extension, since "-123 is
	! allowed.

%2510%	LOOK4CHAR = "-";	! Minus sign

%2510%	IF LEXICAL(.GSTCSCAN) NEQ 0
%2510%	THEN ISNEG = TRUE	! "-" found, must negate later
%2510%	ELSE
	BEGIN	! - not found

%2510%		ISNEG = FALSE;		! Positive number

%2510%		LOOK4CHAR = "+";	! Look for "+"
%2510%		LEXICAL(.GSTCSCAN);	! Skip over + if present

	END;	! - not found


	! Read in all the  digits and process them  to make a  constant.
	! We loop as  long as we  see digits.   When we see  no more  we
	! expect a  "'" to  close  the constant,  otherwise we  have  an
	! invalid character in the constant.

%2510%	LOWWORD = HIWORD = NUMDIGITS = DIG = 0;	! Initialize

	WHILE .DIG NEQ -1
	DO
	BEGIN	! Process all the digits

		DIG = GETDIGIT(.ISOCTAL);	! Next digit
						! -1 non-digit/letter found
						! -2 bad digit/letter found

%2510%		IF .DIG EQL -2 THEN RETURN -1;	! Bad digit, return now.
						! (error message already given)

%2510%		IF .DIG GEQ 0
%2510%		THEN
%2510%		BEGIN	! Valid digit

			NUMDIGITS = .NUMDIGITS + 1;	! One more digit

			! Got a digit.  Shift any previous digits over.  If
			! the low word is full, then we must carry from the
			! low into the high word.  Too many digits, and we
			! truncate off the left and keep the rightmost.

			IF .ISOCTAL 
			THEN
			BEGIN	! Octal constant

				! 3 bits per digit, slide 'em on over!

				IF .NUMDIGITS GTR 12	! Shift into 2nd word?
				THEN HIWORD = (.HIWORD ^ 3) + .LOWWORD<33,3>;

				LOWWORD = (.LOWWORD ^ 3) + .DIG; ! first word

			END	!Octal
			ELSE
			BEGIN	! Hexadecimal

				! 4 bits per digit, slide 'em on over!

				IF (.NUMDIGITS GTR 9)	! Shift into 2nd word?
				THEN HIWORD = (.HIWORD ^ 4) + .LOWWORD<32,4>;

				LOWWORD = (.LOWWORD ^ 4) + .DIG; ! 1st word

			END;	! Hexadecimal

%2510%		END;	! Valid digit

	END;	! Process all the digits



%2510%	! Decide if we have single or double precision

%2510%	IF (NOT .ISOCTAL AND .NUMDIGITS GTR 9)	! Hex
%2510%		OR (.NUMDIGITS GTR 12)		! Oct
%2510%	THEN ISDOUBLE = TRUE			! Double precision
%2510%	ELSE ISDOUBLE = FALSE;			! Single precision

	! Check if we read too many digits and truncated.

	IF (.NUMDIGITS GTR 24)				! Too many octal or hex
		OR ((NOT .ISOCTAL) AND (.NUMDIGITS GTR 18))	! Too many hex
	THEN FATLEX(E64);	! "Constant underflow or overflow"


	! Make sure that the closing quote for the constant is  present.
	! If not, then we haven't found a proper constant!

%2510%	IF .LSAVE EQL 0	THEN LEXL = LEXOPGEN();		! Get lexeme
%2510%
%2510%	IF .LEXL<LEFT> NEQ TICLEX   ! found ... when expecting "'" or ... digit
%2510%	THEN RETURN ERR0L(IF .ISOCTAL	! Different message depending on type
%2510%			  THEN UPLIT ASCIZ'"''" or octal digit'
%2510%			  ELSE UPLIT ASCIZ'"''" or hexidecimal digit');



%2510%	! No digits given?  (O'' or Z'')  This is an error for a regular
%2510%	! octal constant.  Give a message, default is 0.
%2510%	
%2510%	IF .NUMDIGITS EQL 0
%2510%	THEN FATLEX(IF .ISOCTAL	! Different message depending on type
%2510%		    THEN UPLIT ASCIZ'octal digit'
%2510%		    ELSE UPLIT ASCIZ'hexidecimal digit',
%2510%		    .LEXNAM[TICLEX], E0<0,0>);


	! FOUND VALID OCTAL OR HEX CONSTANT!

	! If neccessary, negate the constant.

	IF .ISNEG
	THEN
	BEGIN	! Read in minus sign

		! We use the constant combine routine to handle overflow
		! from negation and bit carry from low to high word.

		C1H = .HIWORD;		! Constant to negate
		C1L = .LOWWORD;

		COPRIX = KDNEGB;	! "Do a double word negation"
		CNSTCM();		! Do the negation

		HIWORD = .C2H;		! Restore the values
		LOWWORD = .C2L;


%2510%		! Negative double precisions must have the sign lit in
%2510%		! their low order words.  For some reason, DMOVN does not
%2510%		! do this.  Later the compiler in its infinite wisdom may
%2510%		! use the low order word, so the low must appear negative
%2510%		! if the high is negative!
%2510%
%2510%		IF (.HIWORD LSS 0) AND (.LOWWORD NEQ 0)
%2510%		THEN LOWWORD = #400000000000 OR .LOWWORD;	! Add bit

	END;	! Read in minus sign


	! Warn users  that  neither  the  77-standard  nor  VMS  Fortran
	! supports this type of constant.

	IF FLAGEITHER THEN CFLEXB(E302);


	! Put the constant that  we've got onto  STK.  We're not  making
	! this look like the BNF parsed it at all, we're just putting on
	! the info needed.   The below  is found by  the DATA  statement
	! processing routine.

	! 2,, ptr to constant
	! 1				"I'm an octal/hex constant!"
	!				(The grammar puts this here)

	! Pointers to other constant table entries are 2,,ptr (2 is  the
	! constant lexeme).  This also puts  something in the left  half
	! so it looks different from  what the other BNF-parsed  entries
	! look like (they don't have anything in their left half of  the
	! first word; <option>/<cnt-1>,,<ptr>).

	STK[SP = .SP+1]<LEFT> = CONSTLEX;		! Constant lexeme

%2510%	STK[.SP]<RIGHT> = MAKECNST(IF .ISDOUBLE
				THEN DOUBLOCT		! Dble prec
				ELSE OCTAL,		! Single prec
				.HIWORD, .LOWWORD);	! Constant values


	! When we return 0, a "1" is put on STK[SP = .SP+1] to indicate
	! to DATASTA that an octal or hex constant was found.

	RETURN 0;	! Found either an octal or hexadecimal constant

END;	! of OCTHEX
ROUTINE GETDIGIT(ISOCTAL)=	![2461] New

!++
! FUNCTIONAL DESCRIPTION:
!
!	Gets an octal or hexadecimal digit from source file.
!
!	Appropriate error messages are given if the digit or letter is
!	out of bounds for the constant.
!
! FORMAL PARAMETERS:
!
!	ISOCTAL		If TRUE, then we're looking for an octal constant,
!			if FALSE, then a hexadecimal one.
!
! IMPLICIT INPUTS:
!
!	GSTCSCAN	Look for a character via LEXICA
!
! IMPLICIT OUTPUTS:
!
!	LOOK4CHAR	Trashed, argument to LEXICA
!
! ROUTINE VALUE:
!
!	Returns:
!
!		0-15		Value of the ASCII octal/hex digit that was
!				found.
!
!		-1		Failed to find a digit (or letter if hex)
!				(Invalid character)
!		-2		Found an invalid digit (or letter if hex)
!
! SIDE EFFECTS:
!
!	Parses the source file to find digits.
!
!--


BEGIN
	REGISTER DIG;	! The digit/character read in


	! Read in  a digit  or letter.  Try for  digit first.   If  this
	! fails, and we have a hex constant, then try for a letter.

	LOOK4CHAR = "?D";	! Any digit

	IF (DIG = LEXICAL(.GSTCSCAN)) EQL 0
	THEN
	BEGIN	! Not a digit

		IF .ISOCTAL
%2510%		THEN RETURN -1	! Invalid character for octal constant
%2510%		ELSE
		BEGIN	! Hexadecimal

			LOOK4CHAR = "?L";	! Any letter
						! (A-F is valid)

			IF (DIG = LEXICAL(.GSTCSCAN)) EQL 0
			THEN RETURN -1;		! Didn't find a letter

		END;	! Hexadecimal

	END;	! Not a digit


	! Found digit or letter.  Check if its valid (in range), and  if
	! so convert it from ASCII to decimal.

	IF .ISOCTAL
	THEN
	BEGIN	! Octal constant

		! Only 0-7 are valid octal characters, letters are > digits.

%2510%		IF (.DIG GTR "7")
		THEN
%2510%		BEGIN	! Invalid digit

			FATLEX(UPLIT ASCIZ 'octal digit', .DIG, E0<0,0>);
%2510%			RETURN -2;
%2510%		END;

		DIG = .DIG - "0";	! Convert from ASCII to numeric

	END	! Octal constant
	ELSE
	BEGIN	! Hex constant

		! Check for range.
		! Only 0-9 and A-F (0-15) are valid hex characters.  0-9 is
		! all digits, there are no letters below A, so try for
		! above F.

%2510%		IF .DIG GTR "F"
		THEN
%2510%		BEGIN	! Invalid hex digit

			FATLEX(UPLIT ASCIZ 'hexadecimal digit', .DIG,
				E0<0,0>);
%2510%			RETURN -2;
%2510%		END;

		! Convert from ASCII to numeric.

		IF .DIG GTR "9"
		THEN DIG = (.DIG - "A") + 10	! Digit A-F
		ELSE DIG = .DIG - "0";		! Digit 0-9

	END;	! Hex constant


	RETURN .DIG;	! Return the digit found

END;	! of GETDIGIT

END
ELUDOM