Google
 

Trailing-Edge - PDP-10 Archives - BB-D480C-SB_1981 - sta2.bli
There are 26 other files named sta2.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/DCE/SJW/EGM

MODULE STA2(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN

!	REQUIRES FTTENX.REQ, LEXNAM, FIRST, TABLES, META72, ASHELP

REQUIRE  FTTENX.REQ;
SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
REQUIRE META72.BLI;
REQUIRE ASHELP.BLI;
SWITCHES LIST;

GLOBAL BIND STA2V = 6^24 + 0^18 + 48;	! Version Date:	17-Jul-81

%(

***** Begin Revision History *****

36	-----	-----	ADD THE INCLUDE STATEMENT SEMANTICS ROUTINE

37	-----	-----	ALLOW LITSTRINGS IN THE PARAMETER STATEMENT

38	-----	-----	FIX REAL*8 X*4  SO IT WORKS

			ALLOW SIGNED CONSTANTS IN THE PARAMETER STATEMENT
39	-----	-----	THE "CLEVER" WAY OF DEALING WITH THE LOOKUP
			SKIP RETURN WAS OPTIMIZED AWAY BY 5(122)
			SO WE MUST NOT BE SO CLEVER THIS TIME

40	-----	-----	FIX UP INCLUDE A LITTLE
41	320	16787	CATCH COMMON STATEMENTS LIKE /X/A(5)B(5) AS ERRORS, (JNT)
42	402	18917	RESTORE FLAGS CORRECTLY AFTER INCLUDE FILE, (DCE)
43	467	VER5	REQUIRE FTTENX.REQ ,(SJW)
44	533	21796	FIX OUTPUT BUFFER PTR FOR INCLUDE FILE TO BE 0., (DCE)
45	540	22096	ICE CAUSED BY BAD COMMON DECLARATION, (DCE)

***** Begin Version 5B *****

46	722	28072	ADD /NOCREF TO INCLUDE FILE PROCESSING, (DCE)
47	755	13884	Allow lower case for INCLUDE/NOLIST/NOCREF under TENEX,
			(EGM)

***** Begin version 6 *****

48	1000	EGM	27-Jun-80	10-29620
	Flag error if no name is given on PROGRAM statement

***** End Revision History *****

)%

GLOBAL	ACTLDATYPE;	!SET TO THE CODE OF THE SPECIFIC DATA TYPE IDENTIFIER
			!IN ORDER TO DIFFERENTIATE BETWEEN REAL*8 AND
			!DOUBLEPRECISION  WHEN DOING THE SIZE MODIFIER
			!OVERRIDE
			!USED IN ASTER  AND SET IN TYPDECLARE

!THE NUMBER IN COMMENT'S IS THE STATEMENTS LOCATION
!IN THE HASH TABLE .
FORWARD
% 16%	SUBRSTA,	!SUBROUTINE 
% 19%	INTESTA,	!INTEGER 
% 29%	LOGISTA,	!LOGICAL - P.30
% 51%	DIMESTA,	!DIMENSION 
% 56%	DOUBSTA,	!DOUBLEPRECISION - P.31
% 64%	ENTRSTA,	!ENTRY 
% 75%	BLOCSTA,	!BLOCKDATA - P.38
% 81%	FUNCSTA,	!FUNCTION 
% 86%	REALSTA,	!REAL - P.29
% 93%	COMMSTA,	!COMMON 
% 96%	COMPSTA,	!COMPLEX - P.32
%121%	PROGSTA,	!PROGRAM 
	PARASTA;	!PARAMETER STATEMENT
	GLOBAL ROUTINE
INCLSTA   =
BEGIN	% INCLUDE STATEMENT%

	GLOBAL SVFLG2;
	EXTERNAL EOPSVPOOL,POOL,EOPRESTORE;
	EXTERNAL LEXICAL,GSTCSCAN,GSTSSCAN,LOOK4CHAR,LEXEMEGEN,GSTEOP;
	BIND EOF = #200;
	MACHOP  LOOKUP = #076, OPEN = #050, JFCL = #255;
	OWN TMP;
	MACRO  DEFAULT =  TMP<LEFT>$,
%[722]%		NOLST =	TMP<0,1>$,
%[722]%		NOCRF =	TMP<1,1>$;
	EXTERNAL SAVFLG;
	MACRO	PROJNUM = DIRECTORY(ICL)<LEFT>$,
		PROGNUM = DIRECTORY(ICL)<RIGHT>$,
		ERRORR(X) = RETURN FATLEX(X<0,0>)$;

	FORWARD
		PPN,PPNUM,SCANFIL,FILSP,SWITCH;

ROUTINE  FILSP  =
BEGIN IF NOT FTTENEX THEN BEGIN
	REGISTER R;

	%GET DEVICE OR FILE NAME%
	WHILE 1 DO
	BEGIN
		EXTERNAL  E122;

		IF (R_SCANFIL())  EQL  0  THEN RETURN 0;
		LOOK4CHAR _ ":";
		IF LEXICAL(.GSTCSCAN)  EQL  0
		THEN
		BEGIN	%FILE NAME%
			EXITLOOP
		END
		ELSE
		BEGIN	%DEVICE NAME%
			IF .DEVICE(ICL)  NEQ  0
			THEN	RETURN  FATLEX( SIXBIT'DEVICE', E122<0,0>);
			DEVICE(ICL)  _ .R
		END
	END	%LOOP%  ;

	%STORE FILE NAME%
	IF .FILENAME(ICL)  NEQ  0
	THEN	RETURN  FATLEX( SIXBIT'FILE', E122<0,0>);
	FILENAME(ICL) _ .R;

	LOOK4CHAR _ ".";
	IF LEXICAL(.GSTCSCAN)  EQL  0
	THEN
	BEGIN
		%DEFAULT%
		DEFAULT _ 1;
		(FILENAME(ICL)+1)  _ SIXBIT'FOR';
	END
	ELSE
	BEGIN
		DEFAULT _ 0;
		(FILENAME(ICL)+1)  _ SCANFIL()
	END;
	RETURN 1
END END;


ROUTINE  PPN  =
BEGIN IF NOT FTTENEX THEN BEGIN	%PICK UP THE PPN%

	LOOK4CHAR _ "[";
	IF LEXICAL (.GSTCSCAN) EQL  0
	THEN	( DIRECTORY(ICL) _ 0;
		  RETURN  0	!NONE
		);

	IF (PROJNUM _ PPNUM() )  EQL 0
	THEN  RETURN -1;	!ERROR
	LOOK4CHAR _ ",";
	IF LEXICAL(.GSTCSCAN)  EQL  0
	THEN	RETURN -1;	!ERROR
	IF ( PROGNUM _ PPNUM() )  EQL  0
	THEN RETURN -1;	!ERROR
	LOOK4CHAR _ "]";
	IF LEXICAL(.GSTCSCAN) EQL  0
	THEN RETURN -1;	!ERROR

	RETURN 1	!GOT ONE
END END;

ROUTINE  PPNUM  =
BEGIN IF NOT FTTENEX THEN BEGIN	%GET PPN%
	REGISTER NUM,C;
	NUM _ 0;
	LOOK4CHAR _ "?D";
	UNTIL  ( C _ LEXICAL(.GSTCSCAN) ) EQL  0
	DO	NUM _ .NUM*8 + .C -"0";
	RETURN .NUM
END END;

ROUTINE  SCANFIL  =
BEGIN IF NOT FTTENEX THEN BEGIN
	%GET FILE NAME%
	REGISTER SIX,C;

	DECR SHIFT FROM  30 TO 0 BY 6
	DO
	BEGIN
		MACHOP  ADDI=#271;
		SIX _ .SIX^6;
		LOOK4CHAR _ "?L";
		IF ( C _ LEXICAL(.GSTCSCAN) )  EQL 0
		THEN
		BEGIN
			LOOK4CHAR _ "?D";
			IF ( C_ LEXICAL(.GSTCSCAN))  EQL  0
			THEN	RETURN  SIX_.SIX^.SHIFT;
		END;
		ADDI(SIX,-" ",C)
	END;
	WHILE 1 DO
	BEGIN	%SKIP ANY MORE CHARACTERS%
		LOOK4CHAR _ "?L";
		IF LEXICAL(.GSTCSCAN)  EQL  0
		THEN
		BEGIN
			LOOK4CHAR _ "?D";
			IF LEXICAL(.GSTCSCAN) EQL 0
			THEN  RETURN .SIX
		END
	END
END END;


ROUTINE   SWITCH =
BEGIN IF NOT FTTENEX THEN BEGIN
![722] REWRITE SWITCH PROCESSING TO ALLOW /NOCREF ON INCLUDE STATEMENT
%[722]%	% GET /NOLIST OR /NOCREF OR BOTH %
%[722]%	LOOK4CHAR_"/";
%[722]%
%[722]%	IF LEXICAL(.GSTCSCAN) EQL 0 THEN RETURN 0;
%[722]%	DO
%[722]%	BEGIN
%[722]%
%[722]%		LOOK4CHAR_PLIT'NOLIST'<36,7>;
%[722]%		IF LEXICAL(.GSTSSCAN) NEQ 0
%[722]%		THEN NOLST_1  !FOUND /NOLIST
%[722]%		ELSE  !TRY NOCREF
%[722]%		BEGIN
%[722]%			LOOK4CHAR_PLIT'NOCREF'<36,7>;
%[722]%			IF LEXICAL(.GSTSSCAN) NEQ 0
%[722]%			THEN NOCRF_1  !FOUND /NOCREF
%[722]%			ELSE RETURN -1    !ERROR
%[722]%		END;
%[722]%		LOOK4CHAR_"/"
%[722]%	END UNTIL LEXICAL(.GSTCSCAN) EQL 0;
%[722]%
%[722]%	RETURN 1;
END END;



	%LETS DO IT%

	IF .FLGREG<ININCLUD>  THEN  RETURN FATLEX(E120<0,0>);

	IF NOT FTTENEX THEN
	BEGIN


	FILENAME(ICL)  _ 0;
	TMP _ 0;
	DIRECTORY(ICL) _ 0;
	DEVICE(ICL) _ 0;

	%GET THE INITIAL ' %
	LOOK4CHAR  _ "'";
	IF LEXICAL(.GSTCSCAN)  EQL  0
	THEN
	BEGIN
		EXTERNAL LEXNAME;
		LEXEMEGEN();
		RETURN FATLEX(PLIT'''',.LEXNAME[.VREG<LEFT>],E0<0,0>);
	END;

	BEGIN
		LABEL  SPEC,LOOP,LOK,CHK;

		SPEC:BEGIN
			WHILE 1 DO
			BEGIN	%GET THE SPEC%
				LOOP:BEGIN
					IF  .FILENAME(ICL) EQL  0 OR .DEVICE(ICL) EQL 0
					THEN	IF  FILSP()  EQL  1
						THEN  LEAVE LOOP	!FOUND ONE
						ELSE	IF .VREG LSS 0 
							THEN RETURN .VREG;
					IF .DIRECTORY(ICL)  EQL  0
					THEN	IF  PPN() EQL  1
						THEN	LEAVE LOOP
						ELSE	IF .VREG  LSS 0
							THEN	ERRORR(E117);

					IF SWITCH()  LSS 0
					THEN ERRORR(E116)
					ELSE	IF .VREG  EQL  1
						THEN LEAVE LOOP;

					LEAVE SPEC	!NOTHING ELSE RECOGNIZABLE
				END %LOOP%
			END %WHILE 1%
		END ;	%SPEC%

		%GET THE FINAL ' %
		LOOK4CHAR  _ "'";
		IF LEXICAL(.GSTCSCAN)  EQL  0
		THEN
		BEGIN
			EXTERNAL LEXNAME;
			LEXEMEGEN();
			RETURN FATLEX(PLIT'''',.LEXNAME[.VREG<LEFT>],E0<0,0>);
		END;
			
		IF LEXEMEGEN()  NEQ  EOSLEX^18
		THEN RETURN  NOEOSERRV;

		%NOW LETS TRY AND OPEN THE FILE%
		IF .DEVICE(ICL)  EQL  0
		  THEN DEVICE(ICL) _ SIXBIT'DSK';
		BEGIN	%MAKE SURE THAT THE DEVICE IS A DISK%
			MACHOP  DEVCHR = #047;
			EXTERNAL  E124;
			VREG _ .DEVICE(ICL);
			DEVCHR ( VREG,4);
			IF NOT .VREG<34,1>  %DISK DEVICE%
			THEN	RETURN  FATLERR(.ISN,E124<0,0>)
		END;

		IF .FILENAME(ICL)  EQL  0
		THEN	ERRORR(E118);	!NO FILE NAME

		STATUS(ICL) _ 0;	!ASCII
		BUFFERS(ICL) _ BUFHDR(ICL)<0,0>;

		OPEN  (ICL, STATUS(ICL));
		JFCL(0,0);

		LOK:BEGIN
		WHILE 1 DO
		BEGIN
	
			VREG _ -1;
			LOOKUP(ICL,FILENAME(ICL));
			VREG _ 0;	!FILE NOT FOUND
			IF .VREG  NEQ 0 THEN LEAVE LOK;	!OK FOUND THE FILE

			%TRY WITHOUT .FOR %
			IF .DEFAULT  NEQ 0
			THEN
			BEGIN
				EXTENSION(ICL) _ 0;
				DEFAULT _ 0
			END
			ELSE	ERRORR(E119)
		END	%WHILE 1%
		END	%LOK%
	END;

	END
	ELSE
	BEGIN	%FTTENEX%

		EXTERNAL OPNICL,E138;
		GLOBAL  ICLPTR;		!FILESPEC POINTER
		LOCAL BASE LIT;
		EXTERNAL LITPOINTER;
		LOCAL	LITPNTSAV,VAL;

		LITPNTSAV _ .LITPOINTER;	!SAVE SO LITERAL CAN BE DELETED

		%PICK UP THE LITSTRING SPEC%
		LIT _ LEXICAL(.GSTLEXEME);
		IF .LIT<LEFT>  NEQ  LITSTRING
		THEN	FATLEX(.LEXNAM[LITSTRING],.LEXNAM[.LIT<LEFT>],E0<0,0>);

		%CHECK FOR EOS%
		IF LEXICAL(.GSTLEXEME ) NEQ  EOSLEX^18
		THEN	RETURN  NOEOSERRV;

		ICLPTR _ ( LIT[LIT1] )<36,7>;		!SPEC POINTER
		VAL _ OPNICL();	!OPEN THE FILE

		IF .VAL  NEQ 0	!WAS THERE AN ERROR
		THEN	RETURN  FATLERR(.VAL,.ISN,E138<0,0>);	
				%MESSAGE POINTER GIVEN IN VREG%

![722] REWRITE SO THAT /NOCREF ALLOWED ON INCLUDE STATEMENT
%[722]%		% OK, GOT IT, NOW LOOK FOR /NOLIST OR /NOCREF %
%[722]%
%[722]%		NOLST_0;
%[722]%		NOCRF_0;
%[722]%
%[722]%		WHILE ..ICLPTR EQL "/"
%[722]%		DO
%[722]%		BEGIN
%[722]%			% SEE WHAT THE SWITCH IS %
%[722]%
%[722]%			LABEL CHKLST;
%[722]%			LOCAL PNT,SAVICL;
%[755]%			REGISTER CHAR;
%[755]%			MACRO UPLOW(L) = %( CONVERT LOWER CASE TO UPPER )%
%[755]%				BEGIN
%[755]%				VREG=L;
%[755]%				IF .VREG GEQ #141 %( LOWER CASE A )% AND
%[755]%				   .VREG LEQ #172 %( LOWER CASE Z )%
%[755]%				THEN VREG=.VREG-#40; %( UPPER CASE )%
%[755]%				.VREG
%[755]%				END$;
%[722]%
%[722]%			%TRY /NOLIST %
%[722]%			VAL_0; !NOLST NOT FOUND YET ON THIS PASS
%[722]%			PNT_(PLIT'NOLIST')<36,7>;
%[722]%			SAVICL_.ICLPTR;
%[722]%		CHKLST:	BEGIN
%[755]%				UNTIL (CHAR_SCANI(PNT)) EQL 0
%[755]%				DO IF .CHAR NEQ UPLOW(SCANI(ICLPTR))
%[722]%					THEN LEAVE CHKLST;
%[722]%				NOLST_1; VAL_1;  !WE FOUND /NOLIST
%[722]%				SCANI(ICLPTR);  !BUMP POINTER
%[722]%			END;
%[722]%
%[722]%			IF .VAL EQL 0 THEN  !TRY FOR /NOCREF
%[722]%			BEGIN
%[722]%				ICLPTR_.SAVICL;  !BACK UP THE POINTER
%[722]%				PNT_(PLIT'NOCREF')<36,7>;
%[722]%
%[755]%				UNTIL (CHAR_SCANI(PNT)) EQL 0
%[722]%				DO
%[722]%				BEGIN
%[755]%					IF .CHAR NEQ UPLOW(SCANI(ICLPTR))
%[722]%					THEN (	EXTERNAL CLOICL;
%[722]%						FATLEX(E116<0,0>);!BAD SWITCH
%[722]%						CLOICL();
%[722]%						RETURN )
%[722]%				END;
%[722]%				NOCRF_1;  !WE FOUND /NOCREF
%[722]%				SCANI(ICLPTR)
%[722]%			END;
%[722]%		END;

		%FREE UP THE LITERAL%
		SAVSPACE( .LIT[LITSIZ]+2 , @LIT );
		LITPOINTER _ .LITPNTSAV;
		IF .LITPOINTER<RIGHT> NEQ 0 THEN (@LITPOINTER)<RIGHT> _ 0;

	END;	%FTTENEX%



	%OK WE GOT THE FILE%
	%SAVE THE CURRENT BUFFERS%
	LEXICAL (.GSTEOP);	!TERMINATE CURRENT STATEMENT
	EOPSVPOOL();

	%SAVE THE INFO%
	BEGIN
		GLOBAL  SVINCL[8];
		EXTERNAL LINENO;
		EXTERNAL  EOPSAVE,CURPOOLEND,CURPTR,STLPTR,STPTR,LINEPTR,SEQLAST,LINELINE,CHARPOS;

		SVINCL[0] _ .EOPSAVE;
		SVINCL[1] _ .CURPOOLEND;
		SVINCL[2] _ .CURPTR;
		SVINCL[3] _ .STLPTR;
		SVINCL[4] _ .STPTR;
		SVINCL[5] _ .LINEPTR;
		IF .SEQLAST  NEQ  0
		THEN	SVINCL[6] _ .LINELINE	!LINESEQUENCE NUMBER
		ELSE	SVINCL[6] _ 0;
		SVINCL[7] _ .CHARPOS;
		IF .CHARPOS  NEQ 72
		THEN	LINELINE _ .LINELINE+1;	!MULTIPLE STATEMENTS ON LINE
		SAVFLG _ .FLGREG<0,36>;
		FLGREG<ININCLUD> _ 1;
		FLGREG<EOCS> _ 1;
![722] HANDLE NO CREFFING TOO
%[722]%		IF .NOCRF THEN  FLGREG<CROSSREF> _ 0;
		IF .NOLST THEN  FLGREG<LISTING> _ 0;
		SVFLG2 _ .FLAGS2;
		FLAGS2<TTYINPUT> _ 0;

		%SET LINENO[1] SO THAT AN * WILL APPEAR NEXT TO THE
			INCLUDED CODES LINE NUMBER %
		LINENO[1] _ '*	';

		CURPOOLEND _ POOL<0,0>;
		IF EOPRESTORE()  EQL  EOF
		THEN
		BEGIN
			EXTERNAL  POSTINCL;
			POSTINCL();	!RESTORE
		END
	END
END;


	GLOBAL ROUTINE
POSTINCL   =
BEGIN
	%RESTORE THE WORLD AFTER AN INCLUDED FILE %
	EXTERNAL  SVINCL[8];
	EXTERNAL  EOPSAVE,CURPOOLEND,CURPTR,STLPTR,STPTR,LINEPTR,SEQLAST,LINELINE;
	EXTERNAL  EOPRESTORE,SVFLG2;

	EXTERNAL LINENO;
	EXTERNAL SAVFLG,GSTEOP,LEXICAL,CHARPOS;
	MACHOP  CLOSE = #070;

	% CLEAN UP LAST LINE%
	LEXICAL(.GSTEOP);

	IF NOT FTTENEX 
	THEN
		CLOSE (ICL,0)	!CLOSE THE FILE
	ELSE
		( EXTERNAL CLOICL;
		  CLOICL();
		);


	EOPSAVE _ .SVINCL[0];
	CURPOOLEND  _ .SVINCL[1];
	CURPTR _ .SVINCL[2];
	STLPTR _ .SVINCL[3];
	STPTR _ .SVINCL[4];
	LINEPTR _ .SVINCL[5];
	IF .SVINCL[6] NEQ  0
	THEN	LINELINE _ .SVINCL[6];	!LINESEQUENCE NUMBER
	CHARPOS _ .SVINCL[7];

	SEQLAST  _ 1;	!SO NO ONE WILL MESS WITH THE LINELINE
	LINENO[1] _ '	';	!RESET LINENO TO TAB

	!KEEP VALUES OF SOME FLAGS WHICH MAY HAVE CHANGED
	! DURING PROCESSING OF THE INCLUDE FILE, AND WHOSE NEW
	! VALUES WE REALLY WANT TO KEEP!

	SAVFLG<BTTMSTFL> _ .FLGREG<BTTMSTFL>; !IF 16 CLOBBERED
	SAVFLG<WARNGERR> _ .FLGREG<WARNGERR>; !WARNINGS GIVEN
	SAVFLG<FATALERR> _ .FLGREG<FATALERR>; !FATAL ERRORS GIVEN
	SAVFLG<LABLDUM> _ .FLGREG<LABLDUM>; !LABELS PASSED AS ARGS
	FLGREG<0,36> _ .SAVFLG;
	FLAGS2 _ .SVFLG2;
	EOPRESTORE();	!RESTORE THE BUFFERS

END;


	GLOBAL ROUTINE
ASTER (TYPE)   =
BEGIN
	% THIS ROUTINE WILL SCAN FOR THE *DIGIT CONSTRUCT FOLLOWING THE
	  DATA TYPE NAME IN TYPE OR IMPLICIT OR FUNCTION STATEMENTS.

	  THE PARAMETER TYPE IS BASED UPON THE DATA TYPE NAME.
	  THIS ROUTINE WILL RETURN AS ITS VALUE:
		1. THE AMMENDED TYPE IF A VALID * CONSTRUCT WAS FOUND
		2. TYPE IF NO * CONSTRUCT WAS FOUND
		3. -1 IF THERE WAS SOME ERROR IN THE * CONSTRUCT

	%

	EXTERNAL LSAVE,LEXL;
	MACRO  ERR50(X)  =  FATLEX( .TYPDIG, X<0,0>, E50<0,0> ) $,
		ERR24(X) =  WARNLEX ( X<0,0>, .TYPDIG, E24<0,0> )  $;
	REGISTER TYPDIG,D;
	
	IF .LSAVE  EQL  0
	THEN
	BEGIN
		LOOK4CHAR _ "*";
		IF LEXICAL( .GSTCSCAN ) EQL  0 THEN RETURN .TYPE;
	END
	ELSE
	BEGIN
		IF .LEXL<LEFT>  NEQ  ASTERISK THEN RETURN .TYPE;
		LSAVE _ 0
	END;

	% GOT AN * %
	LOOK4CHAR _ "?D";	! ANY DIGIT
	IF ( D _ LEXICAL ( .GSTCSCAN ))  EQL  0 THEN D _ SIXBIT" " + " ";
						%THIS WILL CAUSE AN ERROR%
	% GET AS MANY DIGITS AS THERE ARE %
	TYPDIG _ 0;
	DO	TYPDIG _ .TYPDIG^6  +  .D-" "  	! KEEP IN SIXBIT FOR POSSIBLE ERROR OUTPUT
	UNTIL( D _ LEXICAL ( .GSTCSCAN ))  EQL   0  ;

	RETURN  (
		% DO THIS ON  THE BASIS OF ACTLDATYPE IN ORDER TO ALLOW
		  REAL*8 X*4 AND EXCLUDE DOUBLEPRECISION X*4  %

		SELECT  .ACTLDATYPE  OF  NSET

	INTEGER:( IF .TYPDIG  EQL  SIXBIT"2"
		  THEN	(ERR24(INTGPLIT); .ACTLDATYPE )
		  ELSE	IF .TYPDIG  EQL  SIXBIT"4"
			  THEN	.ACTLDATYPE
			  ELSE	ERR50( INTGPLIT)
		);
	REAL:	( IF .TYPDIG EQL  SIXBIT"4"
		  THEN  .ACTLDATYPE
		  ELSE	IF .TYPDIG  EQL  SIXBIT"8"
			  THEN  DOUBLPREC
			  ELSE	ERR50( REALPLIT)
		);
	COMPLEX:( IF .TYPDIG EQL SIXBIT"8"
		  THEN  .ACTLDATYPE
		  ELSE	IF .TYPDIG  EQL  SIXBIT"16"
			  THEN ( ERR24(COMPLIT); .ACTLDATYPE )
			  ELSE	ERR50 ( COMPLIT)
		);
	LOGICAL:( IF .TYPDIG EQL SIXBIT"4"
		  THEN .ACTLDATYPE
		  ELSE	IF .TYPDIG EQL SIXBIT"1"
			  THEN  ( ERR24(LOGIPLIT); .ACTLDATYPE )
			  ELSE	ERR50 ( LOGIPLIT )
		);
	DOUBLPREC:( ERR50 ( DOUBPLIT ) )

	TESN  )

END;	% ROUTINE ASTER %



	GLOBAL ROUTINE 
TYPDECLARE ( DTYPE ) =	!CALLED BY INTESTA,REALSTA,DOUBST
				!COMPST,LOGIST STATATEMENT ROUTINES
				!TO HANDLE THE CHECKING
				!THE DIFFERENCE BETWEEN A FUNCTIONDECLARATION AND A IMPLE TYPE DECLARATION
BEGIN
	EXTERNAL LSAVE;
	EXTERNAL FUNCGEN,TYPEGEN,SAVSPACE,TYPE,STK;
	EXTERNAL PST1ST,PSTATE,PSTIMPL,PSTSPF,ENDSTA;
	REGISTER BASE T1;

	ACTLDATYPE _ .DTYPE;		!SAVE ACTUAL TYPE IDENTIFIER CODE

	% PICK UP THE *N CONSTRUCT IF ANY %
	LSAVE _ 0;	!DIFFERENTIATES BETWEEN THIS AND THE OVERRIDE CALLS
	IF ( IDTYPE _ ASTER ( .DTYPE )) LSS  0  THEN  RETURN .VREG;
	IF SYNTAX( DECLARESPEC) LSS  0  THEN  RETURN .VREG;
	TYPE _ 4;
	T1_ .STK[0];
	 IF .T1[ELMNT] EQL 1
		THEN
		BEGIN	% FUNCTION %
			% CHECK THE STATEMENT ORDERING %
			IF .PSTATE EQL  PST1ST<0,0> 
			THEN
			BEGIN	% FINE ITS THE 1ST STATEMENT %
				PSTATE _ PSTIMPL<0,0>;	! ADJUST PSTATE TO IMPLICIT
				FLGREG<PROGTYP> _ FNPROG;
				FUNCGEN(@.T1[ELMNT1])
			END
			ELSE
			BEGIN	% MISSING END STATEMENT %
				RETURN ENDSTA()
			END
		END
		ELSE
		BEGIN	% TYPE DECLARATION %
			IF .PSTATE EQL  PST1ST<0,0>
			THEN	PSTATE _ PSTSPF<0,0>;	! SPECIFICATION STATE
			TYPEGEN(.T1[ELMNT1])
		END;
	SAVSPACE(.STK[0]<LEFT>,.STK[0])
END;	!OF TYPDECLARE



! TYPE STATEMENTS  *************

	MACRO
DATATYPE ( DTYPE )  =
BEGIN
	RETURN  TYPDECLARE( DTYPE )
END
$;

GLOBAL ROUTINE	INTESTA  =	DATATYPE ( INTEGER );

GLOBAL ROUTINE	REALSTA  =	DATATYPE ( REAL ) ;

GLOBAL ROUTINE 	LOGISTA	=	DATATYPE ( LOGICAL )  ;

GLOBAL ROUTINE	DOUBSTA	=	DATATYPE ( DOUBLPREC ) ;

GLOBAL ROUTINE	COMPSTA	=	DATATYPE ( COMPLEX ) ;


GLOBAL ROUTINE FUNCSTA=
BEGIN
	EXTERNAL STK,FUNCGEN %()%,SAVSPACE %(SIZE,LOC)%,TYPE;
	REGISTER BASE T1;
!SEMANTIC ANALYSIS BEGINS
	T1_.STK[0];IDTYPE_-1;TYPE_4;
	FLGREG<PROGTYP> _ FNPROG;
	FUNCGEN(.T1[ELMNT]);SAVSPACE(0,@STK[0]);
	.VREG
END;
GLOBAL ROUTINE SUBRSTA=
BEGIN
	EXTERNAL STK,FUNCGEN %()%,SAVSPACE %(SIZE,LOC)%,TYPE;
	REGISTER BASE T1;
!SEMANTIC ANALYSIS BEGINS
	T1_.STK[0];IDTYPE_-1;TYPE_0;
	FLGREG<PROGTYP> _ SUPROG;
	FUNCGEN(.T1[ELMNT]);SAVSPACE(0,@STK[0]);
	.VREG
END;
GLOBAL ROUTINE ENTRSTA=
BEGIN
	EXTERNAL NAMDEF;
	EXTERNAL STK,FUNCGEN %()%,SAVSPACE %(SIZE,LOC)%,TYPE,LASDOLABEL ;
	REGISTER BASE T1;
	IF .LASDOLABEL NEQ 0 THEN FATLEX(E75<0,0>); !ENTRY ILLEGAL INSIDE A DO LOOP
	IF .FLGREG<PROGTYP>  EQL  MAPROG THEN RETURN FATLEX(E114<0,0>);	!ENTRY ILLEGAL IN MAIN PROGRAM
!SEMANTIC ANALYSIS BEGINS
	FLGREG<MULTENT> _ 1;	! SET ENTRIES IN SUBROUTINE FLAG
	T1_.STK[0];

	%EQUIVALENCE FUNCTION AND ITS ENTRY NAMES%
	IF .FLGREG<PROGTYP>  EQL  FNPROG
	THEN
	BEGIN
		%WE WILL PRETEND THAT WE ARE THE SYNTAX ANALYZER AND
		 GENERATE AN EQUIVALENCE SYNTAX TREE AND THEN
		 GIVE IT TO EQUISTA FOR DISPOSITION  %

		EXTERNAL  NAME,ENTRY,TBLSEARCH,CORMAN,STK,EQUISTA;
		REGISTER BASE TREE;

		NAME<LEFT> _ 9;	!GET SOME SPACE
		STK[0] _ TREE _ CORMAN();		!ALL NODE

		(.TREE)[0] _ .TREE+1;		!LIST POINTER
		(.TREE)[1] _ 1^18 + .TREE+2;	!ALL POINTER
		(.TREE)[2] _ 1^18 + .TREE+4;	!ALL POINTER
		(.TREE)[3] _ .TREE+6;		!LIST POINTER
		(.TREE)[4] _ (	ENTRY _ .PROGNAME;
					NAME _ IDTAB;
					TBLSEARCH()	);	!FUNCTION NAME
		(.TREE)[4]<LEFT> _ IDENTIFIER;
		(.TREE)[5] _ 0;		!OPTION
		(.TREE)[6] _ 1^18 + .TREE+7;	!ALL POINTER
		(.TREE)[7] _ @.T1[ELMNT];	!ENTRY NAME
		(.TREE)[8] _ 0;		!OPTION

		%NOW PROCESS IT%
		IF EQUISTA()  LSS 0  THEN RETURN .VREG

	END;

	IDTYPE_-1;
	TYPE_1;
	FUNCGEN(.T1[ELMNT]);SAVSPACE(0,@T1);
	.VREG
END;
GLOBAL ROUTINE PROGSTA=
BEGIN
	EXTERNAL NAMDEF;
	EXTERNAL PROGNAME;
	LEXL_LEXEMEGEN();
	IF .LEXL<LEFT> EQL IDENTIFIER
%[1000]% THEN
%[1000]% BEGIN
%[1000]%	LOCAL BASE PR1;
		PR1_ .LEXL<RIGHT>;
		PROGNAME_.PR1[IDSYMBOL];
		NAMDEF( ENTRYDEF, .PR1 );	! DEFINITION OF PROGNAME
		PR1[IDATTRIBUT(FENTRYNAME)] _ 1;	! SET ENTRY POINT FLAG
		LEXL_LEXEMEGEN();
%[1000]% END
%[1000]% ELSE RETURN ERR0L(PLIT 'PROGRAM name');	! Flag missing name

	IF .LEXL<LEFT> NEQ LINEND
	THEN
	BEGIN	%SKIP ANYTHING LEFT FOR CDC COMPATIBILITY%
		EXTERNAL FATLEX,E134;
		DO LEXEMEGEN() UNTIL .VREG<LEFT> EQL LINEND;
		FATLEX(E134<0,0>)
	END;
	.VREG
END;
	GLOBAL ROUTINE 
PARASTA   =
BEGIN
	% PROCESS THE PARAMETER STATEMENT %
	! STK[0] CONTAINS APOINTER TO A LIST POINTER
	! EACH LIST COMPONENT IS AN ALL POINTER TO
	! A 3 ELEMENT BLOCK OF IDENTIFIER - OPTION - CONSTLEX/LITSTRING

	EXTERNAL SAVSPACE,NAMDEF;
	REGISTER  BASE  T2:R2:R1;
	LOCAL BASE T1:POSCON;

	T1 _ @(@STK[0]);	!LIST POINTER
	SAVSPACE ( 0, @STK[0] );	!SAVE THE LIST POINTER

	!PROCESS THE LIST OF ID = CONST
	INCR  PRMLST  FROM  @T1 TO @T1 + .T1<LEFT>
	DO
	BEGIN
		MAP BASE  PRMLST;

		T2 _ .PRMLST[ELMNT];	!ALL POINTER
		R2 _ .T2[ELMNT];		!IDENTIFIER
		%RECORD THE DEFINTION%
		IF NAMDEF ( PARADEF,  .R2 ) LSS 0 THEN RETURN .VREG;
	
		R2[IDATTRIBUT(PARAMT)] _ -1;

		IF .T2[ELMNT1]  EQL  1
		THEN
		BEGIN	%CONSTANT%
			R1 _ .T2[ELMNT2];	!POINTER TO (+/-)CONSTLEX
			CASE  .R1[ELMNT] OF SET
		
			%NO SIGN% BEGIN
				R2[IDPARAVAL] _ .R1[ELMNT1]
			END;

			% + %	BEGIN
				R2[IDPARAVAL] _ .R1[ELMNT2]
			END;
	
			% - %	BEGIN
				POSCON _ .R1[ELMNT2];
				R2[IDPARAVAL] _ ( NEGCNST( POSCON )
						AND #777777 ) + CONSTLEX^18
			END

			TES;

			SAVSPACE ( .R1<LEFT> , @R1 )
		END
		ELSE
		BEGIN
			R2[IDPARAVAL] _ .T2[ELMNT2];	!LITSTRING
		END;

		SAVSPACE ( .T2<LEFT>, @T2 )
	END;
	SAVSPACE ( .T1<LEFT>, @T1)
END;	%PARASTA%
GLOBAL ROUTINE BLOCSTA=
BEGIN
	EXTERNAL PROGNAME,STK,NAMDEF;
	LEXL_LEXEMEGEN();
	IF .LEXL<LEFT> EQL IDENTIFIER
	  THEN(LOCAL BASE PR1;
		PR1_ .LEXL<RIGHT>;
		PROGNAME_.PR1[IDSYMBOL];
		NAMDEF( ENTRYDEF, .PR1 );	! DEFINITION OF NAME
		PR1[IDATTRIBUT(FENTRYNAME)] _ 1;	!ENTRY POINT FLAG
		LEXL_LEXEMEGEN();
		)
	  ELSE PROGNAME _ SIXBIT'.BLOCK';
	FLGREG<PROGTYP> _ BKPROG;	!BLOCK DATA SUBPROGRAM FLAG
	IF .LEXL<LEFT> NEQ LINEND THEN	RETURN NOEOSERRL;
	.VREG
END;
GLOBAL ROUTINE DIMESTA=
BEGIN
	EXTERNAL STK,BLDARRAY %(LIST OF ONEARRAY'S)%,SAVSPACE %(SIZE,LOC)%,TYPE;
	REGISTER BASE T1;
!SEMANTIC ANALYSIS BEGINS
	IDTYPE_-1;TYPE_0;T1_@STK[0];BLDARRAY(.T1[ELMNT]);
	SAVSPACE(0,@STK[0]);
	.VREG
END;
GLOBAL ROUTINE COMMSTA=
BEGIN
	EXTERNAL NAMDEF;
	EXTERNAL STK,BLDARRAY %(ONEARRAY LIST)%,SAVSPACE %(SIZE,LOC)%,TYPE,IDTYPE,BLKSRCH %(NAME)%;
	EXTERNAL FATLEX,E0;
	REGISTER BASE T1; LOCAL BASE T2; REGISTER BASE R1:R2;
!SEMANTIC ANALYSIS BEGINS
!-----------------------------------------------------------------------------------
!THE FIRST LOCATION OF THE LEXEME STACK (STK[0])
!POINTS TO THE LIST OF COMMON GROUPS TO BE SCANNED.
!-----------------------------------------------------------------------------------
	R1_.STK[0];STK[1]_.R1[ELMNT];SAVSPACE(0,@R1);
	INCR CLST FROM @STK[1] TO @STK[1]+.STK[1]<LEFT> DO
	BEGIN
		MAP BASE CLST; R1_.CLST[ELMNT];
		IF .R1[ELMNT] EQL 0 THEN ! BLANK COMMON
		BEGIN
			IF .CLST EQL @STK[1]	!IF WE ARE STILL AT THE BEGINNING OF THE LIST
			THEN	!IT'S OK
				R2_BLKSRCH(SIXBIT '.COMM.')
			ELSE	!SOMEONE FORGOT A COMMA
				FATLEX(PLIT ', OR /',PLIT 'IDENTIFIER',E0<0,0>)
		END
		ELSE !SLASHS SEEN GET BLOCK NAME IF THERE
		BEGIN
			T1_.R1[ELMNT1];
			IF .T1[ELMNT1] EQL 0 THEN R2_BLKSRCH(SIXBIT '.COMM.')
			ELSE
			BEGIN
				T2_.T1[ELMNT2];SAVSPACE(.T1<LEFT>,@T1);
				%CHECK AND DEFINE THE NAME %
				IF NAMDEF( CMNBLK, .T2 ) LSS 0 THEN RETURN .VREG;

				T2[IDATTRIBUT(COMBL)] _ 1; !SET COMMONBLOCK NAME BIT
				R2_BLKSRCH(.T2[IDSYMBOL]);
			END;
			R1_.R1+1; !INCR PTR IF SLASHES FOR CALL TO BLDARRAY COMING UP
		END;
		IDTYPE_-1;TYPE_5;STK[2]<LEFT>_.R2[COMFIRST];

		!MUST BE VERY CAREFUL IF BLDARRAY FAILS, FOR UNDER SOME
		! CIRCUMSTANCES, STK[2] WILL CONTAIN -1 WHICH KILLS US
		STK[2]<RIGHT>_.R2[COMLAST];
		IF BLDARRAY(.R1[ELMNT1]) GEQ 0 THEN
		BEGIN
		!---------------------------------------------------------------------------
		!STK[2] CONTAINS THE INFORMATION REQUIRED BY BLDARRAY TO
		!LINK ELEMENTS OF THE COMMON BLOCK.  IT IS UPDATED BY
		!BLDARRAY TO CONTAIN LINKS TO THE FIRST AND LAST ELEMENT IN
		!THE BLOCK.
		!--------------------------------------------------------------------------
		R2[COMFIRST]_.STK[2]<LEFT>;R2[COMLAST]_.STK[2]<RIGHT>;
		R1 _ .R2[COMFIRST]; !FIRST ITEM IN BLOCK
				DO
				   R1[IDCOMMON] _ .R2  !PUTTING PTR TO BLOCK IN EACH ITEM
				  WHILE (R1 _ .R1[IDCOLINK]) NEQ 0;
		END %OF FIXING UP COMMON POINTERS%
	END;T1_.STK[1];SAVSPACE(.T1<LEFT>,@T1);
	.VREG
END;
END
ELUDOM