Trailing-Edge
-
PDP-10 Archives
-
FORTRAN-10_V7wLink_Feb83
-
sta1.bli
There are 12 other files named sta1.bli in the archive. Click here to see a list.
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
! OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1983
!AUTHOR: F.J. INFANTE, D. B. TOLMAN/SJW/DCE/TFV/EDS/CKS/AHM
MODULE STA1(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4)=
BEGIN
GLOBAL BIND STA1V = 7^24 + 0^18 + #1716; ! Version Date: 17-Jan-83
! 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 Revision History *****
)%
!THE NUMBER IN COMMENT'S IS THE STATEMENTS LOCATION
!IN THE HASH TABLE .
FORWARD
% 3% DATASTA, !DATA
% 18% OPENSTA, !OPEN
% 34% FINDSTA, !FIND
% 39% REWISTA, !REWIND
% 63% BKSPST, !BACKSPACE OR BACKFILE
% 83% CLOSSTA, !CLOSE
% 84% ENDFSTA, !ENDFILE
%???% INQUSTA; ![1267] INQUIRE
EXTERNAL
BLDVAR,
BLDUTILITY,
CNVNODE,
CORMAN,
EXPRESS,
GSTKSCAN,
GSTSSCAN,
LABELS,
LEXEMEGEN,
LEXICA,
LEXL,
LOOK4CHAR,
NAMREF,
NAMSET,
NOLABELS,
NONIOINIO;
EXTERNAL E15,E164,E182,E183,E184,E196;
GLOBAL ROUTINE BKSPST=
BEGIN
EXTERNAL BLDREPT,BLDUTILITY;
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 %
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;
GLOBAL ROUTINE REWISTA=
%1677% BLDUTILITY(REWIDATA);
GLOBAL ROUTINE ENDFSTA=
%1677% BLDUTILITY(ENDFDATA);
GLOBAL ROUTINE FINDSTA=
%1677% BLDUTILITY(FINDDATA);
ROUTINE CMPLXCONGEN(PTR , SIGNN )= !BUILDS A COMPLEX ONSTANT NODE FROM DATA LIST
!SEMANTIC OUTPUT
BEGIN
REGISTER SIGNFLG;
LOCAL BASE REALPT :IMAGPT;
![761] Add KGFRL and KTYPCG for folding /GFLOATING constants
%[761]% EXTERNAL CNSTCM,C1H,C1L,C2H,C2L,COPRIX,KDPRL,KGFRL,KDNEGB,KTYPCB,KTYPCG;
REGISTER BASE T1:T2;
ROUTINE SIGNEDREAL(CONST)=
%(****************************
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
*******************************)%
BEGIN
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;
%(***PROCESS REAL PART**)%
T1 _ .PTR;
SIGNFLG _ .SIGNN;
IF .T1[ELMNT] NEQ 0 !IS IT SIGNED?
THEN
(IF .T1[ELMNT] EQL 2 THEN SIGNFLG _ -1 -.SIGNN;
T1_.T1+1;
);
REALPT_SIGNEDREAL(.T1[ELMNT1]);
%(***PROCESS IMAGINARY PART**)%
SIGNFLG _ .SIGNN;
T1_.T1+2; !SKIP TO IMAG PART
IF .T1[ELMNT] NEQ 0
THEN (IF .T1[ELMNT] EQL 2 THEN SIGNFLG_ -1 -.SIGNN;
T1_.T1+1;
);
IMAGPT _ SIGNEDREAL(.T1[ELMNT1]);
!NOW MAKE ACOMPLEX CONSTANT NODE
RETURN MAKECNST(COMPLEX,.REALPT,.IMAGPT);
END; !OF ROUTINE CPLXCONGEN
GLOBAL ROUTINE DATAGEN(CONLIST)=
BEGIN
EXTERNAL CORMAN,NAME,SAVSPACE;
LOCAL REPEAT,COUNT,DATCSIZ,SIGNFLG;
LOCAL BASE CONNODE :CONPTR;
LABEL DAT1;
MACRO ERR54 = ( FATLEX(E54<0,0>))$;
![761] Add KGFRL to convert DP to SP under /GFLOATING
%[761]% EXTERNAL CNSTCM,C1H,C1L,C2H,C2L,COPRIX,KDPRL,KGFRL,KDNEGB;
MACRO DNEG(X,Y)=
BEGIN
C1H _ X[CONST1]; !HIGH ORDER
C1L _ X[CONST2]; !LOW ORDER
COPRIX _ KDNEGB;
CNSTCM(); !CONVERT TO NEG
MAKECNST(Y,.C2H,.C2L)
END$;
MACRO DDATCONNODE =
BEGIN
NAME<LEFT> _ 2; CONNODE _ CORMAN();
IF .CONPTR EQL 0
THEN (CONPTR<LEFT> _ CONPTR<RIGHT> _ .CONNODE)
ELSE (CONPTR[CLINK] _ .CONNODE;
CONPTR<RIGHT> _.CONNODE;
);
END$;
REGISTER BASE T1:T2; MAP BASE CONLIST;
%
ROUTINE BUILDS A LIST OF DATA CONSTANTS AND KEEPS COUNT FOR LATER USE
BY THE DATA LIST PROCESSING ROUTINES
%
CONPTR _ 0; COUNT _ 0;
INCR CONITEM FROM .CONLIST TO .CONLIST+.CONLIST<LEFT> BY 2 DO
BEGIN
MAP BASE CONITEM;
REPEAT _ 1; !INITIALIZE
SIGNFLG _ 0;
!SEE IF CONSTANT IS LITERAL OR NUMBER
DAT1: IF .CONITEM[ELMNT] EQL 1
THEN !NUMBER
BEGIN
T1 _ .CONITEM[ELMNT1]; !PTR TO 2 OR 3 WORD SET CONST [* CONST]
IF .T1[ELMNT] NEQ 0
THEN( !SIGHNED CONSTANT
IF .T1[ELMNT] EQL 2 !MINUS
THEN SIGNFLG_-1 ELSE SIGNFLG_0;
T1 _ .T1+1;! TO GET PAST THE SIGN
)
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
ELSE
BEGIN %ITS AN INTEGER OR REAL%
T1 _ .T1[ELMNT2]; !POINTER TO CONSTANT-OPTION
T2 _ .T1[ELMNT]; !PTR TO FIRST CONSTANT OR REPEAT COUNT
IF .T1[ELMNT1] NEQ 0
THEN (!REPEAT FACTOR T2 POINTS TO REPEAT CONST
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
IF .T1[ELMNT1] EQL 1
THEN !NUMBER
(
IF .T2[ELMNT] NEQ 0
THEN (!SIGNED NUMBER
IF .T2[ELMNT] EQL 2
THEN SIGNFLG_-1 ELSE SIGNFLG_0;
T2 _ .T2+1
)
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
)
ELSE !LITERAL
DATCSIZ _ .T2[LITSIZ]
)
ELSE ( %NO REPEAT%
DATCSIZ _ IF .T2[DBLFLG] THEN 2 ELSE 1;
%[1032]% SAVSPACE(.T1<LEFT>,.T1);
);
COUNT _ .COUNT + .DATCSIZ * .REPEAT;
IF .SIGNFLG NEQ 0
THEN IF .T2[VALTP1] EQL INTEG1
THEN T2 _ MAKECNST(INTEGER,0,-.T2[CONST2])
ELSE T2 _ DNEG(.T2,.T2[VALTYPE]); !NEGATE THE NUMBER
%[1032]% END; % CONSTANT OR COMPLEX %
%[1032]% T1 _ .CONITEM[ELMNT1];
%[1032]% SAVSPACE(.T1<LEFT>,.T1);
END
ELSE !LITERAL
BEGIN
T2 _ .CONITEM[ELMNT1]; !PTR TO LITERAL STRING NODE
COUNT _ .COUNT + .T2[LITSIZ];
END;
DDATCONNODE; !BUILD AND LINK A DATA CONSTANT NODE
CONPTR[DATARPT] _ .REPEAT;
CONPTR[DCONST] _ .T2;
END; !OF INCR LOOP
RETURN .COUNT^18+ .CONPTR<LEFT>;
END;
GLOBAL ROUTINE DATASTA=
BEGIN
REGISTER BASE T1;
REGISTER BASE R1:R2;
LOCAL ITEMLIST,CONLIST;
EXTERNAL DATAGEN %(LOC,SIZE)%,SAVSPACE %(SIZE,LOC)%,STK,SP,DATALIST,TYPE,NEWENTRY;
EXTERNAL DATASUBCHK;
!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= !STRING SCAN
!PUTS A STRING OF UP TO 6 SIXBIT CHARACTERS
!IN SIX LEFT JUSTIFIED AND RETURNS IT
BEGIN
EXTERNAL LEXICAL,GSTCSCAN,LOOK4CHAR;
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
GLOBAL ROUTINE OPENCLOSE (OPENCLOSDATA) = ! [1527] Rewritten
! Routine to parse the open keyword list (olist) in OPEN and CLOSE 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.
BEGIN
REGISTER BASE K:N:V;
LOCAL FIRSTP;
LABEL DLP;
BIND VECTOR OPNKWD = UPLIT (
SIXBIT 'ACCESS', ! 0
SIXBIT 'ASSOCI', ! 1
SIXBIT 'BLANK', ! 2
SIXBIT 'BLOCKS', ! 3
SIXBIT 'BUFFER', ! 4
SIXBIT 'CARRIA', ! 5
SIXBIT 'DENSIT', ! 6
SIXBIT 'DEVICE', ! 7
SIXBIT 'DIALOG', ! 8
NDIALOG INDEXES SIXBIT '#DIALO', ! 9
SIXBIT 'DIRECT', ! 10
SIXBIT 'DISPOS', ! 11
NERR INDEXES SIXBIT 'ERR', ! 12
SIXBIT 'FILE', ! 13
SIXBIT 'FILESI', ! 14
SIXBIT 'FORM', ! 15
SIXBIT 'INITIA', ! 16
NIOSTAT INDEXES SIXBIT 'IOSTAT', ! 17
SIXBIT 'MODE', ! 18
SIXBIT 'NAME', ! 19
SIXBIT 'PADCHA', ! 20
SIXBIT 'PARITY', ! 21
SIXBIT 'PROTEC', ! 22
NREADONLY INDEXES SIXBIT '#READO', ! 23
SIXBIT 'RECL', ! 24
SIXBIT 'RECORD', ! 25
SIXBIT 'RECTYP', ! 26
SIXBIT 'STATUS', ! 27
SIXBIT 'TYPE', ! 28
NUNIT INDEXES SIXBIT 'UNIT', ! 29
KWDN INDEXES SIXBIT 'VERSIO'); ! 30
STRUCTURE LHVECTOR [I] = (.LHVECTOR+.I)<18,18>,
RHVECTOR [I] = (.RHVECTOR+.I)<0,18>;
BIND CE = 0, ! character expression
IE = 1, ! integer expression
IV = 4, ! integer variable
AR = 3, ! array name or char expression
LB = 2; ! label
MACRO X (A,B) = A^18 + #B$;
! Syntax of keyword's value and FOROTS keyword number
BIND VECTOR OPNDUM = UPLIT (
X (CE,2), ! ACCESS
X (IV,22), ! ASSOCIATEVARIABLE
X (CE,25), ! BLANK
X (IE,5), ! BLOCKSIZE
X (IE,4), ! BUFFERCOUNT
X (CE,26), ! CARRIAGECONTROL
X (CE,24), ! DENSITY
X (CE,3), ! DEVICE
X (AR,1), ! DIALOG
X ( 0,1), ! DIALOG (without =)
X (AR,10), ! DIRECT
X (CE,15), ! DISPOS
X (LB,37), ! ERR
X (CE,6), ! FILE
X (IE,13), ! FILESIZE
X (CE,27), ! FORM
X (IE,13), ! INITIALSIZE
X (IV,21), ! IOSTAT
X (CE,12), ! MODE
X (AR,1), ! NAME
X (CE,31), ! PADCHAR
X (CE,23), ! PARITY
X (IE,7), ! PROTECTION
X ( 0,35), ! READONLY (without =)
X (IE,14), ! RECL
X (IE,14), ! RECORDSIZE
X (CE,32), ! RECTYPE
X (CE,33), ! STATUS
X (CE,33), ! TYPE
X (IE,36), ! UNIT
X (IE,16)), ! VERSION
LHVECTOR OPNDISP = OPNDUM,
RHVECTOR OPNCODE = OPNDUM;
! Values of keywords, pointers to expression nodes
OWN OPNVAL [KWDN+1];
FIRSTP = -1; ! FIRSTP is true iff we are at first
! item in list
DECR I FROM KWDN 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 ! loop until right paren
BEGIN ! not keyword
K = LEXICAL(.GSTKSCAN); ! look for "KEYWORD="
IF .K EQL 0 ! keyword not found
THEN ! check for DIALOG and READONLY
BEGIN ! not keyword
LOOK4CHAR = (UPLIT ASCIZ 'READONLY')<36,7>;
IF LEXICAL(.GSTSSCAN) NEQ 0
THEN
BEGIN ! READONLY
N = NREADONLY; ! set keyword number
V = -1; ! set keyword value (none)
END ! READONLY
ELSE 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 'DIALOG')<36,7>;
IF LEXICAL(.GSTSSCAN) NEQ 0
THEN
BEGIN ! DIALOG
N = NDIALOG; ! set keyword number
V = -1; ! set keyword value (none)
END ! DIALOG
ELSE
BEGIN ! error
LEXL = LEXEMEGEN();
RETURN ERR0L (UPLIT ASCIZ 'keyword');
END; ! error
END;
END ! not keyword
ELSE
BEGIN ! keyword
N = -1; ! set flag for keyword not found yet
DLP: DECR I FROM KWDN TO 0 DO ! look up keyword in table
IF .K EQL .OPNKWD[.I] THEN (N = .I; LEAVE DLP);
IF .N LSS 0 ! if keyword not found
THEN RETURN FATLEX(.K,E183<0,0>) ! say so and abort statement
ELSE
CASE .OPNDISP[.N] OF SET
% character expression %
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, unVAXish and illegal.
IF .V[VALTYPE] NEQ CHARACTER
THEN IF .V[OPRCLS] EQL DATAOPR THEN %OK%
ELSE IF .V[OPRCLS] EQL ARRAYREF THEN %OK%
ELSE FATLEX(.K,E184<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 V[OPERATOR] = HOLLCONST
ELSE FATLEX(E164<0,0>)
! "Char expression used where
! numeric expression required"
ELSE IF .V[VALTYPE] NEQ INTEGER
THEN V = CNVNODE(.V,INTEGER,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;
% 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)
ELSE FATLEX(UPLIT'array or character expression',.K,E196<0,0>)
ELSE IF .V[OPRSP1] GEQ ARRAYNM1
THEN FATLEX(UPLIT'array or character expression',.K,E196<0,0>)
END;
% int 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;
TES;
END; ! keyword
IF .OPNVAL[.N] NEQ 0 ! if keyword already specified, error
THEN FATLEX (.OPNKWD[.N], E182<0,0>);
! "KEYWRD may only be specified once"
OPNVAL[.N] = .V; ! set value of keyword
FIRSTP = 0; ! not first in list any more
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
![1716] Check that UNIT got specified else return fatal error now
%1716% IF .OPNVAL[NUNIT] EQL 0
%1716% THEN RETURN FATLEX (UPLIT'specified',OPNKWD+NUNIT,E15<0,0>);
! Make a statement node and fill it in
NAME = IDOFSTATEMENT = .OPENCLOSDATA;
NAME<RIGHT> = SORTAB;
N = NEWENTRY(); ! N points to empty statement node
N[IOUNIT] = .OPNVAL[NUNIT]; ! set UNIT=
N[IOERR] = .OPNVAL[NERR]; ! set ERR=
N[IOIOSTAT] = .OPNVAL[NIOSTAT]; ! set IOSTAT=
OPNVAL[NUNIT] = OPNVAL[NERR] = OPNVAL[NIOSTAT] = 0; ! clear values out of table
K = .N[IOUNIT]; ! set UNIT expression parent pointer
IF .K[OPRCLS] NEQ DATAOPR
THEN K[PARENT] = .N;
! Count keywords and copy into their block
V = 0; ! V gets keyword count
DECR I FROM KWDN 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 KWDN 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);
(.V)<LEFT> = .OPNCODE[.I]; ! set Forots code
%1571% IF .K GEQ 0 ! unless DIALOG or READONLY
THEN IF .K[OPRCLS] NEQ DATAOPR ! set parent pointer if subnode
THEN K[PARENT] = .N; ! is an expression
V = .V + 1; ! next keyword
END;
END; ! copy keywords into block
END; ! OPENCLOSE
GLOBAL ROUTINE OPENSTA=
BEGIN
EXTERNAL OPENCLOSE;
OPENCLOSE(OPENDATA);
.VREG
END;
GLOBAL ROUTINE CLOSSTA=
BEGIN
EXTERNAL OPENCLOSE;
OPENCLOSE(CLOSDATA);
.VREG
END;
GLOBAL ROUTINE INQUSTA=
BEGIN
%1662% EXTERNAL
%1662% FATLEX, ! Error message routine
%1662% E210;
%1662% ! Give the NYI error - INQUIRE statement is not yet implemented
%1662% RETURN FATLEX(E210<0,0>);
END; ! of INQUSTA
END
ELUDOM