Google
 

Trailing-Edge - PDP-10 Archives - BB-4157E-BM - fortran-compiler/gnrcfn.bli
There are 26 other files named gnrcfn.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: S. MURPHY/DCE/TFV/EGM

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


SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;

GLOBAL BIND GNRCFV = 6^24 + 0^18 + 35;	! Version Date: 22-Jul-81

%(

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

30	-----	-----	MAKE DOTTEDNAMES A GLOBAL SO THAT EXPRES CAN ACCESS
			IT TO RESOLVE LIBRARY FUNCTION ACTUAL PARAMETERS

			DO NOT ALLOW TYPED FUNCTION NAMES TO BE GENERIC.

31	312	16668	FOR THE VARIABLE NUMBER OF ARGUMENTS FUNCTIONS,
			CHECK TO MAKE SURE THAT THERE ARE AT LEAST 2., (JNT)

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

32	563	22541	GIVE CORRECT ERROR MESSAGES FOR BAD ARGUMENT
			TYPES TO LIBRARY ROUTINES., (DCE)
***** Begin Version 6 *****

33	761	TFV	1-Mar-80	-----
	Add dotted names of new library routines into tables.
	Choose name based on /GFLOATING

34	1004	TFV	1-Jul-80	------
	Only choose gdottednames for DP functions

35	1075	EGM	28-May-81	--------
	Add GFL equivalents to IDINT (IGINT) and SNGL (GSNGL).

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

)%

	EXTERNAL
		TBLSEARCH,
		ERROUT;


%(***MAKE A TABLE OF DOTTED FUNCTION NAMES. THE INDEX INTO THIS TABLE FOR
	A GIVEN FUNCTION SHOULD BE THE SAME AS THE INDEX FOR THAT FUNCTION IN
	THE FUNCTION ATTRIBUTE TABLE (WHICH IS IN
	GLOBALS )*****)%
BIND DUMMM= PLIT( DOTTEDNAMES GLOBALLY NAMES
	SIXBIT'ABS.',
	SIXBIT'ACOS.',
	SIXBIT'AIMAG.',
	SIXBIT'AINT.',
	SIXBIT'ALOG.',
	SIXBIT'ALG10.',
	SIXBIT'AMAX0.',
	SIXBIT'AMAX1.',
	SIXBIT'AMIN0.',
	SIXBIT'AMIN1.',
	SIXBIT'AMOD.',
	SIXBIT'ASIN.',
	SIXBIT'ATAN.',
	SIXBIT'ATAN2.',
	SIXBIT'CABS.',
	SIXBIT'CCOS.',
%[761]%	SIXBIT'CDABS.',
	SIXBIT'CEXP.',
	SIXBIT'CLOG.',
	SIXBIT'CMPLX.',
	SIXBIT'CONJG.',
	SIXBIT'COS.',
	SIXBIT'COSD.',
	SIXBIT'COSH.',
%[761]%	SIXBIT'COTAN.',
	SIXBIT'CSIN.',
	SIXBIT'CSQRT.',
	SIXBIT'DABS.',
%[761]%	SIXBIT'DACOS.',
%[761]%	SIXBIT'DASIN.',
	SIXBIT'DATAN.',
	SIXBIT'DATN2.',
	SIXBIT'DBLE.',
	SIXBIT'DCOS.',
%[761]%	SIXBIT'DCOSH.',
%[761]%	SIXBIT'DCOTN.',
	SIXBIT'DEXP.',
	SIXBIT'DFLOT.',
	SIXBIT'DIM.',
	SIXBIT'DLOG.',
	SIXBIT'DLG10.',
	SIXBIT'DMAX1.',
	SIXBIT'DMIN1.',
	SIXBIT'DMOD.',
	SIXBIT'DSIGN.',
	SIXBIT'DSIN.',
%[761]%	SIXBIT'DSINH.',
	SIXBIT'DSQRT.',
%[761]%	SIXBIT'DTAN.',
%[761]%	SIXBIT'DTANH.',
	SIXBIT'EXP.',
	SIXBIT'FLOAT.',
	SIXBIT'IABS.',
	SIXBIT'IDIM.',
	SIXBIT'IDINT.',
	SIXBIT'IFIX.',
	SIXBIT'INT.',
	SIXBIT'ISIGN.',
	SIXBIT'MAX0.',
	SIXBIT'MAX1.',
	SIXBIT'MIN0.',
	SIXBIT'MIN1.',
	SIXBIT'MOD.',
	SIXBIT'REAL.',
	SIXBIT'SIGN.',
	SIXBIT'SIN.',
	SIXBIT'SIND.',
	SIXBIT'SINH.',
	SIXBIT'SNGL.',
	SIXBIT'SQRT.',
%[761]%	SIXBIT'TAN.',
	SIXBIT'TANH.');

