Google
 

Trailing-Edge - PDP-10 Archives - BB-D480F-BB_1985_short - sta2.bli
There are 26 other files named sta2.bli in the archive. Click here to see a list.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR ANY  OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF THE  SOFTWARE  IS  HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT  NOTICE
!AND  SHOULD  NOT  BE  CONSTRUED  AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY  OF  ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.

!AUTHOR: F.J. INFANTE, D. B. TOLMAN/DCE/SJW/EGM/CKS/AHM/TFV/AlB/RVM/PLB/MEM

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


GLOBAL BIND STA2V = #10^24 + 0^18 + #2507;	! Version Date: 20-Dec-84

%(

***** 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

***** Begin Version 7 *****

49	1213	TFV	6-May-81	------
	Modify ASTER to handle CHARACTER*(*), CHARACTER*n, and CHARACTER*(n).
	The length for character data gets put on the stack.  Fix TYPDECLARE
	to handle CHARACTER decl's.  Add CHARSTA the CHARACTER decl semantic
	routine. Move ACTLDATYPE and CHDLEN to GLOBAL.BLI. Add a second 
	argument to FUNCGEN to distinguish 'datatype FUNCTION ...' from
	'FUNCTION ...'.  The first case puts CHLEN on the stack.

50      1214     CKS	1-Jun-81
	Prohibit ENTRY statement in range of block IF as well as DO

51      1224     CKS    12-Jun-81
        Use "LTLSIZ-1" instead of "2" to free up literal node

52	1232	TFV	24-Jun-81	------
	CHARSTA sets CHDECL flag if a character declaration is seen. Used
	in MRP3R and MRP3G to test if we have to scan the symbol table to
	generate high seg character descriptors.

53	1256	CKS	8-Sep-81
	Modify COMMSTA to read the modified output of SYNTAX for the modified
	common statement.  The difference is that COMMON // X is returned with
	a concatenation lexeme instead of two slashes.

54	1267	AHM	6-Oct-81	------
	Define a stub routine SAVESTA for the SAVE statement so we don't
	get undefined symbols when linking.

55	1434	TFV	14-Dec-81	------
	Modify  ENTRSTA   to   handle  multi-entry   function   subprograms.
	Character  and  numeric  entry  points  cannot  occur  in  the  same
	subprogram.  All character  entry points  must be  the same  length;
	they share the descriptor for the function result. All numeric entry
	points are  equivalenced using  the EQUIVALENCE  statement  semantic
	routine.

56	1466	CDM	1-Feb-82
	Added warning for using SAVE statement.  Not yet implemented.

1511	CDM	18-March-82
	Added code for SAVE statement in SAVESTA.
	Added routine LKSVCOMMON for linking common blocks together for
	SAVE statement processing.

1527	CKS	9-Apr-82
	Rewrite ASTER to allow expressions as length specifiers.  Modify
	PARASTA to allow expressions in parameter statements.

1531	CDM	4-May-82
	Changes for code review of SAVE.

1566	CDM	24-Jun-82
	Remove warning for SAVE processing with overlays.

1575	TFV	7-Jul-82
	Modify TYPEDECLARE and ASTER to accept 'var * len (subs) * len'.

1646	TFV	18-Oct-82
	Fix ASTER to give  an error for character  lengths less than  or
	equal to 0.

1656	CKS	25-Oct-82
	Modify parameter statement semantic routine PARASTA to do nothing.
	It's all handled in action routine PARMASSIGN.

1667	TFV	9-Nov-82
	Fix ASTER to give a better  found when expecting error for  type
	declarations.

1704	TFV	21-Dec-82
	Fix type declarations to allow optional comma after the optional
	*size specifier.   The comma  is only  allowed if  the *size  is
	specified.


***** Begin Version 10 *********

2250	AlB	22-Dec-83
	Added Compatibility flagging for Type Declarations.
	Added code to allow LOGICAL*2 with warning.
	Routine:
		ASTER

2252	AlB	27-Dec-83
	Change edit 2250 to use ISN instead of LEXLINE for error line number.
	Routine:
		ASTER

2256	AlB	29-Dec-83
	Change the INCLUDE statement so as to recognize /LIST and /CREF
	switches as valid options.  This is in order to make Fortran-20
	more compatible with VAX-11 Fortran.
	Routine:
		INCLSTA

2261	AlB	5-Jan-84
	Added compatibility check to INCLUDE statement, which is extension
	to Fortran-77.
	Routine:
		INCLSTA

2270	AlB	10-Jan-84
	Turn off compatibility flagging for VAX when equating ENTRY variable
	with FUNCTION variable, so as to avoid redundant (and confusing) warning.
	Routine:
		ENTRSTA

2312	AlB	20-Feb-84
	Fix the INCLUDE switches used by Fortran-10.  This code was
	originally entered with edit 2256, but was never tested in the
	Tops-10 version.

2343	RVM	18-Apr-84
	Have COMMSTA put the COMMON block variables in the proper PSECT
	as it links up the COMMON block chain.

2412	TFV	2-Jul-84
	Split LEXICA into  two modules.   The classifier is  in the  new
	module LEXCLA.   The lexeme  scanner is  in LEXICA.   LEXCLA  is
	called  to  initialize  each  program  unit,  to  classify  each
	statement, to classify the consequent statement of a logical IF,
	and to do the standard end of program and missing end of program
	actions.

2430	CDM	18-Jul-84
	Have the compiler complain /FLAG  for a variable mentioned  more
	than once  in  SAVE statements  (SAVE  A,B,A -  A  is  mentioned
	twice).

2447	PLB	10-Aug-84
	Changes for nested INCLUDE.  Also added code for .SFD's in
	INCLUDE files, and outlawed non-octal digits in PPNs.

2455	MEM	30-Aug-84
	Replace all occurrences of VAX with VMS.

2460	AlB	26-Sep-84
	Force REAL*16 to be treated as REAL*8 instead of REAL*4.

2507	CDM	20-Dec-84
	Add enhancement for IMPLICIT NONE (edit 2473) after code inpsection.
	Check more cases, and add a symbol table walk at the back 
	end to catch unreferenced variables.

***** End V10 Development *****

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

)%

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

!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
% 13%	SAVESTA,	![1267] SAVE STATEMENT
%1511%	LKSVCOMMON;	! Links together Common blocks for SAVE processing

FORWARD
%2447%	FIXLINENO,	!BLAST LINENO[1] FOR INCLSTA/POSTINCL
%1511%	LKSVCOMMON,	! Links together Common blocks for SAVE processing
	POSTINCL;	!CLEAN UP AFTER INCLUDE

EXTERNAL
%2430%	CFLAGB,		! Error message output routine for /FLAG:ALL
%1232%	CHDECL,		! Flag for character declaration seen
%1527%	CNVCONST,	! Convert constant to desired type
	CORMAN,		! Routine to get space from free memory
	DOIFSTK,
	E122,		! Error - Double <frob> name illegal
	E124,		! Error - INCLUDEd files must reside on disk
	E178,		! Error - character and numeric entry points cannot
			! be mixed.
	E179,		! Error - character entry points must have the same
			! length.
