!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,1977 BY DIGITAL EQUIPMENT CORPORATION
!AUTHOR: F.J. INFANTE, D. B. TOLMAN/DCE
MODULE ACT0(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4)=
BEGIN
SWITCHES NOLIST;
REQUIRE LEXNAM.BLI;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;
REQUIRE ASHELP.BLI;

GLOBAL BIND ACT0V = 5^24+1^18+53;		!VERSION DATE: 9-AUG-77

%(
REVISION HISTORY

47	----	-----	ADD ROUTINE TO GENERATE TEMPORARIES FOR
			STATEMENT FUNCTION DUMMIES

48	-----	-----	ADD THE CODE TO PNAMSET TO HANDLE THE *N
			CONSTRUCT AFTER FUNCTION NAMES

49	-----	-----	FIX RECORDMARK TO SIMULATE VARIBLESPEC PRORERLY
			ITS ALL IBMS FAULT!!!!!!

50	-----	-----	FIX ERROR RETURN IN EXPRLIST TO RETURN -1 AND
			THUS SUPRESS AN EXTRANEOUS ERROR MESSAGE

51	-----	-----	SET ACTLDATYPE IN TYPEID FOR ASTER()

***** BEGIN VERSION 4B *****

52	325	17044	CHECK FOR STACK OVERFLOW IN LONG ARG LISTS.

***** BEGIN VERSION 5A *****

53	603	23442	ALLOW * AS NEW STATEMENT LABEL CONSTANT
			BEGINNING CHARACTER

)%

	FORWARD
		FUNCTIONSCAN,	!
		TYPEID,		!
		TOQUOTE,	!
		RECORDMARK,	!
		EXPRLIST,	!
		IMPLICITSPEC,
		LABELS,
		TMPGN,
		SUBLOCAL,
		ASTERTYPE,
		PNAMSET;

	GLOBAL ROUTINE
ASTERTYPE =
BEGIN	%HANDLES THE *N TYPE OVERRIDE CONSTRUCT%

	EXTERNAL ASTER,IDTYPE,STMNDESC,GTYPCOD;

	IF .ORDERCODE(@STMNDESC)  NEQ  GTYPCOD<0,0>
	THEN RETURN 0;

	IF ASTER( .IDTYPE )  LSS 0  THEN RETURN .VREG
	ELSE
		STK[SP_.SP+1] _ .VREG;
	RETURN 0

END;	%ASTERTYPE%
	GLOBAL ROUTINE
PNAMSET  =
BEGIN	% SET PROGNAME SO IT WILL COME OUT ON THE HEADING%

	EXTERNAL PROGNAME,STMNDESC,ENTRSTA,IDTYPE,GTYPCOD,ASTER;

	IF .STMNROUTINE(@STMNDESC) NEQ ENTRSTA<0,0>
	THEN  
	BEGIN
		REGISTER BASE ID;
		ID _ .STK[.SP]<RIGHT>;
		PROGNAME _ .ID[IDSYMBOL];

		%PICK UP AND *N AFTER FUNCTION NAMES
		  IDIOTIC AS IT MAY SEEM  %
		IF .ORDERCODE(@STMNDESC) EQL  GTYPCOD<0,0>	%HAD TYPE SPECIFIED%
		THEN	IF ( IDTYPE _ ASTER(.IDTYPE) ) LSS 0
			THEN	RETURN .VREG;

	END;
	RETURN 0
END;	%PNAMSET%
	GLOBAL ROUTINE
TMPGN  =
BEGIN	% GENERATES A .F TYPE TEMPORARY , RETURNS ITS NAME BUT DOES
	  NOT ENTER IT IN THE SYMBOL TABLE %

	EXTERNAL FNTMP;

	MACRO MAKNAM(NUMB)=
	(.NUMB<9,3>+16)^18 + (.NUMB<6,3>+16)^12 + (.NUMB<3,3>+16)^6
	+ (.NUMB<0,3>+16)$;

		VREG _ SIXBIT'.F'+MAKNAM(FNTMP);
		FNTMP_.FNTMP+1;
		RETURN .VREG
END;	%TMPGN%

	GLOBAL ROUTINE
SUBLOCAL  =
BEGIN	% THIS ROUTINE IS CALLED TO GENERATE A SPECIAL NON-CONFILCTING
	  VARIABLES FOR
	  STATEMENT FUNCTION DUMMY PARAMETERS

	  A DUMMY VARIABLE IS GENERATED AND INSERTED INTO THE SYMBOL
	  TABLE DIRECTLY AFTER THE ACTUAL IDENTIFIER.  THE NAMES ARE
	  THEN INTERCHANGED SO THAT EXPRES WILL GET THE DUMMY.  THEN
	  THE SEMANTIC ROUTINES WILL REINTERCHANGE THE NAMES FOR THE
	  REST OF THE PROGRAM


	  STATEMENT FUNCTION PARAMETERS WILL GET THE TYPE OF THE 
	  ACTUAL VARIABLE, GET DUMMY SET AND FORMLVAR
