Google
 

Trailing-Edge - PDP-10 Archives - bb-4157h-bm_fortran20_v10_16mt9 - fortran-compiler/sta1.bli
There are 12 other files named sta1.bli in the archive. Click here to see a list.

!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
!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/SJW/DCE/TFV/EDS/CKS/AHM/AlB/TJK/MEM

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

GLOBAL BIND STA1V = #10^24 + 0^18 + #2523;	! Version Date: 11-Mar-85

!	LEXNAM, FIRST, TABLES, META72, ASHELP

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

%(

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

57	-----	-----	FIX COMPLEX CONSTANTS IN DATA STATEMENTS SO THAT
			THE ENTIRE CONSTANT CAN BE SIGNED

58	-----	-----	OPENCLOSE - FIX BUG THAT UNIT = WOULD DESTROY
			THE CODE OF THE LAST PARAMETER .

			AND WHILE WE ARE  THERE FIX UP A FEW PARAMETER
			VALUE LEGALITY CHECKS

59	-----	-----	CHECK FOR ILLEGAL LIST DIRECTED REREAD

60	-----	-----	IN DATAGEN - MUST CHECK THE SIGN OF THE
			REPEAT COUNT ITSELF NOT JUST SIGNFLG
			BECAUSE OF POSSIBLE NEGATIVE PARMETERS

61	-----	-----	FIX ERROR MESSAGE CALL FOR NON-ARRAY OPEN
			STATEMENT PARAMETER VALUES

62	313	16666	FIX DIALOG WITH NO =
63	VER5	-----	HANDLE ERR= IN OPENCLOSE, (SJW)
64	424	QA690	ERROR IF DIRECTORY= NOT LITERAL OR ARRAY
			  NAME IN OPENCLOSE, (SJW)

***** Begin Version 5A *****	7-Nov-76

65	521	QA900	FIX E15 PARAMS TO FATLEX IN OPENCLOSE, (SJW)
66	531	20323	GIVE WARNING FOR PARAMETER USED AS ASSOC VAR ,(DCE)

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

67	760	TFV	1-Jan-80	-----
	Add new OPEN arguments and keyword based I/O (for FORTRAN 77)

68	761	TFV	1-Mar-80	-----
	Add indices for folding /GFLOATING constants

69	1005	TFV	1-Jul-80	------
	Fix OPENCLOSE to handle unit specifiers without the unit=

70	1014	TFV	27-Oct-80	Q10-04556
	Allow list directed rereads, making reread just like ACCEPT, TYPE, etc.

71	1015	TFV	27-Oct-80	Q10-04743
	FMT= is not optional for type, accept ,reread, etc.

72	1016	TFV	27-Oct-80	Q10-04759
	Report names for misspelled OPEN/CLOSE parameters

73	1017	TFV	27-Oct-80	Q10-04733
	Fix IOSTAT processing in OPEN/CLOSE. Param table had wrong
	dispatch value. Also fix test for formal argument used as
	an associate variable.

74	1020	TFV	27-Oct-80	Q10-04575
	Add synonms for PDP-11 FORTRAN compatibility to OPEN/CLOSE.
		INITIALSIZE=	- 	FILESIZE=
		NAME=		-	DIALOG=
		TYPE=		-	STATUS=
	Also fix ERR= processing. Only allow ERR=label.

75	1030	TFV	25-Nov-80	------
	Fix ERR=label in OPENCLOSE to check for labelex not constlex.

76	1032	EDS	1-Dec-80	10-30251
	Fix DATAGEN processing of DATA statements.  SAVSPACE was
	not called to free space used by constant options or
	repeat list.

77	1042	TFV	15-Jan-81	-------
	Prohibit list directed encode/decode.

78	1045	TFV	20-Jan-81	-------
	Fix edit 1030.  NONIOINIO and LOOK4LABEL have to be reset.

79	1071	CKS	22-May-81
        Remove TAPEMODE from OPEN keyword plit

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

84	1124	AHM	21-Sep-81	Q20-01651
	Set STORD for IOSTAT variables and ASSOCIATEVARIABLES so they get
	put back in subprogram epilogues.

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

80	1202	DCE	1-Jul-80	-----
	Change calls to DATALIST to be calls to LISTIO for expressions
	on output lists.

82	1233	CKS	28-Jun-81
	Alter some .s and @s in BLDIO1 and BLDEDCODE to conform to new STK
%!	produced by using %OPTCOMMA% instead of [ COMMA ] in the BNF.
%	See comments in STA0.

83	1245	TFV	3-Aug-81	------
	Fix OPENCLOSE to convert character constant args to HOLLERITH
	until FOROTS knows how to cope with character data.

85	1267	AHM	6-Oct-81	------
	Define a stub routine INQUSTA for the INQUIRE statement so we don't
	get undefined symbols when linking.

86      1410	CKS	28-Oct-81
	Modify DATASTA to read the modified tree shape caused by the optional
	comma in DATA A/1/,B/1/.

1527	CKS	27-Apr-82
	Rewrite OPENCLOSE to allow expressions as open specifiers

1546	CKS	31-May-82
	Move PRINSTA, RERESTA, TYPESTA to STA0 for uniformity.

1571	CKS	27-Jun-82
	Don't set parent pointer under OPEN if expression is omitted.
	(DIALOG, READONLY.)

1622	CKS	25-Aug-82
	Correctly handle ASSOCIATEVARIABLE=arrayref and IOSTAT=arrayref.
	Don't blindly call NAMSET on the "variable" if it's an array ref.

1662	TFV	2-Nov-82
	Fix INQUSTA to give the  error Exxx (NYI) 'INQUIRE statement  is
	not yet implemented.'

1676	CKS	18-Nov-82
	Allow hollerith constants as open specifiers.

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

1716	TFV	17-Jan-83	Q20-06103
	Fix OPENCLOSE.  FLGREG is trashed if UNIT is not specified.

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

2043	TJK	24-Feb-84
	Have OPEN and CLOSE recognize  the LIMIT= keyword once  again.
	This keyword takes an integer expression.  Entries were  added
	to the tables OPNKWD and IOCKVEC in OPENCLOSE, and KEYWFLAG in
	CFCHECK.  LIMIT= is illegal for INQUIRE and is flagged as both
	an ANSI and a  VAX incompatibility.  Note  that this edit  was
	somewhat different for V7A and  V10.  Among other things,  V7A
	didn't have to change TABLES but V10 did.


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

2200	TFV	17-Mar-83
	Implement  INQUIRE.   Merge  it  with  OPENCLOSE.   All  INQUIRE
	keyword values are modified by  the statement except ERR,  FILE,
	and UNIT.   Only IOSTAT  and ASSOCIATEVARIABLE  are modified  by
	OPEN and  CLOSE.  Give  a  warning for  probable user  error  of
	character constant where numeric  expression is required.   I.e.
	RECL='40' is treated as RECL=28118614016.

2247	AlB	22-Dec-83
	Add Compatibility Flagging for BACKFILE statement.
	Routine:
		BKSPST

2252	AlB	27-Dec-83
	Change edit 2247 to use ISN instead of LEXLINE for line number.
	Add compatibility flagging for FIND statement.
	Routines:
		BKSPST, FINDSTA

2274	AlB	24-Jan-84
	Added compatibility flagging for OPEN/CLOSE keywords.
	Added CFCHECK and CFSEARCH routines.
	CARRIAGECONTROL keyword now accepted by the INQUIRE statement.
	Routines:
		CFCHECK	CFSEARCH OPENCLOSE

2316	AlB	27-Feb-84
	Changes made in order that this module more nearly conform
	to programming conventions.  The only change in functionality
	is to CFCHECK, which no longer returns a value.

2370	MEM	5-Jun-84
	Changes were made so that specifiers more than 6 characters could be
	recognized past the sixth character in open/close statements. The
	contents of the five tables OPNKWD, IOCKVAL, INQUVAL, IOCKCODE and
	KEYWFLAG are combined and stored in the macro THEKEYS. Previously,
	IOCKVAL, INQUVAL and IOCKCODE had been stored in one table called
	IOCKEYVEC.

2413	MEM	5-Jul-84
	Add the keyword TAPEFORMAT.

2424	MEM	10-Jul-84
	Add the keyword DIALOGUE and correct the error message for putting a
	READONLY keyword in an inquire statement. Previously it gave
	'Found ")" when expecting keyword', and now it gives 'Unrecognized
	keyword READONLY'. Error messages E300 and E182 were corrected also.

2426	MEM	16-Jul-84
	Don't allow a specifier to occur multiple times with different
	spellings in the same open/close/inquire statement. Fix broken
	DIALOG by placing DIALOG(without =) at end of table.

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

2461	CDM	28-Sep-84
	Add octal and  hexadecimal constants for  the Military  Standard
	MIL-STD-1753 to DATA statements.

2467	RVM	17-Oct-84
	Add the OPEN/CLOSE keyword DISP= (a VAX synonym for DISPOSE=).

2476	MEM	7-Nov-84
	Fix index number into THEKEYS for DIALOGUE and READONLY so 
	compatability message has full specifier in it instead of the
	abbreviated 6 character specifier.
	
2477	AlB	15-Nov-84
	Use the global flagger prefixes in CFCHECK.

2503	MEM	27-Nov-84
	Fix index number into THEKEYS for ASSOCIATEVARIABLE, CARRAIGECONTROL,
	and DISPOSE.

2511	MEM	7-Jan-85
	Fixed a couple of error messages in OPENCLOSE which were passing an 
	ascii argument when a sixbit argument was expected. Changed an entry
	in THEKEYS to make RECORDTYPE legal in an inquire statement.

2523	MEM	11-Mar-85
	Separate open and close keyword specifiers.

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

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

)%

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

