Google
 

Trailing-Edge - PDP-10 Archives - BB-4157E-BM - fortran-compiler/lexsup.bli
There are 12 other files named lexsup.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: D. B. TOLMAN/DCE/SJW/EDS

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

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


%(

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

2	-----	-----	MOVE CREFIT TO NEW MODULE  UNEND  IN ORDER TO
			FIX ONCE AND FOR ALL THE SAVING
			THE LAST GETSEG TO FORTB PROBLEM

3	-----	-----	ROUTINE BACKUP - THE CHARACTER POSITION COUNTER
			CHARPOS WAS BEING DECREMENTED RATHER
			THAN INCREMENTD BY 1 AS IT SHOULD HAVE BEEN

4	-----	-----	RETURN FROM LABREF WHEN LABEL TOO LARGE OR 
			TOO SMALL TO AVOID ADDITIONAL SPURIOUS ERROR
			MESSAGES

5	-----	-----	REMOVE EDIT 4 BECAUSE WORSE THINGS HAPPEN
			WHEN THE FINAL LIST OF UNDEFINED LABELS IS
			COMPILED IF NOTHING IS DEFINED.  LIKE INTERNAL
			COMPILER ERRORS.

6	-----	-----	ENDOFLIT WAS NOT ZEROING LAST
			WORD OF THE LITERAL PROPERLY

7	-----	-----	IN LABDEF - DON'T CALL DOCHECK JUST CHECK
			TO SEE IF LIGIT DO TERMINATOR
			DOCHECK CALLED AFTER SEMANTICS NOW
8	362	18245	SEPARATE LOGICAL AND OCTAL REPRESENTATIONS, (DCE)
9	366	18210	FIX SAVLINE CLOBBERING NAME, (DCE)
10	477	QA831	MAKE ERROR MESSAGE NAMLEX'S MORE READABLE

***** Begin Version 5A *****

11	573	-----	REQUIRE DBUGIT.REQ, (SJW)

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

12	737	-----	IMPLEMENT .NEQV. OPERATOR, (DCE)
13	746	13673	ALLOW FORMAT STMNT NUMBERS TO BE ASSIGNED TO VARS,
			(DCE)

***** Begin Version 6 *****

15	1070	CKS	14-May-81
	*** Removed ***

17	1100	EDS	9-Jun-81	10-31141
	Build label definition entry for statement even
	if the label is multiply defined or used in executable
	context and gets a ENF error (E91).  This will prevent
	an NNF error (E70) and an undefined label error.

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

)%

%[1100]%	EXTERNAL E19,E20,E91,E113,E156,E157;

	EXTERNAL  LINELINE,LINEPTR,CHARPOS,CLASLINE,CLASPTR,CLASLPT,CLASPOS,CURPTR,DECREMENT,BACKLINE,CREFIT;

REQUIRE  DBUGIT.REQ;
REQUIRE LEXNAM.BLI;
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES  LIST;

% THESE BINDS ARE REQUIRED BY LEXICAL BECAUSE ITS GETTING TO
	BIG TO COMPILE WITH FIRST AND TABLES  %
GLOBAL  BIND

	GREAL = REAL,
	GLOGI = LOGICAL,
	GINTEGER = INTEGER,
	GDOUBLPREC = DOUBLPREC,
	GDUBOCT = DOUBLOCT,
	GOCTAL = OCTAL;

BIND DUMM  =  PLIT (
	GIDTAB GLOBALLY NAMES  IDTAB,
	GCONTAB GLOBALLY NAMES CONTAB
);






BIND VECTOR NAMLEX=PLIT( LEXNAME GLOBALLY NAMES 
%0%	PLIT'UNKNOWN?0',
%1%	PLIT'IDENTIFIER?0',
%2%	PLIT'CONSTANT?0',
%3%	PLIT'LIT STRING?0',
%4%	PLIT'LABEL',
%5%	PLIT'STATEMENT END?0',
%6%	PLIT'RELATIONAL OP?0',
%7%	PLIT'.NOT.?0',
%8%	PLIT'.AND.?0',
%9%	PLIT'.OR.?0',
%10%	PLIT'.EQV. OR .XOR.?0',
%11%	PLIT'"**" OR "^"?0',
%12%	PLIT'"&"?0',
%13%	PLIT'"("?0',
%14%	PLIT'")"?0',
%15%	PLIT'":" ?0',
%16%	PLIT'","?0',
%17%	PLIT'"$"?0',
%18%	PLIT'"-"?0',
%19%	PLIT'"/"?0',
%20%	PLIT'"+"?0',
%21%	PLIT'"*"?0',
%22%	PLIT'"="?0',
);


