Trailing-Edge
-
PDP-10 Archives
-
BB-4157E-BM
-
fortran-compiler/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) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION
!AUTHOR: F.J. INFANTE, D. B. TOLMAN/SJW/DCE/TFV/EDS/AHM
MODULE STA1(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4)=
BEGIN
! LEXNAM, FIRST, TABLES, META72, ASHELP
SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE META72.BLI;
REQUIRE ASHELP.BLI;
SWITCHES LIST;
GLOBAL BIND STA1V = 6^24 + 0^18 + 84; ! Version Date: 24-Sep-81
%(
***** 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.
***** End Revision History *****
)%
!THE NUMBER IN COMMENT'S IS THE STATEMENTS LOCATION
!IN THE HASH TABLE .
FORWARD
% 3% DATASTA, !DATA
% 8% PRINSTA, !PRINT
% 18% OPENSTA, !OPEN
% 34% FINDSTA, !FIND
% 39% REWISTA, !REWIND
% 45% RERESTA, !REREAD
% 63% BKSPST, !BACKSPACE OR BACKFILE
% 67% DECOSTA, !DECODE
% 83% CLOSSTA, !CLOSE
% 84% ENDFSTA, !ENDFILE
% 95% ENCOSTA, !ENCODE
%113% TYPESTA; !TYPE
%[760]% GLOBAL ROUTINE ZIOSTK=
!-------------------------------------------------------
! ZERO THE STACK ENTRIES FOR I/O KEYWORDS
!
! STK[2] PTR TO UNIT
! STK[3] PTR TO RECORD
! STK[4] PTR TO FORMAT
! STK[5] PTR TO ERR
! STK[6] PTR TO END
! STK[7] [TR TO IOSTAT
!
! THESE FIELDS ARE FILLED IN AS POSITIONAL OR KEYWORD ARGUMENTS ARE FOUND
!----------------------------------------------------------------
%[760]% BEGIN
%[760]% EXTERNAL STK;
%[760]% INCR CNT FROM 2 TO 7 DO STK[.CNT]_0;
%[760]% END;
%[760]% GLOBAL ROUTINE BLDKORU(UPNT)=
%[760]% BEGIN
%[760]% !---------------------------------------------------
%[760]% ! This routine expects apointer to a choice of:
%[760]% ! constant and optional recordmark expression
%[760]% ! or
%[760]% ! variable and optional recordmark expression or a keylist
%[760]% !-----------------------------------------------
%[760]% EXTERNAL NAME,NEWENTRY,STK,SAVSPACE,BLDVAR,SETUSE,BLDKEY;
%[760]% REGISTER BASE T1;
%[760]% REGISTER BASE R1:R2:R3;
%[760]% MACRO ERR55=(FATLEX(E55<0,0>))$;
%[760]% MAP BASE UPNT;
%[760]%
%[760]% SETUSE _ USE; ! FLAG FOR BLDVAR
%[760]% R1_.UPNT[ELMNT1];
%[760]% IF .UPNT[ELMNT] NEQ 1
%[760]% THEN
%[760]% BEGIN ! VARIABLESPEC OR KEYWORD
%[760]% IF .R1[ELMNT1] NEQ 2
%[760]% THEN
%[760]% BEGIN ! VARIABLE
%[760]% IF (R2_STK[2]_ BLDVAR(.R1[ELMNT])) LSS 0 THEN RETURN .VREG;
% BLDVAR ALLOWS ARRAYS WITHOUT SUBSCRIPTS SO DON'T LET THEM THROUGH HERE %
%[760]% IF .R2<LEFT> EQL IDENTIFIER
%[760]% THEN IF .R2[OPRSP1] EQL ARRAYNM1
%[760]% THEN RETURN FATLEX ( R2[IDSYMBOL], ARPLIT<0,0>, E4<0,0> );
%[760]% END
%[760]% ELSE
%[760]% BEGIN ! KEYSPEC
%[760]% R2_.R1[ELMNT];
%[760]% IF BLDKEY(.R2[ELMNT],.R1[ELMNT2]) LSS 0 THEN RETURN .VREG;
%[760]% END;
%[760]% END
%[760]% ELSE STK[2] _ .R1[ELMNT];
%[760]%
%[760]% IF .R1[ELMNT1] EQL 1
%[760]% THEN
%[760]% BEGIN
%[760]% R3_.R1[ELMNT2];
%[760]% STK[3]_.R3[ELMNT];
%[760]% END;
%[760]%
%[760]% .VREG
%[760]% END; !OF BLDKORU
%[760]% GLOBAL ROUTINE BLDUTILITY(NODEDATA)=
%[760]% BEGIN
%[760]% !---------------------------------------------
%[760]% ! This routine expects a pointer to:
%[760]% ! a constant
%[760]% ! or
%[760]% ! a variable
%[760]% ! or
%[760]% ! a parenthesized list of keywords or a unitspec
%[760]% ! followed by keywords
%[760]% !--------------------------------------
%[760]% EXTERNAL NAME,NEWENTRY,STK,SAVSPACE,BLDVAR,SETUSE,BLDKORU,BLDKEY,BLDKLIST, CGERR;
%[760]% REGISTER BASE R1:R2:R3:T1;
%[760]% LOCAL BASE T2;
%[760]%
%[760]% ZIOSTK(); ! ZERO STK[2]-STK[7]
%[760]% R1_.STK[0];
%[760]% SETUSE_USE;
%[760]% CASE .R1[ELMNT] OF SET
%[760]% CGERR(); ! FOR SPEED
%[760]% BEGIN ! CONSTANT
%[760]% STK[2]_.R1[ELMNT1];
%[760]% END;
%[760]% BEGIN ! VARIABLE
%[760]% STK[2]_BLDVAR(.R1[ELMNT1]);
%[760]% END;
%[760]% BEGIN; ! PARENED LIST
%[760]% R2_.R1[ELMNT1];
%[760]% R3_.R2[ELMNT];
%[760]% T1_.R3[ELMNT1];
%[760]% IF .T1[ELMNT1] EQL 1 THEN RETURN FATLEX( PLIT'ALLOWED',
%[760]% PLIT SIXBIT'#RECORD', E15<0,0>);
%[760]% IF BLDKORU(.R2[ELMNT]) LSS 0 THEN RETURN .VREG;
%[760]% IF .R2[ELMNT1] NEQ 0
%[760]% THEN
%[760]% BEGIN ! KEYSPEC
%[760]% IF BLDKLIST(.R2[ELMNT2]) LSS 0 THEN RETURN .VREG;
%[760]% END;
%[760]% SAVSPACE(.R2<LEFT>,@R2);
%[760]% END;
%[760]% TES;
%[760]%
%[760]% NAME_IDOFSTATEMENT_.NODEDATA; NAME<RIGHT>_SORTAB;
%[760]% T1_NEWENTRY();
%[760]%
%[760]% IF .STK[2] EQL 0
%[760]% THEN RETURN FATLEX(PLIT'SPECIFIED',PLIT SIXBIT'UNIT=',E15<0,0>)
%[760]% ELSE
%[760]% BEGIN
%[760]% R2_.STK[2];
%[760]% IF .R2[VALTYPE] NEQ INTEGER THEN RETURN FATLEX(E55<0,0>);
%[760]% T1[IOUNIT]_.STK[2];
%[760]% END;
%[760]%
%[760]% IF .STK[3] NEQ 0 THEN RETURN FATLEX(PLIT'ALLOWED',PLIT SIXBIT'REC=',E15<0,0>);
%[760]% IF .STK[4] NEQ 0 THEN RETURN FATLEX(PLIT'ALLOWED',PLIT SIXBIT'FMT=',E15<0,0>);
%[760]% T1[IOERR]_.STK[5];
%[760]% T1[IOEND]_.STK[6];
%[760]% T1[IOIOSTAT]_.STK[7];
%[760]% SAVSPACE(.R1<LEFT>,@R1);
%[760]%
%[760]% .VREG
%[760]% END;
%[760]%
%[760]% GLOBAL ROUTINE BLDIO1(NODEDATA)= !BUILDS AN IO NODE FOR TYPE,PRINT,PUNCH,ACCEPT,BACKSPACE,BACKFILE,ENDFILE,SKIPFILE,SKIPRECORD
%[760]% BEGIN
%[760]% REGISTER BASE T1;REGISTER BASE R1:R2:R3;
%[760]% EXTERNAL STK,SAVSPACE %(SIZE, LOC)%,BLDFORMAT %(FPNT)%,DATALIST %(LPNT)%,
%[760]% NEWENTRY %()%,TYPE,IODOXPN,BLDKLIST;
%[760]% LOCAL F,IOL;
%[760]% MACRO ERR15A(X,Y) = RETURN FATLEX(Y,X,E15<0,0>)$;
%[760]% !----------------------------------------------------------------------------------------------------------
%[760]% ! This routine expects a pointer in STK[0] to a
%[760]% ! formatid or keylist
%[760]% ! followed by an optional iolist
%[760]% !----------------------------------------------------------------------------------------------------------
%[760]% IOL_0;
%[760]% ZIOSTK();
%[760]%
%[760]% IF .NODEDATA EQL WRITDATA THEN TYPE_WRITEE ELSE TYPE_READD;
%[760]% FLAG_-1;
%[760]% R1_.STK[0];
%[760]% R2_.R1[ELMNT1];
%[760]%
%[760]% IF .R1[ELMNT] EQL 1
%[760]% THEN
%[760]% BEGIN
%[760]% IF BLDFORMAT(.R1[ELMNT1]) LSS 0 THEN RETURN .VREG;
%[760]% IF .R2[ELMNT2] NEQ 0
%[760]% THEN
%[760]% BEGIN
%[760]% R3_.R2[ELMNT3];
%[760]% IF (IOL_DATALIST(.R3[ELMNT])) LSS 0 THEN RETURN .IOL;
%[760]% END;
%[760]% SAVSPACE(.R2<LEFT>,@R2);
%[760]% END
%[760]% ELSE
%[760]% BEGIN
%[760]% IF BLDKLIST(.R1[ELMNT1]) LSS 0 THEN RETURN .VREG;
%[760]% IF .R2[ELMNT1] NEQ 0
%[760]% THEN
%[760]% BEGIN
%[760]% R3_.R2[ELMNT2];
%[760]% IF (IOL_DATALIST(.R3[ELMNT1])) LSS 0 THEN RETURN .VREG;
%[760]% SAVSPACE(.R3<LEFT>,@R3);
%[760]% END;
%[760]% END;
%[760]%
%[760]% NAME_IDOFSTATEMENT_.NODEDATA;NAME<RIGHT>_SORTAB;T1_NEWENTRY();
%[760]%
%[760]% IF .STK[2] NEQ 0
%[760]% THEN ERR15A(PLIT SIXBIT'UNIT=',PLIT'ALLOWED')
%[760]% ELSE T1[IOUNIT]_0;
%[760]%
%[760]% IF .STK[3] NEQ 0
%[760]% THEN ERR15A(PLIT SIXBIT'REC=',PLIT'ALLOWED')
%[760]% ELSE T1[IORECORD]_0;
%[760]%
%[760]% IF .STK[4] EQL 0
%[1076]% ! Formatspec is not optional for type, reread, etc.
%[1076]% THEN ERR15A(PLIT SIXBIT'FMT=',PLIT'OPTIONAL')
%[1076]% ELSE T1[IOFORM]_.STK[4];
%[760]%
%[760]% T1[IOERR]_.STK[5];
%[760]% T1[IOEND]_.STK[6];
%[760]% T1[IOIOSTAT]_.STK[7];
%[760]% T1[IOLIST]_.IOL<LEFT>;
%[760]%
%[760]% IODOXPN(.T1);
%[760]% SAVSPACE(.R1<LEFT>,@R1);
%[760]% RETURN .T1
%[760]% END;
GLOBAL ROUTINE PRINSTA=
BEGIN
REGISTER BASE T1;
!SEMANTIC ANALYSIS BEGINS
T1 _ BLDIO1(WRITDATA); !BUILDS THE PRINT STAEMENT IO NODE
T1[IOUNIT]_MAKECNST(INTEGER,0,-3); !PRINTID
.VREG
END;
GLOBAL ROUTINE TYPESTA=
BEGIN
REGISTER BASE T1;
!SEMANTIC ANALYSIS BEGINS
T1 _ BLDIO1(WRITDATA);
T1[IOUNIT] _ MAKECNST(INTEGER,0,-1); !TYPE ID
.VREG
END;
%[760]% GLOBAL ROUTINE BLDEDCODE(NODEDATA)=
%[760]% BEGIN
%[760]% REGISTER BASE T1;REGISTER BASE R1:R2; LOCAL BASE R3;
%[760]% EXTERNAL STK,SAVSPACE %(SIZE,LOC)%, BLDFORMAT %(FPNT)%,BLDVAR %(VPNT)%,
%[760]% IODOXPN,DATALIST %(LPNT)%,TYPE,CORMAN %()%,NEWENTRY %()%,
%[760]% BLDKEY %(KPNT)%,ZIOSTK %()%;
%[760]% EXTERNAL SETUSE,STMNDESC,BLDKLIST;
%[760]% MACRO ERR15(X)=RETURN FATLEX( INTGPLIT<0,0>, X, E15<0,0> )$;
%[760]% MACRO ERR15A(X,Y)=RETURN FATLEX (Y,X,E15<0,0>)$;
%[760]% LOCAL CH,F,B;
%[760]% !----------------------------------------------------------------------------------------------------------
%[760]% ! This routine expects a pointer to
%[760]% ! character count, formatid, buffer
%[760]% ! followed by an optional keylist
%[760]% ! An iolist is optional
%[760]% !----------------------------------------------------------------------------------------------------------
%[760]% ZIOSTK(); ! ZERO STK[2] THRU STK[7]
%[760]% R1_.STK[0];
%[760]% R2_.R1[ELMNT];
%[760]% R3_.R2[ELMNT];
%[760]% IF .R3[VALTYPE] NEQ INTEGER THEN ERR15 (PLIT SIXBIT 'COUNT');
%[760]% CH_@R3;
%[760]% !
%[760]% !BLDFORMAT RETURNS RESULTS IN STK[4]
%[760]% !
%[760]% FLAG _ 1; ! NO END= OR ERR= FLAG TO BLDFORMAT
%[760]% IF BLDFORMAT(R2[ELMNT1]) LSS 0 THEN RETURN .VREG; !NOTE NON-DOTTED PARAMETER
![1042] Prohibit list directed encode/decode
%[1042]% IF (F_.STK[4]) EQL -1 THEN RETURN FATLEX(KEYWRD(@STMNDESC),E101<0,0>);
%[760]%
%[760]% SETUSE _ IF .TYPE EQL WRITEE THEN SETT ELSE USE; !FLAG FOR BLDVAR
%[760]% IF (B_BLDVAR(.R2[ELMNT3])) LSS 0 THEN RETURN .VREG;
%[760]% IF .R2[ELMNT4] NEQ 0 ! TEST FOR KEYWORDS SPECIFIED
%[760]% THEN
%[760]% BEGIN
%[760]% IF BLDKLIST(.R2[ELMNT5]) LSS 0 THEN RETURN .VREG
%[760]% END;
%[760]% SAVSPACE(.R2<LEFT>,@R2); ! FREE SOME SPACE
%[760]% IF .R1[ELMNT1] NEQ 0
%[760]% THEN
%[760]% BEGIN
%[760]% R2_.R1[ELMNT2];
%[760]% IF (R3 _ DATALIST(.R2[ELMNT1])) LSS 0 THEN RETURN .VREG;
%[760]% SAVSPACE(.R2<LEFT>,@R2)
%[760]% END
%[760]% ELSE R3 _ 0; ! NO IOLIST
%[760]%
%[760]% NAME_IDOFSTATEMENT_.NODEDATA;NAME<RIGHT>_SORTAB;T1_NEWENTRY();
%[760]%
%[760]% ! CHECK KEYWORDS AND FILL IN SOURCE FIELDS
%[760]%
%[760]% IF .STK[2] NEQ 0
%[760]% THEN
%[760]% ERR15A(PLIT SIXBIT'UNIT=',PLIT'ALLOWED')
%[760]% ELSE
%[760]% T1[IOVAR]_.B;
%[760]%
%[760]% IF .STK[3] NEQ 0
%[760]% THEN
%[760]% ERR15A(PLIT SIXBIT'FMT=',PLIT'ALLOWED')
%[760]% ELSE
%[760]% T1[IOCNT]_.CH;
%[760]%
%[760]% T1[IOFORM]_.STK[4];
%[760]% T1[IOERR]_.STK[5];
%[760]% T1[IOEND]_.STK[6];
%[760]% T1[IOIOSTAT]_.STK[7];
%[760]% T1[IOLIST]_.R3<LEFT>;
%[760]% IODOXPN(.T1); !DO DOXPN FOR IOLIST
%[760]% SAVSPACE(.R1<LEFT>,@R1);
%[760]% .VREG
%[760]% END;
GLOBAL ROUTINE ENCOSTA=
BEGIN
!SEMANTIC ANALYSIS BEGINS
TYPE _ WRITEE; !FLAG FOR DATALIST
BLDEDCODE(ENCODATA); !BUILD AN ENCODE STATEMENT NODE
.VREG
END;
GLOBAL ROUTINE DECOSTA=
BEGIN
!SEMANTIC ANALYSIS BEGINS
TYPE _ READD; ! FLAG FOR DATALIST
BLDEDCODE(DECODATA); !BUILD A DECODE STATEMENT NODE
.VREG
END;
GLOBAL ROUTINE RERESTA=
BEGIN
REGISTER BASE T1;
EXTERNAL STMNDESC,FATLEX,E101;
!SEMANTIC ANALYSIS BEGINS
!
![1014] list directed reread is now legal, use readdata not reredata
%[1014]% T1 _ BLDIO1(READDATA);
T1[IOUNIT] _ MAKECNST(INTEGER,0,-6); !RE READ ID
.VREG
END;
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=
BEGIN
!SEMANTIC ANALYSIS BEGINS
BLDUTILITY(REWIDATA); !BUILD A REWIND STATEMENT NODE
.VREG
END;
GLOBAL ROUTINE ENDFSTA=
BEGIN
!SEMANTIC ANALYSIS BEGINS
BLDUTILITY(ENDFDATA); !BUILD AN ENDFILE STATEMENT NODE
.VREG
END;
%[760]% GLOBAL ROUTINE FINDSTA=
%[760]% BEGIN
%[760]% REGISTER BASE T1; REGISTER BASE R1:R2:R3;
%[760]% EXTERNAL STK,SAVSPACE %(SIZE,LOC)%,BLDVAR %(VPNT)%,NEWENTRY %()%;
%[760]% EXTERNAL SETUSE,ZIOSTK,BLDKORU,BLDKLIST;
%[760]% MACRO ERR15(X) = RETURN FATLEX( INTGPLIT<0,0>, X, E15<0,0> ) $;
%[760]% MACRO ERR15A(X,Y) = RETURN FATLEX(Y,X,E15<0,0>)$;
%[760]% !SEMANTIC ANALYSIS BEGINS
%[760]% !----------------------------------------------------------------------------------------------------------
%[760]% ! This routine expects apointer to
%[760]% ! a unitspec with optional recordmark expression
%[760]% ! or a keylist
%[760]% ! followed by an optional keylist
%[760]% !----------------------------------------------------------------------------------------------------------
%[760]% ZIOSTK();
%[760]% SETUSE _ USE;
%[760]% R1_.STK[0];
%[760]% R2_.R1[ELMNT];
%[760]%
%[760]% IF BLDKORU(.R1[ELMNT]) LSS 0 THEN RETURN .VREG;
%[760]%
%[760]% SAVSPACE(.R2<LEFT>,@R2);
%[760]%
%[760]% IF .R1[ELMNT1] NEQ 0
%[760]% THEN
%[760]% BEGIN
%[760]% IF BLDKLIST(.R1[ELMNT2]) LSS 0 THEN RETURN .VREG;
%[760]% END;
%[760]%
%[760]% SAVSPACE(.R1<LEFT>,@R1);
%[760]%
%[760]% NAME_IDOFSTATEMENT_FINDDATA;NAME<RIGHT>_SORTAB;T1_NEWENTRY();
%[760]%
%[760]% IF .STK[2] EQL 0
%[760]% THEN ERR15A(PLIT SIXBIT 'UNIT=', PLIT 'SPECIFIED')
%[760]% ELSE
%[760]% BEGIN
%[760]% R2_.STK[2];
%[760]% IF .R2[VALTYPE] NEQ INTEGER THEN RETURN FATLEX(E55<0,0>);
%[760]% T1[IOUNIT]_.STK[2];
%[760]% END;
%[760]%
%[760]% IF .STK[3] EQL 0
%[760]% THEN ERR15A(PLIT SIXBIT 'REC=', PLIT 'SPECIFIED')
%[760]% ELSE T1[IORECORD]_.STK[3];
%[760]%
%[760]% IF .STK[4] NEQ 0
%[760]% THEN ERR15A(PLIT SIXBIT 'FMT=', PLIT 'ALLOWED')
%[760]% ELSE T1[IOFORM]_0;
%[760]%
%[760]% T1[IOERR]_.STK[5];
%[760]% T1[IOEND]_.STK[6];
%[760]% T1[IOIOSTAT]_.STK[7];
%[760]% .VREG
%[760]% END;
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
[email protected][0]; !T1_LOC(DATASPEC OR LIST A,LINEND)
INCR DAT FROM .T1 TO .T1+.T1<LEFT> DO
BEGIN !PROCESS LIST OF DATA SPECIFICATIONS
MAP BASE DAT;
R1 _ .DAT[ELMNT]; !PTR TO 2 ITEM LIST - 1.DATALIST PTR
! 2.CONLIST PTR
T1 _ .R1[ELMNT1]; !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
ITEMLIST _ DATALIST(.R1[ELMNT]); !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)=
BEGIN
!----------------------------------------------------------------------------------------------------------
!THIS ROUTINE SCANS THE PARAMETERS OF THE open or close STATEMENTS
!FOR THE UNIQUE PARAMETER NAMES SPECIFIED below IN THE PARAM
!PLIT. FOR EACH UNIQUE PARAMETER NAME THERE IS ONLY ONE OF
!SIX POSSIBLE PARAMETER TYPES WHICH IS LEGAL. THESE ARE SPECIFIED
!BY THE SECOND ENTRY OF EACH SUBPLIT AS: CONSTANT OR VARIABLE (0),
!VARIABLE OR LITERAL (1), LITERAL OR ARRAY NAME (2), VARIABLE (3),
!OR A UNIQUE NAME (4). THESE PARAMETERS, AFTER BEING SCANNED
!ARE PLACED IN A PSEUDO-OPEN NODE ON THE STACK in the form
!PARAMETER NUMBER^18+LOC.
! The first parameter is handled differently to allow a default
! unit (without the UNIT=). This can cause problems with
! DIALOG or READONLY since these look like variables. In these
! cases an error is reported.
!----------------------------------------------------------------------------------------------------------
OWN BASE PT;
REGISTER BASE R1:T1:T2;
EXTERNAL FATLEX;
EXTERNAL E143;
EXTERNAL LEXEMEGEN %()%, LSAVE, LEXL, STK,SP,SYNTAX %(META)%,
BLDVAR %(VPNT)%, CORMAN %()%, NEWENTRY %()%,STRNGSCAN;
%[1005]% EXTERNAL LEXICAL,GSTCSCAN,LOOK4CHAR,CGERR;
EXTERNAL NONIOINIO; ! FLAG FOR LABREF THRU LEXICAL
EXTERNAL LABELS %()%; ! SET LOOK4LABELS
%[1045]% EXTERNAL NOLABELS; !to turn off the look4label flag
EXTERNAL E34; ! DUPLICATE ERR= PARAMETER
LABEL OPEN1,OPEN2;
%1124% LOCAL PEXPRNODE IOS;
EXTERNAL SETUSE,NAMREF;
%1124% EXTERNAL NAMSET;
LOCAL OARGID; !OPENARG ID
LOCAL BASE ERRLAB; ! ERR= LABEL
%[1005]% LOCAL FIRSTP; ! 1 if first open parameter
%[1005]% BIND NKEYS = 32; ! size of gotparam array - largest arg type number
%[1005]% OWN GOTPARAM[NKEYS]; ! gotparam[.oargid] = 1 if specified
%[1005]% ! dialog is gotparam[0]
%[1005]% ! dialog= is gotparam[dialog]
%[1005]% LOCAL PNAME; ! sixbit parameter name
MACRO CHKCTYPE(X)=
BEGIN ! give error if constant is not integer or octal
PT _ .X;
IF .PT[VALTYPE] NEQ INTEGER
AND .PT[VALTYPE] NEQ OCTAL
THEN RETURN FATLEX ( PLIT SIXBIT'VALUE',E94<0,0>);
END$;
MACRO CHKTYPE(X)=
BEGIN ! give error if variable is not integer
PT _ .X;
IF .PT[VALTYPE] NEQ INTEGER
THEN RETURN FATLEX ( PT[IDSYMBOL],E94<0,0>);
END$;
MACRO CHKVTYP(X)=
BEGIN ! give error if variable is logical
PT_.X;
IF .PT[VALTYPE] EQL LOGICAL
THEN RETURN FATLEX ( PT[IDSYMBOL],E94<0,0>);
END$;
MACRO
![760] ADD NEW KEYWORDS FOR FORTRAN-77
%[760]% READON = #35$, ! argid for readonly
%[760]% UNITP = #36$, ! argid for unit
%[760]% ERREQ = #37$, ! ARGID FOR ERR=
%[760]% IOSEQ = #21$, ! ARGID FOR IOSTAT=
DIALOG = 1$, ! argid for dialog
%1124% ASSVAR = #22$, ! ARGID for ASSOCIATEVARIABLE=var
ACCESS(I) = (PARAM[I]+1)<LEFT> $,
ARGID(I) = (PARAM[I]+1)<RIGHT> $,
OPENACCESS = 0,0,0,18$, !ACESSS MODE
OPENARGID = 18,18$, !TYPE OF ARGUMENT
![1016] report names of misspelled OPEN/CLOSE parameters
%[1016]% ERR15(X)=(PT_X;RETURN FATLEX(PLIT'OPEN/CLOSE parameter',PT,E15<0,0>))$;
! parameter has already been defined error
%[1005]% MACRO ERR34(X) = RETURN FATLEX (PLIT 'as an OPEN/CLOSE Parameter',
%[1005]% .X,
%[1005]% E34<0,0>)$;
MACHOP BLT=#251;LOCAL RQD;
![760] ADD NEW KEYWORDS
%[760]% BIND NUMPARAM = 30; ! number of keywords in table
! this table of keywords has two word entries:
! sixbit name of keyword
! type of args expected ,, arg type code for arg block
!
! type of args expected is used in the case statement:
! 0 - constant or variable
! 1 - variable or literal
! 2 - literal or array name
! 3 - variable
! 4 - handled specially
BIND PARAM=PLIT( ! CONST VAR LIT NAME ARRAY NULL
%1% SIXBIT'UNIT ',0 ^18+ #36 , ! X X
%2% SIXBIT'FILE ',1 ^18+ #6 , ! X X
%3% SIXBIT'RECORD',0 ^18+ #14 , ! X X
%4% SIXBIT'RECL ',0 ^18+ #14 , ! X X
%5% SIXBIT'ASSOCI',3 ^18+ #22 , ! X
%6% SIXBIT'IOSTAT',3 ^18+ #21 , ! X
%7% SIXBIT'DIALOG',2 ^18+ #1 , ! X X X
%8% SIXBIT'NAME ',2 ^18+ #1 , ! X X X
%9% SIXBIT'DEVICE',1 ^18+ #3 , ! X X
%10% SIXBIT'ACCESS',1 ^18+ #2 , ! X X
%11% SIXBIT'MODE ',1 ^18+ #12 , ! X X
%12% SIXBIT'PROTEC',0 ^18+ #7 , ! X X
%13% SIXBIT'DIRECT',2 ^18+ #10 , ! X X
%14% SIXBIT'DISPOS',1 ^18+ #15 , ! X X
%15% SIXBIT'FILESI',0 ^18+ #13 , ! X X
%16% SIXBIT'INITIA',0 ^18+ #13 , ! X X
%17% SIXBIT'BLOCKS',0 ^18+ #5 , ! X X
%18% SIXBIT'BUFFER',0 ^18+ #4 , ! X X
%19% SIXBIT'VERSIO',0 ^18+ #16 , ! X X
!%% SIXBIT'LIMIT ',0 ^18+ #11 , ! X X
!%% SIXBIT'REELS ',2 ^18+ #17 , ! X X
!%% SIXBIT'MOUNT ',2 ^18+ #20 , ! X X
%20% SIXBIT'PARITY',1 ^18+ #23 , ! X X
%21% SIXBIT'DENSIT',1 ^18+ #24 , ! X X
%22% SIXBIT'BLANK ',1 ^18+ #25 , ! X X
%23% SIXBIT'CARRIA',1 ^18+ #26 , ! X X
%24% SIXBIT'FORM ',1 ^18+ #27 , ! X X
!%% SIXBIT'LABELS',1 ^18+ #30 , ! X X
%25% SIXBIT'PADCHA',1 ^18+ #31 , ! X X
%26% SIXBIT'RECTYP',1 ^18+ #32 , ! X X
%27% SIXBIT'STATUS',1 ^18+ #33 , ! X X
%28% SIXBIT'TYPE ',1 ^18+ #33 , ! X X
!%% SIXBIT'TAPEMO',1 ^18+ #34 , ! X X
%29% SIXBIT'READON',4 ^18+ #35 , ! HANDLED SEPARATELY
%30% SIXBIT'ERR ',4 ^18+ #37 ! HANDLED SEPARATELY %[V5]%
);
BIND OPENPLIT= PLIT'OPEN';
ROUTINE GETVARB =
BEGIN ! scan a variablespec, do not allow array names
IF R1_SYNTAX(VARIABLESPEC) LSS 0 THEN RETURN .R1;
R1_.STK[.SP];
IF (R1 _ STK[.SP]_BLDVAR(@R1)) LSS 0 THEN RETURN .R1;
% BLDVAR ALLOWS ARRAYS WITHOUT SUBSCRIPTS SO DON'T LET THEM THROUGH HERE %
IF .R1<LEFT> EQL IDENTIFIER
THEN IF .R1[OPRSP1] EQL ARRAYNM1
THEN RETURN FATLEX ( R1[IDSYMBOL], ARPLIT<0,0>, E4<0,0> );
END; %GETVARB%
!SEMANTIC ANALYSIS BEGINS
SETUSE _ USE; ! BLDVAR FLAG - ALL VARIABLES HERE ARE REFERENCE
RQD _ 0; !RESET RQUIRED ARG (UNIT)
%[760]% IOS _ 0; ! RESET IOSTAT= PTR
ERRLAB _ 0; ! RESET ERR= LABEL
%1124% INCR I FROM 0 TO NKEYS-1 DO GOTPARAM[.I] _ 0; ! no params yet
%[1005]% FIRSTP _ 1; ! looking for first param
LEXL_LEXEMEGEN(); STK[0]_0; SP_-1; ! get any lexeme
IF .LEXL NEQ LPAREN^18 THEN ERR0L(LPARPLIT); ! not a '(' - error
! scan a parameter then look for the ','
DO
BEGIN
LABEL UNITSKIP;
UNITSKIP:
BEGIN
%[1005]% IF .FIRSTP NEQ 0 ! this is the first parameter - maybe default unit
%[1005]% THEN
%[1005]% BEGIN ! first parameter - constant, variable, or keyword
%[1005]% LEXL _ LEXEMEGEN(); ! get any lexeme
%[1005]% LSAVE _ -1; ! save this lexeme
%[1005]% IF .LEXL<LEFT> EQL CONSTLEX
%[1005]% THEN
%[1005]% BEGIN ! default unit= constant
%[1005]% CHKCTYPE(LEXL<RIGHT>); ! either integer or octal
%[1005]% RQD _ .LEXL<RIGHT>; ! save unit specifier
%[1005]% LSAVE _ 0; ! get next lexeme
%[1005]% OARGID _ UNITP; ! identify this as default unit
%[1005]% LEAVE UNITSKIP; ! go on to next param
%[1005]% END;
%[1005]% IF .LEXL<LEFT> EQL IDENTIFIER
%[1005]% THEN
%[1005]% BEGIN ! variable or keyword
%[1005]% R1 _ .LEXL; ! store away current lexeme
%[1005]% LSAVE _ 0; ! prepare to get another lexeme
%[1005]% LOOK4CHAR _ "="; ! only get an '='
%[1005]% IF LEXICAL( .GSTCSCAN) EQL 0 ! if no '='
%[1005]% THEN
%[1005]% BEGIN ! default unit = variable
%[1005]% LSAVE _ -1; ! don't get another lexeme
%[1005]% CHKTYPE(LEXL<RIGHT>); ! check for integer variable
%[1005]% IF (R1 _ GETVARB()) LSS 0 THEN RETURN .R1; ! error if not variablespec
%[1005]% RQD _ .STK[.SP]<RIGHT>; ! set up unit spec
%[1005]% SP _ .SP - 1; ! remove from stack
%[1005]% OARGID _ UNITP; ! identify it as a unit
%[1005]% LEAVE UNITSKIP;
%[1005]% END
%[1005]% ELSE
%[1005]% BEGIN ! keyword = value
%[1005]% R1 _ .R1[IDSYMBOL]; ! keyword name
%[1005]% LSAVE _ -1;
%[1005]% END;
%[1005]% END
![1016] report names of misspelled OPEN/CLOSE parameters
%[1016]% ELSE ERR15(.LEXL);
%[1005]% END
%[1005]% ELSE
%[1005]% BEGIN ! after first parameter
%[1005]% LEXL_STRNGSCAN();
%[1005]% IF .LEXL EQL 0 THEN ( LEXL_LEXEMEGEN();EXITLOOP ); ! NO NAME TO BE FOUND
%[1005]% R1_.LEXL;
%[1005]% END;
OPEN1:
BEGIN ! try to match a keyword
INCR I FROM 0 TO ( NUMPARAM-1 ) * 2 BY 2 DO
BEGIN
IF .R1 EQL @PARAM[.I] THEN (OARGID_.ARGID(.I);PNAME _ PARAM[.I];R1 _ .ACCESS(.I);LEAVE OPEN1 );
END;
![1016] report names of misspelled OPEN/CLOSE parameters
%[1016]% ERR15(.R1);
END ; %OPEN1%
IF .OARGID EQL UNITP THEN RQD_-1; !SET REQUIRED FLAG
%[1005]% IF .FIRSTP EQL 0
%[1005]% THEN
%[1005]% BEGIN ! first param has already parsed through the '='
%[1005]% LEXL_LEXEMEGEN();
%[1005]% IF .LEXL NEQ EQUAL^18 THEN
![1005] DIALOG AND READONLY WITHOUT ARGUMENTS
%[1005]% (IF .OARGID EQL DIALOG THEN ! DIALOG OR READONLY
%[1005]% (STK[SP_.SP+1]<WHOLE>_DIALOG^18; ! SET TO DIALOG WITH 0 PTR
%[1005]% OARGID _ 0;
%[1005]% LSAVE_-1; ! DON'T GET ANOTHER LEXEME
%[1005]% LEAVE UNITSKIP) ! ON TO NEXT PARAMETER
%[1005]% ELSE IF .OARGID EQL READON THEN ! READONLY
%[1005]% (STK[SP_.SP+1]<WHOLE>_READON^18; ! SET TO READONLY WITH 0 PTR
%[1005]% LSAVE_-1; ! DON'T GET LEXEME
%[1005]% LEAVE UNITSKIP) ! ON TO NEXT PARAMETER
%[1005]% ELSE ERR0L(PLIT'"="');
%[1005]% );
%[1005]% END;
IF .OARGID EQL ERREQ
THEN BEGIN ! PROCESS ERR= LABEL
LABELS (); ! SET "LABEL REQUIRED" SWITCH
NONIOINIO _ 1; ! EXECUTABLE LABEL IN IO STATEMENT OK
ERRLAB _ LEXEMEGEN ();
![1045] reset NONIOINIO and LOOK4LABELS in case we had err='foo', etc.
%[1045]% NONIOINIO _ 0;
%[1045]% NOLABELS(); ! resets look4label flag
![1030] make sure we have a label not a literal, etc.
%[1030]% IF .ERRLAB<LEFT> NEQ LABELEX THEN RETURN FATLEX(PLIT'a label',PLIT SIXBIT'ERR=',E15<0,0>);
LSAVE _ 0; ! GET NEXT LEXEME
LEAVE UNITSKIP; ! DON'T PUT ANYTHING IN STK
END;
LEXL_LEXEMEGEN(); LSAVE _ -1;
CASE .R1 OF SET
BEGIN !CONSTANT OR VARIABLE
IF .LEXL<LEFT> EQL CONSTLEX
THEN (CHKCTYPE(LEXL<RIGHT>);
STK[SP_.SP+1]_.LEXL<RIGHT>;
LSAVE _ 0)
ELSE IF .LEXL<LEFT> EQL IDENTIFIER THEN
BEGIN
CHKTYPE(LEXL<RIGHT>); !MAKE SURE ARG IS INTEGER
IF GETVARB() LSS 0 THEN RETURN .VREG
END ELSE ERR0L(PLIT'constant or variable');
IF .RQD EQL -1 THEN(RQD _ .STK[.SP]<RIGHT>;SP_.SP-1;LEAVE UNITSKIP % DON'T SET OPENARGID%)
END;
BEGIN !VARIABLE OR LITERAL
IF .LEXL<LEFT> EQL LITSTRING THEN (STK[SP_.SP+1]_.LEXL<RIGHT>; LSAVE _ 0)
ELSE IF .LEXL<LEFT> EQL IDENTIFIER THEN
BEGIN
CHKVTYP(LEXL<RIGHT>); !MAKE SURE ARG TYPE IS VALID
IF GETVARB() LSS 0 THEN RETURN .VREG
END ELSE ERR0L (PLIT'variable or literal');
END;
BEGIN !LITERAL OR ARRAY NAME
IF .LEXL<LEFT> EQL LITSTRING THEN STK[SP_.SP+1]_.LEXL<RIGHT>
ELSE IF .LEXL<LEFT> EQL IDENTIFIER THEN
BEGIN
R1_@LEXL;
IF .R1[OPRSP1] NEQ ARRAYNM1
THEN RETURN FATLEX(PLIT'array',R1[IDSYMBOL],E15<0,0>)
ELSE STK[SP_.SP+1]_@R1;
NAMREF ( ARRAYNM1, .R1 )
END ELSE ERR0L (PLIT 'literal or array name');
LSAVE _ 0;
END;
BEGIN !VARIABLE
IF .LEXL<LEFT> EQL IDENTIFIER THEN
BEGIN
CHKTYPE(LEXL<RIGHT>); !MAKE SURE ARG IS INTEGER
!GIVE WARNING FOR SUBROUTINE PARAMETER USED AS ASSOCIATE VAR
T1_.LEXL;
%1124% IF .OARGID EQL ASSVAR AND .T1[OPR1] EQL FMLVARFL
THEN WARNERR(.ISN,E143<0,0>);
IF GETVARB() LSS 0 THEN RETURN .VREG
END ELSE ERR0L(PLIT'variable');
![760] Process IOSTAT=
%[760]% IF .OARGID EQL IOSEQ
%[760]% THEN
%[760]% BEGIN
%[760]% IOS _ .STK[.SP]<RIGHT>;
%1124% NAMSET(.IOS[OPRSP1],.IOS); ! IOSTAT clobbers variables
%[760]% SP _ .SP - 1;
%[760]% LEAVE UNITSKIP;
%[760]% END;
%1124% IF .OARGID EQL ASSVAR
%1124% THEN
%1124% BEGIN
%1124% REGISTER BASE ASS;
%1124% ASS_.STK[.SP]<RIGHT>; ! Get the STE
%1124% NAMSET(.ASS[OPRSP1],.ASS) ! Mark it as stored into
%1124% END
END
TES;
STK[.SP]<OPENARGID>_.OARGID;
END; % OF UNIT SKIP %
%[1005]% IF .GOTPARAM[.OARGID] NEQ 0 THEN ERR34(PNAME);
%[1005]% GOTPARAM[.OARGID] _ 1;
%[1005]% FIRSTP _ 0; ! done with first parameter
IF .LSAVE NEQ 0 THEN LSAVE _ 0 ELSE LEXL _ LEXEMEGEN();
END WHILE .LEXL<LEFT> EQL COMMA;
IF .LEXL NEQ RPAREN^18 THEN ERR0L(RPARPLIT);
IF LEXEMEGEN() NEQ LINEND^18 THEN ERR0L(PLIT'linend');
IF .RQD EQL 0 THEN
RETURN FATLEX(PLIT 'defined',PLIT SIXBIT'UNIT',E15<0,0>);
IF .SP GEQ 0
THEN(
NAME<LEFT>_.SP+1;R1_CORMAN();
T1<LEFT>_STK[0];T1<RIGHT>_.R1;T2_.R1+.SP;BLT(T1,0,T2);
)
ELSE R1 _ 0;
NAME_IDOFSTATEMENT_.OPENCLOSDATA;NAME<RIGHT>_SORTAB;T1_NEWENTRY();
T1[OPSIZ]_.SP+1;T1[OPLST]_.R1; T1[IOUNIT] _ .RQD;
T1 [IOERR] _ .ERRLAB<RIGHT>;
%[760]% T1[IOIOSTAT] _ .IOS<RIGHT>;
SP _ -1;
.VREG
END;
GLOBAL ROUTINE OPENSTA=
BEGIN
EXTERNAL OPENCLOSE;
OPENCLOSE(OPENDATA);
.VREG
END;
GLOBAL ROUTINE CLOSSTA=
BEGIN
EXTERNAL OPENCLOSE;
OPENCLOSE(CLOSDATA);
.VREG
END;
END
ELUDOM