%

	REGISTER BASE ID:SAV:TMP;
	! ID - ACTUAL VARIABLE
	! SAV - USED TO SWITCH NAMES
	! TMP - GENERATED VARIABLE

	EXTERNAL  ENTRY , NAME, NEWENTRY, LEXICAL,GSTLEXEME,TYPE;
	EXTERNAL ASTATFUN,DATASTA,STMNDESC;

			MAP BASE ASTATFUN;

			%GET A VARIABLE%
			STK[SP_.SP+1] _ LEXL _ LEXICAL(.GSTLEXEME);
			IF .LEXL<LEFT>  NEQ  IDENTIFIER
			THEN
				IF .LEXL<LEFT> EQL CONSTLEX
				THEN	RETURN FATLEX(PLIT'DIMENSIONED',ASTATFUN[IDSYMBOL],E15<0,0>)
				ELSE	RETURN ERR0L(IDENPLIT);

			ID _ .LEXL<RIGHT>;

	%NOW GENERATE A NEW SYMBOL , INSERT IT IN THE SYMBOL TABLE
	 AFTER THE ACTUAL SYMBOL AND SWAP THE NAMES %

	SAV _ .ID[CLINK];
	NAME _ IDTAB;
	TMP _ ID[CLINK] _ NEWENTRY();
	TMP[CLINK] _ .SAV;
	TMP[IDSYMBOL] _ .ID[IDSYMBOL];	!REAL NAME
	ID[IDSYMBOL] _  TMPGN();	!NEW NAME

		TMP[IDATTRIBUT(DUMMY)] _ -1;
		TMP[OPERSP] _ FORMLVAR;
		TMP[VALTYPE] _ .ID[VALTYPE];
	RETURN 0
END;	%SUBLOCAL%
GLOBAL ROUTINE FUNCTIONSCAN =
BEGIN
	% SCAN FOR THE STRING "FUNCTION".  IF IT IS FOUND THEN
	  CALL THIS A FUNCTION.  WE WILL INVOKE THE RULE THAT IDENTIFIERS
	  MUST BE LESS THAN OR EQUAL TO 6 CHARACTERS IN MAKING THIS
	  DECISION.
	%
	LOOK4CHAR _ FNPLIT<29,7>;	! SKIP THE BLANK
	IF LEXICAL ( .GSTSSCAN )  EQL  0
	THEN RETURN -1	! NO FUNCTION
	ELSE	RETURN 0	! GOT ONE
END;

GLOBAL ROUTINE LABELS  =
BEGIN
	EXTERNAL LOOK4LABEL;
	% THIS ROUTINE SETS A FLAG THAT INDICATES TO THE LEXICAL
	  ANALYZER THAT WHAT ONE REALLY WANTS HERE IS A LABEL
	  AND NOT A CONSTANT  %
	LOOK4LABEL _ 1;
	RETURN 0
END;



GLOBAL ROUTINE NOLABELS  =
BEGIN
	% SHUT OFF THE LABEL FLAG %
	EXTERNAL LOOK4LABEL;
	LOOK4LABEL _ 0;
	RETURN 0
END;
GLOBAL ROUTINE TYPEID =
BEGIN
	% THIS ROUTINE WILL PICK UP THE DATA TYPE WORDS IN IMPLICIT
	  STATEMENTS.  IT THEN CALLS ASTER TO PICK UP THE *DIGIT CONSTRUCT
	  IF ANY AND THEN SETS THE TYPE FOR USE IN THE ROUTINE
	   IMPLICITSPEC AND RETURNS
	%
	EXTERNAL  LOOK4CHAR,ASTER,TYPE,GSTSSCAN,GSTCSCAN,ACTLDATYPE;
	REGISTER R1,R2;
	LOOK4CHAR _ "?L";	! ANY LETTER
	SELECT LEXICAL( .GSTCSCAN ) OF NSET
	"I": EXITSELECT (R1_INTEGER;R2_INTGPLIT<22,7>);
	"R": EXITSELECT (R1_REAL;R2_REALPLIT<22,7>);
	"D": EXITSELECT  (R1_DOUBLPREC;R2_DOUBPLIT<22,7>);
	"C": EXITSELECT (R1_COMPLEX;R2_COMPLIT<22,7>);
	"L": EXITSELECT (R1_LOGICAL;R2_LOGIPLIT<22,7>);
	OTHERWISE: RETURN FATLEX(E17<0,0>)
	TESN;

	LOOK4CHAR _ .R2;
	IF LEXICAL( .GSTSSCAN )  EQL  0  THEN  RETURN FATLEX(E17<0,0>);

	ACTLDATYPE _ .R1;
	RETURN ( TYPE _ ASTER(.R1) )