FORWARD
% 63%	BKSPST,		!BACKSPACE OR BACKFILE 
% 39%	REWISTA,	!REWIND 
% 84%	ENDFSTA,	!ENDFILE 
% 34%	FINDSTA,	!FIND 
	CMPLXCONGEN(2),
	SIGNEDREAL(1),
	DATAGEN(1),
%  3%	DATASTA,	!DATA 
	STRNGSCAN,
%2370%	COMPARE,        ! comparison used in routine SEARCH
%2370%	SEARCH,         ! search for open/close/inquire keyword
	OPENCLOSE(1),
%2316%	CFSEARCH(2),	!Search a table for Compatibility Flagger
%2316%	CFCHECK(4),	!Compatibility Flagger for OPEN/CLOSE/INQUIRE
% 18%	OPENSTA,	!OPEN 
% 83%	CLOSSTA,	!CLOSE 
%???%	INQUSTA;	![1267] INQUIRE

EXTERNAL
%2477%	ANSIPLIT,	! 'Extension to Fortran-77: '
	BLDREPT,
	BLDUTILITY,
	BLDVAR,
%2477%	BOTHPLIT,	! 'Fortran-77 and VMS: '
	C1H,
	C1L,
	C2H,
	C2L,
%2252%	CFLAGB,		! Put out flagger warning
	CNSTCM,
	CNVNODE,
	COPRIX,
	CORMAN,
	DATALIST,
	DATASUBCHK,
	E164,
	E182,
	E183,
	E196,
	E212,	! CHARACTER constant used where numeric expression required.
	E213,	! INQUIRE - neither UNIT nor FILE keywords were specified
	E214,	! INQUIRE - both UNIT and FILE keywords were specified
	E215,	! HOLLERITH constant used where numeric expression required.
%2455%	E226,	! VMS incompatibility: Different default file name
%2252%	E239,	! Extension to Fortran-77: FIND statement
%2455%	E247,	! Fortran-77 or VMS: Keyword xxxxx
%2455%	E248,	! Fortran-77 or VMS: Keyword value for xxxxx
%2247%	E268,	! Extension to Fortran-77: xxxxx statement
%2455%	E275,	! VMS incompatibility: ASSOCIATEVARIBLE not set by VMS on OPEN
%2370%  E299,   ! replaced E184	
%2424%	E300,	! replaced E15
%2511%	E305,	! same as E196 but has ascii, instead of sixbit, argument
	EXPRESS,
	GSTCSCAN,
	GSTKSCAN,
	GSTSSCAN,
	KDNEGB,
	KDPRL,
%2370%	KEYBUFFER,	! 4 word buffer containing keyword found in LEXICA
%2370%   KEYLENGTH,	! number of characters in KEYBUFFER
	KGFRL,
	KTYPCB,
	KTYPCG,
	LABELS,
	LEXEMEGEN,
	LEXICAL,
	LEXL,
	LOOK4CHAR,
	NAME,
	NAMREF,
	NAMSET,
	NEWENTRY,
	NOLABELS,
	NONIOINIO,
	SAVSPACE,
	STK,
	SP,
	TYPE,
%2477%	VMSPLIT;	!' VMS incompatibility: '
 !MEM
! THEKEYS is a macro which contains the contents of the tables OPNKWD,
! IOCKVAL, OPNCKVAL, IOCKCODE, and KEYWFLAG. These five tables are each 
! expanded separately.  Since all five of these tables must match,
! combining them together simplifies the task of adding to these tables
! at a later date. The tables OPNKWD, IOCKVAL, OPNCKVAL and IOCKCODE are
! used in routine OPENCLOSE and KEYWFLAG is used in routine CFCHECK.

BIND
	IL = 0,			! illegal keyword for statement
	CE = 1,			! character expression, numeric scalar,
				! or numeric arrayref
	IE = 2,			! integer expression
	AR = 3,			! array name or char expression
	LB = 4,			! label
	CV = 5,			! character variable or array ref
	IV = 6,			! integer variable or array ref
	LV = 7;			! logical variable or array ref



MACRO
	CFANSI	= 0$,	! Keyword is not recognized by Fortran-77
	CFVMS 	= 1$,	! Keyword is not recognized by VMS
	CFVANSI = 2$,	! Keyword is recognized by ANSI, but extra
			!	tests must be done
	CFVVMS	= 3$,	! Keyword is recognized by VMS, but extra
			!	tests must be done


	![2370] created macro THEKEYS which has 5 fields
	![2523] separated open/close into 2 fields
	! field 1 = keyword names for open/close/inquire statements
	! field 2 = inquire value types
	! field 3 = close value types
	! field 4 = open value types
	! field 5 = FOROTS keyword numbers
	! field 6 = flags which determine whether any given keyword is to be
	! 	    flagged as an extension to Fortran-77, an incompatibility 
	! 	    with VMS, or both. 

	THEKEYS(XX) =
		XX(NACCESS INDEXES PLIT ASCIZ 'ACCESS',			! 1
%2455%			CV, CE, CE, OPNCACCESS,  1^CFVANSI+1^CFVVMS),
%2503%		XX(PLIT ASCIZ 'ASSOCI',					! 2
%2455%			IL, IV, IV, OPNCASSOCIATE,1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'ASSOCIATE',
%2455%			IL, IV, IV, OPNCASSOCIATE,1^CFANSI+1^CFVMS),
%2503%		XX(NASSOC INDEXES PLIT ASCIZ 'ASSOCIATEVARIABLE',
%2455%			IL, IV, IV, OPNCASSOCIATE,1^CFANSI+1^CFVVMS),
		XX(PLIT ASCIZ 'BLANK',					! 3
			CV, CE, CE, OPNCBLANK,   0),
		XX(PLIT ASCIZ 'BLOCKS',					! 4
			IL, CE, IE, OPNCBLOCKSIZE,1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'BLOCKSIZE',
			IL, IE, IE, OPNCBLOCKSIZE,1^CFANSI),
		XX(PLIT ASCIZ 'BUFFER',					! 5
			IL, IE, IE, OPNCBUFCOUNT,1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'BUFFERCOUNT',
			IL, IE, IE, OPNCBUFCOUNT,1^CFANSI),