! MACROS WHICH DEFINE THE RELATIONAL LEXEME CODES  

MACRO
	REL(N) = RELATIONLOP^18+N$,
	DOTNE = REL(6)$,
	DOTEQ = REL(2)$,
	DOTGT = REL(7)$,
	DOTLT = REL(1)$,
	DOTGE = REL(5)$,
	DOTLE = REL(3)$;


BIND	DUMMIE = PLIT (
	% THIS IS A TABLE USED TO SCAN FOR AND IDENTIFY THE "."ED OPERATORS %

	NDOTOP GLOBALLY NAMES	'EQV',	LOGICALMATCH^18+2,	![737]
				'E',	DOTNE,
				'OT',	LOGICALNOT^18,
				0,
				'.NE. OR .NOT. OR .NEQV.?0', ![737]
	ADOTOP GLOBALLY NAMES	'ND',	LOGICALAND^18,
				0,
				'.AND.?0',

	ODOTOP GLOBALLY NAMES	'R',	LOGICALOR^18,
				0,
				'.OR.?0',

	XDOTOP GLOBALLY NAMES	'OR',	LOGICALMATCH^18+2,
				0,
				'.XOR.?0',

	EDOTOP GLOBALLY NAMES	'QV',	LOGICALMATCH^18+1,
				'Q',	DOTEQ,
				0,
				'.EQ. OR .EQV.?0',

	GDOTOP GLOBALLY NAMES	'T',	DOTGT,
				'E',	DOTGE,
				0,
				'.GT. OR .GE.?0',

	LDOTOP GLOBALLY NAMES	'T',	DOTLT,
				'E',	DOTLE,
				0,
				'.LT. OR .LE.?0',

	TDOTOP GLOBALLY NAMES	'RUE',	-2,
				0,
				'.TRUE.?0',

	FDOTOP GLOBALLY NAMES	'ALSE',	-1,
				0,
				'.FALSE.?0'
);


BIND  DUMDUM  =  PLIT (   DOTOPTAB  GLOBALLY NAMES

	% THIS TABLE GIVES A POINTER TO THE VALID CHARACTER STRINGS
	  WHICH COULD FOLLOW THE FIRST LETTER OF A DOTTED OPERATOR%

	%A%	ADOTOP<36,7>,
	%B%	0,
	%C%	0,
	%D%	0,
	%E%	EDOTOP<36,7>,
	%F%	FDOTOP<36,7>,
	%G%	GDOTOP<36,7>,
	%H%	0,
	%I%	0,
	%J%	0,
	%K%	0,
	%L%	LDOTOP<36,7>,
	%M%	0,
	%N%	NDOTOP<36,7>,
	%O%	ODOTOP<36,7>,
	%P%	0,
	%Q%	0,
	%R%	0,
	%S%	0,
	%T%	TDOTOP<36,7>,
	%U%	0,
	%V%	0,
	%W%	0,
	%X%	XDOTOP<36,7>,
	%Y%0,
	%Z%	0
);





	GLOBAL  ROUTINE
BACKPRINT  =

BEGIN
	LOCAL  TLINE,TCUR,TPTR,ADJUST;
	EXTERNAL LINELINE,CURPTR,LINEPTR,BACKLINE,NOCR,PRINT,CLASLPT;

	% THIS ROUTINE IS CALLED IF A LINE TERMINATOR WAS ENCOUNTERED
	  DURING SOME LOOKAHEAD AND NO BACKUP WAS REQUIRED  %

	% SAVE CURRENT LINE ATTRIBUTES %
	TLINE_ .LINELINE;
	TCUR _ .CURPTR;
	TPTR _ .LINEPTR;
	ADJUST _ @(@BACKLINE<RIGHT>+3) - .CLASLPT;	! CHECK TO SEE IF BUFFER WAS MOVED

	% PRINT THOSE LINES THAT WERE MISSED %
	DO
	BEGIN
		LINELINE _ @(@BACKLINE<RIGHT>+1) - .ADJUST;
		CURPTR _ @(@BACKLINE<RIGHT>+2) - .ADJUST;
		LINEPTR _ @(@BACKLINE<RIGHT> + 3) - .ADJUST;
		NOCR _ 1;
		PRINT();
	END
	UNTIL ( BACKLINE<RIGHT> _ @(@BACKLINE<RIGHT>))  EQL  0;

	BACKLINE _ 0;
	LINELINE _ .TLINE;
	CURPTR _ .TCUR;
	LINEPTR _ .TPTR;