%1531%	E192,		! "Illegal in SAVE statement"
%2455%	E244,		! "VMS incompatibility: /NOCREF"
%2455%	E245,		! "VMS incompatibility: /CREF"
%2455%	E246,		! "VMS incompatibility: Default for VMS is /NOLIST"
%2256%	E291,		! "Conflicting INCLUDE switches"
%2261%	E292,		! "Extension to Fortran-77: INCLUDE statement"
%2430%	E301,		! "Variable xxx already declared in SAVE statement"
	ENTRY,		! Parameter for TBLSEARCH
	EQUISTA,	! Routine to do semantic processing for EQUIVALENCE
%1511%	FATLERR,	! Error routine
	FUNCGEN,	! Routine to  processes  the argument  list  for  an
			! ENTRY, FUNCTION or SUBROUTINE statement
%2447%	ICLEVEL,	! Current INCLUDE level
%2412%	LEXCLA,		! Classifier entry point
%2412%	LEXICAL,	! Lexeme entry point
	LINENO,
	NAMDEF,
	NAME,		! Parameter for TBLSEARCH
%1511%	NUMSAVCOMMON,	! Number of commons to SAVE.
%1531%	PTRSAVCOMMON,	! Linked list of commons to SAVE.
	SAVSPACE,	! Routine to return space to free memory
%1511%	SAVALL,		! SAVE with no arguments specified
%1511%	SAVBLC,		! SAVE blank common
%2447%	SAVFLG[INCLMAX],! Array of saved flags (during INCLUDE)
%1511%	SAVLOC,		! SAVE local variables
%1511%	SAVNED,		! SAVE rel block is needed
	STK,
	TBLSEARCH,	! Routine to lookup a symbol table entry
	TYPE,
	WARNLEX;

%2447%	BIND	WRDS2SAVE = 8;			!NUMBER OF WORDS PER LEVEL
%2447%	STRUCTURE SAVTBL[I,J]=[I*J](.SAVTBL+.I*J+.J);
%2447%	OWN SAVTBL SVINCL[WRDS2SAVE,INCLMAX];	!TABLE OF SAVED VALUES

%2447%	MACRO	ICLCHAN = (ICL + .ICLEVEL)$;	!INCLUDE CHANNEL

GLOBAL ROUTINE INCLSTA=
BEGIN	% INCLUDE STATEMENT%

%2447%	OWN PTHBLK[10];			!BLOCK FOR FULL INCLUDE PATH
	OWN TMP;

%2256%	GLOBAL ICLPTR;
%2447%	GLOBAL SVFLG2[INCLMAX];		!AREA TO SAVE FLAG2 DURING INCLUDE

	EXTERNAL EOPSVPOOL,POOL,EOPRESTORE;
	EXTERNAL LEXICAL,GSTCSCAN,GSTSSCAN,LOOK4CHAR,LEXEMEGEN,GSTEOP;
	BIND EOF = #200;