![761] Table for dotted names under /GFLOATING
%[761]% BIND GDUMMM= PLIT( GDOTTEDNAMES GLOBALLY NAMES
%[761]%	SIXBIT'ABS.',
%[761]%	SIXBIT'ACOS.',
%[761]%	SIXBIT'AIMAG.',
%[761]%	SIXBIT'AINT.',
%[761]%	SIXBIT'ALOG.',
%[761]%	SIXBIT'ALG10.',
%[761]%	SIXBIT'AMAX0.',
%[761]%	SIXBIT'AMAX1.',
%[761]%	SIXBIT'AMIN0.',
%[761]%	SIXBIT'AMIN1.',
%[761]%	SIXBIT'AMOD.',
%[761]%	SIXBIT'ASIN.',
%[761]%	SIXBIT'ATAN.',
%[761]%	SIXBIT'ATAN2.',
%[761]%	SIXBIT'CABS.',
%[761]%	SIXBIT'CCOS.',
%[761]%	SIXBIT'CGABS.',
%[761]%	SIXBIT'CEXP.',
%[761]%	SIXBIT'CLOG.',
%[761]%	SIXBIT'CMPLX.',
%[761]%	SIXBIT'CONJG.',
%[761]%	SIXBIT'COS.',
%[761]%	SIXBIT'COSD.',
%[761]%	SIXBIT'COSH.',
%[761]%	SIXBIT'COTAN.',
%[761]%	SIXBIT'CSIN.',
%[761]%	SIXBIT'CSQRT.',
%[761]%	SIXBIT'GABS.',
%[761]%	SIXBIT'GACOS.',
%[761]%	SIXBIT'GASIN.',
%[761]%	SIXBIT'GATAN.',
%[761]%	SIXBIT'GATN2.',
%[761]%	SIXBIT'GBLE.',
%[761]%	SIXBIT'GCOS.',
%[761]%	SIXBIT'GCOSH.',
%[761]%	SIXBIT'GCOTN.',
%[761]%	SIXBIT'GEXP.',
%[761]%	SIXBIT'GFLOT.',
%[761]%	SIXBIT'DIM.',
%[761]%	SIXBIT'GLOG.',
%[761]%	SIXBIT'GLG10.',
%[761]%	SIXBIT'GMAX1.',
%[761]%	SIXBIT'GMIN1.',
%[761]%	SIXBIT'GMOD.',
%[761]%	SIXBIT'GSIGN.',
%[761]%	SIXBIT'GSIN.',
%[761]%	SIXBIT'GSINH.',
%[761]%	SIXBIT'GSQRT.',
%[761]%	SIXBIT'GTAN.',
%[761]%	SIXBIT'GTANH.',
%[761]%	SIXBIT'EXP.',
%[761]%	SIXBIT'FLOAT.',
%[761]%	SIXBIT'IABS.',
%[761]%	SIXBIT'IDIM.',
%[1075]% SIXBIT'IGINT.',
%[761]%	SIXBIT'IFIX.',
%[761]%	SIXBIT'INT.',
%[761]%	SIXBIT'ISIGN.',
%[761]%	SIXBIT'MAX0.',
%[761]%	SIXBIT'MAX1.',
%[761]%	SIXBIT'MIN0.',
%[761]%	SIXBIT'MIN1.',
%[761]%	SIXBIT'MOD.',
%[761]%	SIXBIT'REAL.',
%[761]%	SIXBIT'SIGN.',
%[761]%	SIXBIT'SIN.',
%[761]%	SIXBIT'SIND.',
%[761]%	SIXBIT'SINH.',
%[1075]% SIXBIT'GSNGL.',
%[761]%	SIXBIT'SQRT.',
%[761]%	SIXBIT'TAN.',
%[761]%	SIXBIT'TANH.');