END;



	GLOBAL ROUTINE
SAVLINE   =

BEGIN
	LOCAL  ADDR;
	LOCAL NAMESAVE;
	EXTERNAL  NAME,CORMAN,LINELINE,CURPTR,LINEPTR,BACKLINE;

	% THIS LINE IS BEING PASSED OVER DURING A LOOKAHEAD WITHOUT PRINTING
	  IF NO BACKUP IS NEEDED THEN THIS LINE WILL HAVE TO BE PRINTED %

	% SAVE THE LINE ATTRIBUTES %
	NAMESAVE_.NAME;
	NAME<LEFT> _ 4;
	ADDR _ CORMAN();
	NAME_.NAMESAVE;

	(@ADDR)<FULL> _ 0;	! LINK
	((@ADDR)+1)<FULL> _ .LINELINE;
	((@ADDR)+2)<FULL> _ .CURPTR ;
	((@ADDR)+3)<FULL> _ .LINEPTR ;

	IF .BACKLINE  EQL 0
	THEN
	BEGIN	
		BACKLINE<LEFT> _ @ADDR;
		BACKLINE<RIGHT> _ @ADDR;
	END
	ELSE
	BEGIN
		(@BACKLINE<LEFT>) _ @ADDR;
		BACKLINE<LEFT> _ @ADDR
	END
END;



	GLOBAL ROUTINE
BAKSAV =

BEGIN
	% SAVE THE CURRENT POSITION FOR POSSIBLE BACKUP %
	EXTERNAL  CLASPTR,CLASLINE,CLASPOS,CLASLPT,CHARPOS;
	
	CLASPTR _ .CURPTR;
	CLASLINE _ .LINELINE;
	CLASPOS _ .CHARPOS;
	CLASLPT _ .LINEPTR;
END;



	GLOBAL ROUTINE 
BACKUP =

BEGIN
	% BACKUP TO JUST BEFORE THE SAVED CHARACTER POSITION %

	CURPTR _ .CLASPTR;
	DECREMENT ( CURPTR<0,0> );
	LINELINE _ .CLASLINE;
	CHARPOS _ .CLASPOS + 1;
	LINEPTR _ .CLASLPT;
	BACKLINE _ 0;
END;



	GLOBAL ROUTINE 
LITDEF ( CHARS )  =

BEGIN
	% MAKE A LITERAL TABLE ENTRY FOR .CHARS CHARACTERS %
	LOCAL WDS;
	LOCAL PEXPRNODE  LITENTRY;
	EXTERNAL  NAME,NEWENTRY;

	WDS _ ( .CHARS -1 ) /5 + 2;
	NAME<LEFT> _ ( IF .WDS LEQ 2  THEN  5  ELSE  3 + .WDS );
	NAME<RIGHT> _ LITTAB;
	LITENTRY _ NEWENTRY();
	LITENTRY[LITSIZ] _ .WDS;
	LITENTRY[OPERATOR] _ LITCONST;
	LITENTRY[LITEXWDFLG] _ 1;	! TRAILING NULL FLAG

	RETURN  .LITENTRY
END;



	GLOBAL ROUTINE
ENDOFLIT  ( POINT, LITENTRY, LASTWORD )  =

BEGIN
	% CLEAN UP THE LITERAL ENTRY AND RETURN ANY UNUSED STORAGE %

	% POINT < RIGHT>  IS ADDRESS OF ZERO WORD TERMINATOR
	  ZERO THE WORD, CALCULATE THE LENGTH OF THE LITERAL, SET
	  THE SIZE, AND RETURN UNUSED PORTION TO FREE STORAGE %

	MAP  PEXPRNODE  LITENTRY;
	EXTERNAL SAVSPACE;
	LOCAL  WDS;

	(.POINT<RIGHT>+1)<FULL> _ 0;	! ZERO LAST WORD
	LITENTRY[LITSIZ] _ .POINT - .LITENTRY - 1;
	SAVSPACE ( .LASTWORD - .POINT - 1 , .POINT+2 );
END;






	GLOBAL ROUTINE
LABDEF   =

BEGIN
	% MAKE A STATEMENT LABEL DEFINITION ENTRY  %
	REGISTER T1,T2;
	EXTERNAL  LABLOFSTATEMENT,TBLSEARCH,STALABL,NAME,ENTRY,FATLERR,STMNDESC,GFORMAT,ISN;
	MAP  BASE  T1:T2;

	BIND LABDF = 3;	!CREFIT PARAMETER
	IF .FLGREG<CROSSREF>  THEN  CREFIT( .STALABL, LABDF);


	% MAKE THE ENTRY %
	NAME _ LABTAB;
	ENTRY[0] _ .STALABL;
	T1 _ TBLSEARCH();

	IF ( T2 _ .T1[SNHDR] )  NEQ  0
	THEN
	BEGIN	% MULTIPLY DEFINED %
		FATLERR ( .T2[SRCISN], .T1[SNUMBER], .ISN,E20<0,0>);
