diff options
author | Steven G. Kargl <kargls@comcast.net> | 2004-08-29 15:58:16 +0000 |
---|---|---|
committer | Paul Brook <pbrook@gcc.gnu.org> | 2004-08-29 15:58:16 +0000 |
commit | e8525382d986350f38193ca20504631bfadc43ba (patch) | |
tree | 764a8802dba0b681b9c0d6f4248a2b2513c2b2fc /gcc | |
parent | 766ff1b11748f66da98c901b9498a90e72698c05 (diff) | |
download | gcc-e8525382d986350f38193ca20504631bfadc43ba.zip gcc-e8525382d986350f38193ca20504631bfadc43ba.tar.gz gcc-e8525382d986350f38193ca20504631bfadc43ba.tar.bz2 |
check.c (gfc_check_besn, [...]): New functions.
2004-08-29 Steven G. Kargl <kargls@comcast.net>
Paul Brook <paul@codesourcery.com>
* check.c (gfc_check_besn, gfc_check_g77_math1): New functions.
* f95-lang.c (DO_DEFINE_MATH_BUILTIN): Define.
(DEFINE_MATH_BUILTIN, DEFINE_MATH_BUILTIN_C): Use it.
(build_builtin_fntypes): New function.
(gfc_init_builtin_functions): Use it.
* gfortran.h (enum gfc_generic_isym_id): Add GFC_ISYM_{J,Y}{0,1,N}
and GFC_ISYM_ERF{,C}.
(gfc_c_int_kind): Declare.
* intrinsic.c (add_functions): Add [d]bes* and [d]erf*.
* intrinsic.h (gfc_check_besn, gfc_check_g77_math1, gfc_resolve_besn,
gfc_resolve_g77_math1): Add prototypes.
* resolve.c (gfc_resolve_besn, gfc_resolve_g77_math1): New functions.
* mathbuiltins.def: Add comment. Change third argument. Use
DEFINE_MATH_BUILTIN_C. Add bessel and error functions.
* trans-intrinsic.c (BUILT_IN_FUNCTION): Define.
(DEFINE_MATH_BUILTIN, DEFINE_MATH_BUILTIN_C): Use it.
* trans-types.c (gfc_c_int_kind): Declare.
(gfc_init_kinds): Set it.
testsuite/
* gfortran.dg/g77/README: Update.
* gfortran.dg/g77/erfc.f: Copy from g77.f-torture.
* gfortran.dg/g77/intrinsic-unix-bessel.f: Ditto.
* gfortran.dg/g77/intrinsic-unix-erf.f: Ditto.
libgfortran/
* intrinsics/bessel.c: New file.
* intrinsics/erf.c: New file.
* Makefie.am: Add intrinsics/bessel.c and intrinsics/erf.c.
* configure.ac: Test for C99 Bessel and Error functions.
* Makefile.in: Regenerate.
* config.h.in: Regenerate.
* configure: Regenerate.
Co-Authored-By: Paul Brook <paul@codesourcery.com>
From-SVN: r86727
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/fortran/ChangeLog | 22 | ||||
-rw-r--r-- | gcc/fortran/check.c | 38 | ||||
-rw-r--r-- | gcc/fortran/f95-lang.c | 61 | ||||
-rw-r--r-- | gcc/fortran/gfortran.h | 9 | ||||
-rw-r--r-- | gcc/fortran/intrinsic.c | 83 | ||||
-rw-r--r-- | gcc/fortran/intrinsic.h | 4 | ||||
-rw-r--r-- | gcc/fortran/iresolve.c | 28 | ||||
-rw-r--r-- | gcc/fortran/mathbuiltins.def | 43 | ||||
-rw-r--r-- | gcc/fortran/trans-intrinsic.c | 13 | ||||
-rw-r--r-- | gcc/fortran/trans-types.c | 3 | ||||
-rw-r--r-- | gcc/testsuite/ChangeLog | 8 | ||||
-rwxr-xr-x | gcc/testsuite/gfortran.dg/g77/README | 6 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/g77/erfc.f | 39 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/g77/intrinsic-unix-bessel.f | 109 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/g77/intrinsic-unix-erf.f | 61 |
15 files changed, 491 insertions, 36 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 85c4d23..fd405fe 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,6 +1,28 @@ 2004-08-29 Steven G. Kargl <kargls@comcast.net> Paul Brook <paul@codesourcery.com> + * check.c (gfc_check_besn, gfc_check_g77_math1): New functions. + * f95-lang.c (DO_DEFINE_MATH_BUILTIN): Define. + (DEFINE_MATH_BUILTIN, DEFINE_MATH_BUILTIN_C): Use it. + (build_builtin_fntypes): New function. + (gfc_init_builtin_functions): Use it. + * gfortran.h (enum gfc_generic_isym_id): Add GFC_ISYM_{J,Y}{0,1,N} + and GFC_ISYM_ERF{,C}. + (gfc_c_int_kind): Declare. + * intrinsic.c (add_functions): Add [d]bes* and [d]erf*. + * intrinsic.h (gfc_check_besn, gfc_check_g77_math1, gfc_resolve_besn, + gfc_resolve_g77_math1): Add prototypes. + * resolve.c (gfc_resolve_besn, gfc_resolve_g77_math1): New functions. + * mathbuiltins.def: Add comment. Change third argument. Use + DEFINE_MATH_BUILTIN_C. Add bessel and error functions. + * trans-intrinsic.c (BUILT_IN_FUNCTION): Define. + (DEFINE_MATH_BUILTIN, DEFINE_MATH_BUILTIN_C): Use it. + * trans-types.c (gfc_c_int_kind): Declare. + (gfc_init_kinds): Set it. + +2004-08-29 Steven G. Kargl <kargls@comcast.net> + Paul Brook <paul@codesourcery.com> + * gfortran.h (enum gfc_generic_isym_id): Add GFC_ISYM_GET?ID. (gfc_check_f, gfc_simplify_f): Add f0. * intrinsic.c (do_check): Call f0. Flatten. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index a010dce..6bc9e09 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -525,6 +525,28 @@ gfc_check_atan2 (gfc_expr * y, gfc_expr * x) } +/* BESJN and BESYN functions. */ + +try +gfc_check_besn (gfc_expr * n, gfc_expr * x) +{ + + if (scalar_check (n, 0) == FAILURE) + return FAILURE; + + if (type_check (n, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (x, 1) == FAILURE) + return FAILURE; + + if (type_check (x, 1, BT_REAL) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + try gfc_check_btest (gfc_expr * i, gfc_expr * pos) { @@ -728,6 +750,22 @@ gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary, } +/* This is used for the g77 one-argument Bessel functions, and the + error function. */ + +try +gfc_check_g77_math1 (gfc_expr * x) +{ + + if (scalar_check (x, 0) == FAILURE) + return FAILURE; + + if (type_check (x, 0, BT_REAL) == FAILURE) + return FAILURE; + + return SUCCESS; +} + try gfc_check_huge (gfc_expr * x) diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index 673e208..b822a89 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -712,38 +712,64 @@ gfc_define_builtin (const char * name, } -#define DEFINE_MATH_BUILTIN(code, name, nargs) \ - gfc_define_builtin ("__builtin_" name, mfunc_double[nargs-1], \ +#define DO_DEFINE_MATH_BUILTIN(code, name, argtype, tbase) \ + gfc_define_builtin ("__builtin_" name, tbase##double[argtype], \ BUILT_IN_ ## code, name, true); \ - gfc_define_builtin ("__builtin_" name "f", mfunc_float[nargs-1], \ + gfc_define_builtin ("__builtin_" name "f", tbase##float[argtype], \ BUILT_IN_ ## code ## F, name "f", true); +#define DEFINE_MATH_BUILTIN(code, name, argtype) \ + DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_) + +/* The middle-end is missing builtins for some complex math functions, so + we don't use them yet. */ +#define DEFINE_MATH_BUILTIN_C(code, name, argtype) \ + DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_) +/* DO_DEFINE_MATH_BUILTIN (C##code, "c" name, argtype, mfunc_c)*/ + + +/* Create function types for builtin functions. */ + +static void +build_builtin_fntypes (tree * fntype, tree type) +{ + tree tmp; + + /* type (*) (type) */ + tmp = tree_cons (NULL_TREE, float_type_node, void_list_node); + fntype[0] = build_function_type (type, tmp); + /* type (*) (type, type) */ + tmp = tree_cons (NULL_TREE, float_type_node, tmp); + fntype[1] = build_function_type (type, tmp); + /* type (*) (int, type) */ + tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node); + tmp = tree_cons (NULL_TREE, type, tmp); + fntype[2] = build_function_type (type, tmp); +} + + /* Initialisation of builtin function nodes. */ + static void gfc_init_builtin_functions (void) { - tree mfunc_float[2]; - tree mfunc_double[2]; + tree mfunc_float[3]; + tree mfunc_double[3]; + tree mfunc_cfloat[3]; + tree mfunc_cdouble[3]; tree func_cfloat_float; tree func_cdouble_double; tree ftype; tree tmp; - tmp = tree_cons (NULL_TREE, float_type_node, void_list_node); - mfunc_float[0] = build_function_type (float_type_node, tmp); - tmp = tree_cons (NULL_TREE, float_type_node, tmp); - mfunc_float[1] = build_function_type (float_type_node, tmp); - + build_builtin_fntypes (mfunc_float, float_type_node); + build_builtin_fntypes (mfunc_double, double_type_node); + build_builtin_fntypes (mfunc_cfloat, complex_float_type_node); + build_builtin_fntypes (mfunc_cdouble, complex_double_type_node); + tmp = tree_cons (NULL_TREE, complex_float_type_node, void_list_node); func_cfloat_float = build_function_type (float_type_node, tmp); - - tmp = tree_cons (NULL_TREE, double_type_node, void_list_node); - mfunc_double[0] = build_function_type (double_type_node, tmp); - tmp = tree_cons (NULL_TREE, double_type_node, tmp); - mfunc_double[1] = build_function_type (double_type_node, tmp); - - tmp = tree_cons (NULL_TREE, complex_double_type_node, void_list_node); func_cdouble_double = build_function_type (double_type_node, tmp); @@ -835,6 +861,7 @@ gfc_init_builtin_functions (void) "alloca", false); } +#undef DEFINE_MATH_BUILTIN_C #undef DEFINE_MATH_BUILTIN #include "gt-fortran-f95-lang.h" diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a633603..89c182d 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -286,6 +286,12 @@ enum gfc_generic_isym_id GFC_ISYM_ASSOCIATED, GFC_ISYM_ATAN, GFC_ISYM_ATAN2, + GFC_ISYM_J0, + GFC_ISYM_J1, + GFC_ISYM_JN, + GFC_ISYM_Y0, + GFC_ISYM_Y1, + GFC_ISYM_YN, GFC_ISYM_BTEST, GFC_ISYM_CEILING, GFC_ISYM_CHAR, @@ -301,6 +307,8 @@ enum gfc_generic_isym_id GFC_ISYM_DOT_PRODUCT, GFC_ISYM_DPROD, GFC_ISYM_EOSHIFT, + GFC_ISYM_ERF, + GFC_ISYM_ERFC, GFC_ISYM_ETIME, GFC_ISYM_EXP, GFC_ISYM_EXPONENT, @@ -1518,6 +1526,7 @@ extern int gfc_default_double_kind; extern int gfc_default_character_kind; extern int gfc_default_logical_kind; extern int gfc_default_complex_kind; +extern int gfc_c_int_kind; /* symbol.c */ void gfc_clear_new_implicit (void); diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 4e68090..414cc1a 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -969,6 +969,68 @@ add_functions (void) make_generic ("atan2", GFC_ISYM_ATAN2); + /* Bessel and Neumann functions for G77 compatibility. */ + + add_sym_1 ("besj0", 1, 0, BT_REAL, dr, + gfc_check_g77_math1, NULL, gfc_resolve_g77_math1, + x, BT_REAL, dr, 0); + + add_sym_1 ("dbesj0", 1, 0, BT_REAL, dd, + gfc_check_g77_math1, NULL, gfc_resolve_g77_math1, + x, BT_REAL, dd, 0); + + make_generic ("besj0", GFC_ISYM_J0); + + add_sym_1 ("besj1", 1, 0, BT_REAL, dr, + gfc_check_g77_math1, NULL, gfc_resolve_g77_math1, + x, BT_REAL, dr, 1); + + add_sym_1 ("dbesj1", 1, 0, BT_REAL, dd, + gfc_check_g77_math1, NULL, gfc_resolve_g77_math1, + x, BT_REAL, dd, 1); + + make_generic ("besj1", GFC_ISYM_J1); + + add_sym_2 ("besjn", 1, 0, BT_REAL, dr, + gfc_check_besn, NULL, gfc_resolve_besn, n, BT_INTEGER, di, 1, + x, BT_REAL, dr, 1); + + add_sym_2 ("dbesjn", 1, 0, BT_REAL, dd, + gfc_check_besn, NULL, gfc_resolve_besn, n, BT_INTEGER, di, 1, + x, BT_REAL, dd, 1); + + make_generic ("besjn", GFC_ISYM_JN); + + add_sym_1 ("besy0", 1, 0, BT_REAL, dr, + gfc_check_g77_math1, NULL, gfc_resolve_g77_math1, + x, BT_REAL, dr, 0); + + add_sym_1 ("dbesy0", 1, 0, BT_REAL, dd, + gfc_check_g77_math1, NULL, gfc_resolve_g77_math1, + x, BT_REAL, dd, 0); + + make_generic ("besy0", GFC_ISYM_Y0); + + add_sym_1 ("besy1", 1, 0, BT_REAL, dr, + gfc_check_g77_math1, NULL, gfc_resolve_g77_math1, + x, BT_REAL, dr, 1); + + add_sym_1 ("dbesy1", 1, 0, BT_REAL, dd, + gfc_check_g77_math1, NULL, gfc_resolve_g77_math1, + x, BT_REAL, dd, 1); + + make_generic ("besy1", GFC_ISYM_Y1); + + add_sym_2 ("besyn", 1, 0, BT_REAL, dr, + gfc_check_besn, NULL, gfc_resolve_besn, n, BT_INTEGER, di, 1, + x, BT_REAL, dr, 1); + + add_sym_2 ("dbesyn", 1, 0, BT_REAL, dd, + gfc_check_besn, NULL, gfc_resolve_besn, n, BT_INTEGER, di, 1, + x, BT_REAL, dd, 1); + + make_generic ("besyn", GFC_ISYM_YN); + add_sym_1 ("bit_size", 0, 1, BT_INTEGER, di, gfc_check_i, gfc_simplify_bit_size, NULL, i, BT_INTEGER, di, 0); @@ -1113,6 +1175,27 @@ add_functions (void) make_generic ("epsilon", GFC_ISYM_NONE); + /* G77 compatibility for the ERF() and ERFC() functions. */ + add_sym_1 ("erf", 1, 0, BT_REAL, dr, + gfc_check_g77_math1, NULL, gfc_resolve_g77_math1, + x, BT_REAL, dr, 0); + + add_sym_1 ("derf", 1, 0, BT_REAL, dd, + gfc_check_g77_math1, NULL, gfc_resolve_g77_math1, + x, BT_REAL, dd, 0); + + make_generic ("erf", GFC_ISYM_ERF); + + add_sym_1 ("erfc", 1, 0, BT_REAL, dr, + gfc_check_g77_math1, NULL, gfc_resolve_g77_math1, + x, BT_REAL, dr, 0); + + add_sym_1 ("derfc", 1, 0, BT_REAL, dd, + gfc_check_g77_math1, NULL, gfc_resolve_g77_math1, + x, BT_REAL, dd, 0); + + make_generic ("erfc", GFC_ISYM_ERFC); + /* G77 compatibility */ add_sym_1 ("etime", 0, 1, BT_REAL, 4, gfc_check_etime, NULL, NULL, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index cff8a53..b2ffb15 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -35,6 +35,7 @@ try gfc_check_all_any (gfc_expr *, gfc_expr *); try gfc_check_allocated (gfc_expr *); try gfc_check_associated (gfc_expr *, gfc_expr *); try gfc_check_atan2 (gfc_expr *, gfc_expr *); +try gfc_check_besn (gfc_expr *, gfc_expr *); try gfc_check_btest (gfc_expr *, gfc_expr *); try gfc_check_char (gfc_expr *, gfc_expr *); try gfc_check_cmplx (gfc_expr *, gfc_expr *, gfc_expr *); @@ -47,6 +48,7 @@ try gfc_check_dot_product (gfc_expr *, gfc_expr *); try gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_etime (gfc_expr *); try gfc_check_etime_sub (gfc_expr *, gfc_expr *); +try gfc_check_g77_math1 (gfc_expr *); try gfc_check_huge (gfc_expr *); try gfc_check_i (gfc_expr *); try gfc_check_iand (gfc_expr *, gfc_expr *); @@ -231,6 +233,7 @@ void gfc_resolve_any (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_asin (gfc_expr *, gfc_expr *); void gfc_resolve_atan (gfc_expr *, gfc_expr *); void gfc_resolve_atan2 (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_besn (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_btest (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ceiling (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_char (gfc_expr *, gfc_expr *, gfc_expr *); @@ -252,6 +255,7 @@ void gfc_resolve_exp (gfc_expr *, gfc_expr *); void gfc_resolve_exponent (gfc_expr *, gfc_expr *); void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_fraction (gfc_expr *, gfc_expr *); +void gfc_resolve_g77_math1 (gfc_expr *, gfc_expr *); void gfc_resolve_getgid (gfc_expr *); void gfc_resolve_getpid (gfc_expr *); void gfc_resolve_getuid (gfc_expr *); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index eef424f..6df9583 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -269,6 +269,24 @@ gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x, } +/* Resolve the BESYN and BESJN intrinsics. */ + +void +gfc_resolve_besn (gfc_expr * f, gfc_expr * n, gfc_expr * x) +{ + gfc_typespec ts; + + f->ts = x->ts; + if (n->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + gfc_convert_type (n, &ts, 2); + } + f->value.function.name = gfc_get_string ("<intrinsic>"); +} + + void gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos) { @@ -544,6 +562,16 @@ gfc_resolve_fraction (gfc_expr * f, gfc_expr * x) } +/* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */ + +void +gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x) +{ + f->ts = x->ts; + f->value.function.name = gfc_get_string ("<intrinsic>"); +} + + void gfc_resolve_getgid (gfc_expr * f) { diff --git a/gcc/fortran/mathbuiltins.def b/gcc/fortran/mathbuiltins.def index c46c1d5..0bbf8d9 100644 --- a/gcc/fortran/mathbuiltins.def +++ b/gcc/fortran/mathbuiltins.def @@ -1,14 +1,29 @@ -DEFINE_MATH_BUILTIN (ACOS, "acos", 1) -DEFINE_MATH_BUILTIN (ASIN, "asin", 1) -DEFINE_MATH_BUILTIN (ATAN, "atan", 1) -DEFINE_MATH_BUILTIN (ATAN2, "atan2", 2) -DEFINE_MATH_BUILTIN (COS, "cos", 1) -DEFINE_MATH_BUILTIN (COSH, "cosh", 1) -DEFINE_MATH_BUILTIN (EXP, "exp", 1) -DEFINE_MATH_BUILTIN (LOG, "log", 1) -DEFINE_MATH_BUILTIN (LOG10, "log10", 1) -DEFINE_MATH_BUILTIN (SIN, "sin", 1) -DEFINE_MATH_BUILTIN (SINH, "sinh", 1) -DEFINE_MATH_BUILTIN (SQRT, "sqrt", 1) -DEFINE_MATH_BUILTIN (TAN, "tan", 1) -DEFINE_MATH_BUILTIN (TANH, "tanh", 1) +/* DEFINE_MATH_BUILTIN (CODE, NAME, ARGTYPE) + NAME The name of the builtin + SNAME The name of the builtin as a string + ARGTYPE The type of the arguments. See f95-lang.c + + Use DEFINE_MATH_BUILTIN_C if the complex versions of the builtin are + also available. */ +DEFINE_MATH_BUILTIN_C (ACOS, "acos", 0) +DEFINE_MATH_BUILTIN_C (ASIN, "asin", 0) +DEFINE_MATH_BUILTIN_C (ATAN, "atan", 0) +DEFINE_MATH_BUILTIN (ATAN2, "atan2", 1) +DEFINE_MATH_BUILTIN_C (COS, "cos", 0) +DEFINE_MATH_BUILTIN_C (COSH, "cosh", 0) +DEFINE_MATH_BUILTIN_C (EXP, "exp", 0) +DEFINE_MATH_BUILTIN_C (LOG, "log", 0) +DEFINE_MATH_BUILTIN_C (LOG10, "log10", 0) +DEFINE_MATH_BUILTIN_C (SIN, "sin", 0) +DEFINE_MATH_BUILTIN_C (SINH, "sinh", 0) +DEFINE_MATH_BUILTIN_C (SQRT, "sqrt", 0) +DEFINE_MATH_BUILTIN_C (TAN, "tan", 0) +DEFINE_MATH_BUILTIN_C (TANH, "tanh", 0) +DEFINE_MATH_BUILTIN (J0, "j0", 0) +DEFINE_MATH_BUILTIN (J1, "j1", 0) +DEFINE_MATH_BUILTIN (JN, "jn", 2) +DEFINE_MATH_BUILTIN (Y0, "y0", 0) +DEFINE_MATH_BUILTIN (Y1, "y1", 0) +DEFINE_MATH_BUILTIN (YN, "yn", 2) +DEFINE_MATH_BUILTIN (ERF, "erf", 0) +DEFINE_MATH_BUILTIN (ERFC, "erfc", 0) diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 43e1e94..ec56895 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -85,9 +85,16 @@ gfc_intrinsic_map_t; /* ??? The NARGS==1 hack here is based on the fact that (c99 at least) defines complex variants of all of the entries in mathbuiltins.def except for atan2. */ -#define DEFINE_MATH_BUILTIN(ID, NAME, NARGS) \ +#define BUILT_IN_FUNCTION(ID, NAME, HAVE_COMPLEX) \ { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, true, \ - NARGS == 1, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, + HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, + +#define DEFINE_MATH_BUILTIN(id, name, argtype) \ + BUILT_IN_FUNCTION (id, name, false) + +/* TODO: Use builtin function for complex intrinsics. */ +#define DEFINE_MATH_BUILTIN_C(id, name, argtype) \ + BUILT_IN_FUNCTION (id, name, true) #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \ { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, true, HAVE_COMPLEX, true, \ @@ -117,6 +124,8 @@ static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] = LIBF_FUNCTION (NONE, NULL, false) }; #undef DEFINE_MATH_BUILTIN +#undef DEFINE_MATH_BUILTIN_C +#undef BUILT_IN_FUNCTION #undef LIBM_FUNCTION #undef LIBF_FUNCTION diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index e247fb3..d1ace6d 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -84,6 +84,7 @@ int gfc_default_double_kind; int gfc_default_character_kind; int gfc_default_logical_kind; int gfc_default_complex_kind; +int gfc_c_int_kind; /* Query the target to determine which machine modes are available for computation. Choose KIND numbers for them. */ @@ -232,6 +233,8 @@ gfc_init_kinds (void) /* Choose the integer kind the same size as "void*" for our index kind. */ gfc_index_integer_kind = POINTER_SIZE / 8; + /* Pick a kind the same size as the C "int" type. */ + gfc_c_int_kind = INT_TYPE_SIZE / 8; } /* Make sure that a valid kind is present. Returns an index into the diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index beb4aa1..84c03ab 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2004-08-29 Steven G. Kargl <kargls@comcast.net> + Paul Brook <paul@codesourcery.com> + + * gfortran.dg/g77/README: Update. + * gfortran.dg/g77/erfc.f: Copy from g77.f-torture. + * gfortran.dg/g77/intrinsic-unix-bessel.f: Ditto. + * gfortran.dg/g77/intrinsic-unix-erf.f: Ditto. + 2004-08-28 Paul Brook <paul@codesourcery.com> PR libfortran/17195 diff --git a/gcc/testsuite/gfortran.dg/g77/README b/gcc/testsuite/gfortran.dg/g77/README index f5d6c35..2605369 100755 --- a/gcc/testsuite/gfortran.dg/g77/README +++ b/gcc/testsuite/gfortran.dg/g77/README @@ -167,15 +167,15 @@ cpp.F (Renamed cpp3.F) Y cpp2.F - Compiler warnings dcomplex.f Y dnrm2.f Y Add dg-warning as required -erfc.f Link errors +erfc.f Y exp.f Compiler warnings and fails f90-intrinsic-bit.f F 16581 Compile errors f90-intrinsic-mathematical.f Y f90-intrinsic-numeric.f Y int8421.f Y intrinsic-f2c-z.f F Execution fail -intrinsic-unix-bessel.f Link errors -intrinsic-unix-erf.f Link erros +intrinsic-unix-bessel.f Y +intrinsic-unix-erf.f Y intrinsic-vax-cd.f F Execution fail intrinsic77.f F PR 16580 Compiler ICE io0.f & io0.x diff --git a/gcc/testsuite/gfortran.dg/g77/erfc.f b/gcc/testsuite/gfortran.dg/g77/erfc.f new file mode 100644 index 0000000..0ab0aee --- /dev/null +++ b/gcc/testsuite/gfortran.dg/g77/erfc.f @@ -0,0 +1,39 @@ +c { dg-do run } +c============================================== test.f + real x, y + real*8 x1, y1 + x=0. + y = erfc(x) + if (y .ne. 1.) call abort + + x=1.1 + y = erfc(x) + if (abs(y - .1197949) .ge. 1.e-6) call abort + +* modified from x=10, y .gt. 1.5e-44 to avoid lack of -mieee on Alphas. + x=8 + y = erfc(x) + if (y .gt. 1.2e-28) call abort + + x1=0. + y1 = erfc(x1) + if (y1 .ne. 1.) call abort + + x1=1.1d0 + y1 = erfc(x1) + if (abs(y1 - .1197949d0) .ge. 1.d-6) call abort + + x1=10 + y1 = erfc(x1) + if (y1 .gt. 1.5d-44) call abort + end +c================================================= +!output: +! 0. 1.875 +! 1.10000002 1.48958981 +! 10. 5.00220949E-06 +! +!The values should be: +!erfc(0)=1 +!erfc(1.1)= 0.1197949 +!erfc(10)<1.543115467311259E-044 diff --git a/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-bessel.f b/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-bessel.f new file mode 100644 index 0000000..0b5789d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-bessel.f @@ -0,0 +1,109 @@ +c { dg-do run } +c intrinsic-unix-bessel.f +c +c Test Bessel function intrinsics. +c These functions are only available if provided by system +c +c David Billinghurst <David.Billinghurst@riotinto.com> +c + real x, a + double precision dx, da + integer i + integer*2 j + integer*1 k + integer*8 m + logical fail + common /flags/ fail + fail = .false. + + x = 2.0 + dx = x + i = 2 + j = i + k = i + m = i +c BESJ0 - Bessel function of first kind of order zero + a = 0.22389077 + da = a + call c_r(BESJ0(x),a,'BESJ0(real)') + call c_d(BESJ0(dx),da,'BESJ0(double)') + call c_d(DBESJ0(dx),da,'DBESJ0(double)') + +c BESJ1 - Bessel function of first kind of order one + a = 0.57672480 + da = a + call c_r(BESJ1(x),a,'BESJ1(real)') + call c_d(BESJ1(dx),da,'BESJ1(double)') + call c_d(DBESJ1(dx),da,'DBESJ1(double)') + +c BESJN - Bessel function of first kind of order N + a = 0.3528340 + da = a + call c_r(BESJN(i,x),a,'BESJN(integer,real)') + call c_r(BESJN(j,x),a,'BESJN(integer*2,real)') + call c_r(BESJN(k,x),a,'BESJN(integer*1,real)') + call c_d(BESJN(i,dx),da,'BESJN(integer,double)') + call c_d(BESJN(j,dx),da,'BESJN(integer*2,double)') + call c_d(BESJN(k,dx),da,'BESJN(integer*1,double)') + call c_d(DBESJN(i,dx),da,'DBESJN(integer,double)') + call c_d(DBESJN(j,dx),da,'DBESJN(integer*2,double)') + call c_d(DBESJN(k,dx),da,'DBESJN(integer*1,double)') + +c BESY0 - Bessel function of second kind of order zero + a = 0.51037567 + da = a + call c_r(BESY0(x),a,'BESY0(real)') + call c_d(BESY0(dx),da,'BESY0(double)') + call c_d(DBESY0(dx),da,'DBESY0(double)') + +c BESY1 - Bessel function of second kind of order one + a = 0.-0.1070324 + da = a + call c_r(BESY1(x),a,'BESY1(real)') + call c_d(BESY1(dx),da,'BESY1(double)') + call c_d(DBESY1(dx),da,'DBESY1(double)') + +c BESYN - Bessel function of second kind of order N + a = -0.6174081 + da = a + call c_r(BESYN(i,x),a,'BESYN(integer,real)') + call c_r(BESYN(j,x),a,'BESYN(integer*2,real)') + call c_r(BESYN(k,x),a,'BESYN(integer*1,real)') + call c_d(BESYN(i,dx),da,'BESYN(integer,double)') + call c_d(BESYN(j,dx),da,'BESYN(integer*2,double)') + call c_d(BESYN(k,dx),da,'BESYN(integer*1,double)') + call c_d(DBESYN(i,dx),da,'DBESYN(integer,double)') + call c_d(DBESYN(j,dx),da,'DBESYN(integer*2,double)') + call c_d(DBESYN(k,dx),da,'DBESYN(integer*1,double)') + + if ( fail ) call abort() + end + + subroutine failure(label) +c Report failure and set flag + character*(*) label + logical fail + common /flags/ fail + write(6,'(a,a,a)') 'Test ',label,' FAILED' + fail = .true. + end + + subroutine c_r(a,b,label) +c Check if REAL a equals b, and fail otherwise + real a, b + character*(*) label + if ( abs(a-b) .gt. 1.0e-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end + + subroutine c_d(a,b,label) +c Check if DOUBLE PRECISION a equals b, and fail otherwise + double precision a, b + character*(*) label + if ( abs(a-b) .gt. 1.0d-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end diff --git a/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-erf.f b/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-erf.f new file mode 100644 index 0000000..460ddee --- /dev/null +++ b/gcc/testsuite/gfortran.dg/g77/intrinsic-unix-erf.f @@ -0,0 +1,61 @@ +c { dg-do run } +c intrinsic-unix-erf.f +c +c Test Bessel function intrinsics. +c These functions are only available if provided by system +c +c David Billinghurst <David.Billinghurst@riotinto.com> +c + real x, a + double precision dx, da + logical fail + common /flags/ fail + fail = .false. + + x = 0.6 + dx = x +c ERF - error function + a = 0.6038561 + da = a + call c_r(ERF(x),a,'ERF(real)') + call c_d(ERF(dx),da,'ERF(double)') + call c_d(DERF(dx),da,'DERF(double)') + +c ERFC - complementary error function + a = 1.0 - a + da = a + call c_r(ERFC(x),a,'ERFC(real)') + call c_d(ERFC(dx),da,'ERFC(double)') + call c_d(DERFC(dx),da,'DERFC(double)') + + if ( fail ) call abort() + end + + subroutine failure(label) +c Report failure and set flag + character*(*) label + logical fail + common /flags/ fail + write(6,'(a,a,a)') 'Test ',label,' FAILED' + fail = .true. + end + + subroutine c_r(a,b,label) +c Check if REAL a equals b, and fail otherwise + real a, b + character*(*) label + if ( abs(a-b) .gt. 1.0e-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end + + subroutine c_d(a,b,label) +c Check if DOUBLE PRECISION a equals b, and fail otherwise + double precision a, b + character*(*) label + if ( abs(a-b) .gt. 1.0d-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end |