GLOBAL ROUTINE MAKLIBFN(FNNAMENTRY,FNCALLNODE)=
%(***************************************************************************
	THIS ROUTINE IS CALLED FOR EVERY CALL TO A LIBRARY FN.
	THE ARG "FNNAMENTRY" IS A PTR TO THE ENTRY IN THE FUNCTION NAME
	TABLE FOR THIS FUNCTION.
	THE ARG "FNCALLNODE" IS A PTR TO THE EXPRESSION NODE FOR THE FUNCTION
	CALL BEING PROCESSED. ARG2PTR OF THIS EXPRESSION NODE POINTS TO
	THE ARGUMENT LIST FOR THIS CALL. ALL ARGS ON THIS LIST SHOULD
	ALREADY HAVE BEEN PROCESSED BY EXPRTYPER.

	THIS ROUTINE CHECKS FOR WHETHER THE FUNCTION IS A GENERIC ONE AND
	IF SO, REPLACES THE FUNCTION NAME BY THE ACTUAL FUNCTION NAME TO BE USED.

	THIS ROUTINE SUBSTITUTES A DOTTED FUNCTION NAME FOR THE NAME
	USED BY THE ORIGINAL PROGRAM.
	IT MAKES A SYMBOL TABLE ENTRY FOR THE  DOTTED FUNCTION NAME TO BE USED.
	AND SETS ARG1PTR OF THE FUNCTION CALL NODE TO POINT TO
	THAT SYMBOL TABLE ENTRY. IT SETS THE "FUNCTION
	ATTRIBUTE" AND VALUE-TYPE FIELDS OF THE SYMBOL TABLE ENTRY CREATED
	FROM THE VALUES FOUND IN THE "LIBRARY FUNCTION ATTRIBUTE TABLE" ENTRY
	FOR THE FUNCTION.

	IF THE FN IS NOT GENERIC AND THE ARG IS NOT OF THE EXPECTED TYPE, IT
	PRINTS AN ERROR MESSAGE. ALSO IF THE FN IS GENERIC BUT THE ARG IS OF
	A TYPE NOT HANDLED, IT PRINTS AN ERROR MESSAGE.

	IF THE NUMBER OF ARGS DOES NOT AGREE WITH THE REQUIRED NUMBER, PRINTS
	AN ERROR MESSAGE.
***************************************************************************)%
BEGIN
	OWN BASE  SYMENTRY;	!UN DOTTED SYMBOL TABLE ENTRY POINTER
	MAP PEXPRNODE FNCALLNODE;
	OWN PEXPRNODE FNSYMENTRY;	!SYMBOL TABLE ENTRY CREATED FOR THE FN NAME
	OWN ARGUMENTLIST ARGLST;	!THE ARGUMENT LIST UNDER THE NODE FOR THIS FN-CALL

	EXTERNAL LIBFUNTAB,LIBATTRIBUTES;
	EXTERNAL FATLEX,WARNERR;
	MAP LIBATTSTR LIBATTRIBUTES;
	OWN FNIX;		!INDEX FOR THE FUNCTION-NAME IN THE LIBATTRIBUTES TABLE
	OWN ARG1TYPE;		!TYPE OF FIRST FN ARGUMENT (TYPE OF FN)
	OWN PEXPRNODE ARG1NODE;	!EXPRESSION NODE FOR THE FIRST ARG ON THE ARGLIST



	FNIX_.FNNAMENTRY-LIBFUNTAB<0,0>;
	SYMENTRY _ .FNCALLNODE[ARG1PTR];	!SET SYMBOL TABLE POINTER

	ARGLST_.FNCALLNODE[ARG2PTR];	!PTR TO THE ARGUMENT LIST
	ARG1NODE_.ARGLST[1,ARGNPTR];	!PTR TO THE FIRST ARGUMENT


	%(***CHECK THAT THE ARGS ARE OF THE EXPECTED TYPE - IF NOT GIVE AN ERROR MESSAGE***)%

	ARG1TYPE_.ARG1NODE[VALTYPE];
	IF .ARG1TYPE EQL OCTAL OR .ARG1TYPE EQL LOGICAL
	THEN
	%(***FOR THE ARG OF TYPE OCTAL OR LOGICAL - ALWAYS ACCEPT IT AS IS.
		DO NO TYPE CHECKING AND DO NOT CALL SOME OTHER FN IN THE CASE
		OF A GENERIC FN
	*******)%
	BEGIN END

	ELSE
	%(***IF THE FN IS GENERIC, GET A PTR TO THE ACTUAL FN TO USE***)%
	IF .LIBATTRIBUTES[.FNIX,ATTGENERFLG]
		AND  NOT  .SYMENTRY[IDATTRIBUT(INTYPE)]	%EXPLICITLY TYPED FUNCTIONS CANNOT BE GENERIC%
	THEN
	BEGIN
		OWN ACTFN;		!PTR TO THE ENTRY IN THE LIBRARY FN NAME TABLE
					! FOR THE ACTUAL FN TO BE USED WHEN THE
					! FN NAME USED BY THE ORIG PROG WAS A GENERIC ONE
		ACTFN_.LIBATTRIBUTES[.FNIX,ATTACTFN,.ARG1NODE[VALTP1]];

		%(***IF THERE IS NO FUNCTION CORRESPONDING TO THE ARGTYPE USED,
			THEN GIVE AN ERROR MESSAGE AND USE THE ORIGINAL FN NAME***)%
		IF .ACTFN EQL ILGARGTYPE
		THEN
		BEGIN
			EXTERNAL E80;
			WARNERR(.FNNAMENTRY,.ISN,E80<0,0>);


		END
		%(***IF HAVE CHNGED THE FUNCTION NAME TO BE REFERRED TO***)%
		ELSE
		%(*** CHANGE THE VALUE OF THE INDEX INTO THE FUNCTION
			NAME TABLE***)%
		FNIX_(.ACTFN)<0,0>-LIBFUNTAB<0,0>;
	END
	ELSE
	BEGIN

		%(***FOR NON GENERIC FNS - CHECK THAT THE FIRST ARG HAS THE
			TYPE INDICATED BY THE LIBRARY-FN ATTRIBUTE TABLE -
			IF NOT, GIVE AN ERROR MESSAGE
		*******)%
		!MAKE SURE THAT FOR A NON-GENERIC FUNCTION, THE TYPE BEING
		! COMPARED AGAINST FOR LATER ARGUMENTS IS THE TYPE OF THE FUNCTION
		! RATHER THAN THE TYPE OF THE FIRST ARGUMENT.
		ARG1TYPE_.LIBATTRIBUTES[.FNIX,ATTARGTYP];
		IF .ARG1NODE[VALTYPE] NEQ .ARG1TYPE
		THEN 
		BEGIN
			EXTERNAL E80;
			WARNERR(.FNNAMENTRY,.ISN,E80<0,0>);
		END;
	END;


	%(***MAKE A SYMBOL TABLE ENTRY FOR THE DOTTED NAME FOR THIS FN***)%
	NAME_IDTAB;