%[1100]%	LABLOFSTATEMENT _ .T1;
	END
	ELSE
	BEGIN	% CHECK FORMAT VS EXECUTABLE  %
		EXTERNAL  GFORMAT,DOCHECK;
		
		IF .ORDERCODE(@STMNDESC)  EQL  GFORMAT<0,0>
		THEN	
		BEGIN	% FORMAT STATEMENT LABEL %
			IF .T1[SNEXECU]
			THEN
			BEGIN	% A NO NO %
				FATLERR(.STALABL,.ISN,E91<0,0>);
			END
%[1100]%	 	ELSE T1[SNIO] _ 1;
%[1100]%		LABLOFSTATEMENT _ .T1;
		END
		ELSE
		BEGIN	% EXECUTABLE STATEMENT %
			IF .T1[SNIO]
			THEN
			BEGIN
				FATLERR( .STALABL,.ISN,E113<0,0> );
%[1100]%			LABLOFSTATEMENT _ .T1;
			END
			ELSE
			BEGIN
				EXTERNAL FATLEX,E67;
				 T1[SNEXECU] _ 1;
				 LABLOFSTATEMENT _ .T1 ;
				% DO NEST CHECKING %
				IF .T1[SNDOLVL]  NEQ  0
				THEN	% CHECK FOR RATIONAL DOLOOP TERMINATION STATEMENT  %
					IF .BADOTERM( @STMNDESC )  THEN  FATLEX(E67<0,0>)
			END
		END;


	END	
END;	%LABDEF%




	GLOBAL ROUTINE
LABREF     =

BEGIN
	GLOBAL NONIOINIO;	! IF SET IT INDICATES THAT THE LABEL IS OK EVEN THOUGH ITS AN
			! EXECUTABLE LABEL IN AN IO STATEMENT

	%  THIS ROUTINE HANDLES LABEL REFERENCES  %
	% THE LABEL IS IN ENTRY[1] , IN DECIMAL  %

	EXTERNAL  FATLEX,LEXLINE,NAME,ENTRY,TBLSEARCH,GIOCODE,STMNDESC,LOOK4LABEL;
	REGISTER T1,T2;
	MAP  BASE  T1;
	BIND LABRF = 4;	!CREFIT PARAMETER

	LOOK4LABEL _ 0;

	% CHECK FOR LEGAL LABEL  %
	IF  .ENTRY[1]   LEQ 0 OR  .ENTRY[1]  GTR 99999
	THEN   (  FATLEX(E19<0,0>);  ENTRY[1] _ 0);
			% ONE DOES NOT RETURN HERE ON AN ERROR BECAUSE
			  THEN NO LABEL IS RETURNED AND WHEN THE COMPILER
			  CHECKS AT THE END FOR UNDEFINED LABELS THERE
			  IS A BIG HOLE AND WE GO OFF THE DEEP END.
			  SO ITS SEEMS BEST TO SUFFER THOROUGH A FEW
			  UNLIKELY EXTRANEOUS MESSAGES ASSOCIATED WITH
			  MORE THAN ONE OCCURRANCE OF LARGE OR 0 LABELS %

	IF .FLGREG<CROSSREF>  THEN CREFIT( .ENTRY[1], LABRF );


	ENTRY[0] _ .ENTRY[1];
	NAME _ LABTAB;
	T1 _ TBLSEARCH();

	% CHECK LEGALITY OF REFERENCE %
	IF ( T2 _ .ORDERCODE(@STMNDESC) )  EQL  GIOCODE<0,0>  AND NOT .NONIOINIO
	THEN
	BEGIN	% IN IO STATEMENT %
		IF .T1[ SNEXECU ] 
%[1100]%	THEN	FATLEX ( .ENTRY[0],  E156<0,0> )
		ELSE	% OK %
			T1[ SNIO ] _ 1;
	END
	ELSE
	BEGIN	% NON- IO STATEMENTS %