%2503%		XX(PLIT ASCIZ 'CARRIA',					! 6
%2455%			CV, CE, CE, OPNCCARRIAGE,1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'CARRIAGE',
%2455%			CV, CE, CE, OPNCCARRIAGE,1^CFANSI+1^CFVMS),
%2503%		XX(NCARR INDEXES PLIT ASCIZ 'CARRIAGECONTROL',
%2455%			CV, CE, CE, OPNCCARRIAGE,1^CFANSI+1^CFVVMS),
		XX(PLIT ASCIZ 'DENSIT',					! 7
%2455%			IL, CE, CE, OPNCDENSITY, 1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'DENSITY',
%2455%			IL, CE, CE, OPNCDENSITY, 1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'DEVICE',					! 8
%2455%			IL, CE, CE, OPNCDEVICE,  1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'DIALOG',					! 9
%2455%			IL, AR, AR, OPNCDIALOG,  1^CFANSI+1^CFVMS),
%2424%		XX(PLIT ASCIZ 'DIALOGUE',
%2455%			IL, AR, AR, OPNCDIALOG,  1^CFANSI+1^CFVMS),
		XX(NDIRECT INDEXES PLIT ASCIZ 'DIRECT',			! 10
%2455%			CV, AR, AR, OPNCDIRECT,  1^CFVANSI+1^CFVVMS),
		XX(PLIT ASCIZ 'DIRECTORY',
%2455%			CV, AR, AR, OPNCDIRECT,  1^CFANSI+1^CFVMS),
%2503%		XX(PLIT ASCIZ 'DISP',					! 11
%2467%			IL, CE, CE, OPNCDISPOSE, 1^CFANSI+1^CFVVMS),
		XX(PLIT ASCIZ 'DISPOS',
%2455%			IL, CE, CE, OPNCDISPOSE, 1^CFANSI+1^CFVMS),
%2503%		XX(NDISPOS INDEXES PLIT ASCIZ 'DISPOSE',
%2455%			IL, CE, CE, OPNCDISPOSE, 1^CFANSI+1^CFVVMS),
		XX(NERR INDEXES PLIT ASCIZ 'ERR',			! 12
			LB, LB, LB, OPNCERREQ,   0),
		XX(PLIT ASCIZ 'EXIST',					! 13
			LV, IL, IL, IOCEXIST,    0),
		XX(NFILE INDEXES PLIT ASCIZ 'FILE',			! 14
			CE, CE, CE, OPNCFILE,    1^CFVANSI),
		XX(PLIT ASCIZ 'FILESI',
%2455%			IL, IE, IE, OPNCFILESIZE,1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'FILESIZE',
%2455%			IL, IE, IE, OPNCFILESIZE,1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'FORM',					! 15
			CV, CE, CE, OPNCFORM,    0),
		XX(PLIT ASCIZ 'FORMAT',
			CV, IL, IL, IOCFORMATTED,1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'FORMATTED',
			CV, IL, IL, IOCFORMATTED,0),
		XX(PLIT ASCIZ 'INITIA',					! 16
%2455%			IL, IE, IE, OPNCFILESIZE,1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'INITIAL',
%2455%			IL, IE, IE, OPNCFILESIZE,1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'INITIALIZE',
%2455%			IL, IE, IE, OPNCFILESIZE,1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'INITIALSIZE',
%2455%			IL, IE, IE, OPNCFILESIZE,1^CFANSI),
		XX(NIOSTAT INDEXES PLIT ASCIZ 'IOSTAT',			! 17
			IV, IV, IV, OPNCIOSTAT,  0),
		XX(PLIT ASCIZ 'LIMIT',					! 18
%2455%			IL, IE, IE, OPNCLIMIT,   1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'MODE',					! 19
%2455%			IL, CE, CE, OPNCMODE,    1^CFANSI+1^CFVMS),
		XX(NNAME INDEXES PLIT ASCIZ 'NAME',			! 20
			CV, AR, AR, IOCNAME,     1^CFVANSI),
		XX(PLIT ASCIZ 'NAMED',
			LV, IL, IL, IOCNAMED,    0),
		XX(PLIT ASCIZ 'NEXTRE',					! 21
			IV, IL, IL, IOCNEXTREC,  1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'NEXTREC',
			IV, IL, IL, IOCNEXTREC,  0),
		XX(PLIT ASCIZ 'NUMBER',					! 22
			IV, IL, IL, IOCNUMBER,   0),
		XX(PLIT ASCIZ 'OPENED',					! 23
			LV, IL, IL, IOCOPENED,   0), 
		XX(PLIT ASCIZ 'PADCHA',					! 24
%2455%			IL, CE, CE, OPNCPADCHAR, 1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'PADCHAR',
%2455%			IL, CE, CE, OPNCPADCHAR, 1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'PARITY',					! 25
%2455%			IL, CE, CE, OPNCPARITY,  1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'PROTEC',					! 26
%2455%			IL, IE, IE, OPNCPROTECTION,1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'PROTECTION',
%2455%			IL, IE, IE, OPNCPROTECTION,1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'RECL',					! 27
			IV, IE, IE, OPNCRECORDSIZE,0),
		XX(PLIT ASCIZ 'RECORD',
			IL, IE, IE, OPNCRECORDSIZE,1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'RECORDSIZE',
			IL, IE, IE, OPNCRECORDSIZE,1^CFANSI),
		XX(PLIT ASCIZ 'RECORDTYPE',				! 28
%2511%			CE, CE, CE, OPNCRECTYPE, 1^CFANSI),
		XX(PLIT ASCIZ 'RECTYP',
%2511%			CE, CE, CE, OPNCRECTYPE, 1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'RECTYPE',
%2511%			CE, CE, CE, OPNCRECTYPE, 1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'SEQUEN',					! 29
			CV, IL, IL, IOCSEQUENTIAL,1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'SEQUENTIAL',			
			CV, IL, IL, IOCSEQUENTIAL,0),
		XX(NSTATUS INDEXES PLIT ASCIZ 'STATUS',			! 30
%2455%			IL, CE, CE, OPNCSTATUS,   1^CFVANSI+1^CFVVMS),
%2413%		XX(PLIT	ASCIZ 'TAPEFO',					! 31
%2413%			IL, IL, AR,OPNCTAPEFO,1^CFANSI+1^CFVMS),
%2413%		XX(PLIT	ASCIZ 'TAPEFORMAT',
%2413%			IL, IL, AR,OPNCTAPEFO,1^CFANSI+1^CFVMS),
		XX(NTYPE INDEXES PLIT ASCIZ 'TYPE',			! 32
%2455%			IL, CE, CE, OPNCSTATUS,   1^CFANSI+1^CFVVMS),
		XX(PLIT ASCIZ 'UNFORM',					! 33
			CV, IL, IL, IOCUNFORMATTED,1^CFANSI+1^CFVMS),
		XX(PLIT ASCIZ 'UNFORMATTED',
			CV, IL, IL, IOCUNFORMATTED,0),
		XX(NUNIT INDEXES PLIT ASCIZ 'UNIT',			! 34
			IE, IE, IE, OPNCUNIT,    0),
		XX(PLIT ASCIZ 'VERSIO',					! 35
%2455%			IL, IE, IE, OPNCVERSION, 1^CFANSI+1^CFVMS),
		XX(KWDN INDEXES PLIT ASCIZ 'VERSION',
%2455%			IL, IE, IE, OPNCVERSION, 1^CFANSI+1^CFVMS),


%2426%  ! start of table entries without =

%2426%		XX(NDIALOG INDEXES PLIT ASCIZ 'DIALOG',			! 36
%2455%			IL, 0, 0, OPNCNEDIALOG,  1^CFANSI+1^CFVMS),
%2426%		XX(PLIT ASCIZ 'DIALOGUE',				
%2455%			IL, 0, 0, OPNCNEDIALOG,  1^CFANSI+1^CFVMS),
%2426%		XX(NREADO INDEXES PLIT ASCIZ 'READON',			! 37
%2426%			IL, IL, 0, OPNCREADONLY,1^CFANSI+1^CFVMS),
%2426%		XX(PLIT ASCIZ 'READONLY',				
%2476%			IL, IL, 0, OPNCREADONLY,1^CFANSI)

	$;

! table of keyword names for open/close/inquire statements

	MACRO XX1(A,B,C,D,E,F) = A $;
BIND	OPNKWD = PLIT(THEKEYS(XX1));

! table of inquire value types
	
 	MACRO XX2(A,B,C,D,E,F) = B $;
BIND	INQUKVAL = PLIT(THEKEYS(XX2));

! table of close value types

 	MACRO XX3(A,B,C,D,E,F) = C $;
BIND	CLOSKVAL = PLIT(THEKEYS(XX3));

! table of open value types

 	MACRO XX4(A,B,C,D,E,F) = D $;
BIND	OPNKVAL = PLIT(THEKEYS(XX4));

! table of FOROTS keyword numbers

        MACRO XX5(A,B,C,D,E,F) = E $;
BIND	IOCKCODE = PLIT(THEKEYS(XX5));

! table of flags which determine whether any given keyword is to be
! flagged as an extension to Fortran-77, an incompatibility with VMS,
! or both. 

        MACRO XX6(A,B,C,D,E,F) = F $;
BIND	KEYWFLAG = PLIT(THEKEYS(XX6));
GLOBAL ROUTINE BKSPST=
BEGIN
	REGISTER R;
	BIND DUM = PLIT( SP NAMES 'SPACE?0', FIL NAMES 'FILE?0'  );

	R _ BACKDATA;
	LOOK4CHAR _ SP<36,7>;
	DECR I FROM 1 TO 0
	DO
	BEGIN
		IF LEXICAL(.GSTSSCAN)  NEQ 0
		THEN
		BEGIN	% GOT ONE %
%2247%			IF FLAGEITHER		!Compatibility check
%2247%			THEN
%2247%				IF .R EQL BKFILDATA
%2252%				THEN CFLAGB((PLIT 'BACKFILE?0')<0,0>,E268);

			IF SYNTAX(UTILSPEC)  LSS   0  THEN RETURN .VREG;
			RETURN  BLDUTILITY(.R)
		END;
		R _ BKFILDATA;	! TRY FILE
		LOOK4CHAR _ FIL<36,7>
	END;
	RETURN FATLEX(E12<0,0>);	!MISSPELLED
END;	! of BKSPST

GLOBAL ROUTINE REWISTA=
%1677%	BLDUTILITY(REWIDATA);

GLOBAL ROUTINE ENDFSTA=
%1677%	BLDUTILITY(ENDFDATA);

GLOBAL ROUTINE FINDSTA=
%2252%	BEGIN
%2252%	IF FLAGANSI THEN WARNERR(.ISN,E239<0,0>); !Compatibility flagger
%1677%	BLDUTILITY(FINDDATA)
%2252%	END;
ROUTINE CMPLXCONGEN(PTR,SIGNN)=
BEGIN
	!BUILDS A COMPLEX CONSTANT NODE FROM DATA LIST

	REGISTER
		SIGNFLG,
		BASE T1,
		BASE T2;
	LOCAL
		BASE REALPT,
		BASE IMAGPT;

	! PROCESS REAL PART
	T1 _ .PTR;
	SIGNFLG _ .SIGNN;
	IF .T1[ELMNT] NEQ 0 !IS IT SIGNED?
	THEN 
	BEGIN
		IF .T1[ELMNT] EQL 2 THEN SIGNFLG _ -1  -.SIGNN;
		T1_.T1+1;
	END;
	REALPT_SIGNEDREAL(.T1[ELMNT1],.SIGNFLG);

	! PROCESS IMAGINARY PART
	SIGNFLG _ .SIGNN;
	T1_.T1+2; !SKIP TO IMAG PART
	IF .T1[ELMNT] NEQ 0
	THEN
	BEGIN
		IF .T1[ELMNT] EQL 2 THEN SIGNFLG_ -1 -.SIGNN;
		T1_.T1+1;
	END;
	IMAGPT _ SIGNEDREAL(.T1[ELMNT1],.SIGNFLG);

	! NOW MAKE ACOMPLEX CONSTANT NODE
	RETURN MAKECNST(COMPLEX,.REALPT,.IMAGPT);
