Trailing-Edge
-
PDP-10 Archives
-
CFS_TSU04_19910205_1of1
-
update/ftncsr/gnrcfn.bli
There are 26 other files named gnrcfn.bli in the archive. Click here to see a list.
!COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1972, 1988
!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: S. MURPHY/DCE/TFV/EGM/CDM/AHM/RVM
MODULE GNRCFN(SREG=#17,VREG=#15,FREG=#16,DREGS=4,RESERVE(0,1,2,3)) =
BEGIN
GLOBAL BIND GNRCFV = #11^24 + 0^18 + #4604; ! Version Date: 26-Sep-88
%(
***** 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).
***** Begin Version 7 *****
36 1241 CDM 29-Jul-81 ----
Add intrinsic functions (ANINT, DDIM, DINT, DNINT, DPROD, IDNINT,
NINT) and their G-Floating counterparts (GDIM, GINT, GNINT, GPROD,
IGNINT) and change MAKLIBFN to always look in the GDOTTEDNAMES
table whenever /GFL is specified.
37 1252 CDM 10-Aug-81
Add names for inline generic functions for which 77-standard gives
no specific names. Also change MAKLIBFN so that when it finds CMPLX
called with only 1 argument, it changes the function name to CMP1.R,
since CMPLX may now have 1 or 2 arguments.
40 1264 CDM 25-Sept-81
Add CMPL.C, MAX, MIN, LOG10, CHAR, ICHAR, INDEX, LEN, LGE, LGT,
LLE, LLT, NOP's to function tables.
In MAKLIBFN, make character data arguments illegal for generic
functions.
41 1270 CDM 6-Oct-81
Changes to MAKLIBFN;
-Added one more argument to the call,
-Added error for octal and literal argments to non-specific generic
function,
-Added warning for declaration of function to something other
than the value found in LIBATTRIBUTES.
42 1275 CDM 20-Oct-81
Added code to MAKLIBFN to check if a function with no (or less)
arguments is called. SIN() is illegal for a library function!
43 1434 CDM 14-Dec-81
Add length for character library functions (CHAR in particular).
44 1436 SRM 16-Dec-81
Set CHARUSED if call an intrinsic function that takes a character
arg or returns a character value
1505 AHM 12-Mar-82
Make MAKELIBFN set the psect index of symbol table entries for
dotted function names to .CODE.
1513 RVM 22-Mar-82
Take the code that forms the symbol table entry for the dotted
names of library functions out of MAKLIBFN and make it into a
new global routine MAKDOTTEDNAME. Also, have MAKDOTTEDNAME set
INEXTERN for the dotted name if the undotted name has INEXTERN
set. (HSCHD in OUTMOD uses INEXTERN to determine if a descriptor
needs to be created for a character routine.) Also set the global
flag CHDECL if MAKDOTTEDNAME sees a intrinsic character. CHDECL
is used to signal that HSCHD needs to be called at all!
1543 RVM 25-May-82
Under /GFLOATING, the function CMPL.G should be used to convert
two DOUBLE PRECISION numbers to COMPLEX.
1535 CDM 1-June-82
Error message for ICHAR with character constant of length > 1.
1551 AHM 4-Jun-82
Remove edit 1505 because external references no longer have
their psect index set.
1567 CDM 24-Jun-82
Set IDFNFOLD in symbol table if function could be folded into
a constant.
***** Begin Version 10 *****
2301 RVM 28-Jan-84
Make the compiler know about the MIL SPEC/VAX FORTRAN bit
manipulation functions. They are new INTRINSIC functions.
***** End V10 Development *****
2577 MEM 17-Sep-86
Under FLAGANSI, check ATTFLAGANSI bit of LIBATTRIBUTES for
intrinsic functions and give warning if necessary.
***** End Revision History *****
***** Begin Version 11 *****
4516 CDM 2-Oct-85
Phase I.I for VMS long symbols. Pass Sixbit to all error message
routines, do not pass addresses of Sixbit anymore. In later edits
this will pass [length,,pointer to symbol] instead of a pointer to
this to the error message routines.
4527 CDM 1-Jan-86
VMS Long symbols phase II. Convert all internal symbols from
one word of Sixbit to [length,,pointer].
***** End V11 Development *****
***** Begin Version 11A *****
4604 DCE 26-Sep-88
Correct edit 2577 so that the name gets passed correctly (instead
of a pointer to the name).
***** End Version 11A *****
ENDV11
)%
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;
EXTERNAL
%1436% CHARUSED, ! Flag for character operator used in prog
%1513% CHDECL, ! Flag for character identifier used in prog
%1434% CGERR, ! Internal compiler error routine
%1252% ?CMP1.RENT, ! Pointer into table for 1 arg 'CMPL1.R'.
%1252% CMPLXENT, ! Pointer to 2 argument complex 'CMPLX'.
E80, ! Illegal argument type
%1275% E81, ! Not correct number of arguments
%1270% E169, ! Error this argument illegal
%1270% E170, ! Warning - ingoring declaration
%1535% E203, ! ICHAR - char const len longer than 1
%2577% E294, ! non F77 function or subroutine
ERROUT,
%1270% FATLERR, ! Error routine.
FATLEX, ! Fatal error routine.
LIBFUNTAB,
LIBATTRIBUTES,
%4516% ONEWPTR, ! Returns [1,,pointer] for sixbit passed to it
TBLSEARCH,
WARNERR;
MAP LIBATTSTR LIBATTRIBUTES;
%(***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.',
%1241% SIXBIT'ANINT.',
SIXBIT'ASIN.',
SIXBIT'ATAN.',
SIXBIT'ATAN2.',
%2301% SIXBIT'BTEST.',
SIXBIT'CABS.',
SIXBIT'CCOS.',
%[761]% SIXBIT'CDABS.',
SIXBIT'CEXP.',
%1264% SIXBIT'CHAR.',
SIXBIT'CLOG.',
%1252% SIXBIT'CMP1.D',
%1252% SIXBIT'CMP1.I',
%1252% SIXBIT'CMP1.R',
%1264% SIXBIT'CMPL.C',
%1252% SIXBIT'CMPL.D',
%1252% SIXBIT'CMPL.I',
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.',
%1252% SIXBIT'DBLE.C',
%1252% SIXBIT'DBLE.I',
SIXBIT'DCOS.',
%[761]% SIXBIT'DCOSH.',
%[761]% SIXBIT'DCOTN.',
%1241% SIXBIT'DDIM.',
SIXBIT'DEXP.',
SIXBIT'DFLOT.',
SIXBIT'DIM.',
%1241% SIXBIT'DINT.',
SIXBIT'DLOG.',
SIXBIT'DLG10.',
SIXBIT'DMAX1.',
SIXBIT'DMIN1.',
SIXBIT'DMOD.',
%1241% SIXBIT'DNINT.',
%1241% SIXBIT'DPROD.',
SIXBIT'DSIGN.',
SIXBIT'DSIN.',
%[761]% SIXBIT'DSINH.',
SIXBIT'DSQRT.',
%[761]% SIXBIT'DTAN.',
%[761]% SIXBIT'DTANH.',
SIXBIT'EXP.',
SIXBIT'FLOAT.',
SIXBIT'IABS.',
%2301% SIXBIT'IAND.',
%2301% SIXBIT'IBCLR.',
%2301% SIXBIT'IBITS.',
%2301% SIXBIT'IBSET.',
%1264% SIXBIT'ICHAR.',
SIXBIT'IDIM.',
SIXBIT'IDINT.',
%1241% SIXBIT'IDNIN.',
%2301% SIXBIT'IEOR.',
SIXBIT'IFIX.',
%1264% SIXBIT'INDEX.',
SIXBIT'INT.',
%1252% SIXBIT'INT.C',
%2301% SIXBIT'IOR.',
%2301% SIXBIT'ISHFT.',
%2301% SIXBIT'ISHFC.',
SIXBIT'ISIGN.',
%1264% SIXBIT'LEN.',
%1264% SIXBIT'LGE.',
%1264% SIXBIT'LGT.',
%1264% SIXBIT'LLE.',
%1264% SIXBIT'LLT.',
%1241% SIXBIT'LOG.',
%1264% SIXBIT'LOG10.',
%1264% SIXBIT'MAX.',
SIXBIT'MAX0.',
SIXBIT'MAX1.',
%1264% SIXBIT'MIN.',
SIXBIT'MIN0.',
SIXBIT'MIN1.',
SIXBIT'MOD.',
%1241% SIXBIT'NINT.',
%1264% SIXBIT'NOP.', !Should not be called.
%1264% SIXBIT'NOP.', !Should not be called.
%1264% SIXBIT'NOP.', !Should not be called.
%1264% SIXBIT'NOP.', !Should not be called.
%2301% SIXBIT'NOT.',
SIXBIT'REAL.',
%1252% SIXBIT'REAL.C',
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.',
%1241% SIXBIT'ANINT.',
%[761]% SIXBIT'ASIN.',
%[761]% SIXBIT'ATAN.',
%[761]% SIXBIT'ATAN2.',
%2301% SIXBIT'BTEST.',
%[761]% SIXBIT'CABS.',
%[761]% SIXBIT'CCOS.',
%[761]% SIXBIT'CGABS.',
%[761]% SIXBIT'CEXP.',
%1264% SIXBIT'CHAR.',
%[761]% SIXBIT'CLOG.',
%1252% SIXBIT'CMP1.D',
%1252% SIXBIT'CMP1.I',
%1252% SIXBIT'CMP1.R',
%1264% SIXBIT'CMPL.C',
%1543% SIXBIT'CMPL.G',
%1252% SIXBIT'CMPL.I',
%[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.',
%1252% SIXBIT'DBLE.C',
%1252% SIXBIT'DBLE.I',
%[761]% SIXBIT'GCOS.',
%[761]% SIXBIT'GCOSH.',
%[761]% SIXBIT'GCOTN.',
%1241% SIXBIT'GDIM.',
%[761]% SIXBIT'GEXP.',
%[761]% SIXBIT'GFLOT.',
%[761]% SIXBIT'DIM.',
%1241% SIXBIT'GINT.',
%[761]% SIXBIT'GLOG.',
%[761]% SIXBIT'GLG10.',
%[761]% SIXBIT'GMAX1.',
%[761]% SIXBIT'GMIN1.',
%[761]% SIXBIT'GMOD.',
%1241% SIXBIT'GNINT.',
%1241% SIXBIT'GPROD.',
%[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.',
%2301% SIXBIT'IAND.',
%2301% SIXBIT'IBCLR.',
%2301% SIXBIT'IBITS.',
%2301% SIXBIT'IBSET.',
%1264% SIXBIT'ICHAR.',
%[761]% SIXBIT'IDIM.',
%[1075]% SIXBIT'IGINT.',
%1241% SIXBIT'IGNIN.',
%2301% SIXBIT'IEOR.',
%[761]% SIXBIT'IFIX.',
%1264% SIXBIT'INDEX.',
%[761]% SIXBIT'INT.',
%1252% SIXBIT'INT.C',
%2301% SIXBIT'IOR.',
%2301% SIXBIT'ISHFT.',
%2301% SIXBIT'ISHFC.',
%[761]% SIXBIT'ISIGN.',
%1264% SIXBIT'LEN.',
%1264% SIXBIT'LGE.',
%1264% SIXBIT'LGT.',
%1264% SIXBIT'LLE.',
%1264% SIXBIT'LLT.',
%1241% SIXBIT'LOG.',
%1264% SIXBIT'LOG10.',
%1264% SIXBIT'MAX.',
%[761]% SIXBIT'MAX0.',
%[761]% SIXBIT'MAX1.',
%1264% SIXBIT'MIN.',
%[761]% SIXBIT'MIN0.',
%[761]% SIXBIT'MIN1.',
%[761]% SIXBIT'MOD.',
%1241% SIXBIT'NINT.',
%1264% SIXBIT'NOP.', !Should not be called.
%1264% SIXBIT'NOP.', !Should not be called.
%1264% SIXBIT'NOP.', !Should not be called.
%1264% SIXBIT'NOP.', !Should not be called.
%2301% SIXBIT'NOT.',
%[761]% SIXBIT'REAL.',
%1252% SIXBIT'REAL.C',
%[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 MAKDOTTEDNAME(FNIX,SYMTABPTR) = ![1513] Created from MAKLIBFN
%(***************************************************************************
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. 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.
This routine returns a pointer to the STE it created for the
dotted name.
The arg "FNIX" is the index for the function name in the
LIBATTRIBUTES table.
The arg "SYMTABPTR" is a pointer to the STE for the function name
used in the original program (the undotted, possibly generic, name).
***************************************************************************)%
BEGIN
%1270% MAP PEXPRNODE SYMTABPTR; !Pointer into symbol table for origonal
%4527% REGISTER BASE FNSYMENTRY; !Symbol table entry created for the fn name
%2577% ! Ansi flagging for functions (all functions are vms compatible)
%2577% IF FLAGANSI
%2577% THEN IF .LIBATTRIBUTES[.FNIX,ATTFLAGANSI]
!**;[4604], MAKDOTTEDNAME,5425, DCE, 26-Sep-88
%4604% THEN WARNERR(.SYMTABPTR[IDSYMBOL],.ISN,E294<0,0>);
NAME = IDTAB;
![1004] Choose dotted names based on /GFLOATING.
%1241% IF .GFLOAT
%1004% THEN ENTRY[0] = .GDOTTEDNAMES[.FNIX]
%1004% ELSE ENTRY[0] = .DOTTEDNAMES[.FNIX];
%4516% ENTRY = ONEWPTR(.ENTRY[0]);
%1505% FNSYMENTRY = 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[VALTYPE] = .LIBATTRIBUTES[.FNIX,ATTRESTYPE];
FNSYMENTRY[IDFNATTRIB] = .LIBATTRIBUTES[.FNIX,ATTFNATTRIB];
FNSYMENTRY[OPERSP] = FNNAME;
%1513% ! Get the INEXTERN bit from the original STE. If this routine
%1513% ! is character, HSCHD will use this bit to decide if it should
%1513% ! allocate a descriptor.
%1513% FNSYMENTRY[IDATTRIBUT(INEXTERN)] = .SYMTABPTR[IDATTRIBUT(INEXTERN)];
%1567% ! Mark whether there's any chance of folding the function call
%1567% ! into a constant.
%1567% FNSYMENTRY[IDFNFOLD] = .LIBATTRIBUTES[.FNIX,ATTFNFOLD];
%1434% ! If this is the character function CHAR() then set the length
%1434% ! in the symbol table to 1. If it is not CHAR, then complain
%1434% ! with an ?ICE since we'll have a new function that must be set.
%1434% IF .FNSYMENTRY[VALTYPE] EQL CHARACTER
%1434% THEN
%1434% BEGIN ! Character function
%1513% ! Using a INTRINSIC character function declare a character
%1513% ! identifier--the name of the character function.
%1513% CHDECL = TRUE;
%4527% IF .FNSYMENTRY[ID1ST6CHAR] EQL SIXBIT 'CHAR.'
%1434% THEN FNSYMENTRY[IDCHLEN] = 1
%1434% ELSE CGERR();! Error, must figure out what length
%1434% ! we need for this new function
%1434% END; ! Character function
%1270% ! Check if the function has been declared in a type statement and
%1270% ! it is not of the type of the original call. If so, it's ignored.
%1270% IF .SYMTABPTR[IDATTRIBUT(INTYPE)] AND
%1270% (.FNSYMENTRY[VALTYPE] NEQ .SYMTABPTR[VALTYPE])
%1270% THEN WARNERR(.SYMTABPTR[IDSYMBOL],.ISN,E170<0,0>);
RETURN .FNSYMENTRY
END; ! of MAKDOTTEDNAME
GLOBAL ROUTINE MAKLIBFN(FNNAMENTRY,FNCALLNODE,SYMTABPTR)=
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine is called for every call to a library Function.
!
! 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 calls MAKDOTTEDNAME to substitute a dotted function
! name for the function name used by the original program. This
! routine also sets ARG1PTR of the function call node to point to the
! STE of the dotted name.
!
! 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.
!
! FORMAL PARAMETERS:
!
! FNNAMENTRY is a pointer to the entry in the function name table for
! this function.
!
! FNCALLNODE is a pointer 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.
!
! SYMTABPTR is a pointer to the STE for the function name used in the
! original program (the undotted, possibly generic, name).
!
! IMPLICIT INPUTS:
!
! Unknown
!
! IMPLICIT OUTPUTS:
!
! Unknown
!
! ROUTINE VALUE:
!
! None
!
! SIDE EFFECTS:
!
! Unknown
!
!--
BEGIN
MAP PEXPRNODE FNCALLNODE;
%1270% MAP PEXPRNODE SYMTABPTR; ! Pointer into symbol table for
%4527% LOCAL
ARG1TYPE, ! Type of first fn argument (type of fn)
%4527% BASE ARG1NODE, ! Expression node for the first arg on
! the arglist
ARGUMENTLIST ARGLST, ! The argument list under the node for
! this fn-call
FNIX, ! Index for the function-name in the
! LIBATTRIBUTES table
%4527% BASE FNSYMENTRY, ! Function symbol table entry
! original
BASE SYMENTRY; ! Un dotted symbol table entry pointer
SYMENTRY = .FNCALLNODE[ARG1PTR]; !SET SYMBOL TABLE POINTER
ARGLST = .FNCALLNODE[ARG2PTR]; !PTR TO THE ARGUMENT LIST
ARG1NODE = .ARGLST[1,ARGNPTR]; !PTR TO THE FIRST ARGUMENT
%1275% !If there are less than 1 argument (no arg or the compiler put
%1275% ! trash in the count) complain that this is illegal.
%1275% IF .ARGLST[ARGCOUNT] LSS 1
%1275% THEN
%1275% BEGIN
%4527% WARNERR(ONEWPTR(@@FNNAMENTRY<SYMPOINTER>),.ISN,E81<0,0>);
%1275% RETURN; !No use continuing
%1275% END;
%1252% ! If function is CMPLX and has only one argument, change the
%1252% ! function to CMP1.R.
%1252% IF .FNNAMENTRY EQL CMPLXENT<0,0> AND
%1252% .ARGLST[ARGCOUNT] EQL 1 THEN
%1252% FNNAMENTRY = ?CMP1.RENT; !Set to CMPL.R
FNIX = .FNNAMENTRY-LIBFUNTAB<0,0>; !Diplacement off table.
%(*** 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
%1270% OR .ARG1TYPE EQL DOUBLOCT
THEN
BEGIN
%(***For the arg of type OCTAL or LOGICAL - accept the argument unless
generic function has no name in standard so that the
interpretation of how to treat the argument is unclear.
Do no type checking and do not call some other fn in the case
of a generic fn.
*******)%
%1270% IF .LIBATTRIBUTES[.FNIX,ATTSPGEN]
%1270% THEN FATLERR(.ISN,E169<0,0>);
END
ELSE
%(***If the fn is generic, get a ptr to the actual fn to use***)%
IF .LIBATTRIBUTES[.FNIX,ATTGENERFLG]
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
! function name. Also if the function is generic, the
! value type CAN NOT be character! To allow character
! arguments, the table to decide which function under
! the generic is really being called would have to be
! re-worked.
IF .ACTFN EQL ILGARGTYPE
%1270% OR .ARG1TYPE EQL CHARACTER
%1270% OR .ARG1TYPE EQL HOLLERITH
THEN WARNERR(.SYMTABPTR[IDSYMBOL],.ISN,E80<0,0>)
ELSE !*** If have changed the function name to be referred
! to, 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
%4527% THEN WARNERR(ONEWPTR(@@FNNAMENTRY<SYMPOINTER>),.ISN,E80<0,0>)
END;
%1513% ! Get dotted name of the intrinsic routine
%1513% FNCALLNODE[ARG1PTR] = FNSYMENTRY = MAKDOTTEDNAME(.FNIX,.SYMTABPTR);
%1513% FNCALLNODE[VALTYPE] = .FNSYMENTRY[VALTYPE];
%1535% ! If function ICHAR with constant argument, check if the
%1535% ! argument is over 1 character long.
%1535%
%4527% IF .FNSYMENTRY[ID1ST6CHAR] EQL SIXBIT 'ICHAR.'
%1535% THEN
%1535% BEGIN
%1535% IF .ARG1NODE[OPR1] EQL CONSTFL THEN
%1535% IF .ARG1NODE[LITLEN] NEQ 1
%1535% THEN FATLERR(.ISN,E203<0,0>);
%1535% END;
! 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)
%4527% THEN WARNERR(ONEWPTR(@@FNNAMENTRY<SYMPOINTER>),.ISN,E81<0,0>)
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
%4527% LOCAL PEXPRNODE ARGNODE;
ARGNODE = .ARGLST[.I,ARGNPTR];
IF .ARGNODE[VALTYPE] NEQ .ARG1TYPE
%4527% THEN WARNERR(ONEWPTR(@@FNNAMENTRY<SYMPOINTER>),
.ISN,E80<0,0>)
END
END;
%(****** Set OPERSP in the function call node
to indicate library function **************)%
FNCALLNODE[OPERSP] = LIBARY;
%1436% ! Set CHARUSED if the prog contains calls to intrinsic
%1436% ! character functions.
%1436% IF .FNCALLNODE[VALTYPE] EQL CHARACTER
%1436% OR .ARG1TYPE EQL CHARACTER
%1436% THEN
%1436% CHARUSED = TRUE;
END; ! of MAKLIBFN
END
ELUDOM