%2447%	MACHOP	CALLI = #047;		!IMMEDIATE CALL (TOPS-10)
%2447%	MACRO	FILOP&(X) = CALLI(X,#155)$; !GENERAL FILE OPERATOR
%2447%	  BIND	&FORED = #1;		!FILOP. LOOKUP FUNCTION

%2447%	MACHOP	JSYS = #104;		!JUMP TO SYSTEM (TOPS-20)
%2447%	MACRO	CLOSF = JSYS(0,#22)$;	!CLOSE JFN IN AC1

	MACRO  DEFAULT =  TMP<LEFT>$,
%2256%		NOLST =	TMP<0,2>$, ! 1 if /NOLIST, 2 if /LIST, 0 otherwise
%2256%		NOCRF =	TMP<2,2>$; ! 1 if /NOCREF, 2 if /CREF, 0 otherwise

	MACRO	ERRORR(X) = RETURN FATLEX(X<0,0>)$;

	FORWARD
%2447%		PATH,PPNUM,SCANFIL,FILSP,SWIT10,SWIT20(2);

ROUTINE  FILSP  =
BEGIN	!FILSP
IF NOT FTTENEX
THEN
BEGIN	!TOPS-10
	REGISTER R;

	%GET DEVICE OR FILE NAME%
	WHILE 1 DO
	BEGIN	%LOOP%

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

	%STORE FILE NAME%
%2447%	IF @FILENAME(ICLCHAN+1) NEQ 0
	THEN	RETURN  FATLEX( SIXBIT'FILE', E122<0,0>);
%2447%	FILENAME(ICLCHAN+1) _ .R;

	LOOK4CHAR _ ".";
	IF LEXICAL(.GSTCSCAN)  EQL  0
	THEN
	BEGIN
		%DEFAULT%
		DEFAULT _ 1;
%2447%		(FILENAME(ICLCHAN+1)+1) _ SIXBIT'FOR';
	END
	ELSE
	BEGIN
		DEFAULT _ 0;
%2447%		(FILENAME(ICLCHAN+1)+1) _ SCANFIL()
	END;
	RETURN 1
END	!TOPS-10
END;	!FILSP


ROUTINE	PATH =			!PICK UP A FULL PATH

!++
! Created from old routine PPN [2447] /PLB
! FUNCTIONAL DESCRIPTION:
!
!	Parse a full file path for INCLUDE
!
! FORMAL PARAMETERS:
!
!	None
!
! IMPLICIT INPUTS:
!
!	ICLCHAN
!
! IMPLICIT OUTPUTS:
!
!	Sets up current INCLUDE level directory pointer.
!	Sets up full path in PTHBLK[]
!
! ROUTINE VALUE:
!
!	-1	Error parsing path
!	 0	No path found
!	 1	Success
!
! SIDE EFFECTS:
!
!	Reads tokens.
!
!--

BEGIN	!PATH
IF NOT FTTENEX
THEN
BEGIN	!TOPS-10
	REGISTER PTR;			!POINTER (INDEX) INTO PATH BLOCK
	LABEL SFDLOP;

	LOOK4CHAR = "[";
	IF LEXICAL(.GSTCSCAN) EQL 0
	THEN
	BEGIN	!NO [ FOUND
		DIRECTORY(ICLCHAN+1) = 0;
		RETURN 0		!NONE
	END;	!NO [ FOUND

	IF (PTHBLK[2]<LEFT> = PPNUM()) EQL 0 !GET PROJECT
	THEN RETURN -1;			!ERROR

	LOOK4CHAR = ",";		!LOOK FOR A COMMA
	IF LEXICAL(.GSTCSCAN) EQL 0
	THEN RETURN -1;			!ERROR

	IF (PTHBLK[2]<RIGHT> = PPNUM()) EQL 0 !GET PROGRAMMER
	THEN RETURN -1;			!ERROR

	PTR = 3;			!INDEX TO FIRST SFD WORD
	PTHBLK[9] = 0;			!ENSURE LAST WORD OF PATH IS ZERO

SFDLOP:	DO
	BEGIN	!SFDLOP
		PTHBLK[.PTR] = 0;	!ZERO NEXT SFD WORD
		LOOK4CHAR = ",";	!LOOK FOR A COMMA
		IF LEXICAL(.GSTCSCAN) EQL 0
		THEN LEAVE SFDLOP;	!NO COMMA, DONE!!

		IF (PTHBLK[.PTR] = SCANFIL()) EQL 0 !PICK UP SIXBIT
		THEN RETURN -1;		!FATAL ERROR IF BLANK

		PTR = .PTR + 1		!ADVANCE POINTER
	END	!SFDLOP
	WHILE .PTR LSS 9;

	LOOK4CHAR = "]";		!LOOK FOR CLOSING BRACKET
	IF LEXICAL(.GSTCSCAN) EQL 0
	THEN RETURN -1;			!ERROR?!!

	DIRECTORY(ICLCHAN+1) = PTHBLK<0,0>; !POINT DIRECTORY TO PATH BLOCK

	RETURN 1			!GOT ONE
END	!TOPS-10
END;	!PATH

ROUTINE PPNUM =			!PARSE OFF AN OCTAL NUMBER FOR PJ/PN
BEGIN	!PPNUM
IF NOT FTTENEX
THEN
BEGIN	!TOPS-10
	REGISTER NUM,C;
	NUM _ 0;
	LOOK4CHAR _ "?D";		!LOOK FOR ANY DIGIT
	UNTIL  ( C _ LEXICAL(.GSTCSCAN) ) EQL  0
%2447%	DO IF .C LEQ "7"		!LEGAL "OIT"??
%2447%	THEN NUM _ .NUM*8 + .C -"0"	!YES, ADD IN
%2447%	ELSE RETURN 0;			!NO, NOT AN OIT!!, RETURN ERROR
	RETURN .NUM
END	!TOPS-10
END;	!PPNUM

ROUTINE	SCANFIL  =
BEGIN	!SCANFIL
IF NOT FTTENEX
THEN
BEGIN	!TOPS-10
	%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	!TOPS-10
END;	!SCANFIL


ROUTINE   SWIT10 =	![2256]
%2256%	! Allow /LIST, /CREF, /NOLIST and /NOCREF

BEGIN IF NOT FTTENEX THEN BEGIN

%[722]%	LOOK4CHAR_"/";
%[722]%
%[722]%	IF LEXICAL(.GSTCSCAN) EQL 0 THEN RETURN 0;
%[722]%	DO
%[722]%	BEGIN
%[722]%
%2312%		LOOK4CHAR=(UPLIT ASCIZ 'NOLIST')<36,7>;
%[722]%		IF LEXICAL(.GSTSSCAN) NEQ 0
%2256%		THEN			! Got /NOLIST
%2256%		    IF .NOLST EQL 2	! Check conflict with /LIST
%2256%		    THEN WARNLEX(E291<0,0>)
%2256%		    ELSE NOLST=1
%[722]%		ELSE  !TRY NOCREF
%[722]%		BEGIN
%2312%		    LOOK4CHAR=(UPLIT ASCIZ 'NOCREF')<36,7>;
%[722]%		    IF LEXICAL(.GSTSSCAN) NEQ 0
%2256%		    THEN		! Got /NOCREF
%2256%			BEGIN
%2455%			IF FLAGVMS THEN WARNLEX(E244<0,0>); ! VMA doesn't have /NOCREF
%2256%			IF .NOCRF EQL 2 ! Check conflict with /CREF
%2256%			THEN WARNLEX(E291<0,0>)
%2256%			ELSE NOCRF=1
%2256%			END
%2256%		    ELSE
%2256%			BEGIN
%2312%			LOOK4CHAR=(UPLIT ASCIZ 'LIST')<36,7>;
%2256%			IF LEXICAL(.GSTSSCAN) NEQ 0
%2256%			THEN		! Got /LIST
%2256%			    IF .NOLST EQL 1	! Check conflict with /NOLIST
%2256%			    THEN WARNLEX(E291<0,0>)
%2256%			    ELSE NOLST=2
%2256%			ELSE
%2256%			    BEGIN
%2312%			    LOOK4CHAR=(UPLIT ASCIZ 'CREF')<36,7>;
%2256%			    IF LEXICAL(.GSTSSCAN) NEQ 0
%2256%			    THEN	! Got /CREF
%2256%				BEGIN
%2455%				IF FLAGVMS THEN WARNLEX(E245<0,0>); ! VMS doesn't have /CREF
%2256%				IF .NOCRF EQL 1 ! Check conflict with /NOCREF
%2256%				THEN WARNLEX(E291<0,0>)
%2256%				ELSE NOCRF=2
%2256%				END
%2256%			    ELSE RETURN -1	! Error
%2256%			    END
%2256%			END
%[722]%		END;
%[722]%		LOOK4CHAR_"/"
%[722]%	END UNTIL LEXICAL(.GSTCSCAN) EQL 0;
%[722]%
%[722]%	RETURN 1;
END END;

ROUTINE SWIT20 (SWTEST,ORGICL) =	![2256]
! Try to match a switch (Fortran-20 version)
! SWTEST points to desired value of switch
! ORGICL points to switch in the INCLUDE text
BEGIN
	IF FTTENEX
	THEN	BEGIN
		REGISTER CHAR1,CHAR2;	! Current characters to match
		LOCAL PNT;		! Pointer to literal to be matched

		ICLPTR=.ORGICL;		! Start here in INCLUDE text
		PNT=.SWTEST;		! Match this literal

		UNTIL (CHAR1 = SCANI(PNT)) EQL 0
		DO	BEGIN
			CHAR2=SCANI(ICLPTR);
			IF  .CHAR2 GEQ "a" AND .CHAR2 LEQ "z"
			THEN CHAR2=.CHAR2-#40;	! Convert lower- to upper-case
			IF .CHAR1 NEQ .CHAR2
			THEN	! No match
				BEGIN
				ICLPTR=.ORGICL;	! Reset the pointer
				RETURN FALSE
				END
			END;

		SCANI(ICLPTR);			! Bump to next '/' or end
		RETURN TRUE			! Match
		END; ! If FTTENEX
END; ! of SWIT20

	%LETS DO IT%

%2447%	IF .FLGREG<ININCLUD>			!IN INCLUDE NOW?
%2447%	THEN
%2447%	BEGIN	!NOW IN INCLUDE
%2447%		IF .ICLEVEL EQL INCLMAX-1 	!NOW AT BOTTOM? (ZERO BASED)
%2447%		THEN ERRORR(E120);		!YES, NESTED TO DEEPLY
%2447%	END	!NOW IN INCLUDE
%2447%	ELSE ICLEVEL = -1;			!FIRST INCLUDE FILE
%2447%						!(KEPT PRE-INCREMENTED
%2447%						!UNTIL OPEN)

%2261%	IF FLAGANSI THEN WARNLEX(E292<0,0>);	! INCLUDE is extension to ANSI

	NOLST=NOCRF=0;	! Preset the defaults

	IF NOT FTTENEX THEN
	BEGIN	!TOPS-10

%2447%	FILENAME(ICLCHAN+1)  _ 0;
	TMP _ 0;
%2447%	DIRECTORY(ICLCHAN+1) _ 0;
%2447%	DEVICE(ICLCHAN+1) _ 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
%2447%					IF @FILENAME(ICLCHAN+1) EQL 0
%2447%					OR @DEVICE(ICLCHAN+1) EQL 0
					THEN	IF  FILSP()  EQL  1
						THEN  LEAVE LOOP !FOUND ONE
						ELSE	IF .VREG LSS 0 
							THEN RETURN .VREG;
%2447%					IF @DIRECTORY(ICLCHAN+1) EQL 0
%2447%					THEN IF PATH() EQL 1
					THEN LEAVE LOOP
					ELSE IF .VREG  LSS 0
					THEN ERRORR(E117);

					IF SWIT10()  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%
%2447%		IF @DEVICE(ICLCHAN+1)  EQL  0
%2447%		THEN DEVICE(ICLCHAN+1) _ SIXBIT'DSK';
		BEGIN	%MAKE SURE THAT THE DEVICE IS A DISK%
%2447%			MACHOP  CALLI = #047;
%2447%			MACRO	DEVCHR(X) = CALLI(X,#4) $,
%2447%				DV&DSK = 34,1 $;

%2447%			VREG _ @DEVICE(ICLCHAN+1);
%2447%			DEVCHR(VREG);
%2447%			IF NOT .VREG<DV&DSK> !NOT A DISK?
			THEN	RETURN  FATLERR(.ISN,E124<0,0>)
		END;

%2447%		IF @FILENAME(ICLCHAN+1)  EQL  0
		THEN	ERRORR(E118);	!NO FILE NAME

%2447%		STATUS(ICLCHAN+1) _ 0;	!ASCII
%2447%		BUFFERS(ICLCHAN+1) _ BUFHDR(ICLCHAN+1)<0,0>;

		LOK:BEGIN
		WHILE 1 DO
		BEGIN
%2447%			REGISTER T1;	!REGISTER FOR FILOP.
%2447%			LOCAL ARGBLK[6]; !FILOP. BLOCK

%2447%			ARGBLK[0] = (ICLCHAN+1)^18 + &FORED;	!CHN,,FNC
%2447%			ARGBLK[1] = @STATUS(ICLCHAN+1);		!COPY I/O MODE
%2447%			ARGBLK[2] = @DEVICE(ICLCHAN+1);		!DEVICE
%2447%			ARGBLK[3] = @BUFFERS(ICLCHAN+1);	!0,,IHDR
%2447%			ARGBLK[4] = 3;				!0,,IBUFCNT
%2447%			ARGBLK[5] = FILENAME(ICLCHAN+1)<0,0>;	!0,,LKPBLK
%2447%
%2447%			T1 = 6^18 + ARGBLK<0,0>;		!LEN,,ADDR
%2447%			IFSKIP FILOP&(T1)			!PERFORM OPEN
%2447%			THEN LEAVE LOK;				!OK!!

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

	END	!TOPS-10
	ELSE
	BEGIN	%FTTENEX%

		EXTERNAL OPNICL,E138;
		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
%2447%		VAL = OPNICL();		!OPEN THE FILE, RETURNS JFN OR
%2447%					!BP TO ERROR STRING
%2447%		IF .VAL<LEFT> EQL 0	!WAS THERE AN ERROR?
%2447%		THEN XDEVJFN(ICLCHAN+1) = .VAL	!NO WAS A JFN
%2447%		ELSE RETURN FATLERR(.VAL,.ISN,E138<0,0>); !YES, GIVE ERROR

%2256%	! Test for switches
%2256%	! Allow /LIST, /NOLIST, /CREF and /NOCREF
%2256%	! Warn if /LIST used with /NOLIST and if /CREF used with /NOCREF
%2455%	! VMS compatibility warning if /CREF or /NOCREF, or if neither
%2455%	! /LIST nor /NOLIST used (VMS default /NOLIST, we default /LIST)

%[722]%		WHILE ..ICLPTR EQL "/"
%[722]%		DO
%[722]%		BEGIN
%2256%		    IF SWIT20((UPLIT ASCIZ 'NOLIST')<36,7>,.ICLPTR)
%2256%		    THEN 			! Got /NOLIST
%2256%			IF .NOLST EQL 2		!  and best not have /LIST
%2256%			THEN WARNLEX(E291<0,0>)
%2256%			ELSE NOLST=1
%2256%		    ELSE
%2256%			IF SWIT20((UPLIT ASCIZ 'LIST')<36,7>,.ICLPTR)
%2256%			THEN			! Got /LIST
%2256%			    IF .NOLST EQL 1	!  and best not have /NOLIST
%2256%			    THEN WARNLEX(E291<0,0>)
%2256%			    ELSE NOLST=2
%2256%			ELSE
%2256%			    IF SWIT20((UPLIT ASCIZ 'NOCREF')<36,7>,.ICLPTR)
%2256%			    THEN		! Got /NOCREF
%2256%				IF .NOCRF EQL 2	!  and best not have /CREF
%2256%				THEN WARNLEX(E291<0,0>)
%2256%				ELSE
%2256%				    BEGIN
%2455%				    IF FLAGVMS THEN WARNLEX(E244<0,0>); ! No /NOCREF on VMS
%2256%				    NOCRF=1
%2256%				    END
%2256%			    ELSE
%2256%				IF SWIT20((UPLIT ASCIZ 'CREF')<36,7>,.ICLPTR)
%2256%				THEN			! Got /CREF
%2256%				    IF .NOCRF EQL 1	!  and best not have /NOCREF
%2256%				    THEN WARNLEX(E291<0,0>)
%2256%				    ELSE
%2256%				 	BEGIN
%2455%					IF FLAGVMS THEN WARNLEX(E245<0,0>); ! No /CREF on VMS
%2256%					NOCRF=2
%2256%					END
%2256%				ELSE
%2256%				BEGIN
%2447%					LOCAL ACSAVE;
%2447%					REGISTER AC1=1;
%2447%
%2447%					ACSAVE = .AC1; !SAVE AC1
%2447%					AC1 = @XDEVJFN(ICLCHAN+1);
%2447%					IFSKIP CLOSF THEN .VREG; !IGNORE ERROR
%2447%					AC1 = .ACSAVE; !RESTORE AC1
%2256%					FATLEX(E116<0,0>); ! Bad switch
%2256%					RETURN
%2256%				END
%2256%		END; ! of WHILE

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

	END;	%FTTENEX%

%2455%	IF FLAGVMS		! VMS compatibility insists that we
%2256%	THEN	IF .NOLST EQL 0	! have either /NOLIST or /LIST
%2256%		THEN WARNLEX(E246<0,0>);


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

	BEGIN	!SAVE THE INFO
		EXTERNAL  EOPSAVE,CURPOOLEND,CURPTR,STLPTR,STPTR;
		EXTERNAL  LINEPTR,SEQLAST,LINELINE,CHARPOS;

%2447%		ICLEVEL = .ICLEVEL + 1;		!FINALLY INCREMENT LEVEL!!
%2447%						!KEPT UN-INCREMENTED 'TILL NOW
%2447%		SVINCL[0,.ICLEVEL] _ .EOPSAVE;
%2447%		SVINCL[1,.ICLEVEL] _ .CURPOOLEND;
%2447%		SVINCL[2,.ICLEVEL] _ .CURPTR;
%2447%		SVINCL[3,.ICLEVEL] _ .STLPTR;
%2447%		SVINCL[4,.ICLEVEL] _ .STPTR;
%2447%		SVINCL[5,.ICLEVEL] _ .LINEPTR;
		IF .SEQLAST  NEQ  0
%2447%		THEN SVINCL[6,.ICLEVEL] _ .LINELINE !LINE SEQUENCE NUMBER
%2447%		ELSE SVINCL[6,.ICLEVEL] _ 0;
%2447%		SVINCL[7,.ICLEVEL] _ .CHARPOS;
		IF .CHARPOS  NEQ 72
		THEN	LINELINE _ .LINELINE+1;	!MULTIPLE STATEMENTS ON LINE

%2447%		SAVFLG[.ICLEVEL] _ .FLGREG<0,36>;
		FLGREG<ININCLUD> _ 1;
		FLGREG<EOCS> _ 1;
	
%2256%		IF .NOCRF EQL 1 THEN  FLGREG<CROSSREF> = 0;
%2256%		IF .NOLST EQL 1 THEN  FLGREG<LISTING> = 0;

		SVFLG2[.ICLEVEL] _ .FLAGS2;
		FLAGS2<TTYINPUT> _ 0;

%2447%		FIXLINENO();		!ZAP LINENO[1]

		CURPOOLEND _ POOL<0,0>;
		IF EOPRESTORE()  EQL  EOF
		THEN POSTINCL()		!RESTORE
	END	!SAVE THE INFO
END;	! of INCLSTA
GLOBAL ROUTINE POSTINCL=
BEGIN
	%RESTORE THE WORLD AFTER AN INCLUDED FILE %
	EXTERNAL  EOPSAVE,CURPOOLEND,CURPTR,STLPTR;
	EXTERNAL  STPTR,LINEPTR,SEQLAST,LINELINE;
	EXTERNAL  EOPRESTORE,SVFLG2;

	EXTERNAL SAVFLG,GSTEOP,CHARPOS;

%2447%	MACHOP	CALLI = #047;		!IMMEDIATE CALL (TOPS-10)
%2447%	MACRO	FILOP&(X) = CALLI(X,#155) $; !GENERAL FILE OPERATOR
%2447%	BIND	 &FOCLS = #7;		!FILOP. CLOSE FUNCTION

%2447%	MACHOP	JSYS = #104;		!JUMP TO SYSTEM (TOPS-20)
%2447%	MACRO	CLOSF = JSYS(0,#22) $;	!CLOSE JFN IN AC1

	% CLEAN UP LAST LINE%
%2412%	LEXCLA(.GSTEOP);

	IF NOT FTTENEX 
	THEN
%2447%	BEGIN	!TOPS-10
%2447%		REGISTER T1;		!FILOP. CHANNEL
%2447%		LOCAL ARG;		!FILOP. BLOCK
%2447%
%2447%		ARG = ICLCHAN^18 + &FOCLS; !CHAN,,FUNCTION
%2447%		T1 = 1^18 + ARG<0,0>;	!LENGTH,,ADDR
%2447%		IFSKIP FILOP&(T1)	!CLOSE CHANNEL
%2447%		THEN .VREG		!IGNORE ERRORS
%2447%	END	!TOPS-10
	ELSE
%2447%	BEGIN	!TOPS-20
%2447%		REGISTER AC1=1;
%2447%		LOCAL ACSAVE;
%2447%
%2447%		ACSAVE = .AC1;		!SAVE AC1
%2447%		AC1 = @XDEVJFN(ICLCHAN); !GET JFN
%2447%		IFSKIP CLOSF THEN .VREG; !CLOSE AND IGNORE ERROR
%2447%		AC1 = .ACSAVE		!RESTORE AC1
%2447%	END;	!TOPS-20

%2447%	EOPSAVE	   = @SVINCL[0,.ICLEVEL];
%2447%	CURPOOLEND = @SVINCL[1,.ICLEVEL];
%2447%	CURPTR	   = @SVINCL[2,.ICLEVEL];
%2447%	STLPTR	   = @SVINCL[3,.ICLEVEL];
%2447%	STPTR	   = @SVINCL[4,.ICLEVEL];
%2447%	LINEPTR	   = @SVINCL[5,.ICLEVEL];
%2447%	IF @SVINCL[6,.ICLEVEL] NEQ 0
%2447%	THEN LINELINE = @SVINCL[6,.ICLEVEL]; !LINE SEQUENCE NUMBER
%2447%	CHARPOS = @SVINCL[7,.ICLEVEL];

	SEQLAST _ 1;		!SO NO ONE WILL MESS WITH THE LINELINE

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

%2447%	SAVFLG[.ICLEVEL]<BTTMSTFL> _ .FLGREG<BTTMSTFL>; !IF 16 CLOBBERED
%2447%	SAVFLG[.ICLEVEL]<WARNGERR> _ .FLGREG<WARNGERR>; !WARNINGS GIVEN
%2447%	SAVFLG[.ICLEVEL]<FATALERR> _ .FLGREG<FATALERR>; !FATAL ERRORS GIVEN
%2447%	SAVFLG[.ICLEVEL]<LABLDUM> _ .FLGREG<LABLDUM>; !LABELS PASSED AS ARGS
%2447%	FLGREG<0,36> _ .SAVFLG[.ICLEVEL];
%2447%	FLAGS2 _ .SVFLG2[.ICLEVEL];

%2447%	ICLEVEL = .ICLEVEL - 1;		!DECREMENT INCLUDE LEVEL
%2447%	IF .ICLEVEL LSS 0		!DID WE JUST LEAVE THE LAST INCLUDE?
%2447%	THEN LINENO[1] _ '?I'		!YES, RESET LINENO TO TAB
%2447%	ELSE FIXLINENO();		!NO, MAKE IT <*><NUMBER>
	EOPRESTORE();			!RESTORE THE BUFFERS

END;	! of POSTINCL
ROUTINE FIXLINENO =

!++
! New [2447] /PLB
! FUNCTIONAL DESCRIPTION:

!	Setup LINENO[1] so that a *1 will appear next to the INCLUDEd
!	code's line number.  The second level of INCLUDE file will
!	have *2, the third *3; level 10 will be listed as *A etc.
!
!	This routine assumes .FLGREG<ININCLUD> is set.
!
! FORMAL PARAMETERS:
!
!	None
!
! IMPLICIT INPUTS:
!
!	ICLEVEL = Current INCLUDE level
!
! IMPLICIT OUTPUTS:
!
!	Blasts LINENO[1]
!
! ROUTINE VALUE:
!
!	None
!
! SIDE EFFECTS:
!
!	None
!
!--

BEGIN
	REGISTER C;
	LINENO[1] = '*x?I?0';		!SET UP TEMPLATE
	IF .ICLEVEL+1 LEQ 9		!LEVEL 9 OR LESS (ZERO BASED)
	THEN C = .ICLEVEL+1+"0"		!YES, GET DIGIT 1..9
	ELSE C = .ICLEVEL+1+"A"-10;	!NO, GET LETTER A..C
	LINENO[1]<22,7> = .C;		!BLAST IN LEVEL INDICATOR
	RETURN .VREG			!RETURN NOVALUE
END;	!FIXLINENO
GLOBAL ROUTINE ASTER(TYPE) =		! [1527] Rewritten
BEGIN
	!***************************************************************
	! This routine will scan for the *length construct following the
	! data type name in type or IMPLICIT or FUNCTION statements, and
%1575%	! for the forms 'var * len  (subs) * len' in type  declarations.
	! The parameter TYPE  is based  upon the data  type name.   This
	! routine will return as its value:
	!	1. The amended TYPE if a valid * construct was found
	!	2. TYPE if no * construct was found
	!	3. -1 if there was some error in the * construct
	!
%1575%	! Two words are deposited on STK:
%1575%	!	length for character data or 0
%1575%	!	flag = 1 if *size was specified
	!***************************************************************

	MACRO	ERR50(X) = FATLEX( .CHLEN, X<0,0>, E50<0,0>)$,
		ERR24(X) = WARNLEX( X<0,0>, .CHLEN, E24<0,0>)$,
%2252%		ERR251(X) = WARNERR( X<0,0>, .ISN, E251<0,0>)$;

	REGISTER
		BASE T1,
		D;

	EXTERNAL
		E251,	! Extension to Fortran-77: xxxxx length specifier
		CONSTEXPR,
		CHLEN,
		CHDLEN,
		ACTLDATYPE;

%1575%	! Put the default character length on  STK and also a zero  word
%1575%	! for the flag word for *size was specified

%1575%	STK[SP = .SP + 1] = CHLEN = .CHDLEN;
%1575%	STK[SP = .SP + 1] = 0;
	
	! Look at upcoming character.  If '*', continue below, otherwise return

	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 *, set the flag for *size specified and check for '(*)'

%1575%	STK[.SP] = 1;
	LOOK4CHAR = (UPLIT ASCIZ '(*)')<36,7>;

	IF LEXICAL(.GSTSSCAN) NEQ 0
	THEN
	BEGIN
		IF .TYPE NEQ CHARACTER 
		THEN RETURN FATLEX (UPLIT'constant',UPLIT'(*)',E0<0,0>);
		CHLEN = LENSTAR;
	END
	ELSE
	BEGIN	! digits for length

		LOOK4CHAR = "?D";	! any digit
		IF (D = LEXICAL(.GSTCSCAN)) NEQ 0
		THEN
		BEGIN	! *digits
			CHLEN = .D - "0";
			WHILE (D = LEXICAL(.GSTCSCAN)) NEQ 0
			DO CHLEN = .CHLEN*10 + .D - "0";
		END	! *digits
		ELSE

		BEGIN	! *(expression)
			LOOK4CHAR = "(";
			IF LEXICAL(.GSTCSCAN) NEQ 0
			THEN			
			BEGIN	
				IF CONSTEXPR() LSS 0 THEN RETURN .VREG;

				IF .LSAVE NEQ 0 THEN LSAVE = 0
						ELSE LEXL = LEXEMEGEN();

				IF .LEXL<LEFT> NEQ RPAREN
				THEN RETURN ERR0L(RPARPLIT);

				T1 = .STK[.SP];
				SP = .SP - 1;
				CHLEN = .T1[CONST2];
			END
			ELSE
%1667%			BEGIN	! error - give found when expecting error

%1667%				IF .LSAVE EQL 0
%1667%				THEN
%1667%				BEGIN
%1667%					LEXL = LEXEMEGEN();
%1667%					LSAVE = -1;
%1667%				END;

%1667%				RETURN ERR0L(UPLIT ASCIZ'integer constant or "("');

			END;	! error - give found when expecting error

		END;	! *(expression)

%1646%		! Give Illegal CHARACTER size modifier is less than 1

%1646%		IF .CHLEN LEQ 0 THEN RETURN ERR50(CHARPLIT);

	END;

	STK[.SP - 1] = .CHLEN;		! Set size specifier on STK

	! Check the specified size to see if it is legal.  Do the  check
	! on the basis of ACTLDATYPE of the statement in order to  allow
	! REAL*8 X*4  and to  exclude doubleprecision  X*4.  Return  the
	! datatype.

	SELECT .ACTLDATYPE OF NSET

	INTEGER:(
		IF .CHLEN EQL 2
		THEN
		BEGIN
			ERR24(INTGPLIT);
			RETURN .ACTLDATYPE
		END;

%2250%		IF .CHLEN EQL 4
%2250%		THEN
%2250%			BEGIN
%2250%			IF FLAGANSI THEN ERR251(INTGPLIT);
%2250%			RETURN .ACTLDATYPE
%2250%			END;

		RETURN ERR50(INTGPLIT);
		);

	REAL:(
%2250%		IF .CHLEN EQL 4
%2250%		THEN
%2250%			BEGIN
%2250%			IF FLAGANSI THEN ERR251(REALPLIT);
%2250%			RETURN .ACTLDATYPE
%2250%			END;

%2250%	  	IF .CHLEN EQL 8
%2250%		THEN
%2250%			BEGIN
%2250%			IF FLAGANSI THEN ERR251(REALPLIT);
%2250%			RETURN DOUBLPREC
%2250%			END;

	  	IF .CHLEN EQL 16
		THEN
		BEGIN
%2460%			ERR24(DOUBPLIT);
%2460%			RETURN DOUBLPREC
		END;

		RETURN ERR50(REALPLIT)
		);

	COMPLEX:(
%2250%		IF .CHLEN EQL 8
%2250%		THEN
%2250%			BEGIN
%2250%			IF FLAGANSI THEN ERR251(COMPLIT);
%2250%			RETURN .ACTLDATYPE
%2250%			END;

		IF .CHLEN EQL 16
		THEN
		BEGIN
			ERR24(COMPLIT);
			RETURN .ACTLDATYPE
		END;

		IF .CHLEN EQL 32
		THEN
		BEGIN
			ERR24(COMPLIT);
			RETURN .ACTLDATYPE
		END;

		RETURN ERR50(COMPLIT)
		);

	LOGICAL:(
%2250%		IF .CHLEN EQL 4
%2250%		THEN
%2250%			BEGIN
%2250%			IF FLAGANSI THEN ERR251(LOGIPLIT);
%2250%			RETURN .ACTLDATYPE
%2250%			END;

%2250%		IF .CHLEN EQL 2
%2250%		THEN
%2250%			BEGIN
%2250%			ERR24(LOGIPLIT);
%2250%			RETURN .ACTLDATYPE
%2250%			END;

		IF .CHLEN EQL 1
		THEN
		BEGIN
			ERR24(LOGIPLIT);
			RETURN .ACTLDATYPE
		END;

		RETURN ERR50(LOGIPLIT)
		);

	DOUBLPREC:(RETURN ERR50(DOUBPLIT));

	CHARACTER:(RETURN .ACTLDATYPE);

	TESN

END;	! of  ASTER

GLOBAL ROUTINE TYPDECLARE(DTYPE)=
BEGIN
	!***************************************************************
	! Called  by  INTESTA,  REALSTA,  LOGIST,  DOUBST,  COMPST,  and
	! CHARSTA statement routines.   It handles  the *size  modifier,
	! then uses  the  syntax  of DECLARESPEC  to  parse  a  function
	! declaration or an  explicit type declaration.   It then  calls
	! either FUNCGEN or TYPEGEN to handle the semantics.
	!***************************************************************

	EXTERNAL LSAVE;
	EXTERNAL FUNCGEN,TYPEGEN,SAVSPACE,TYPE,STK;
	EXTERNAL PST1ST,PSTATE,PSTIMPL,PSTSPF,ENDSTA;
%1213%	EXTERNAL CHDLEN,ACTLDATYPE;
	REGISTER BASE T1;

	ACTLDATYPE _ .DTYPE;		!SAVE ACTUAL TYPE IDENTIFIER CODE

%1213%	! Default length for character data is 1.
%1213%	CHDLEN _ 1;

	! PICK UP THE *N CONSTRUCT IF ANY

	LSAVE _ 0;	
	IF ( IDTYPE _ ASTER ( .DTYPE )) LSS  0  THEN  RETURN .IDTYPE;

%1575%	! ASTER leaves two words on STK:
%1575%	!	length for character data
%1575%	!	flag = 1 if *size was specified

%1704%	! Scan for optional comma after optional *n construct

%1704%	IF .STK[.SP] EQL 1
%1704%	THEN
%1704%	BEGIN	! *size was specified, look for optional comma

%1704%		IF .LSAVE  EQL  0
%1704%		THEN
%1704%		BEGIN
%1704%			LOOK4CHAR = ",";
%1704%			LEXICAL( .GSTCSCAN );	! Skip comma
%1704%		END
%1704%		ELSE
%1704%		BEGIN
%1704%			IF .LEXL<LEFT> EQL COMMA
%1704%			THEN LSAVE = 0;
%1704%		END;

%1704%	END;	! *size was specified, look for optional comma

%1575%	! Fetch default length for character data left on stack by ASTER

%1575%	IF .IDTYPE EQL CHARACTER
%1575%	THEN CHDLEN _ .STK[.SP - 1]
%1575%	ELSE CHDLEN _ 0;

%1575%	SP = .SP - 2;		! Discard the two words ASTER put on STK

	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;

%1213%			! Add second parameter to FUNCGEN; this is the
%1213%			! 'datatype FUNCTION ....' case
%1213%			FUNCGEN(@.T1[ELMNT1], 1)
			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	CHARSTA	=
BEGIN

%1213%	! Add CHARSTA for character declaration


	! Set flag for character declaration seen used
	! in MRP3R and MRP3G to test if we have to scan
	! the symbol table to generate high seg
	! character descriptors.

	CHDECL _ -1;

	DATATYPE ( CHARACTER ) ;	! Now process the character statement

END;	! of CHARSTA

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;

%[1213]%	! Add second parameter to FUNCGEN; this is 'FUNCTION ...' case
%[1213]%	FUNCGEN(.T1[ELMNT], 0);
	SAVSPACE(0,@STK[0]);
	.VREG

END;	! of FUNCSTA

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;

%[1213]%	! Add second parameter to FUNCGEN; this is 'SUBROUTINE ...' case
%[1213]%	FUNCGEN(.T1[ELMNT], 0);
	SAVSPACE(0,@STK[0]);
	.VREG

END;	! of SUBRSTA

GLOBAL ROUTINE ENTRSTA=
BEGIN
	! Process an ENTRY statement

%1434%	! Rewritten by TFV on 14-Dec-81

	REGISTER
		BASE FUNCID,	! Name of this function subprogram
		BASE IDSYM,	! Name of the entry point
		BASE PTR,	! Pointer to the syntactic output
		BASE TREE;	! Pointer to the block to  pass  to  the
				! EQUIVALENCE statement semantic routine

	LOCAL
%2455%		SAVEFLAG,	! Save FLAGVMS setting
		VAL;		! Used to avoid VREG usage

	! Check for error -  entry illegal inside a do or block if

	IF .DOIFSTK NEQ 0 THEN FATLEX(E75<0,0>);

	! Check for error - entry illegal in main program

	IF .FLGREG<PROGTYP> EQL MAPROG THEN RETURN FATLEX(E114<0,0>);

	IDTYPE = -1;		! Flag for FUNCGEN
	FLGREG<MULTENT> = 1;	! Set entries in subroutine flag
	PTR = .STK[0];		! Pointer to syntactic output

	IDSYM = @.PTR[ELMNT];	! Symbol table entry for this
				! entry point

%1531%	! An ENTRY point can not be in a SAVE statement.

%1531%	IF .IDSYM[IDSAVVARIABLE]
%1531%	THEN	FATLERR(.IDSYM[IDSYMBOL],UPLIT(ASCIZ'ENTRY name'),
%1531%		.ISN,E192<0,0>);

	! Equivalence a  numeric function  and  its entry  names,  character
	! functions and their entry points just share the descriptor for the
	! result.

	IF .FLGREG<PROGTYP> EQL FNPROG
	THEN
	BEGIN	! Function subprogram

		ENTRY = .PROGNAME;	! Name of this subprogram
		NAME = IDTAB;
		FUNCID = TBLSEARCH();	! Lookup symbol table entry for
					! the subprogram name

		IF .FUNCID[VALTYPE] NEQ CHARACTER
		THEN
		BEGIN	! Numeric function subprogram

			! Give an error if this is a character entry  point.
			! If it is numeric, pretend  that we are the  syntax
			! analyzer and  generate  an  EQUIVALENCE  statement
			! syntax tree  and  then  give  it  to  EQUISTA  for
			! semantic processing.

			! Check for error - character and numeric entry
			! points cannot be mixed.

			IF .IDSYM[VALTYPE] EQL CHARACTER
			THEN RETURN FATLEX(E178<0,0>);

			NAME<LEFT> = 9;			! Size of syntax tree
			STK[0] = TREE = CORMAN();	! Get some space

			(.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] = .FUNCID;		! Function name
			(.TREE)[4]<LEFT> = IDENTIFIER;
			(.TREE)[5] = 0;			! Option
			(.TREE)[6] = 1^18 + .TREE + 7;	! All pointer
			(.TREE)[7] = .IDSYM;		! Entry name
			(.TREE)[8] = 0;			! Option

			! Now process the syntax tree using the EQUIVALENCE
			! statement semantic routine.
%2270%			! Compatibility flagging is turned off so that we
%2270%			! won't put out a 'program name same as entry name'
%2270%			! flagger warning.

%2455%			SAVEFLAG=.F2<CFLGVMS>;	! Remember what flag setting is
%2455%			F2<CFLGVMS>=0;		! Turn off flagging temporarily
%2270%			VAL=EQUISTA();		! Equate progname to entryname
%2455%			F2<CFLGVMS>=.SAVEFLAG;	! Maybe turn flagging back on
%2270%			IF .VAL LSS 0 THEN RETURN .VAL ! Return if error
		END	! Numeric function subprogram
		ELSE
		BEGIN	! Character function subprogram

			! Check for error - character and numeric entry
			! points cannot be mixed.

			IF .IDSYM[VALTYPE] NEQ CHARACTER
			THEN RETURN FATLEX(E178<0,0>);

			! Check for error - Character entry points must have
			! the same length.

			IF .IDSYM[IDCHLEN] NEQ .FUNCID[IDCHLEN]
			THEN RETURN FATLEX(E179<0,0>);

			IDTYPE = CHARACTER;		! used by funcgen

		END;	! Character function subprogram

	END	! Function subprogram
%2507%	ELSE
%2507%	BEGIN	! Subroutine subprogram
%2507%
%2507%		IDSYM[IDSUBROUTINE] = 1;	! Mark symbol as subroutine
%2507%
%2507%	END;	! Subroutine subprogram


	TYPE = 1;

%1213%	! Add second parameter to FUNCGEN; this is 'ENTRY ...' case

%1213%	FUNCGEN(.PTR[ELMNT],0);
	SAVSPACE(0,@PTR)

END;	! of ENTRSTA

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;	! of PROGSTA

GLOBAL ROUTINE PARASTA=

! Parameter statement.
! [1656] All semantics are done in action routines; just return.

RETURN 0;				! RETURN SUCCESS

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;	! of BLOCSTA

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;	! of DIMESTA

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
%1511%			BEGIN	!IT'S OK
				R2_BLKSRCH(SIXBIT '.COMM.');
%1511%				! We need a SAVE rel block
%1511%				SAVBLC _ TRUE;
%1511%				SAVNED _ TRUE;
%1511%			END
			ELSE	!SOMEONE FORGOT A COMMA
				FATLEX(PLIT ', OR /',PLIT 'IDENTIFIER',E0<0,0>)
		END
		ELSE !SLASHS SEEN GET BLOCK NAME IF THERE
		BEGIN
%1256%			IF .R1[ELMNT] EQL 2 
				! OPTION 2, // SEEN.  MEANS BLANK COMMON
%1256%			THEN
%1511%			BEGIN
			 	R2_BLKSRCH(SIXBIT '.COMM.');
%1511%				! Need to rel block to SAVE this
%1511%				SAVBLC _ TRUE;
%1511%				SAVNED _ TRUE;
%1511%			END
			ELSE	! OPTION 1, /IDENTIFIER/ SEEN.
			BEGIN
				T1_.R1[ELMNT1];
				T2_.T1[ELMNT1];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]);
				R1_.R1+1; !INCR PTR IF SLASHES FOR CALL TO BLDARRAY COMING UP
			END;
		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
			BEGIN
				!PUTTING PTR TO COMMON BLOCK IN EACH ITEM
				R1[IDCOMMON] _ .R2;

%2343%				!Put variable in proper psect
%2343%				IF .R1[VALTYPE] EQL CHARACTER
%2343%				THEN
%2343%				BEGIN	!Character
%2343%					R1[IDPSECT] = PSCODE;
%2343%					R1[IDPSCHARS] = .R2[COMPSECT];
%2343%				END	!Character
%2343%				ELSE
%2343%				BEGIN	!Non-Character
%2343%					R1[IDPSECT] = .R2[COMPSECT];
%2343%					R1[IDPSCHARS] = PSOOPS;
%2343%				END;	!Non-Character
			END
			WHILE (R1 _ .R1[IDCOLINK]) NEQ 0;
		END %OF FIXING UP COMMON POINTERS%

	END;
	T1_.STK[1];SAVSPACE(.T1<LEFT>,@T1);
	.VREG

END;	! of COMMSTA

GLOBAL ROUTINE SAVESTA=	![1511] New  [1531] Rewrite

! Processes SAVE statements

BEGIN
	REGISTER BASE PTR1;	! Pointer to something
	REGISTER BASE PTR2;	! Pointer to something
	REGISTER BASE SYMTAB;	! Symbol table entry
	

	SAVNED = TRUE;	! We need a save statement

	! STK[0]
	! | len-1,,ptr | ---> | 0=no args 	   |
	!		      +--------------------+
	!		      | len-1,,ptr to args |

	PTR1 = .STK<RIGHT>;

	IF .PTR1[ELMNT] EQL 0
	THEN	! No arguments given, set global flag.
	BEGIN
		SAVALL = TRUE;	! Save everything possible
		SAVLOC = TRUE;	! Save locals (non-commons)
	END
	ELSE
	BEGIN	! Arguments are given, process them.

		PTR1 = .PTR1[ELMNT1];	! Get the pointer

		INCR ARG FROM .PTR1<RIGHT> TO .PTR1<RIGHT> + .PTR1<LEFT>
			BY 2 DO
		BEGIN	! For each argument to SAVE

			MAP BASE ARG;

			! | len-1,,ptr to args | ---> | 1=var, 2=common	|
			!			      +-----------------+
			!			      | len-1,,ptr	|

			IF .ARG[ELMNT] EQL 1
			THEN
			BEGIN	! Variable or array

				SYMTAB = .ARG[ELMNT1];		! Symbol table

%2430%				! If this has  been declared  in a  SAVE
%2430%				! statement before, then  tell the  user
%2430%				! this is extraneous.
%2430%
%2430%				IF .SYMTAB[IDSAVVARIABLE]
%2430%				THEN IF FLAGEITHER		! /FLAG given
%2430%				     THEN CFLAGB(.SYMTAB[IDSYMBOL], E301<0,0>)
%2430%				ELSE SYMTAB[IDSAVVARIABLE] = 1;	! Found in SAVE

				SAVLOC = TRUE;			! Save locals

				! If this variable is declared in a common,
				! then give an error.
				IF .SYMTAB[IDATTRIBUT(INCOM)]
				THEN 	FATLERR(.SYMTAB[IDSYMBOL],
					UPLIT(ASCIZ'COMMON variable'),
					.ISN,E192<0,0>);

				! Dummy's are illegal.
				IF .SYMTAB[IDATTRIBUT(DUMMY)]
				THEN	FATLERR(.SYMTAB[IDSYMBOL],
					UPLIT(ASCIZ'Dummy argument'),
					.ISN,E192<0,0>);

				! External function name is illegal
				IF .SYMTAB[IDATTRIBUT(INEXTERN)] OR
				   .SYMTAB[IDATTRIBUT(USERFUNCTION)]
				THEN 	FATLERR(.SYMTAB[IDSYMBOL],
					UPLIT(ASCIZ'External name'),
					.ISN,E192<0,0>);

			END	! Variable or array
			ELSE
			BEGIN	! Named common block name

				! | len-1,,ptr | ---> | 23 octal (/)	  |
				! 		      +-------------------+
				! 		      | ptr to symbol tbl |
				!		      +-------------------+
				! 		      | 23 octal (/)	  |

				PTR2 = .ARG[ELMNT1];
				SYMTAB = .PTR2[ELMNT1];	! Symbol table

				! Don't link this  name if  it was  already
				! specified in a SAVE.
				IF NOT .SYMTAB[IDSAVCOMMON]
				THEN	LKSVCOMMON(.SYMTAB);	! Link it in

			END;	! Named common block name
					
		END;	! For each argument to SAVE

	END;	! Arguments are given, process them.


END;	! of SAVESTA

GLOBAL ROUTINE LKSVCOMMON(SYMTAB)=	![1531] Rewrite
BEGIN
	! Put passed  common  symbol  table pointer  into  linked  list  of
	! commons for SAVE statement processing.

	REGISTER BASE NEWLINK;	! New link to be added to PTRSAVCOMMON

	MAP BASE SYMTAB;	! Passed argument - symbol table entry to 
				! be added.


	! Get one word for the link
	NAME<LEFT> = 1;
	NEWLINK = CORMAN();

	! Place in ptr to symbol table
	NEWLINK[CW0L] = .SYMTAB;

	! Place in ptr to previous common symbol or 0
	NEWLINK[CLINK] =  .PTRSAVCOMMON;
	PTRSAVCOMMON = .NEWLINK;

	! Bump count of commons by one
	NUMSAVCOMMON = .NUMSAVCOMMON + 1;

	! Mark that this common is to be SAVE-d
	SYMTAB[IDSAVCOMMON] = 1;

END;	! of LKSVCOMMNON

END
ELUDOM