Trailing-Edge
-
PDP-10 Archives
-
FORTRAN-10_Alpha_31-jul-86
-
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, 1986
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
!AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!AUTHOR: F.J. INFANTE, 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 = #11^24 + 0^18 + #4526; ! Version Date: 3-Dec-85
! LEXNAM, FIRST, TABLES, META72, ASHELP
SWITCHES NOLIST;
REQUIRE FTTENX.REQ; ![4526]
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.
***** End Revision History *****
***** 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 and TAPEFORMAT legal in an inquire
statement.
2523 MEM 11-Mar-85
Separate open and close keywords specifiers.
***** End V10 Development *****
2552 MEM 16-Sep-85
Removed open specifier RECTYPE.
***** End Revision History *****
***** Begin Version 11 *****
4500 MEM 22-Jan-85
Entries in THEKEYS for BYTESIZE, KEY=, ORGANIZATION, SHARED, USEROPEN,
and KEYED were added. Add KEYED as a valid vms access value.
4502 MEM 22-Jan-85
Created routine DELESTA to perform ANSI flagging for DELETE statement
and to perform keyword processing.
4512 CDM 26-Aug-85
Delete old never called routines. TMPGEN, STRNGSCAN, ZSIXBIT.
4526 MEM 3-Dec-85
Give an error when RMS stuff is used on TOPS10.
ENDV11
)%
!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
DELESTA, !DELETE
CMPLXCONGEN(2),
SIGNEDREAL(1),
DATAGEN(1),
% 3% DATASTA, !DATA
%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
%4502% E267, ! Extension to Fortran-77: xxxxx statement
%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
%4500% E316, ! VMS keyword ?B ignored
%4500% E317, ! Too many keys specified for indexed file
%4500% E320, ! Illegal key type - must be INTEGER or CHARACTER
%4526% E322, ! TOPS20 ONLY: xxx
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
%4500% NV = 8; ! no alloc variable
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
%4526% CFTOPS10 = 4$, ! Keyword is not recognized on TOPS10
%4526% CFVTOPS10 = 5$, ! Keyword is recognized by TOPS10, but extra
%4526% ! tests must be done
![2370] created macro THEKEYS which has 5 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 or incompatible with TOPS10.
THEKEYS(XX) =
XX(NACCESS INDEXES PLIT ASCIZ 'ACCESS',
%2455% CV, CE, CE, OPNCACCESS,1^CFVANSI+1^CFVVMS+1^CFVTOPS10),
%2503% XX(PLIT ASCIZ 'ASSOCI',
%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',
CV, CE, CE, OPNCBLANK, 0),
XX(PLIT ASCIZ 'BLOCKS',
IL, IE, IE, OPNCBLOCKSIZE,1^CFANSI+1^CFVMS),
XX(PLIT ASCIZ 'BLOCKSIZE',
IL, IE, IE, OPNCBLOCKSIZE,1^CFANSI),
XX(PLIT ASCIZ 'BUFFER',
IL, IE, IE, OPNCBUFCOUNT,1^CFANSI+1^CFVMS),
XX(PLIT ASCIZ 'BUFFERCOUNT',
IL, IE, IE, OPNCBUFCOUNT,1^CFANSI),
%4500% XX(PLIT ASCIZ 'BYTESIZE',
%4500% IV, IL, IE, IOCBYTESIZE,1^CFANSI+1^CFVMS),
%2503% XX(PLIT ASCIZ 'CARRIA',
%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),
%4500% XX(NDFILE INDEXES PLIT ASCIZ 'DEFAULTFILE',
%4500% CE, IL, CE, IOCDEFAULTF,1^CFANSI),
XX(PLIT ASCIZ 'DENSIT',
%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',
%2455% IL, CE, CE, OPNCDEVICE, 1^CFANSI+1^CFVMS),
XX(PLIT ASCIZ 'DIALOG',
%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',
%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',
%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',
LB, LB, LB, OPNCERREQ, 0),
XX(PLIT ASCIZ 'EXIST',
LV, IL, IL, IOCEXIST, 0),
%4500% XX(PLIT ASCIZ 'EXTENDSIZE',
%4500% IL, IL, IE, OPNCEXTEND, 1^CFANSI),
XX(NFILE INDEXES PLIT ASCIZ 'FILE',
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',
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',
%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',
IV, IV, IV, OPNCIOSTAT, 0),
%4500% XX(NKEY INDEXES PLIT ASCIZ 'KEY',
%4526% IL, IL, IE, OPNCKEY,1^CFANSI+1^CFTOPS10),
%4500% XX(PLIT ASCIZ 'KEYED',
%4526% CE, IL, IL, IOCKEYED,1^CFANSI+1^CFTOPS10),
XX(PLIT ASCIZ 'LIMIT',
%2455% IL, IE, IE, OPNCLIMIT, 1^CFANSI+1^CFVMS),
%4500% XX(PLIT ASCIZ 'MAXREC',
%4500% IL, IL, IE, OPNCMAXREC, 1^CFANSI),
XX(PLIT ASCIZ 'MODE',
%2455% IL, CE, CE, OPNCMODE, 1^CFANSI+1^CFVMS),
XX(NNAME INDEXES PLIT ASCIZ 'NAME',
CV, AR, AR, IOCNAME, 1^CFVANSI),
XX(PLIT ASCIZ 'NAMED',
LV, IL, IL, IOCNAMED, 0),
XX(PLIT ASCIZ 'NEXTRE',
IV, IL, IL, IOCNEXTREC, 1^CFANSI+1^CFVMS),
XX(PLIT ASCIZ 'NEXTREC',
IV, IL, IL, IOCNEXTREC, 0),
XX(PLIT ASCIZ 'NUMBER',
IV, IL, IL, IOCNUMBER, 0),
XX(PLIT ASCIZ 'OPENED',
LV, IL, IL, IOCOPENED, 0),
%4500% XX(NORGAN INDEXES PLIT ASCIZ 'ORGANIZATION',
%4526% AR, IL, AR, IOCORGANIZATION,1^CFANSI+1^CFVVMS+1^CFTOPS10),
XX(PLIT ASCIZ 'PADCHA',
%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',
%2455% IL, CE, CE, OPNCPARITY, 1^CFANSI+1^CFVMS),
XX(PLIT ASCIZ 'PROTEC',
%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',
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',
%2511% CE, CE, CE, IOCRECTYPE, 1^CFANSI),
XX(PLIT ASCIZ 'SEQUEN',
CV, IL, IL, IOCSEQUENTIAL,1^CFANSI+1^CFVMS),
XX(PLIT ASCIZ 'SEQUENTIAL',
CV, IL, IL, IOCSEQUENTIAL,0),
XX(NSTATUS INDEXES PLIT ASCIZ 'STATUS',
%2455% IL, CE, CE, OPNCSTATUS, 1^CFVANSI+1^CFVVMS),
%2413% XX(PLIT ASCIZ 'TAPEFO',
%2511% AR, IL, AR, IOCTAPEFO,1^CFANSI+1^CFVMS),
%2413% XX(PLIT ASCIZ 'TAPEFORMAT',
%2511% AR, IL, AR, IOCTAPEFO,1^CFANSI+1^CFVMS),
XX(NTYPE INDEXES PLIT ASCIZ 'TYPE',
%2455% IL, CE, CE, OPNCSTATUS, 1^CFANSI+1^CFVVMS),
XX(PLIT ASCIZ 'UNFORM',
CV, IL, IL, IOCUNFORMATTED,1^CFANSI+1^CFVMS),
XX(PLIT ASCIZ 'UNFORMATTED',
CV, IL, IL, IOCUNFORMATTED,0),
XX(NUNIT INDEXES PLIT ASCIZ 'UNIT',
IE, IE, IE, OPNCUNIT, 0),
%4500% XX(NUSER INDEXES PLIT ASCIZ 'USEROPEN',
%4500% IL, IL, NV, OPNCUSEROPEN, 1^CFANSI),
XX(PLIT ASCIZ 'VERSIO',
%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',
%2455% IL, 0, 0, OPNCNEDIALOG, 1^CFANSI+1^CFVMS),
%2426% XX(PLIT ASCIZ 'DIALOGUE',
%2455% IL, 0, 0, OPNCNEDIALOG, 1^CFANSI+1^CFVMS),
%4500% XX(NNOSPAN INDEXES PLIT ASCIZ 'NOSPANBLOCKS',
%4500% IL, IL, 0, OPNCNOSPAN, 1^CFANSI),
%2426% XX(NREADO INDEXES PLIT ASCIZ 'READON',
%2426% IL, IL, 0, OPNCREADONLY,1^CFANSI+1^CFVMS),
%2426% XX(PLIT ASCIZ 'READONLY',
%2476% IL, IL, 0, OPNCREADONLY,1^CFANSI),
%4500% XX(NSHARE INDEXES PLIT ASCIZ 'SHARED',
%4526% IL, IL, 0, OPNCSHARED, 1^CFANSI+1^CFTOPS10),
$;
! 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;
GLOBAL ROUTINE DELESTA=
!++
! FUNCTIONAL DESCRIPTION:
!
! To build a delete statement node and flag it as incompatible with ANSI
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! STK Points to the address of the block of specifiers built by
! KEYSCAN
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN ![4502] New
%4526% IF NOT FTTENEX THEN FATLEX (UPLIT ASCIZ 'DELETE statement',E322<0,0>);
IF FLAGANSI THEN WARNERR((PLIT ASCIZ 'DELETE')<0,0>,.ISN,E267<0,0>); !Compatibility flagger
BLDUTILITY(DELEDATA)
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
[email protected][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
ROUTINE KEYEQ =
!++
! FUNCTIONAL DESCRIPTION:
!
! parses KEY=(<kspec> {, <kspec>}) in OPEN statements
! where kspec is <integer expression> : <integer expression> [: <type>]
! where type is INTEGER | CHARACTER
!
! FORMAL PARAMETERS:
!
! None
!
! IMPLICIT INPUTS:
!
! LEXL current lexeme
!
! IMPLICIT OUTPUTS:
!
! LOOK4CHAR Pointer to character string to look for
!
! ROUTINE VALUE:
!
! IOKEY field of source tree node for open stm
!
! SIDE EFFECTS:
!
! None
!
!--
! New [4500] MEM
BEGIN
BIND
INT = UPLIT(ASCIZ 'INTEGER')<36,7>,
CHR = UPLIT(ASCIZ 'CHARACTER')<36,7>;
LOCAL OPNKEYLIST KEYTAB; ! list of keys
LOCAL BASE V; ! general scratch
LOCAL COUNT, ! number of keys
MORE; ! we have another key coming
! allocate space for max number of keys
NAME<LEFT> = MAXKEYS*KEYSIZE;
KEYTAB = CORMAN();
! we should start with a lparen
LEXL = LEXEMEGEN();
IF .LEXL<LEFT> NEQ LPAREN
THEN RETURN FATLEX(.LEXNAM[LPAREN],.LEXNAM[.LEXL<LEFT>],E0<0,0>);
COUNT=0;
MORE=TRUE;
DO
BEGIN
COUNT = .COUNT+1;
EXPRESS(); ! get integer expression
KEYTAB[.COUNT,KEYLOW] = V = .STK[.SP];
SP = .SP - 1;
IF .V[VALTYPE] EQL CHARACTER
THEN RETURN FATLEX(E164<0,0>); ! Character expression used where
! numeric expression required
IF .LEXL<LEFT> NEQ COLON ! colon should follow integer expression
THEN RETURN FATLEX(.LEXNAM[COLON],.LEXNAM[.LEXL<LEFT>],E0<0,0>);
LEXL = LEXEMEGEN();
EXPRESS(); ! get another integer expression
KEYTAB[.COUNT,KEYHIGH] = V = .STK[.SP];
SP = .SP - 1;
IF .V[VALTYPE] EQL CHARACTER
THEN RETURN FATLEX(E164<0,0>); ! Character expression used where
! numeric expression required
IF .LEXL<LEFT> EQL COLON ! optionally can have : INTEGER
THEN ! or : CHARACTER
BEGIN
LOOK4CHAR = CHR;
IF LEXICAL(.GSTSSCAN) EQL 0
THEN ! CHARACTER not found
BEGIN
LOOK4CHAR = INT;
IF (V = LEXICAL(.GSTSSCAN)) EQL 0
THEN RETURN FATLEX(V,E320<0,0>) ! INTEGER not found
ELSE KEYTAB[.COUNT,KEYTYPE] = INTEGER;
END
ELSE KEYTAB[.COUNT,KEYTYPE] = CHARACTER;
LEXL = LEXEMEGEN();
END
ELSE KEYTAB[.COUNT,KEYTYPE] = CHARACTER; ! default = CHARACTER
IF .LEXL<LEFT> EQL COMMA
THEN
BEGIN
IF .COUNT LSS MAXKEYS THEN LEXL = LEXEMEGEN()
ELSE RETURN FATLEX(E317<0,0>); ! Too many keys
END
ELSE MORE = FALSE;
END
WHILE .MORE;
! we should end with a rparen
IF .LEXL<LEFT> NEQ RPAREN
THEN RETURN FATLEX(.LEXNAM[RPAREN],.LEXNAM[.LEXL<LEFT>],E0<0,0>)
ELSE LEXL = LEXEMEGEN();
KEYTAB[NUMKEYS] = .COUNT; ! store count
! return space in rest of KEYTAB
SAVSPACE((MAXKEYS - .COUNT)*KEYSIZE -1,KEYTAB[.COUNT+1]);
! return KEYTAB
RETURN .KEYTAB
END;
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
!
!--
!R ewritten [4500] 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;
WHILE (.MID LEQ .LAST) AND (.MID GEQ .FIRST)
DO
BEGIN
IF (ISEQUAL=COMPARE(.MID)) EQL 1
THEN RETURN .MID ! KEYBUFFER = OPNKWD[MID] so return MID
ELSE IF .ISEQUAL EQL 0
THEN LAST = .MID-1 ! KEYBUFFER < OPNKWD[MID] so search
! between OPNKWD[FIRST] and
! OPNKWD[MID-1]
ELSE FIRST = .MID+1; ! KEYBUFFER > OPNKWD[MID] so search
! between OPNKWD[MID+1] and
! OPNKWD[LAST]
MID=(.FIRST + .LAST)/2;
END;
RETURN -1; ! KEYBUFFER is not in OPNKWD
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, READONLY and SHARED 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 and SHARED are 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.
%4500% REGISTER BASE K:V;
%4500% REGISTER INDEX;
%4500% LOCAL BASE NODE:KEYINFO;
LOCAL FIRSTP;
LABEL DLP;
%4500% OWN OPNVAL [MAXKWD+1];! value of keyword, pointer to expression node
%4500% ! into the entries between maxotskwd and maxkwd
%4500% ! will be stored the keyword values for the
%4500% ! VMS keywords that we accept but ignore, since
%4500% ! we ignore what is after maxotsword there is no
%4500% ! point to initially zero it out below
%4500% KEYINFO = 0; ! no KEY= info
FIRSTP = -1; ! FIRSTP is true iff we are at first item in
! list
DECR I FROM MAXKWD+1 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, SHARED and READONLY
BEGIN ! not keyword
IF .FIRSTP ! if first thing in list
THEN ! must be unit expression
BEGIN ! unit expression
%4500% INDEX = 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
%4500% INDEX = 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
%4500% INDEX = 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
%4500% INDEX = 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
%4500% INDEX = NDIALOG; ! set keyword number
V = -1; ! set keyword value (none)
END;
END
%4500% ELSE
%4500% BEGIN
%4500% LOOK4CHAR = (UPLIT ASCIZ 'SHARED')<36,7>;
%4500% IF LEXICAL(.GSTSSCAN) NEQ 0
%4500% THEN
%4500% BEGIN
%4500% IF (.OPENCLOSDATA EQL INQUDATA)
%4500% OR (.OPENCLOSDATA EQL CLOSDATA)
%4500% THEN RETURN FATLEX(KEYBUFFER,E183<0,0>)
%4500% ELSE
%4500% BEGIN
%4500% INDEX = NSHARE; ! set keyword number
%4500% V = -1; ! set keyword value (none)
%4500% END;
%4500% END
%4500% ELSE
%4500% BEGIN
%4500% LOOK4CHAR = (UPLIT ASCIZ 'NOSPANBLOCKS')<36,7>;
%4500% IF LEXICAL(.GSTSSCAN) NEQ 0
%4500% THEN
%4500% BEGIN
%4500% IF (.OPENCLOSDATA EQL INQUDATA)
%4500% OR (.OPENCLOSDATA EQL CLOSDATA)
%4500% THEN RETURN FATLEX(KEYBUFFER,E183<0,0>)
%4500% ELSE
%4500% BEGIN
%4500% INDEX = NNOSPAN; ! set keyword number
%4500% V = -1; ! set keyword value (none)
%4500% END;
%4500% END
ELSE
BEGIN ! error - found whatever when expecting keyword
LEXL = LEXEMEGEN();
RETURN ERR0L (UPLIT ASCIZ 'keyword');
END; ! error - found whatever when expecting keyword
%4500% END; ! either NOSPANBLOCKS or error
%4500% END; ! either SHARED or error
END; ! either DIALOG, SHARED or error
END; ! either DIALOGUE, DIALOG, SHARED or error
END; ! either READON, DIALOGUE, DIALOG, SHARED or error
END; ! either READONLY, READON, DIALOGUE, DIALOG, SHARED or error
END ! not keyword
ELSE
BEGIN ! keyword
%4500% INDEX = SEARCH(0,KWDN); ! search for KEYBUFFER in OPNKWD
%2370% ! if it is found then its index is returned
%2370% ! otherwise -1 is returned
%4500% IF .INDEX 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[.INDEX] ! INQUIRE statement
%2523% ELSE IF .OPENCLOSDATA EQL CLOSDATA
%2523% THEN .CLOSKVAL[.INDEX] ! CLOSE statement
%2523% ELSE .OPNKVAL[.INDEX]) ! 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
%4500% IF .INDEX EQL NKEY THEN KEYINFO = KEYEQ()
%4500% ELSE
%4500% 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);
%4500% END;
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;
%4500% %no alloc fnname%
%4500% BEGIN
%4500% LEXL = LEXEMEGEN();
%4500% V = .LEXL<RIGHT>;
%4500% IF .V[OPR1] NEQ FNNAMFL
%4500% THEN FATLEX(UPLIT'FUNCTION NAME',KEYBUFFER,E305<0,0>);
%4500% V[IDATTRIBUT(NOALLOC)] = 1;
%4500% END;
TES;
END; ! keyword
%4500% IF .OPNVAL[.IOCKCODE[.INDEX]] NEQ 0 ! if keyword already specified, error
%4500% THEN FATLEX (.OPNKWD[.INDEX], E182<0,0>);
! "KEYWRD may only be specified once"
%4500% IF .INDEX NEQ NKEY ! if keyword is not KEY=
%4500% THEN OPNVAL[.IOCKCODE[.INDEX]] = .V; ! set value of keyword
FIRSTP = 0; ! not first in list any more
%4500% IF .IOCKCODE[.INDEX] GTR MAXOTSKWD ! VMS keyword is ignored
%4500% THEN WARNLEX(.OPNKWD[.INDEX],E316<0,0>);
%4526% IF NOT FTTENEX
%4526% THEN
%4526% BEGIN
%4526% IF (1^CFTOPS10 AND .KEYWFLAG[.INDEX]) NEQ 0
%4526% THEN FATLEX (.OPNKWD[.INDEX],E322<0,0>)
%4526% ELSE IF (1^CFVTOPS10 AND .KEYWFLAG[.INDEX]) NEQ 0
%4526% THEN
%4526% BEGIN
%4526% MACRO X (LITVAL) = (UPLIT ASCIZ 'LITVAL')<36,7>$;
%4526%
%4526% IF .INDEX EQL (NACCESS)
%4526% THEN IF .V[OPR1] EQL CONSTFL
%4526% THEN IF CFSEARCH(.V,UPLIT(X (KEYED),0))
%4526% THEN FATLEX (UPLIT ASCIZ 'ACCESS=''KEYED''',E322<0,0>)
%4526% END;
%4526% END;
%2274% IF FLAGEITHER ! If flagging incompatibilities, check keywords and their values
%4500% THEN CFCHECK(.INDEX,.OPNKWD[.INDEX],.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
%4500% IF .OPNVAL[.IOCKCODE[NUSER]] EQL 0
%4500% THEN 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 !No unit specified
%2200% THEN
%2200% BEGIN ! No unit specifier
%2426% IF .OPNVAL[.IOCKCODE[NFILE]] EQL 0 !No file specified
%4500% THEN IF .OPNVAL[.IOCKCODE[NDFILE]] EQL 0!no defaultfile
%2200% THEN RETURN FATLEX(E213<0,0>);
%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
%4500% AND .OPNVAL[.IOCKCODE[NDFILE]] 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;
%4500% NODE = NEWENTRY(); ! NODE points to empty statement node
%4500% NODE[IOUNIT] = .OPNVAL[.IOCKCODE[NUNIT]]; ! set UNIT=
%4500% NODE[IOFILE] = .OPNVAL[.IOCKCODE[NFILE]]; ! set FILE=
%4500% NODE[IOERR] = .OPNVAL[.IOCKCODE[NERR]]; ! set ERR=
%4500% NODE[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;
%4500% IF .NODE[IOUNIT] NEQ 0
%2200% THEN
%2200% BEGIN
%4500% K = .NODE[IOUNIT]; ! set UNIT expression parent pointer
IF .K[OPRCLS] NEQ DATAOPR
%4500% THEN K[PARENT] = .NODE;
%2200% END;
%4500% IF .NODE[IOFILE] NEQ 0
%2200% THEN
%2200% BEGIN
%4500% K = .NODE[IOFILE]; ! set FILE expression parent pointer
IF .K[OPRCLS] NEQ DATAOPR
%4500% THEN K[PARENT] = .NODE;
%2200% END;
%4500% IF .NODE[IOIOSTAT] NEQ 0
%2200% THEN
%2200% BEGIN
%4500% K = .NODE[IOIOSTAT]; ! set IOSTAT expression parent pointer
IF .K[OPRCLS] NEQ DATAOPR
%4500% THEN K[PARENT] = .NODE;
%2200% END;
NODE[IOKEY] = .KEYINFO; ! store IOKEY into NODE
! 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
%4500% NAME<LEFT> = NODE[OPSIZ] = .V; ! set keyword count
%4500% NODE[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
%4500% THEN K[PARENT] = .NODE; ! 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),
%4500% X (KEYED),
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);
![4500] Table of ORGANIZATION values acceptable to VMS
BIND ORGANIV = UPLIT (
X (INDEXED),
X (RELATIVE),
X (SEQUENTIAL),
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
%4500% ELSE
%4500% IF .KX EQL (NORGAN) THEN KTABLE = ORGANIV
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