END;	! of CMPLXCONGEN
ROUTINE SIGNEDREAL(CONST,SIGNFLG)=
BEGIN
	!***************************************************************
	! GIVEN A  PTR  TO  A  CONSTANT TABLE  ENTRY  FOR  THE  REAL  OR
	! IMAGINARY PART OF A COMPLEX CONST, (WHERE THAT PART MAY ITSELF
	! BE ANY TYPE) RETURN  THE SINGLE-WD REAL VALUE  TO BE USED  FOR
	! THAT PART OF THE CONSTANT.  THE REGISTER-VARIABLE "SIGNFLG" IS
	! ASSUMED TO  BE "TRUE"  IF THE  CONSTANT INDICATED  BY  "CONST"
	! SHOULD BE NEGATED.
	! 	SIGNN - IS THE SIGN OF THE TOTAL CONSTANT
	!***************************************************************

	MAP PEXPRNODE CONST;
	C1H_.CONST[CONST1];	!HI ORDER PART
	C1L_.CONST[CONST2];	!LOW ORDER PART

	%(***IF CONST IS NOT REAL, CONVERT IT TO REAL. THE CONSTANT FOLDING
		ROUTINE TAKES ITS ARG IN THE GLOBALS C1H,C1L***)%
	IF .CONST[VALTYPE] NEQ REAL
	THEN
	BEGIN
		COPRIX_KKTPCNVIX(REAL2,.CONST[VALTP2]);	!INDEX INTO CONSTNT FOLDER
							! FOR THE TYPE-CONV DESIRED
		CNSTCM();	!CONVERT THE CONST IN C1H,C1L
				! LEAVING RESULT IN C2H,C2L;
		C1H_.C2H;
		C1L_.C2L
	END;

	%(***ROUND THE 2 WD REAL TO A SINGLE-WD REAL***)%
	IF .CONST[VALTYPE] NEQ DOUBLOCT
	THEN
	BEGIN	!DONT ROUND DOUBLE-OCTAL
![761] Convert DP to Sp based on /GFLOATING
%[761]%			IF .GFLOAT		!INDEX INTO THE CONST FOLDER FOR ROUNDING
%[761]%				THEN COPRIX_KGFRL	! DOUBLE-WD REAL TO SINGLE-WD REAL
%[761]%				ELSE COPRIX_KDPRL;

		CNSTCM();	!ROUND THE DOUBLE-WD REAL IN C1H-C1L, LEAVING
				! RESULT IN C2H

		C1H_ .C2H
	END;

	%(***IF THE VALUE SHOULD BE NEGATED, DO SO***)%
	IF .SIGNFLG
	THEN RETURN -.C1H
	ELSE RETURN .C1H
END;	! of SIGNEDREAL
GLOBAL ROUTINE DATAGEN(CONLIST)=
!++
! FUNCTIONAL DESCRIPTION:
!
!	Routine builds  a list  of DATA  constants and  keeps count  for
!	later use by the DATA list processing routines.
!
! FORMAL PARAMETERS:
!
!	CONLIST		List of the constants read in by the BNF
!
! IMPLICIT INPUTS:
!
!	Unknown
!
! IMPLICIT OUTPUTS:
!
!	Unknown
!
! ROUTINE VALUE:
!
!	Returns a linked list of DATA constants.
!
! SIDE EFFECTS:
!
!	Unknown
!
!--


BEGIN

MACRO ERR54 = ( FATLEX(E54<0,0>))$;

MACRO DNEG(X,Y)=		! Double precision negate
BEGIN
	C1H _ X[CONST1];	!HIGH ORDER
	C1l _ X[CONST2];	!LOW ORDER
	COPRIX _ KDNEGB;
	CNSTCM();	!CONVERT TO NEG
	MAKECNST(Y,.C2H,.C2L)
END$;

LOCAL	BASE CONNODE,	! Data constant node
	BASE CONPTR,	! Pointer to the list of constants returned
	COUNT,		! Number of words
	DATCSIZ,	! Size for this constant (w/o repeat)
	REPEAT,		! Repeat count (if any)
	SIGNFLG;	! Set if negative sign was read

LABEL	DAT1;

REGISTER
	BASE T1,
	BASE T2;

MAP	BASE CONLIST;


	CONPTR _ 0;
	COUNT _ 0;

	INCR CONITEM FROM .CONLIST TO .CONLIST+.CONLIST<LEFT> BY 2
	DO
	BEGIN	! Each constant

		MAP BASE CONITEM;

		REPEAT _ 1;	!INITIALIZE
		SIGNFLG _ 0;

		! See if constant is:
		!
		! 	1	Octal/Hexadecimal
		!	2	Literal
		!	3	[+/-] Number


%2461%		! If the constant is octal or hex, then the  information
%2461%		! was put on the stack by an action routine.  The parser
%2461%		! insists on putting the  position of the production  in
%2461%		! the  grammar  AFTER  anything  put  on  STK,  so   the
%2461%		! information is in a different order for this case.
%2461%		
%2461%		IF .CONITEM[ELMNT1] EQL 1
%2461%		THEN
%2461%		BEGIN	! Octal/hex constant
%2461%
%2461%			! Pointer to constant
%2461%			T2 = .CONITEM[ELMNT]<RIGHT>;
%2461%
%2461%			! Count of number of words it uses
%2461%			COUNT = .COUNT + (IF .T2[VALTYPE] EQL OCTAL
%2461%					  THEN 1	! Single word
%2461%					  ELSE 2);	! Double word
%2461%
%2461%		END	! Octal/hex constant
%2461%	 	ELSE IF .CONITEM[ELMNT] EQL 2
%2461%	        THEN
		BEGIN	! Literal

			T2 _ .CONITEM[ELMNT1]; !PTR TO LITERAL STRING NODE
			COUNT _ .COUNT + .T2[LITSIZ];

		END	! Literal
%2461%	        ELSE
	DAT1:	BEGIN	! Number, CONITEM[ELMNT] = 3 

			! Ptr to 2 or 3 word set CONST [* CONST]
			T1 _ .CONITEM[ELMNT1];
			IF .T1[ELMNT] NEQ 0
			THEN
			BEGIN	! Signed constant
				IF .T1[ELMNT] EQL 2	! Minus
				THEN SIGNFLG_-1 ELSE SIGNFLG_0;
				T1 _ .T1+1;		! To get past the sign
			END	! Signed constant
			ELSE SIGNFLG _ 0;

			! Now decide  whether  we  have  a  constant  or
			! complex constant

			IF .T1[ELMNT1]  EQL  2
			THEN
			BEGIN	! Complex constant
				T2 _ CMPLXCONGEN( .T1[ELMNT2] , .SIGNFLG );
				COUNT _ .COUNT + 2;
				SIGNFLG _ 0;	!COMPLEX SIGNS ARE DONE
			END	! Complex constant
			ELSE
			BEGIN	! Number

				T1 _ .T1[ELMNT2];	!POINTER TO CONSTANT-OPTION
				T2 _ .T1[ELMNT]; !PTR TO FIRST CONSTANT OR REPEAT COUNT
				IF .T1[ELMNT1] NEQ 0
				THEN
				BEGIN	! Repeat count exists

					! Check for errors.  Non-integer
					! or negative repeat counts  are
					! not allowed.

					IF .T2[VALTYPE] NEQ INTEGER
					THEN (ERR54; REPEAT _ 0; LEAVE DAT1);

					%DO THIS IN CASE OF NEGATIVE PARAMETER VALUES%
					IF .SIGNFLG  NEQ  0
					THEN T2 _ MAKECNST(INTEGER,0,-.T2[CONST2]);
					IF .T2[CONST2] LSS 0
					THEN (ERR54; REPEAT _ 0; LEAVE DAT1);

					REPEAT _ .T2[CONST2];	!REPEAT VALUE
%[1032]%				T2 _ .T1;		!SAVE PTR
					T1 _ .T1[ELMNT2];	!PTR TO REPEATED CONST OR LITERAL
%[1032]%				SAVSPACE(.T2<LEFT>,.T2);
					T2 _ .T1[ELMNT2]; !PTR TO ACTUAL CONSTANT OR LITSTRING NODE

					! A  repeat   count   has   been
					! processed, now do the constant
					! to repeat.

					! Have:
					!	1 octhex constant
					!	2 literal constant
					!	3 [+/-] number

%2461%					IF .T1[ELMNT2] EQL 1
%2461%					THEN
%2461%					BEGIN	! Octal/hex
%2461%	
%2461%						T2 _ .T1[ELMNT1];  ! Const
%2461%						IF .T2[OPERSP]EQL OCTAL
%2461%						THEN DATCSIZ = 1   ! 1 word
%2461%						ELSE DATCSIZ = 2;  ! 2 words
%2461%	
%2461%					END	! Octal/hex
%2461%					ELSE IF .T1[ELMNT1] EQL 2
%2461%					THEN
%2461%					BEGIN	! Literal

						DATCSIZ _ .T2[LITSIZ]

%2461%					END	! Literal
%2461%					ELSE IF .T1[ELMNT1] EQL 3
					THEN
					BEGIN	! Number

						IF .T2[ELMNT] NEQ 0
						THEN
						BEGIN	! Signed number
							IF .T2[ELMNT] EQL 2
							THEN SIGNFLG_-1
							ELSE SIGNFLG_0;
							T2 _ .T2+1
						END	! Signed number
						ELSE SIGNFLG _ 0;

						%NOW WHAT KIND OF CONSTANT DO WE HAVE%
						IF .T2[ELMNT1]  EQL  2
						THEN
						BEGIN	%COMPLEX%
							T2_ CMPLXCONGEN( .T2[ELMNT2] , .SIGNFLG );
							COUNT _ .COUNT+2;
							SIGNFLG _ 0
						END
						ELSE
						BEGIN	%REAL OR INTEGER OR DOUBLE%
							T2 _ .T2[ELMNT2];	!CONSTANT LEXEME
							DATCSIZ _ IF .T2[DBLFLG]
								THEN 2
								ELSE 1
						END
					END;	! Number
				END	! Repeat count exists
				ELSE
				BEGIN	! No repeat
					DATCSIZ _ IF .T2[DBLFLG] THEN 2 ELSE 1;