END;
GLOBAL ROUTINE IMPLICITSPEC=
BEGIN
	% THIS ROUTINE WILL PICK UP THE LETTER AND LETTER-LETTER
	  CONSTRUCTS IN IMPLICIT STATEMENTS.  IT WILL THEN ASJUST THE
	  BASIC TYPE TABLE APPROPRIATELY.
	%
	LOCAL L1,L2;
	EXTERNAL TYPE,TYPTAB;
	
	LOOK4CHAR _ "?L";	! ANY LETTER
	IF (L1 _ LEXICAL( .GSTCSCAN ))  EQL  0 THEN RETURN  FATLEX(E18<0,0>);
	L1 _ .L1 - "A";

	% WE HAVE A LETTER IN L1.  LETS LOOK FOR THE -  %
	LOOK4CHAR _ "-";
	IF LEXICAL ( .GSTCSCAN )  EQL  0
	THEN
	BEGIN	% JUST SINGLE LETTER %
		IF .TYPTAB[.L1]<LEFT> EQL #777777 THEN WARNLEX(E88<0,0>) ELSE TYPTAB[.L1]<LEFT> _ #777777;
		TYPTAB[.L1]<RIGHT> _ .TYPE; !SET IMPLICIT TYPE FOR IDENTIFIERS
		RETURN 0
	END
	ELSE
	BEGIN	% LOOK FOR THE SECOND LETTER %
		LOOK4CHAR _ "?L";
		IF (L2 _ LEXICAL( .GSTCSCAN ) )  EQL  0  THEN  RETURN FATLEX(E18<0,0>);
		% GOT ONE SO CHECK TO SEE IF THEY ARE IN ASCENDING ORDER %
		L2 _ .L2 - "A";
		IF .L1  LEQ .L2
		THEN
		BEGIN	%OK%
			DO (TYPTAB[.L1]<RIGHT> _ .TYPE;  !SET IMPLICIT TYPE FOR RANGE OF LETTERS
				IF .TYPTAB[.L1]<LEFT> EQL #777777 THEN WARNLEX(E88<0,0>) ELSE TYPTAB[.L1]<LEFT> _ #777777;
			   ) WHILE (L1 _ .L1+1) LEQ .L2;
			RETURN 0
		END
		ELSE
			RETURN FATLEX(E18<0,0>)
	END
END;
GLOBAL ROUTINE TOQUOTE=
BEGIN
	% PICKS UP THE "TO" FOR ASSIGN STATEMENTS  %
	LOOK4CHAR _ ( PLIT'TO?0' )<36,7>;
	IF LEXICAL( .GSTSSCAN )  EQL  0
	THEN	RETURN FATLEX(E10<0,0>)
	ELSE	RETURN 0