![1004] Choose dotted names based on /GFLOATING for DP functions
%[1004]%	IF .GFLOAT AND .LIBATTRIBUTES[.FNIX,ATTRESTYPE] EQL DOUBLPREC
%[1004]%		THEN ENTRY[0]_.GDOTTEDNAMES[.FNIX]
%[1004]%		ELSE ENTRY[0]_.DOTTEDNAMES[.FNIX];
	FNCALLNODE[ARG1PTR]_TBLSEARCH();



	%(***SET THE VALUE-TYPE AND FUNCTION ATTRIBUTE FIELDS OF THE SYMBOL TABLE ENTRY
		AND SET THE VALUE TYPE FIELD OF THE FUNCTION-CALL NODE***)%
	FNSYMENTRY_.FNCALLNODE[ARG1PTR];
	FNSYMENTRY[VALTYPE]_.LIBATTRIBUTES[.FNIX,ATTRESTYPE];
	FNCALLNODE[VALTYPE]_.FNSYMENTRY[VALTYPE];
	FNSYMENTRY[IDFNATTRIB]_.LIBATTRIBUTES[.FNIX,ATTFNATTRIB];

	FNSYMENTRY[OPERSP]_FNNAME;


	%(***CHECK THAT THE NUMBER OF ARGUMENTS AGREES WITH THE NUMBER SPECIFIED
		FOR THE FN BY THE LIBRARY FN ATTRIBUTE TABLE***)%
	IF ((.LIBATTRIBUTES[.FNIX,ATTARGCT] NEQ VARGCTFLG) AND .ARGLST[ARGCOUNT] NEQ .LIBATTRIBUTES[.FNIX,ATTARGCT])
		OR ((.LIBATTRIBUTES[.FNIX,ATTARGCT] EQL VARGCTFLG) AND .ARGLST[ARGCOUNT] LSS 2)
	THEN
	BEGIN
		EXTERNAL E81;
		WARNERR(.FNNAMENTRY,.ISN,E81<0,0>);
	END


	ELSE
	%(***IF THE FUNCTION HAS MORE THAN ONE ARG, SUCCESSIVE ARGS MUST HAVE
		THE SAME TYPE AS THE FIRST ARG***)%
	BEGIN
		!ONLY NEED TO TEST THE REST OF THE ARGUMENT LIST
		INCR I FROM 2 TO .ARGLST[ARGCOUNT]
		DO
		BEGIN
			OWN PEXPRNODE ARGNODE;
			ARGNODE_.ARGLST[.I,ARGNPTR];
			IF .ARGNODE[VALTYPE] NEQ .ARG1TYPE
			THEN
			BEGIN
				EXTERNAL E80;
				WARNERR(.FNNAMENTRY,.ISN,E80<0,0>);
			END
		END
	END;
	%(******SET OPERSP IN THE FUNCTION CALL NODE
		TO INDICATE LIBRARY FUNCTION**************)%
	FNCALLNODE[OPERSP]_LIBARY;
END;