Trailing-Edge
-
PDP-10 Archives
-
BB-4157E-BM
-
fortran-compiler/sta0.bli
There are 26 other files named sta0.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) 1973,1981 BY DIGITAL EQUIPMENT CORPORATION
!AUTHOR: F.J. INFANTE/HPW/ D. B. TOLMAN/DCE/TFV
MODULE STA0(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN
SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE META72.BLI;
REQUIRE ASHELP.BLI;
SWITCHES LIST;
GLOBAL BIND STA0V = 6^24 + 0^18 + 55; ! Version Date: 27-Jul-81
%(
***** Begin Revision History *****
44 ----- ----- CATCH ILLEGAL LIST DIRECTED RANDOM ACCESS
45 ----- ----- MOVE DO INDEX MODIFICATION CHECK TO NAMSET SO THAT
IT WILL GET ALL CASES OF MODIFICATION
46 336 17259 CHECK FOR ILLEGAL I/O LIST WITH NAMELIST
***** Begin Version 5B *****
47 742 ----- STOP/PAUSE STATEMENTS NOW TAKE DIGIT STRINGS
INSTEAD OF OCTAL STRINGS
48 745 ----- ARGUMENT LIST COULD NOT BE .GTR. 124 - FIX IT, (DCE)
***** Begin Version 6 *****
49 760 TFV 1-Oct-79 ------
Rewrite RWBLD to accept either positional (old style) or keyword
(new style) control information lists
50 766 DCE 14-May-80 -----
Give error messages for the following:
1. GO TO A where A is dimensioned
2. GO TO A(I) where A is dimensioned
3. ASSIGN 10 TO A(I) where A is dimensioned
54 1076 TFV 8-Jun-81 ------
Allow list-directed I/O without an iolist.
55 1114 CKS 22-Jun-81 -----
Fix check in RWBLD for namelist IO without IO list. It was using
R2 as if it contained a format statement pointer; make it be true.
***** End Revision History *****
)%
!THE NUMBER IN COMMENT'S IS THE STATEMENTS LOCATION
!IN THE HASH TABLE .
FORWARD
MULTIASGN,
ASSIGNMENT, ! ASSIGNMENT
% 1% PUNCSTA, !PUNCH
% 38% CALLSTA, !CALL
% 49% GOTOSTA, !GOTO
% 53% PAUSSTA, !PAUSE
% 57% RETUSTA, !RETURN
% 73% ACCESTA, !ACCEPT
% 78% READSTA, !READ
% 90% WRITSTA, !WRITE
% 98% CONTSTA, !CONTINUE
%109% ASSISTA, !ASSIGN
%114% STOPSTA; !STOP
GLOBAL ROUTINE
MULTIASGN ( LEFTSIDE ) =
BEGIN
REGISTER BASE R1:R2;
EXTERNAL NEWENTRY %()%,SAVSPACE %(SIZE,LOC)%,STK,ASGNTYPER,LABLOFSTATEMENT;
EXTERNAL WARNLEX;
MACRO
EXPRBASE=1,0,FULL$;
NAME_IDOFSTATEMENT_ASGNDATA;NAME<RIGHT>_SORTAB;
R1_NEWENTRY();
R2_.STK[0];
R1[RHEXP]_.R2[ELMNT1] % EXPRESSION POINTER %;
R1[LHEXP]_R2_.LEFTSIDE;
ASGNTYPER(.R1); !CHECKING FOR ASSIGNMENT CONVERSION
R2 _ .R1[LHEXP]; !RESTORING EXP PTR INCASE OF TYPE CONVERSION NODE INSERTED
IF .R2[OPRCLS] EQL DATAOPR THEN R1[A1VALFLG]_1 ELSE R2[PARENT] _ .R1;
R2 _ .R1[RHEXP]; !RESTORE RH EXP PTR
IF .R2[OPRCLS] EQL DATAOPR THEN R1[A2VALFLG]_1
ELSE ( R2[PARENT] _ .R1; IF .R2[FNCALLSFLG] THEN R1[FNCALLSFLG] _1);
SAVSPACE(.STK[0]<LEFT>,@STK[0])
END;
GLOBAL ROUTINE
ASSIGNMENT =
BEGIN
EXTERNAL NAMSET,NAMDEF;
REGISTER BASE T1:T2;
EXTERNAL STK,SP,NEWENTRY %()%,SAVSPACE %(SIZE,LOC)%,MULTIASGN %()%,PROGNAME;
!------------------------------------------------------------------------------------------------------------------
! SYNTAX RETURNS A LIST POINTER (COUNT^18+LOC) IN STK[0]. THIS LIST CONTAINS:
!
! IDENTIFIER(20^18+LOC) - TO BE ASSIGNED
! POINTER TO LOGICAL EXPRESSION - (COUNT^18+LOC)
!
!------------------------------------------------------------------------------------------------------------------
T1_.STK[0]; !T1_LIST POINTER (COUNT^18+LOC)
T2_.T1[ELMNT]; !T2_LOC(IDENTIFIER)
% CHECK TO SEE IF ITS REALLY A VARIABLE %
IF NAMSET( VARIABL1, .T2 ) LSS 0 THEN RETURN .VREG;
% GENERATE THE ASSIGNMENT NODE %
MULTIASGN(.T2) ! GIVE IT THE LEFT HAND SIDE
END;
GLOBAL ROUTINE ASSISTA=
BEGIN
EXTERNAL SAVSPACE %(SIZE,LOC)%,BLDVAR %(VPNT)%,NEWENTRY %()%, ASIPTR,TBLSEARCH %()%,STK,TYPE,SETUSE,NAMSET;
%[766]% EXTERNAL E147;
MAP BASE ASIPTR;REGISTER BASE R1:R2;
!SEMANTIC ANALYSIS BEGINS
!--------------------------------------------------------------------------------
!THE CALL TO SYNTAX LEAVES A LIST POINTER ON THE STACK (STK[0]).
!THE POINTER POINTS TO THE LIST:
!
!LABEL (LABELEX^18+LOC) - THE LABEL TO BE ASSIGNED
!VARIABLESPEC - POINTER TO SCALAR OR ARRAY ELEMENT
!--------------------------------------------------------------------------------
R1_.STK[0]; !R1_LIST POINTER
% SET SETUSE FLAG FOR BLDVAR %
SETUSE _ SETT;
IF(STK[2]_R2_BLDVAR(.R1[ELMNT1])) LSS 0 THEN RETURN .VREG;
% BLDVAR ALLOWS ARRAYS WITHOUT SUBSCRIPTS SO DON'T LET THEM THROUGH HERE %
IF .R2<LEFT> EQL IDENTIFIER
THEN IF .R2[OPRSP1] EQL ARRAYNM1
THEN RETURN FATLEX ( R2[IDSYMBOL], ARPLIT<0,0>, E4<0,0> );
![766] GIVE WARNING FOR ASSIGN INTO SUBSCRIPTED VARIABLE
%[766]% IF .R2<LEFT> EQL ARRAYREF
%[766]% THEN WARNLEX(E147<0,0>);
R2[IDATTRIBUT(INASSI)]_1;
NAME_IDOFSTATEMENT_ASSIDATA;NAME<RIGHT>_SORTAB;R2_NEWENTRY();
R2[ASILBL]_.R1[ELMNT];R2[ASISYM]_@STK[2];SAVSPACE(.R1<LEFT>,@R1);
IF .ASIPTR<LEFT> EQL 0 THEN ASIPTR<LEFT>_ASIPTR<RIGHT>_@R2
ELSE
BEGIN
ASIPTR[ASILINK]_@R2;ASIPTR<RIGHT>_@R2
END;
.VREG
END;
GLOBAL ROUTINE GOTOSTA=
BEGIN
EXTERNAL SAVSPACE %(SIZE,LOC)%,TBLSEARCH %()%,NEWENTRY %()%,STK,BLDVAR %(VPNT)%,SETUSE;
EXTERNAL EXPRTYPER,CNVNODE; !DOES TYPE CONVERSION IF NECESSARY
%[766]% EXTERNAL E147;
MACRO GETLAB =
INCR LLST FROM @STK[2] TO @STK[2]+.STK[2]<LEFT> DO
BEGIN
MAP BASE LLST;
LLST[ELMNT] _ .(@LLST[ELMNT])<RIGHT>
END
$;
LOCAL BASE T1; REGISTER BASE R1:T2:R2;
!SEMANTIC ANALYSIS BEGINS
!---------------------------------------------------------------------------------
!THE SYNTAX ROUTINE RETURNS A POINTER IN STK[0] TO THE LIST:
!
!CHOICE 1 - SIMPLE GOTO
! LABEL (LABELEX^18+LOC)
!CHOICE 2 - ASSIGNED OR COMPUTED GOTO
! CHOICE 1 - ASSIGNED GOTO
! COUNT^18+LOC - POINTER TO ASSIGNED VARIABLE AND LABEL LIST
! CHOICE 2 - COMPUTED GOTO
! COUNT^18+LOC - POINTER TO LABEL LIST AND CONTROL EXPRESSION
!
!SEE EXPANSION OF METASYMBOL GOTO FOR COMPLETE EXPANSION
!---------------------------------------------------------------------------------
R1_.STK[0]; !R1_LIST POINTER
IF .R1[ELMNT] EQL 1 THEN !CHOICE 1 - SIMPLE GOTO
BEGIN
NAME_IDOFSTATEMENT_GOTODATA;NAME<RIGHT>_SORTAB;T1_NEWENTRY();
T1[GOTOLBL]_.R1[ELMNT1];T1[GOTONUM]_T1[GOTOLIST]_0;
RETURN
END;
!------------------------------------------------------------------------------
!AT THIS POINT WE HAVE EITHER A COMPUTED OR ASSIGNED GOTO.
!R1[ELMNT1] TELLS US WHICH. CHOICE 1 = ASSIGNED GOTO,
!CHOICE 2 = COMPUTED GOTO.
!------------------------------------------------------------------------------
R2_.R1[ELMNT2]; !R2_LOC (ASSIGNED OR COMPUTED GOTO COMPONENTS)
IF .R1[ELMNT1] EQL 1 THEN !ASSIGNED GOTO
BEGIN
SETUSE _ SETT; ! BLDVAR FLAG
IF (STK[1]_T1_BLDVAR(.R2[ELMNT])) LSS 0 THEN RETURN .VREG;
% CHECK BLDVAR RETURN FOR UNSUBSCRIPTED ARRAY REFERENCE %
![766] ADD WARNING FOR "GO TO A(I)" WHERE A IS DIMENSIONED
![766] ALSO FIX THE CASE "GO TO A" WHERE A IS DIMENSIONED
%[766]% IF .T1<LEFT> EQL ARRAYREF
%[766]% THEN WARNLEX(E147<0,0>);
IF .T1<LEFT> EQL IDENTIFIER
%[766]% THEN IF .T1[OPRSP1] EQL ARRAYNM1
THEN RETURN FATLEX ( T1[IDSYMBOL], ARPLIT, E4<0,0> ) ;
IF .R2[ELMNT1] NEQ 0 THEN !ASSIGNED GOTO WITH LABEL LIST
BEGIN
T1_.R2[ELMNT2];STK[2]_.T1[ELMNT1]; !SKIP OPTIONAL COMMA
GETLAB;
SAVSPACE(.R2[ELMNT2]<LEFT>,.R2[ELMNT2]);
STK[2]<LEFT> _ .STK[2]<LEFT>+1; !INCREMENT COUNT OF LABELS
END
ELSE STK[2]_0;NAME_IDOFSTATEMENT_AGODATA;
END
ELSE
BEGIN !COMPUTED GOTO
STK[2]_.R2[ELMNT];
GETLAB;
T2 _ STK[1] _.R2[ELMNT2]; !SKIP OPTIONAL COMMA
STK[2]<LEFT> _ .STK[2]<LEFT>+1; !INCREMENT COUNT OF LABELS
IF .T2[VALTYPE] NEQ INTEGER THEN STK[1] _ CNVNODE(.T2,INTEGER,0);
NAME_IDOFSTATEMENT_CGODATA;
END;
SAVSPACE(.R1<LEFT>,@R1);
NAME<RIGHT>_SORTAB;T1_NEWENTRY();
!PTR TO LABEL NUM OF LABELS INLIST PTR TO LIST
T1[GOTOLBL]_.STK[1];T1[GOTONUM]_.STK[2]<LEFT>;T1[GOTOLIST]_.STK[2]<RIGHT>;
T2_.T1[GOTOLBL]; IF .T2[OPRCLS] NEQ DATAOPR THEN T2[PARENT] _ .T1;
.VREG
END;
GLOBAL ROUTINE CALLSTA=
BEGIN
REGISTER T2=2;
%[745]% REGISTER BASE T1; MAP BASE T2;
%[745]% LOCAL BASE R1:R2;
EXTERNAL E121;
EXTERNAL STK,SAVSPACE %(SIZE,LOC)%,CORMAN %()%,NEWENTRY %()%,TBLSEARCH %()%,NAMSET,NAMREF,NAMDEF;
MACRO
CARGPTR=0,0,RIGHT$,CAFLGFLD=0,0,LEFT$,
ERR15(X) = RETURN FATLEX(X,R2[IDSYMBOL],E15<0,0>) $;
MACHOP BLT=#251;
LOCAL BASE CALLNODE;
!SEMANTIC ANALYSIS BEGINS
!------------------------------------------------------------------------------------------------------------
!THIS ROUTINE EXPECTS TO RETURN A POINTER IN STK[0] TO A SUBROUTINE NAME OPTIONALLY FOLLOWED BY AN
!ARGUMENT LIST. SEE EXPANSION OF METASYMBOL CALL FOR DETAILS.
!------------------------------------------------------------------------------------------------------------
R1_.STK[0];
R2_.R1[ELMNT]; !R2_LOC(SUBROUTINE NAME)
% DEFINE AND CHECK THE FUNCTION NAME %
IF NAMREF( FNNAME1 , .R2 ) LSS 0 THEN RETURN .VREG;
IF .R2[IDATTRIBUT(SFN)] THEN RETURN FATLERR(.ISN,E121<0,0>);
STK[1]_.R2;
!
!MAKE A CALL STATEMENT NODE
!
NAME_IDOFSTATEMENT_CALLDATA;NAME<RIGHT>_SORTAB;CALLNODE _NEWENTRY();
IF .R1[ELMNT1] NEQ 0 THEN !ARGUMENT LIST
BEGIN
![745] REWRITE WHOLE ROUTINE TO HANDLE REAL LONG ARGUMENT LISTS
%[745]% LOCAL LISTPTR, TOTELMNTS;
%[745]% LISTPTR _ .R1[ELMNT2];
%[745]% TOTELMNTS _ 0;
%[745]% !CALCULATE TOTAL NUMBER OF PARAMETERS IN LIST
%[745]% INCR LISTNUM FROM 0 TO .LISTPTR<LEFT> DO
%[745]% TOTELMNTS_.TOTELMNTS+.(.LISTPTR<RIGHT>+.LISTNUM)<LEFT>+1;
%[745]% TOTELMNTS_.TOTELMNTS / 2; !GET REAL COUNT!
%[745]%
%[745]% !GET FREE SPACE FOR TOTAL COMPRESSED ARG LIST
%[745]% NAME<LEFT>_ARGLSTSIZE(.TOTELMNTS);
%[745]% CALLNODE[CALLIST]_R2_CORMAN();
%[745]% (@R2)<FULL>_0; (.R2+1)<FULL> _ .TOTELMNTS;
%[745]% R2_.R2+2;
%[745]%
%[745]% !WALK EACH OF THE POTENTIAL LISTS OF ARGUMENTS
%[745]% INCR LISTNUM FROM 0 TO .LISTPTR<LEFT> DO
%[745]% BEGIN
%[745]% T1_@(.LISTPTR<RIGHT>+.LISTNUM);
%[745]%
%[745]% !LOOK AT EACH ELEMENT IN EACH LIST
INCR ARG FROM @T1 TO @T1+.T1<LEFT> BY 2 DO
BEGIN
MAP BASE ARG:R2;
T2_.ARG[ELMNT1];
R2[CAFLGFLD]_0;R2[CARGPTR]_.T2;
IF .ARG[ELMNT] EQL 1 THEN !EXPRESSION
BEGIN
IF .T2[OPRCLS] EQL DATAOPR
THEN (R2[P1AVALFLG]_1;
IF .T2[OPRSP1] EQL ARRAYNM1
OR .T2[OPRSP1] EQL VARIABL1
THEN NAMSET(VARYREF, .T2 )
)
ELSE
BEGIN
T2[PARENT] _ .CALLNODE;
IF .T2[OPRCLS] EQL ARRAYREF
THEN NAMSET( ARRAYNM1, .T2[ARG1PTR])
END;
END
ELSE !STATEMENT NUMBER
BEGIN
R2[P1AVALFLG]_1;
END;R2_.R2+1;
![745] CLEAN UP AFTER ALL THE ARGUMENTS ARE DONE, AND RECLAIM FREE SPACE
%[745]% END;
%[745]% SAVSPACE(.T1<LEFT>,.T1); !FOR EACH PARTIAL ARGUMENT LIST
%[745]% T1_@(.R1[ELMNT2]+.LISTNUM); !GO TO NEXT PARTIAL LIST
%[745]% END;
%[745]% SAVSPACE(.LISTPTR<LEFT>,.R1[ELMNT2]); !CLEAN UP ALL PTRS TO ARGLISTS
%[745]% END ELSE R2_0;
%[745]% CALLNODE[CALSYM]_.STK[1];
FLGREG<BTTMSTFL>_0;
SAVSPACE(.R1<LEFT>,@R1);
.VREG
END;
GLOBAL ROUTINE RETUSTA=
BEGIN
REGISTER BASE T1:R2;
EXTERNAL STK,EXPRTYPER,SAVSPACE %(SIZE,LOC)%,NEWENTRY %()%;
EXTERNAL LSAVE,LEXL,LEXNAME,EXPRESS,CNVNODE;
LEXL_LEXEMEGEN(); LSAVE _ -1;
IF .LEXL<LEFT> NEQ LINEND
THEN
BEGIN
IF ( STK[0] _ EXPRESS() ) LSS 0
THEN RETURN .VREG;
IF .LEXL<LEFT> NEQ EOSLEX
THEN RETURN NOEOSERRL
END
ELSE STK[0] _ 0;
!SEMANTIC ANALYSIS BEGINS
!-----------------------------------------------------------------------------------------------------------
!THIS ROUTINE EXPECTS IN STK[0], A POINTER TO AN OPTIONAL RETURN EXPRESSION OR 0.
!-----------------------------------------------------------------------------------------------------------
NAME_IDOFSTATEMENT_RETUDATA;NAME<RIGHT>_SORTAB;R2_NEWENTRY();
R2[RETEXPR]_T1_.STK[0];
IF .T1 NEQ 0
THEN (IF .T1[OPRCLS] NEQ DATAOPR THEN T1[PARENT] _ .R2;
IF .T1[VALTYPE] NEQ INTEGER THEN R2[RETEXPR] _ CNVNODE(.T1,INTEGER,0);
);
.VREG
END;
GLOBAL ROUTINE CONTSTA=
BEGIN
EXTERNAL NEWENTRY;
IF LEXEMEGEN() NEQ LINEND^18 THEN RETURN NOEOSERRV;
!SEMANTIC ANALYSIS BEGINS
NAME _ IDOFSTATEMENT _ CONTDATA; NAME<RIGHT>_SORTAB; NEWENTRY();
.VREG
END;
%[742]% GLOBAL ROUTINE LITOR6DIGIT=
BEGIN
!
!PARSES OPTIONAL [LITERAL OR 6-DIGIT STRING ] AFTER STOP OR PAUSE
!RETURNS LEXEME FOR EITHER
!
REGISTER R2;
EXTERNAL GSTOPOBJ,STLEXEME,LEXICAL;
IF ( R2_LEXICAL( .GSTOPOBJ )) EQL 0
THEN
BEGIN % ITS NOT A DIGIT OR ' %
IF LEXICAL (.GSTLEXEME ) NEQ EOSLEX^18
THEN
BEGIN % AND ITS NOT ENDOF STATEMENT EITHER %
%[742]% RETURN FATLEX( PLIT'string or 6-digit integer?0',LEXPLITV,E0<0,0>)
END
% ELSE EOS IS OK %
END
ELSE
BEGIN % MAKE SURE THAT THERE WERE NO ERRORS IN THE OBJECT %
IF .R2 EQL EOSLEX^18
THEN RETURN -1; ! SOME SORT OF ERROR OCCURED
%OTHERWISE ITS AN INTEGER OR LITERAL
WHICH MUST BE FOLLOWED BY EOS %
IF LEXICAL(.GSTLEXEME) NEQ EOSLEX^18
THEN RETURN NOEOSERRV
END;
RETURN .R2
END; % LITOR6DIGIT %
GLOBAL ROUTINE STOPSTA=
BEGIN
REGISTER BASE R1:R2;
%[742]% EXTERNAL STK,SAVSPACE %(SIZE,LOC)%,NEWENTRY %()%,LITOR6DIGIT;
%[742]% IF (R2 _ LITOR6DIGIT()) LSS 0 THEN RETURN -1;
NAME_IDOFSTATEMENT_STOPDATA;NAME<RIGHT>_SORTAB;R1_NEWENTRY();
R1[STOPIDENT]_@R2;
.VREG
END;
GLOBAL ROUTINE PAUSSTA=
BEGIN
REGISTER BASE R1:R2;
%[742]% EXTERNAL STK,SAVSPACE %(SIZE,LOC)%,NEWENTRY %()%,LITOR6DIGIT;
%[742]% IF (R2 _ LITOR6DIGIT()) LSS 0 THEN RETURN -1;
NAME_IDOFSTATEMENT_PAUSDATA;NAME<RIGHT>_SORTAB;R1_NEWENTRY();
R1[PAUSIDENT]_.R2;
.VREG
END;
GLOBAL ROUTINE RWBLD(NODEDATA)=
BEGIN
%[760]% REGISTER BASE T1;REGISTER BASE R1:R2:R3;
%[760]% EXTERNAL ZIOSTK,STK,SAVSPACE,BLDKORU,KORFBLD,BLDKLIST,
%[760]% BLDFORMAT,DATALIST,NEWENTRY,NAMLSTOK,IODOXPN;
%[760]% LOCAL L1,L2,IOL;
%[760]% MAP BASE L1:L2;
%
ROUTINE BUILDS A READ OR WRITE STATEMENT NODE
CALLED FROM READST OR WRITST WITH READ OR WRITE DATA
DOESN'T RETURN ANYTHING SIGNIFICANT EXCEPT WHEN ERROR CONDITION
THEN RETURNS -1
%
%[760]% !----------------------------------------------------------------------------------------------------------
%[760]% !This routine expects a pointer in STK[0] to:
%[760]% ! choice 1 - iospec
%[760]% ! pointer to:
%[760]% ! pointer to:
%[760]% ! keylist or unitspec
%[760]% ! option
%[760]% ! pointer to:
%[760]% ! keylist or formatspec
%[760]% ! option
%[760]% ! keylist
%[760]% ! option
%[760]% ! iolist
%[760]% ! or
%[760]% ! choice 2 - formatid
%[760]% ! pointer to:
%[760]% ! formatspec
%[760]% ! option
%[760]% ! iolist
%[760]% !
%[760]% ! Note the unitspec can have a recordmark followed by an expression
%[760]% ! (i.e. unit'rec or unit#rec)
!----------------------------------------------------------------------------------------------------------
%[760]% NAMLSTOK _ 1;
%[760]% ZIOSTK();
%[760]% IOL _ 0;
%[760]% FLAG _ -1;
%[760]% L1 _ .STK[0];
%[760]%
%[760]% IF .L1[ELMNT] EQL 1
%[760]% THEN
%[760]% BEGIN ! IOSPEC
%[760]% R1 _ .L1[ELMNT1];
%[760]% R2 _ .R1[ELMNT];
%[760]% ! build keylist or unitspec
%[760]% IF BLDKORU(.R2[ELMNT]) LSS 0 THEN RETURN .VREG;
%[760]%
%[760]% IF .R2[ELMNT1] NEQ 0
%[760]% THEN
%[760]% BEGIN
%[760]% R3 _ .R2[ELMNT2];
%[760]% ! build keylist or formatspec
%[760]% IF KORFBLD(.R3[ELMNT]) LSS 0 THEN RETURN .VREG;
%[760]% IF .R3[ELMNT1] NEQ 0
%[760]% THEN
%[760]% BEGIN
%[760]% ! build keylist
%[760]% IF BLDKLIST(.R3[ELMNT2]) LSS 0 THEN RETURN .VREG;
%[760]% END;
%[760]% END;
%[760]%
%[760]% ! build an iolist
%[760]% IF .R1[ELMNT1] NEQ 0
%[760]% THEN
%[760]% BEGIN
%[760]% R2 _ .R1[ELMNT2];
%[760]% IF (IOL_DATALIST(.R2[ELMNT1])) LSS 0 THEN RETURN .VREG;
%[760]% END;
%[760]% END ! IOSPEC
%[760]% ELSE
%[760]% BEGIN ! FORMATID
%[760]% IF BLDFORMAT(.L1[ELMNT1]) LSS 0 THEN RETURN .VREG;
%[760]% R1 _ .L1[ELMNT1];
%[760]% ! build an iolist
%[760]% IF .R1[ELMNT2] NEQ 0
%[760]% THEN
%[760]% BEGIN
%[760]% R2 _ .R1[ELMNT3];
%[760]% IF (IOL_DATALIST(.R2[ELMNT])) LSS 0 THEN RETURN .VREG;
%[760]% END;
%[760]% END;
%[760]%
%[760]% NAMLSTOK _ 0;
%[760]% NAME_IDOFSTATEMENT_.NODEDATA;NAME<RIGHT>_SORTAB;T1_NEWENTRY();
%[760]%
%[760]% !if no unit was specified or unit=* give default
%[760]% IF .STK[2] EQL 0 OR .STK[2] EQL -1
%[760]% THEN
%[760]% BEGIN
%[760]% IF .NODEDATA EQL READDATA
%[760]% THEN T1[IOUNIT] _ MAKECNST(INTEGER,0,-5)
%[760]% ELSE T1[IOUNIT] _ MAKECNST(INTEGER,0,-3);
%[760]% END
%[760]% ELSE
%[760]% BEGIN
%[760]% R1 _ .STK[2];
%[760]% IF .R1[VALTYPE] NEQ INTEGER THEN RETURN FATLEX(E55<0,0>);
%[760]% T1[IOUNIT] _ .STK[2];
%[760]% END;
%[760]%
%[760]% IF .STK[3] NEQ 0
%[760]% THEN
%[760]% BEGIN
%[760]% ! list directed random i/o
%[760]% IF .STK[4] EQL -1 THEN RETURN FATLEX(PLIT'RANDOM ACCESS?0',E101<0,0>);
%[760]% T1[IORECORD] _ .STK[3];
%[760]% END;
%[760]%
%[760]% IF .STK[4] NEQ 0
%[760]% THEN
%[760]% BEGIN
%[1114]% R2 _ .STK[4];
%[760]% IF .R2 NEQ -1
%[760]% THEN
%[760]% BEGIN
%[760]% IF .R2[IDATTRIBUT(NAMNAM)] EQL 1
%[760]% ! namelist i/o with an iolist
%[760]% THEN IF .IOL NEQ 0 THEN RETURN FATLEX(E102<0,0>);
%[760]% END;
%[760]% T1[IOFORM] _ .STK[4];
%[760]% END;
%[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]% .T1
END;
GLOBAL ROUTINE READSTA=
BEGIN
!SEMANTIC ANALYSIS BEGINS
!
TYPE _ READD; !FLAG FOR DATALIST
RWBLD(READDATA); !BUILD READ/WRITE NODE
.VREG
END;
GLOBAL ROUTINE ACCESTA=
BEGIN
REGISTER BASE T1;
EXTERNAL BLDIO1;
T1 _ BLDIO1(READDATA); !BUILD A READ NODE
T1[IOUNIT] _ MAKECNST(INTEGER,0,-4); !ACCEPT ID
.VREG
END;
GLOBAL ROUTINE PUNCSTA=
BEGIN
REGISTER BASE T1;
EXTERNAL BLDIO1;
T1 _ BLDIO1(WRITDATA); !BUILD A WRITE (PUNCH) NODE
T1[IOUNIT] _ MAKECNST(INTEGER,0,-2); !PUNCH PAPER TAPE ID
.VREG
END;
GLOBAL ROUTINE WRITSTA=
BEGIN
!SEMANTIC ANALYSIS BEGINS
TYPE _ WRITEE; ! FLAG FOR DATALIST
RWBLD(WRITDATA); !BUILD A WRITE IO STATEMENT NODE
.VREG
END;
END
ELUDOM