Google
 

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