%[1032]%				SAVSPACE(.T1<LEFT>,.T1);
				END;	! No repeat
				COUNT _ .COUNT + .DATCSIZ  * .REPEAT;

				IF .SIGNFLG NEQ 0  !NEGATE THE NUMBER
				THEN IF .T2[VALTP1] EQL INTEG1
				THEN T2 _ MAKECNST(INTEGER,0,-.T2[CONST2])
				ELSE T2 _ DNEG(.T2,.T2[VALTYPE]);

%[1032]%		END;	! Number
%[1032]%
%[1032]%		T1 _ .CONITEM[ELMNT1];
%[1032]%		SAVSPACE(.T1<LEFT>,.T1);
		END;	!Number

		! Build and link a data constant node
		NAME<LEFT> _ 2;
		CONNODE _ CORMAN();

		IF .CONPTR EQL 0
		THEN (CONPTR<LEFT> _ CONPTR<RIGHT> _ .CONNODE)
		ELSE
		BEGIN
			CONPTR[CLINK] _ .CONNODE;
			CONPTR<RIGHT> _.CONNODE;
		END;

		CONPTR[DATARPT] _ .REPEAT;
		CONPTR[DCONST] _ .T2;

	END;	! Each constant

	RETURN .COUNT^18+ .CONPTR<LEFT>;

END;	! of DATAGEN
GLOBAL ROUTINE DATASTA=
!++
! Processing for DATA statements
!--
BEGIN
	REGISTER BASE T1;
	REGISTER BASE R1:R2;
	LOCAL ITEMLIST,CONLIST;


	!SEMANTIC ANALYSIS BEGINS
	T1_@.STK[0];	!T1_LOC(DATASPEC OR LIST A,LINEND)

%1410%	! The optional comma preceding the first DATALIST is not allowed.  It
%1410%	! is too hard to prevent it in the BNF syntax, so check here.
%1410%	R1 _ .T1[ELMNT];	! point to first DATALIST
%1410%	IF .R1[ELMNT] NEQ 0	! check for comma preceding it
%1410%	THEN FATLEX(.LEXNAM[IDENTIFIER],.LEXNAM[COMMA],E0<0,0>);
%1410%				! "Found comma when expecting identifier"

	INCR DAT FROM .T1 TO .T1+.T1<LEFT> DO
	BEGIN !PROCESS LIST OF DATA SPECIFICATIONS

		MAP BASE DAT;
		R1 _ .DAT[ELMNT]; !PTR TO 3 ITEM LIST - 1.OPTIONAL COMMA [1410]
				   !			2.DATALIST PTR
				   !			3.CONLIST PTR
%1410%		T1 _ .R1[ELMNT2]; !PROCESS CONLIST PTR FIRST FO COUNT NUMBER OF CONSTANTS
		!T1 POINTS TO 3 WORD LIST (SLASH,CONLISTPTR,SLASH)
		R2 _ .T1[ELMNT1]; !GET PTR TO LIST OF CONSTANT SPECS
		SAVSPACE (.T1<LEFT>,.T1); !GET BACK SPACE
		CONLIST _ DATAGEN(.R2);
		SAVSPACE(.R2<LEFT>,.R2);
	!
	!NOW PROCESS LIST OF DATA ITEM SPECIFICATIONS
	!USE THE SAME ROUTINE AS USED BY IO LISTS AND RETURN PTR
	!TO SAME KIND OF LIST STRUCTURE AS IO LISTS
	!
		TYPE _ DATALST; !SIGNAL DATA STATEMENT TO DATALIST ROUTINE
		SP _ 0; !RESET FOR USE IN DATALIST
%1410%		ITEMLIST _ DATALIST(.R1[ELMNT1]); !USEING FIRST ITEM POINTED TO BY R1
		DATASUBCHK(.ITEMLIST<LEFT>,0,0);	!CHECK SUBSCRIPTS ON LIST ITEMS FOR VALIDITY
		SAVSPACE(.R1<LEFT>,.R1); !RETRIEVE SOME SPACE
		!
		!NOW BUILD A DATA STATEMENT NODE AND LINK TO ANY PREVIOUS ONES
		!
		NAME _ DATATAB; !ID OF DATA TABLE FOR NEWENTRY
		R2 _ NEWENTRY();
		!FILL IN PTRS TO LISTS IN DATA NODE
		!
		R2[DATITEMS] _ .ITEMLIST<LEFT>;  R2[DATCONS] _ .CONLIST;
		R2[DATCOUNT] _ .CONLIST<LEFT>; !NUMBER OF CONSTANTS SPECIFIED
		R2[DATISN]_.ISN;	!STMNT NUMBER (NEEDED FOR ERROR MESSAGES
					! IN ALLOCATION ROUTINE)
	END; !OF INCR LOOP
	T1 _ @.STK[0]; SAVSPACE(.T1<LEFT>,.T1); SAVSPACE(0,.STK[0]);
	.VREG
END;	! of DATASTA
GLOBAL ROUTINE STRNGSCAN=
BEGIN
	! STRING SCAN - PUTS A STRING OF UP TO 6 SIXBIT CHARACTERS
	! IN SIX LEFT JUSTIFIED AND RETURNS IT

	REGISTER SIX,C;
	LOOK4CHAR _ "?L";	! ANY LETTER
	DECR SHIFT FROM 30 TO 0 BY 6 DO !PACK THE FIRST 6 CHARACTERS
	BEGIN
		MACHOP ADDI=#271;
		SIX_.SIX^6;
		IF ( C _ LEXICAL(.GSTCSCAN  ) )  EQL  0
		THEN	RETURN ( SIX _ .SIX^.SHIFT )	! NO MORE LETTERS
		ELSE	ADDI ( SIX, -" ", C )	! CONVERT TO SIXBIT AND PUT IN SIX
	END;
	DO
	IF LEXICAL(.GSTCSCAN) EQL  0  THEN RETURN .SIX	! SKIP ALL CHARS PAST 6
	WHILE 1;
END;	! of STRNGSCAN
ROUTINE COMPARE(TBLINDEX) =

!++
! FUNCTIONAL DESCRIPTION:
!
! 	Compare will compare KEYBUFFER and OPNKWD[.TBLINDEX] to test if they
!	are equivalent. 
!
! FORMAL PARAMETERS:
!
!	TBLINDEX  present index into OPNKWD
!
! IMPLICIT INPUTS:
!
!	KEYBUFFER contains an open/close/inquire specifier which was found
!                 in LEXICA	
!	KEYLENGTH number of characters in KEYBUFFER
!	OPNKWD	  table of open/close/inquire keywords
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
! 	If KEYBUFFER < OPNKWD[.TBLINDEX] then compare will return 0
!       	     =                 		                 1
!              	     >                           		 2
!
! SIDE EFFECTS:
!
!	None
!
!--


! New [2370] MEM 
BEGIN
	REGISTER ITEM; ! ptr to present word in OPNKWD[.TBLINDEX] being compared
	REGISTER NWORDS;  ! number of words that have to be compared since
		       ! OPNKWD[.TBLINDEX] may be up to 4 words long
	      

	ITEM = .OPNKWD[.TBLINDEX];
	NWORDS = @(.ITEM-1)-1;  ! (.ITEM-1) fetches the number of words in this
			     	! table entry from the count in the plit
				! one more must be subtracted since we are
				! counting from 0 instead of from one

	INCR INDEX FROM 0 TO .NWORDS
	DO
	BEGIN
		IF .KEYBUFFER[.INDEX] LSS @.ITEM
		THEN RETURN 0                   ! KEYBUFFER < OPNKWD[.TBLINDEX]
		ELSE IF .KEYBUFFER[.INDEX] GTR @.ITEM
		THEN RETURN 2                   ! KEYBUFFER > OPNKWD[.TBLINDEX]
		ELSE ITEM = .ITEM + 1;          ! set item to point to next
						! word in OPNKWD[.TBLINDEX]
	END;

	IF .KEYLENGTH/5 GTR .NWORDS	! KEYLENGTH = number of characters in
	THEN RETURN 0			! KEYBUFFER
					! KEYLENGTH/5 = number of words in
					! KEYBUFFER
					! if KEYLENGTH/5 > NWORDS
					! then KEYBUFFER > OPNKWD[TBLINDEX]

	ELSE RETURN 1; 			! KEYBUFFER = OPNKWD[TBLINDEX]
END;
	
ROUTINE SEARCH(FIRST,LAST) =

!++
! FUNCTIONAL DESCRIPTION:
!
! search performs a binary search to see if KEYBUFFER is in OPNKWD
!
! FORMAL PARAMETERS:
!
!	FIRST index to first entry in part of table (OPNKWD) to be searched
!	LAST  index to last entry in part of table (OPNKWD) to be searched
!
! IMPLICIT INPUTS:
!
!	KEYBUFFER contains an open/close/inquire specifier which was found
!                 in LEXICA	
!	OPNKWD	  table of open/close/inquire keywords
!
!	
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	search will return -1 if KEYBUFFER is not found in OPNKWD
!	otherwise, search will return the index of the entry in OPNKWD
!	which matches KEYBUFFER
!
! SIDE EFFECTS:
!
!	None
!
!--