END;
GLOBAL ROUTINE RECORDMARK=
BEGIN
	EXTERNAL LEXEMEGEN,LSAVE,STK,SP,EXPRESSION,LEXL,COPYLIST;
	EXTERNAL ENTRY,FINDSTA,STMNDESC;
	IF .LEXL<LEFT> EQL IDENTIFIER
	THEN
	  BEGIN	% WE MUST LOOK FOR THE OPTIONAL SUBSCRIPTS FOLLOWING THE IDENTIFIED
		  BECAUSE SOME UNMENTIONABLE COMPANY LIKES 'S AS WELL AS # FOR
		  RECORD MARKS AND ONE DOES NOT GET 'S BACK FROM THE LEXICAL
		  ANALYZER VERY EASILY
		%

		LOCAL LSP1;
		LSP1 _ .SP-1;	!SAVING SP
		LOOK4CHAR _ "(";
		IF LEXICAL(.GSTCSCAN)  NEQ  0
		THEN
		  BEGIN	% PICK UP THE SUBSCRIPT EXPRESSION %
			LOCAL LSP;
			STK[SP _ .SP+1] _ 1;	!ARRAY REF OPTION
			LSP _ .SP;	!SAVING
			WHILE 1 DO
			BEGIN
				LSAVE _ 0;	!SO EXPRESSION WILL GENERATE ITS OWN LEXEME
				IF  EXPRESSION() LSS 0
				THEN RETURN -1;
				!EXPRESSION WILL ALWAYS CREATE NEXT LEXEME
				IF .LEXL<LEFT> NEQ COMMA THEN EXITLOOP;
			END;
			IF .LEXL<LEFT> NEQ RPAREN THEN ERR0L(RPARPLIT);
			COPYLIST(.LSP); !PUT LIST IN FREE STORAGE
			COPYLIST(.LSP);	!FORM ALL POINTER A'LA VARIABLESPEC
		  END
		ELSE STK[SP _ .SP+1] _ 0;
		COPYLIST(.LSP1);
	  END;
	% NOW WE MUST LOOK FOR THE RECORD MARK %
	LOOK4CHAR _ "'";
	IF LEXICAL(.GSTCSCAN )  EQL  0
	THEN
	BEGIN	% TRY # %
		LOOK4CHAR _ "#";
		IF LEXICAL ( .GSTCSCAN ) EQL  0
		THEN
		BEGIN	% COULD NOT FIND ANY %
			IF .STMNROUTINE(@STMNDESC)  EQL  FINDSTA<0,0>
			THEN
			BEGIN	% IT IS NOT OPTIONAL IN FIND STATEMENTS %
				LEXEMEGEN();
				RETURN ERR0V( PLIT'" OR #?0' )
			END
			ELSE	RETURN -1;	! IT WAS OPTIONAL
		END
	END;
	RETURN .VREG	! FOUND A RECORD MARK
END;
GLOBAL ROUTINE EXPRLIST=
BEGIN
!------------------------------------------------------------------------------------------------------------------
! PROCESS THE ARGUMENT LIST OF A CALL STATEMENT
	LOCAL LSP;
	![325]  EXPRLIST @ 3656
	MACRO STKSIZE=250$;   ![325] FOR CHECKING STK OVERFLOW
	EXTERNAL EXPRES,STK,SP,SYNTAX %(NODE)%,LSAVE,LEXEMEGEN %()%,LEXL,COPYLIST %(START)%,NAMREF;
	EXTERNAL  LOOK4LABEL;
	REGISTER BASE T1;
	T1_.STK[.SP-1];	!T1_LOC(IDENTIFIER)
	IF NAMREF(FNNAME1, .T1 ) LSS 0 THEN RETURN .VREG;	! AME CONFLICT
	T1[OPERSP] _ IF .T1[IDATTRIBUT(DUMMY)] THEN FORMLFN ELSE FNNAME;
!------------------------------------------------------------------------------------------------------------------
!	NOW SCAN THE LIST OF EXPRESSIONS (ONE OR MORE SEPERATED BY COMMAS)
!	WHICH MUST FOLLOW.
!------------------------------------------------------------------------------------------------------------------
	LSP_.SP;
	LSAVE_-1;
	WHILE 1 DO
	BEGIN
		LEXL_LEXEMEGEN();
		FLGREG<FELFLG>_1;
		IF (.LEXL<LEFT> NEQ DOLLAR) AND (.LEXL<LEFT> NEQ ANDSGN)
	!**;[603], EXPRLIST @3686, DCE, 9-AUG-77
	!**;[603], ALLOW * AS INITIAL CHARACTER FOR LABEL TOO.
	%[603]%	AND (.LEXL<LEFT> NEQ ASTERISK)
		THEN (STK[SP_.SP+1]_1; !EXPRESSION
			IF EXPRES() LSS 0 THEN RETURN .VREG;
			!EXPRES PUTS ITS RESULT  ON STK[SP_.SP+1] AND RETURNS NEXT LEX IN LEXL
		     )
		ELSE (STK[SP_.SP+1] _ 2; !LABEL ARG
			LOOK4LABEL _ 1;
			STK[SP_.SP+1] _ LEXEMEGEN();
			IF .VREG<LEFT>   NEQ LABELEX
			THEN	RETURN FATLEX(LABLPLIT,LEXPLITV,E0<0,0>);
			LEXL _ LEXEMEGEN();
		     );
		IF .LEXL<LEFT> NEQ COMMA THEN  EXITLOOP;

	%[325]  EXPRLIST @ 3684.  MAKE SURE THAT A SUPER LONG LIST
	OF ARGUMENTS WILL NOT OVERFLOW STK.%
	%[325]%	IF .SP GTR STKSIZE-3 THEN (COPYLIST(.LSP);LSP_.SP); 
	END;
	LSAVE _ -1;
	COPYLIST(.LSP);
	RETURN 0
END;
END ELUDOM