![746] ALLOW ASSIGN STATEMENTS TO PICK UP FORMAT STATEMENT LABELS.
![746] THIS IS IN PREPARATION FOR USING THEM IN I/O STATEMENTS FOR
![746] THE FORTRAN-77 STANDARD.
%[746]%		EXTERNAL ASSISTA;
%[746]%		NONIOINIO _ 0;
%[746]%		! ASSIGN STATEMENT COULD MEAN EITHER TYPE, SO JUST GET OUT...
%[746]%		IF .(@STMNDESC)<RIGHT> EQL ASSISTA<0,0> THEN RETURN .T1;
		IF .T1[ SNIO ]
%[1100]%	THEN	FATLEX ( .ENTRY[0],E157<0,0> )
		ELSE	%OK%
			T1[ SNEXECU ] _ 1;

	END;

	RETURN .T1
END;





BEGIN	% TRACE ROUTINES %

	IF DBUGIT
	THEN
	BEGIN


		GLOBAL ROUTINE
	TRACLEX  ( VALUE )  =
	BEGIN
		EXTERNAL  STRNGOUT,ENDOFILE,LEXNAME;

		OWN LEXEME;
		LEXEME _ .VALUE;

		IF .VALUE<LEFT>  GEQ  IDENTIFIER AND .VALUE<LEFT>  LEQ  LASTLEX
		THEN
		BEGIN
			STRNGOUT ( .LEXNAME[.VALUE<LEFT>] );
			IF .VALUE<LEFT>  EQL  LITSTRING
			THEN
			BEGIN
				EXTERNAL  CHAROUT;
				BIND CR=#15,LF=#12;
				CHAROUT(CR);CHAROUT(LF);
				STRNGOUT( .VALUE<RIGHT>+3 );
				CHAROUT(CR);CHAROUT(LF)
			END
		END
		ELSE
			IF .VALUE  EQL ENDOFILE<0,0>
			THEN	STRNGOUT(PLIT'ENDOFILE?0')
			ELSE
				IF .VALUE  EQL ( NOT ENDOFILE<0,0>)
				THEN	STRNGOUT(PLIT'NOT ENDOFILE?0')
				ELSE
					IF .VALUE   EQL  1
					THEN	STRNGOUT(PLIT'TRUE?0')
					ELSE
						IF .VALUE  EQL  0
						THEN	STRNGOUT(PLIT'FALSE?0')
						ELSE	STRNGOUT(PLIT'UNKNOWN?0');

	STRNGOUT ( PLIT'	RETURNED?M?J?0');

	RETURN .VALUE
	END;	% TRACLEX%
	GLOBAL ROUTINE 
TRACE(STATE,CHAR,CODE,ACTION)  =
BEGIN
	BIND CR = 13, LF = 10;
	EXTERNAL LINENO;
	BIND LASTBIGCODE = 32,LASTSMALCODE=11;
	EXTERNAL BIGSTATE,SMALSTATE,STBITS,STPACK;
	EXTERNAL STRNGOUT,CHAROUT,DECODELINE;
	LOCAL TMP;

	STRNGOUT ( PLIT( 'CHAR	'));
	IF .CHAR LSS " " THEN CHAROUT (" ") ELSE CHAROUT(.CHAR);
	CHAROUT("/");
	DECODELINE (.CHAR);
	STRNGOUT(LINENO<0,0>);
	STRNGOUT ( PLIT('CODE	'));
	DECODELINE(.CODE);
	STRNGOUT(LINENO<0,0>);
	STRNGOUT (PLIT('ACTION	'));
	DECODELINE (.ACTION);
	STRNGOUT(LINENO<0,0>);
	STRNGOUT (PLIT('STATE	'));

	IF @@STATE EQL  1	% CODETYPE BIG %
	THEN
	BEGIN	% BIGSTATE %
		TMP _ ((.STATE<RIGHT> - BIGSTATE<0,0>  ) /( LASTBIGCODE+1 )) * STPACK<0,0>
			+ (STPACK<0,0>-(.STATE<30,6>/STBITS<0,0>)-1);
		DECODELINE(.TMP);
		STRNGOUT (LINENO<0,0>);
		CHAROUT("B")
	END
	ELSE
	BEGIN	% SMALSTATE %
		TMP _ ((.STATE<RIGHT> - SMALSTATE<0,0>  ) /( LASTSMALCODE+1 )) * STPACK<0,0>
			+ (STPACK<0,0>-(.STATE<30,6>/STBITS<0,0>)-1);
		DECODELINE(.TMP);
		STRNGOUT (LINENO<0,0>);
		CHAROUT("S")
	END;

	CHAROUT(CR);  CHAROUT (LF);

END;	%ROUTINE TRACE %

	END
END;


END
ELUDOM