! New [2370] MEM
BEGIN
	REGISTER  MID,     ! index to middle of part of table to be searched
		  ISEQUAL; ! = 0 if KEYBUFFER < OPNKWD[MID]
			   ! = 1 if KEYBUFFER = OPNKWD[MID]
			   ! = 2 if KEYBUFFER > OPNKWD[MID]

	MID=(.FIRST + .LAST)/2;
	
	IF (.MID GTR .LAST) OR (.MID LSS .FIRST)
	THEN RETURN -1;			! KEYBUFFER is not in OPNKWD

	IF (ISEQUAL=COMPARE(.MID)) EQL 1
	THEN RETURN .MID	 	! KEYBUFFER = OPNKWD[MID] so return MID
	ELSE IF .ISEQUAL EQL 0 
	THEN RETURN SEARCH(.FIRST,.MID-1) ! KEYBUFFER < OPNKWD[MID] so search 
					! between OPNKWD[FIRST] and
					! OPNKWD[MID-1]
	ELSE RETURN SEARCH(.MID+1,.LAST); ! KEYBUFFER > OPNKWD[MID] so search 
					! between OPNKWD[MID+1] and
					! OPNKWD[LAST]
END;
GLOBAL ROUTINE OPENCLOSE(OPENCLOSDATA)=
BEGIN

%2200%	! modified for INQUIRE by TFV, 16-Mar-83

! Routine to parse  the open  keyword list  (olist) in  OPEN, CLOSE  and
! INQUIRE statements. The list can have the following forms:
!
!	(u,keywords)
!	(keywords)
!
! where
!	u	 is an integer expression specifying the unit number
!	keywords is a list of either KEYWORD=EXPRESSION or just KEYWORD
!
! The keywords DIALOG and READONLY cause problems if they are  specified
! first in  the  keyword  list  because they  are  not  followed  by  =.
! Therefore it is  ambiguous whether they  are a keyword  or a  variable
! name specifying the  unit number.   READONLY is not  a valid  variable
! name so  it is  parsed  as a  keyword.  DIALOG  is  parsed as  a  unit
! expression.
!
! OPEN and CLOSE must have a unit specifier.  INQUIRE must have either a
! unit or a file specifier, but not both.


	REGISTER BASE K:N:V;
	LOCAL FIRSTP;
	LABEL DLP;


%2426%	OWN OPNVAL [MAXOTSKWD+1];! value of keyword, pointer to expression node

	FIRSTP = -1;		! FIRSTP is true iff we are at first item in
				! list

	DECR I FROM MAXOTSKWD TO 0 DO OPNVAL[.I] = 0; ! clear keyword value table

	IF LEXEMEGEN() NEQ LPAREN^18 THEN RETURN ERR0V(LPARPLIT);
					! read left paren to start list

DO
BEGIN					! loop until right paren
	K = LEXICAL(.GSTKSCAN);		! look for "KEYWORD="
	IF .K EQL 0			! keyword not found
	THEN				! check for DIALOG and READONLY
	BEGIN	! not keyword

	        IF .FIRSTP		! if first thing in list
		THEN			! must be unit expression
		BEGIN	! unit expression
			N = NUNIT;	! set keyword number
			IF EXPRESS() LSS 0 THEN RETURN .VREG; ! read expression
			V = .STK[.SP];	! pop expression off stack
			SP = .SP - 1;
			IF .V[VALTYPE] NEQ INTEGER ! convert to integer
			THEN V = CNVNODE(.V,INTEGER,0); ! if necessary
		END	! unit expression
		ELSE
		BEGIN
			LOOK4CHAR = (UPLIT ASCIZ 'READONLY')<36,7>;
%2424%		        IF LEXICAL(.GSTSSCAN) NEQ 0
			THEN
			BEGIN
%2424%				IF (.OPENCLOSDATA EQL INQUDATA)
%2523%				OR (.OPENCLOSDATA EQL CLOSDATA)
%2424%				THEN RETURN FATLEX(KEYBUFFER,E183<0,0>)
				ELSE
				BEGIN
%2476%					N = NREADO+1; ! set keyword number
					V = -1;	    ! set keyword value (none)
				END;
			END
			ELSE
			BEGIN
			LOOK4CHAR = (UPLIT ASCIZ 'READON')<36,7>;
%2424%		        IF LEXICAL(.GSTSSCAN) NEQ 0
%2424%			THEN
%2424%			BEGIN
%2424%				IF .OPENCLOSDATA EQL INQUDATA
%2523%				OR (.OPENCLOSDATA EQL CLOSDATA)
%2424%				THEN RETURN FATLEX(KEYBUFFER,E183<0,0>)
%2424%				ELSE
%2424%				BEGIN
%2424%					N = NREADO; ! set keyword number
%2424%					V = -1;	    ! set keyword value (none)
%2424%				END;
%2424%			END
	
			ELSE
			BEGIN	! either DIALOG (or DIALOGUE) without = or error
%2424%			LOOK4CHAR = (UPLIT ASCIZ 'DIALOGUE')<36,7>;
%2424%			IF LEXICAL(.GSTSSCAN) NEQ 0
%2424%			THEN	
%2424%			BEGIN	
%2424%				IF .OPENCLOSDATA EQL INQUDATA
%2424%				THEN RETURN FATLEX(KEYBUFFER,E183<0,0>)
%2424%				ELSE	
%2424%				BEGIN
%2476%					N = NDIALOG+1; ! set keyword number
%2424%					V = -1;      ! set keyword value (none)
%2424%				END;
%2424%			END
%2424%
%2424%			ELSE
%2424%			BEGIN
				LOOK4CHAR = (UPLIT ASCIZ 'DIALOG')<36,7>;
				IF LEXICAL(.GSTSSCAN) NEQ 0
				THEN
				BEGIN
%2424%					IF .OPENCLOSDATA EQL INQUDATA
%2424%					THEN RETURN FATLEX(KEYBUFFER,E183<0,0>)
					ELSE
					BEGIN
						N = NDIALOG; ! set keyword number
						V = -1;      ! set keyword value (none)
					END;
				END
				ELSE
				BEGIN ! error - found whatever when expecting keyword				
					LEXL = LEXEMEGEN();
					RETURN ERR0L (UPLIT ASCIZ 'keyword');
				END;	! error - found whatever when expecting keyword
			END;	! either DIALOG without = or error
		END;	! either DIALOGUE (or DIALOG) without = or error
	        END;	! either READON, DIALOGUE, DIALOG or error
		END;	! either READONLY, READON, DIALOGUE, DIALOG or error
	END	! not keyword

	ELSE	
	BEGIN	! keyword

%2370%		N = SEARCH(0,KWDN); ! search for KEYBUFFER in OPNKWD
%2370%				    ! if it is found then its index is returned
%2370%			            ! otherwise -1 is returned
	
		IF .N LSS 0          ! if keyword not found
%2370%		THEN RETURN FATLEX(KEYBUFFER,E183<0,0>); ! say so and abort statement

%2200%		! dispatch on the legal values for this keyword in  this
%2200%		! type of statement, i.e. OPEN and CLOSE vs. INQUIRE

%2200%		CASE (IF .OPENCLOSDATA EQL INQUDATA
%2370%		      THEN .INQUKVAL[.N]	! INQUIRE statement
%2523%		      ELSE IF .OPENCLOSDATA EQL CLOSDATA	
%2523%		      THEN .CLOSKVAL[.N]	! CLOSE statement
%2523%		      ELSE .OPNKVAL[.N])	! OPEN statement
%2200%		OF SET

%2200%		! illegal keyword for this statement, say so and abort
%2200%		BEGIN
%2370%			RETURN FATLEX(KEYBUFFER,E183<0,0>)
%2200%		END;

		! character expression, numeric scalar, or numeric arrayref
		BEGIN
			IF EXPRESS() LSS 0 THEN RETURN .VREG;
			V = .STK[.SP];	! pop expression off stack
			SP = .SP - 1;

			! Any character expression is OK.  Numeric expression
			! must be scalar or arrayref.  More complex expressions
			! are hereby decreed meaningless, unVMSish and illegal.

			IF .V[VALTYPE] NEQ CHARACTER
			THEN IF .V[OPRCLS] EQL DATAOPR THEN %OK%
			     ELSE IF .V[OPRCLS] EQL ARRAYREF THEN %OK%
%2370%			     ELSE FATLEX(KEYBUFFER,E299<0,0>);
					! "Illegal <keyword> specifier"
		END;

		! integer expression
		BEGIN
			IF EXPRESS() LSS 0 THEN RETURN .VREG;
			V = .STK[.SP];	! pop expression off stack
			SP = .SP - 1;

			! Convert numeric expressions to integer if necessary.
			! Character expressions are an error, except convert
			! character constants to hollerith.

			IF .V[VALTYPE] EQL CHARACTER
			THEN IF .V[OPERATOR] EQL CHARCONST
			     THEN
%2200%			     BEGIN
%2200%				WARNLEX(E212<0,0>);
%2200%					! CHARACTER constant used  where
%2200%					! numeric expression required
%2200%				V[OPERATOR] = HOLLCONST
%2200%			     END
			     ELSE FATLEX(E164<0,0>) 
					! Character expression used where
					! numeric expression required
%2200%			ELSE IF .V[OPERATOR] EQL HOLLCONST
%2200%			     THEN WARNLEX(E215<0,0>)
%2200%					! HOLLERITH constant used  where
%2200%					! numeric expression required
%2200%			     ELSE IF .V[VALTYPE] NEQ INTEGER
				  THEN V = CNVNODE(.V,INTEGER,0);
		END;

		% char expr or numeric array name %
		BEGIN
			FLGREG<FELFLG> = 1;	! allow bare array names
			IF EXPRESS() LSS 0 THEN RETURN .VREG;
			V = .STK[.SP];		! pop expression off stack
			SP = .SP - 1;

			! If expression is numeric, it must be an array name.
			! Use NAMREF to check this. If expression is character,
			! it can be anything but an array or function name.

			IF .V[VALTYPE] NEQ CHARACTER
%1676%			  AND .V[VALTYPE] NEQ HOLLERITH
			THEN IF .V[OPRCLS] EQL DATAOPR
			     THEN NAMREF(ARRAYNM1,.V)
%2511%			     ELSE FATLEX(UPLIT'array or character expression',KEYBUFFER,E305<0,0>)
			ELSE IF .V[OPRSP1] GEQ ARRAYNM1
%2511%			     THEN FATLEX(UPLIT'array or character expression',KEYBUFFER,E305<0,0>)
		END;

		% label %
		BEGIN
			LABELS();	
			NONIOINIO = 1;
			V = LEXL = LEXEMEGEN();		! read label
			NOLABELS();
			NONIOINIO = 0;
			IF .V<LEFT> NEQ LABELEX		! check that it is
			THEN RETURN ERR0L(.LEXNAM[LABELEX]); ! a label
		END;

%2200%		% char variable %
		BEGIN
			IF SYNTAX(VARIABLESPEC) LSS 0 THEN RETURN .VREG;
			V = BLDVAR(.STK[.SP]);	! pop variable off stack
			SP = .SP - 1;

			IF .V[OPRCLS] EQL ARRAYREF ! call NAMSET; this stmt
			THEN NAMSET(ARRAYNM1,.V[ARG1PTR]) ! modifies the 
			ELSE NAMSET(VARIABL1,.V);  ! variable

%2200%			IF .V[VALTYPE] NEQ CHARACTER  ! must be type char
%2200%			THEN FATLEX (UPLIT'CHARACTER', .V[IDSYMBOL], E196<0,0>);
		END;

		% integer variable %
		BEGIN
			IF SYNTAX(VARIABLESPEC) LSS 0 THEN RETURN .VREG;
			V = BLDVAR(.STK[.SP]);	! pop variable off stack
			SP = .SP - 1;

%1622%			IF .V[OPRCLS] EQL ARRAYREF ! call NAMSET; this stmt
%1622%			THEN NAMSET(ARRAYNM1,.V[ARG1PTR]) ! modifies the 
			ELSE NAMSET(VARIABL1,.V);  ! variable

			IF .V[VALTYPE] NEQ INTEGER ! must be type integer
			THEN FATLEX (UPLIT'INTEGER', .V[IDSYMBOL], E196<0,0>);
		END;

%2200%		% logical variable %
		BEGIN
			IF SYNTAX(VARIABLESPEC) LSS 0 THEN RETURN .VREG;
			V = BLDVAR(.STK[.SP]);	! pop variable off stack
			SP = .SP - 1;

			IF .V[OPRCLS] EQL ARRAYREF ! call NAMSET; this stmt
			THEN NAMSET(ARRAYNM1,.V[ARG1PTR]) ! modifies the 
			ELSE NAMSET(VARIABL1,.V);  ! variable

%2200%			IF .V[VALTYPE] NEQ LOGICAL ! must be type logical
%2200%			THEN FATLEX (UPLIT'LOGICAL', .V[IDSYMBOL], E196<0,0>);
		END;

		TES;

	END;	! keyword

%2426%	IF .OPNVAL[.IOCKCODE[.N]] NEQ 0		! if keyword already specified, error
%2424%	THEN FATLEX (.opnkwd[.n], E182<0,0>); 
					! "KEYWRD may only be specified once"

%2426%	OPNVAL[.IOCKCODE[.N]] = .V;		! set value of keyword

	FIRSTP = 0;			! not first in list any more

%2274%	IF FLAGEITHER	! If flagging incompatibilities, check keywords and their values
%2370%	THEN CFCHECK(.N,.OPNKWD[.N],.V,.OPENCLOSDATA);

	IF .LSAVE NEQ 0 THEN LSAVE = 0 ELSE LEXL = LEXEMEGEN();	! read lexeme
END
WHILE .LEXL<LEFT> EQL COMMA;		! while comma-separated list

IF .LEXL<LEFT> NEQ RPAREN THEN RETURN ERR0L(RPARPLIT);   ! read terminating )
IF LEXEMEGEN() NEQ LINEND^18 THEN RETURN ERR0V(EOSPLIT); ! followed by EOS

%2200%	! Check that  UNIT  (or FILE  for  INQUIRE) got  specified  else
%2200%	! return fatal error now.

%2200%	IF .OPENCLOSDATA NEQ INQUDATA
%2200%	THEN
%2200%	BEGIN	! OPEN/CLOSE
%2426%		IF .OPNVAL[.IOCKCODE[NUNIT]] EQL 0
%2424%		THEN RETURN FATLEX (UPLIT'specified',.(OPNKWD+NUNIT),E300<0,0>);
%2200%	END	! OPEN/CLOSE
%2200%	ELSE
%2200%	BEGIN	! INQUIRE
%2426%		IF .OPNVAL[.IOCKCODE[NUNIT]] EQL 0
%2200%		THEN
%2200%		BEGIN	! No unit specifier
%2426%			IF .OPNVAL[.IOCKCODE[NFILE]] EQL 0
%2200%			THEN RETURN FATLEX(E213<0,0>);	! neither unit nor file
%2200%		END	! No unit specifier
%2200%		ELSE	! unit specifier - check for file specifier too
%2426%			IF .OPNVAL[.IOCKCODE[NFILE]] NEQ 0
%2200%			THEN RETURN FATLEX(E214<0,0>);	! both unit and file
%2200%	END;	! INQUIRE

%2455%	! Since VMS default file names differ from ours, if we are flagging
%2455%	! VMS incompatibilities we put out a warning if no file name was
%2274%	! specified in an OPEN statement.

%2455%	IF FLAGVMS
%2274%	THEN
%2274%		IF.OPENCLOSDATA EQL OPENDATA AND
%2426%	          .OPNVAL[.IOCKCODE[NFILE]] EQL 0 AND .OPNVAL[.IOCKCODE[NNAME]] EQL 0
%2455%		THEN WARNLEX (E226<0,0>); ! VMS has different default file name

	! Make a statement node and fill it in

	NAME = IDOFSTATEMENT = .OPENCLOSDATA;
	NAME<RIGHT> = SORTAB;
	N = NEWENTRY();		! N points to empty statement node

%2426%	N[IOUNIT] = .OPNVAL[.IOCKCODE[NUNIT]];		! set UNIT=
%2426%	N[IOFILE] = .OPNVAL[.IOCKCODE[NFILE]];		! set FILE=
%2426%	N[IOERR] = .OPNVAL[.IOCKCODE[NERR]];		! set ERR=
%2426%	N[IOIOSTAT] = .OPNVAL[.IOCKCODE[NIOSTAT]];	! set IOSTAT=

	! clear values out of table

%2426%	OPNVAL[.IOCKCODE[NUNIT]] = OPNVAL[.IOCKCODE[NFILE]]
%2426%	= OPNVAL[.IOCKCODE[NERR]] = OPNVAL[.IOCKCODE[NIOSTAT]] = 0;

%2200%	IF .N[IOUNIT] NEQ 0
%2200%	THEN
%2200%	BEGIN
		K = .N[IOUNIT];		! set UNIT expression parent pointer
		IF .K[OPRCLS] NEQ DATAOPR
		THEN K[PARENT] = .N;
%2200%	END;

%2200%	IF .N[IOFILE] NEQ 0
%2200%	THEN
%2200%	BEGIN
		K = .N[IOFILE];		! set FILE expression parent pointer
		IF .K[OPRCLS] NEQ DATAOPR
		THEN K[PARENT] = .N;
%2200%	END;

%2200%	IF .N[IOIOSTAT] NEQ 0
%2200%	THEN
%2200%	BEGIN
		K = .N[IOIOSTAT];	! set IOSTAT expression parent pointer
		IF .K[OPRCLS] NEQ DATAOPR
		THEN K[PARENT] = .N;
%2200%	END;

	! Count keywords and copy into their block

	V = 0;					! V gets keyword count
	DECR I FROM MAXOTSKWD TO 0 DO
	IF .OPNVAL[.I] NEQ 0 THEN V = .V + 1;

	IF .V GTR 0 
	THEN
	BEGIN	! copy keywords into block
		NAME<LEFT> = N[OPSIZ] = .V;	! set keyword count
		N[OPLST] = V = CORMAN();	! get block, store its address

		DECR I FROM MAXOTSKWD TO 0 DO	! copy from OPNVAL into block
		IF .OPNVAL[.I] NEQ 0
		THEN
		BEGIN
			K = .OPNVAL[.I];	! copy expression ptr
			(.V)<RIGHT> = (IF .K LSS 0 THEN 0 ELSE .K);
%2370%			(.V)<LEFT> = .I;	! set Forots code

%1571%			IF .K GEQ 0	! unless DIALOG or READONLY
			THEN IF .K[OPRCLS] NEQ DATAOPR ! set parent pointer if
			     THEN K[PARENT] = .N;    ! subnode is an expression

			V = .V + 1;	! next keyword
		END;
	END;	! copy keywords into block

END;	! of OPENCLOSE
ROUTINE CFSEARCH (VALUE,TABLE) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Search TABLE for entry containing VALUE
!
! FORMAL PARAMETERS:
!
!	TABLE is the address of a list of pointers to sixbit values.
!	VALUE is a pointer to the expression node containing the character
!		constant to be found in the table.
!
! IMPLICIT INPUTS:
!
!	CONST1 entry in CONTAB
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	True if VALUE is found in TABLE, False otherwise
!
! SIDE EFFECTS:
!
!	None
!
!--


!New [2274] AlB
BEGIN
	REGISTER
		TPTR,		! Byte pointer to table value
		VPTR,		! Byte pointer to value for which we search
		V,		! Character from value
		T;		! Character from table

	LOCAL
		BASE CONTAB,	! Entry in constant table
		CONSTV;		! Byte pointer to constant value

	LABEL INNERLOOP;

	CONTAB=.VALUE;			! Construct a byte pointer to
	CONSTV=(CONTAB[CONST1])<36,7>;	! the character string to be found

	WHILE (TPTR = ..TABLE) NEQ 0 DO	! Zero implies end of list
	BEGIN
		VPTR=.CONSTV;
		INNERLOOP:		! Try to match current table entry
		WHILE (T = SCANI(TPTR)) NEQ 0 DO ! Entry is delimited by null byte
		BEGIN
			V=SCANI(VPTR);	! Character from VALUE
			IF .V GTR "Z" THEN V=.V-32;	! Lower- to Upper case
			IF .V NEQ .T THEN LEAVE INNERLOOP !No match
		END;
		IF .T EQL 0
		THEN RETURN TRUE;	! Match with current table entry
		TABLE=.TABLE+1		! Try next table entry
	END;
	RETURN FALSE	! VALUE does not match any entry in TABLE
END;	! of CFSEARCH
ROUTINE CFCHECK (KX,KNAME,KVALUE,STYPE) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Check for compatibility of an OPEN/CLOSE/INQUIRE keyword with
!	Fortran-77 and/or VMS.
!	This routine is entered if and only if incompatibilities are
!	being flagged.
!
! FORMAL PARAMETERS:
!
!	KX is the index into the keyword tables.
!	KNAME is pointer to the name of the keyword.
!	KVALUE is pointer to the value expression node
!	STYPE is type of statement (OPEN, CLOSE or INQUIRE)
!
! IMPLICIT INPUTS:
!
!	Value of the flagger bits in F2 (FLAGANSI and FLAGVMS)
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	Compiler warning messages may be issued.
!
!--


!New [2274] AlB
BEGIN

%2316%	MACRO X (LITVAL) = (UPLIT ASCIZ 'LITVAL')<36,7>$;

! Table of ACCESS values acceptable to Fortran-77

	BIND ACCESSA = UPLIT (
		X (DIRECT),
		X (SEQUENTIAL),
		0);

! Table of ACCESS values acceptable to VMS

	BIND ACCESSV = UPLIT (
		X (APPEND),
		X (DIRECT),
		X (SEQUENTIAL),
		0);

! Table of STATUS values acceptable to Fortran-77 on OPEN

	BIND STATUSO = UPLIT (
		X (NEW),
		X (OLD),
		X (SCRATCH),
		X (UNKNOWN),
		0);

! Table of STATUS values acceptable on CLOSE 

	BIND STATUSC = UPLIT (
		X (DELETE),
		X (KEEP),
		0);

! Table of CARRIAGECONTROL values acceptable to VMS

	BIND CARRIAGEV = UPLIT (
		X (FORTRAN),
		X (LIST),
		0);

! Table of DISPOSE values acceptable to VMS

	BIND DISPOSEV = UPLIT (
		X (DELETE),
		X (KEEP),
		X (PRINT),
		X (SAVE),
		0);
	LOCAL
		KF,		! Conditions to be tested
		KTABLE,		! Pointer to table to be searched
		BASE KV,	! Pointer to keyword value
		PREFIX;		! The prefix for any warning

	KV=.KVALUE;	! Pointer to keyword value

	!Retain only conditions to be tested
	KF = .KEYWFLAG[.KX] AND
%2455%	    (FLAGANSI*(1^CFANSI + 1^CFVANSI) + FLAGVMS*(1^CFVMS + 1^CFVVMS));

	IF .KF<CFVANSI,1>
	THEN
	BEGIN	! Extra processing for Fortran-77
		IF .KX EQL (NFILE)
		THEN	!FILE keyword
		BEGIN
			KF=.KF - 1^CFVANSI;	! Turn off 'keyword value'
			IF .STYPE EQL CLOSDATA	! If it is CLOSE,
			THEN KF=.KF OR 1^CFANSI	! then turn on 'keyword'
		END

		ELSE
		IF .KX EQL (NNAME) OR .KX EQL (NDIRECT)
		THEN	!NAME, DIRECT or DIRECTORY keyword
		BEGIN
			KF=.KF-1^CFVANSI;	! Turn off 'keyword value'
			IF .STYPE NEQ INQUDATA	! Unless it is INQUIRE,
			THEN KF=.KF+1^CFANSI	! Turn on 'keyword'
		END

		ELSE
		BEGIN	! Test for keyword values
			KTABLE=0;	! Start with no table
			IF .KV[OPR1] EQL CONSTFL ! Check only constants
			THEN	! Test values
				IF .KX EQL (NACCESS) THEN KTABLE = ACCESSA
				ELSE
				IF .KX EQL (NSTATUS)
				THEN
					IF .STYPE EQL CLOSDATA
					THEN KTABLE = STATUSC
					ELSE KTABLE = STATUSO;

			IF .KTABLE EQL 0
			THEN	! No table, so no warning
				KF = .KF - 1^CFVANSI
			ELSE	! If value in table, no warning
				IF CFSEARCH(.KV, .KTABLE)
				THEN KF = .KF - 1^CFVANSI
		END

	END;	! Extra processing for Fortran-77

%2455%	IF .KF<CFVVMS,1>
	THEN
%2455%	BEGIN	! Extra processing for VMS
		IF .KX EQL (NASSOC)
%2455%		THEN	!ASSOCIATEVARIABLE not set by VMS on OPEN
		BEGIN
%2455%			KF = .KF - 1^CFVVMS;	! Turn off the bit
			IF .STYPE EQL OPENDATA THEN WARNLEX(E275<0,0>)
		END

		ELSE
		IF .KX EQL (NDIRECT)
		THEN	!DIRECT or DIRECTORY keyword
		BEGIN
%2455%			KF = .KF - 1^CFVVMS;	! Turn off 'keyword values'
			IF .STYPE NEQ INQUDATA	! Unless it is INQUIRE,
%2455%			THEN KF = .KF + 1^CFVMS	! turn on 'keyword'
		END

		ELSE
		BEGIN	! Looking at values
			KTABLE=0;	! Start with no table
			IF .KV[OPR1] EQL CONSTFL ! Check only constants
			THEN	! Test values
				IF .KX EQL (NACCESS) THEN KTABLE = ACCESSV
				ELSE
				IF .KX EQL (NCARR) THEN KTABLE = CARRIAGEV
				ELSE
				IF .KX EQL (NDISPOS) THEN KTABLE = DISPOSEV
				ELSE
				IF .KX EQL (NSTATUS) OR .KX EQL (NTYPE)
				THEN
					IF .STYPE EQL CLOSDATA
					THEN KTABLE = STATUSC
					ELSE KTABLE = STATUSO;

			IF .KTABLE EQL 0
			THEN	! No table, so no warning
%2455%				KF = .KF - 1^CFVVMS
			ELSE	! If value in table, no warning
				IF CFSEARCH(.KV, .KTABLE)
%2455%				THEN KF = .KF - 1^CFVVMS
		END	! Looking at values
%2455%	END;	! Extra processing for VMS

%2316%	IF .KF EQL 0 THEN RETURN;	! Go away if we found nothing

	! Special names for the keywords
!	IF .KX EQL NREADO	[2370] removed
!	THEN KNAME=PLIT ASCIZ 'READON'
!	ELSE
!	IF .KX EQL NDIALOG
!	THEN KNAME=PLIT ASCIZ 'DIALOG';

	!Determine prefix for any keyword warning
	IF .KF<CFANSI,1>
	THEN
%2455%		IF .KF<CFVMS,1>
%2477%		THEN PREFIX = BOTHPLIT	! Both
%2477%		ELSE PREFIX = ANSIPLIT	! Fortran-77 only
	ELSE
%2455%		IF .KF<CFVMS,1>
%2477%		THEN PREFIX = VMSPLIT	! VMS only
		ELSE PREFIX = 0;

	IF .PREFIX NEQ 0
	THEN WARNLEX(.KNAME,.PREFIX,E247<0,0>); ! Keyword .KNAME

	!Determine prefix for any keyword value warning
	IF .KF<CFVANSI,1>
	THEN
%2455%		IF .KF<CFVVMS,1>
%2477%		THEN PREFIX = BOTHPLIT	! Both
%2477%		ELSE PREFIX = ANSIPLIT	! Fortran-77 only
	ELSE
%2455%		IF .KF<CFVVMS,1>
%2477%		THEN PREFIX = VMSPLIT	! VMS only
		ELSE PREFIX = 0;

	IF .PREFIX NEQ 0
%2316%	THEN WARNLEX(.KNAME,.PREFIX,E248<0,0>) ! Keyword value for .KNAME

END;	! of CFCHECK [2316]
GLOBAL ROUTINE OPENSTA=
	OPENCLOSE(OPENDATA);

GLOBAL ROUTINE CLOSSTA=
	OPENCLOSE(CLOSDATA);

GLOBAL ROUTINE INQUSTA=
	OPENCLOSE(INQUDATA);	![2200] Rewritten by TFV on 23-Mar-83

END
ELUDOM