This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[gfortran] Front-end and library calls for large kinds
- From: FX Coudert <fxcoudert at gmail dot com>
- To: gfortran <fortran at gcc dot gnu dot org>, patch <gcc-patches at gcc dot gnu dot org>
- Date: Sun, 26 Jun 2005 17:27:57 +0200
- Subject: [gfortran] Front-end and library calls for large kinds
[This mail is long, but you can read the first paragraph and then skip
to the last one if you don't want the details]
Attached patch adds front-end and library support for mathematical
functions taking real(10), real(16) and integer(16) argument(s). Right
now, we do have minimal support for these kinds (can declare such
variables, add/substract/multiply and divide them) and I/O support. What
is missing is to be able to build function calls with them, such as:
real(10) :: x = 2
x = sqrt(x)
This requires modifications of the front-end, and library support (for
functions other than those in libm). Attached patch provides front-end
support for all such constructions, but library support is limited to
some functions (set_exponent, fraction, ...). But, when this first patch
will be reviewed, accepted and commited, adding other functions will be
fairly easy.
An example on what we can now do on i686-linux can be found in attached
file real10.f90.
Some details on the patch:
* For the library part, functions for all kinds are now protected by
preprocessor directives such as "#if defined (HAVE_GFC_REAL_16)" to
ensure that only code for available kinds is compiled
* For the front-end part, a choice had to be made. Attached patch adds
support for all possible kinds, constructs all possible trees, while
only those related to available kinds will ever be used on a given
system. I modified the gfc_get_int_type and other gfc_get_*_type
functions so that they don't issue an internal error if the kind does
not exist, but return NULL.
This patch was regtesting on i686-linux. Could someone review it? I'm
not asking for commit approval yet; since I don't know the guts of the
front-end very well, I'd like someone familiar with it to tell me if the
way I do it is right. Steven, Paul or Steven, you seem to be the ones
for this job, can one of you do it?
FX
PS: I will be out of town, with no internet access, from July 6th until
the end of August. I do hope we can get this in good form before that.
Otherwise, anybody is welcome to use this small piece of work any way
they like to contribute large kinds support for gfortran!
Index: gcc/fortran/f95-lang.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/f95-lang.c,v
retrieving revision 1.37
diff -u -3 -p -r1.37 f95-lang.c
--- gcc/fortran/f95-lang.c 25 Jun 2005 00:40:34 -0000 1.37
+++ gcc/fortran/f95-lang.c 26 Jun 2005 15:05:39 -0000
@@ -726,6 +726,8 @@ gfc_define_builtin (const char * name,
#define DO_DEFINE_MATH_BUILTIN(code, name, argtype, tbase) \
+ gfc_define_builtin ("__builtin_" name "l", tbase##longdouble[argtype], \
+ BUILT_IN_ ## code ## L, name "l", true); \
gfc_define_builtin ("__builtin_" name, tbase##double[argtype], \
BUILT_IN_ ## code, name, true); \
gfc_define_builtin ("__builtin_" name "f", tbase##float[argtype], \
@@ -768,17 +770,22 @@ gfc_init_builtin_functions (void)
{
tree mfunc_float[3];
tree mfunc_double[3];
+ tree mfunc_longdouble[3];
tree mfunc_cfloat[3];
tree mfunc_cdouble[3];
+ tree mfunc_clongdouble[3];
tree func_cfloat_float;
tree func_cdouble_double;
+ tree func_clongdouble_longdouble;
tree ftype;
tree tmp;
build_builtin_fntypes (mfunc_float, float_type_node);
build_builtin_fntypes (mfunc_double, double_type_node);
+ build_builtin_fntypes (mfunc_longdouble, long_double_type_node);
build_builtin_fntypes (mfunc_cfloat, complex_float_type_node);
build_builtin_fntypes (mfunc_cdouble, complex_double_type_node);
+ build_builtin_fntypes (mfunc_clongdouble, complex_long_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);
@@ -786,30 +793,45 @@ gfc_init_builtin_functions (void)
tmp = tree_cons (NULL_TREE, complex_double_type_node, void_list_node);
func_cdouble_double = build_function_type (double_type_node, tmp);
+ tmp = tree_cons (NULL_TREE, complex_long_double_type_node, void_list_node);
+ func_clongdouble_longdouble =
+ build_function_type (long_double_type_node, tmp);
+
#include "mathbuiltins.def"
/* We define these separately as the fortran versions have different
semantics (they return an integer type) */
+ gfc_define_builtin ("__builtin_roundl", mfunc_longdouble[0],
+ BUILT_IN_ROUNDL, "roundl", true);
gfc_define_builtin ("__builtin_round", mfunc_double[0],
BUILT_IN_ROUND, "round", true);
gfc_define_builtin ("__builtin_roundf", mfunc_float[0],
BUILT_IN_ROUNDF, "roundf", true);
+
+ gfc_define_builtin ("__builtin_truncl", mfunc_longdouble[0],
+ BUILT_IN_TRUNCL, "truncl", true);
gfc_define_builtin ("__builtin_trunc", mfunc_double[0],
BUILT_IN_TRUNC, "trunc", true);
gfc_define_builtin ("__builtin_truncf", mfunc_float[0],
BUILT_IN_TRUNCF, "truncf", true);
+ gfc_define_builtin ("__builtin_cabsl", func_clongdouble_longdouble,
+ BUILT_IN_CABSL, "cabsl", true);
gfc_define_builtin ("__builtin_cabs", func_cdouble_double,
BUILT_IN_CABS, "cabs", true);
gfc_define_builtin ("__builtin_cabsf", func_cfloat_float,
BUILT_IN_CABSF, "cabsf", true);
+ gfc_define_builtin ("__builtin_copysignl", mfunc_longdouble[1],
+ BUILT_IN_COPYSIGNL, "copysignl", true);
gfc_define_builtin ("__builtin_copysign", mfunc_double[1],
BUILT_IN_COPYSIGN, "copysign", true);
gfc_define_builtin ("__builtin_copysignf", mfunc_float[1],
BUILT_IN_COPYSIGNF, "copysignf", true);
/* These are used to implement the ** operator. */
+ gfc_define_builtin ("__builtin_powl", mfunc_longdouble[1],
+ BUILT_IN_POWL, "powl", true);
gfc_define_builtin ("__builtin_pow", mfunc_double[1],
BUILT_IN_POW, "pow", true);
gfc_define_builtin ("__builtin_powf", mfunc_float[1],
Index: gcc/fortran/iresolve.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/iresolve.c,v
retrieving revision 1.36
diff -u -3 -p -r1.36 iresolve.c
--- gcc/fortran/iresolve.c 25 Jun 2005 00:40:35 -0000 1.36
+++ gcc/fortran/iresolve.c 26 Jun 2005 15:05:43 -0000
@@ -1159,7 +1159,8 @@ gfc_resolve_reshape (gfc_expr * f, gfc_e
{
case 4:
case 8:
- /* case 16: */
+ case 10:
+ case 16:
if (source->ts.type == BT_COMPLEX)
f->value.function.name =
gfc_get_string (PREFIX("reshape_%c%d"),
@@ -1476,6 +1477,8 @@ gfc_resolve_transpose (gfc_expr * f, gfc
{
case 4:
case 8:
+ case 10:
+ case 16:
switch (matrix->ts.type)
{
case BT_COMPLEX:
Index: gcc/fortran/trans-decl.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-decl.c,v
retrieving revision 1.62
diff -u -3 -p -r1.62 trans-decl.c
--- gcc/fortran/trans-decl.c 25 Jun 2005 00:40:36 -0000 1.62
+++ gcc/fortran/trans-decl.c 26 Jun 2005 15:05:46 -0000
@@ -94,10 +94,15 @@ tree gfor_fndecl_associated;
gfc_powdecl_list gfor_fndecl_math_powi[3][2];
tree gfor_fndecl_math_cpowf;
tree gfor_fndecl_math_cpow;
+tree gfor_fndecl_math_cpowl10;
+tree gfor_fndecl_math_cpowl16;
tree gfor_fndecl_math_ishftc4;
tree gfor_fndecl_math_ishftc8;
+tree gfor_fndecl_math_ishftc16;
tree gfor_fndecl_math_exponent4;
tree gfor_fndecl_math_exponent8;
+tree gfor_fndecl_math_exponent10;
+tree gfor_fndecl_math_exponent16;
/* String functions. */
@@ -1685,11 +1690,16 @@ gfc_build_intrinsic_function_decls (void
{
tree gfc_int4_type_node = gfc_get_int_type (4);
tree gfc_int8_type_node = gfc_get_int_type (8);
+ tree gfc_int16_type_node = gfc_get_int_type (16);
tree gfc_logical4_type_node = gfc_get_logical_type (4);
tree gfc_real4_type_node = gfc_get_real_type (4);
tree gfc_real8_type_node = gfc_get_real_type (8);
+ tree gfc_real10_type_node = gfc_get_real_type (10);
+ tree gfc_real16_type_node = gfc_get_real_type (16);
tree gfc_complex4_type_node = gfc_get_complex_type (4);
tree gfc_complex8_type_node = gfc_get_complex_type (8);
+ tree gfc_complex10_type_node = gfc_get_complex_type (10);
+ tree gfc_complex16_type_node = gfc_get_complex_type (16);
/* String functions. */
gfor_fndecl_copy_string =
@@ -1787,37 +1797,56 @@ gfc_build_intrinsic_function_decls (void
/* Power functions. */
{
- tree type;
- tree itype;
- int kind;
- int ikind;
- static int kinds[2] = {4, 8};
+ tree ctype, rtype, itype, jtype;
+ int rkind, ikind, jkind;
+#define NIKINDS 3
+#define NRKINDS 4
+ static int ikinds[NIKINDS] = {4, 8, 16};
+ static int rkinds[NRKINDS] = {4, 8, 10, 16};
char name[PREFIX_LEN + 10]; /* _gfortran_pow_?n_?n */
- for (ikind=0; ikind < 2; ikind++)
+ for (ikind=0; ikind < NIKINDS; ikind++)
{
- itype = gfc_get_int_type (kinds[ikind]);
- for (kind = 0; kind < 2; kind ++)
+ itype = gfc_get_int_type (ikinds[ikind]);
+
+ for (jkind=0; jkind < NIKINDS; jkind++)
+ {
+ jtype = gfc_get_int_type (ikinds[jkind]);
+ if (itype && jtype)
+ {
+ sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
+ ikinds[jkind]);
+ gfor_fndecl_math_powi[jkind][ikind].integer =
+ gfc_build_library_function_decl (get_identifier (name),
+ jtype, 2, jtype, itype);
+ }
+ }
+
+ for (rkind = 0; rkind < NRKINDS; rkind ++)
{
- type = gfc_get_int_type (kinds[kind]);
- sprintf(name, PREFIX("pow_i%d_i%d"), kinds[kind], kinds[ikind]);
- gfor_fndecl_math_powi[kind][ikind].integer =
- gfc_build_library_function_decl (get_identifier (name),
- type, 2, type, itype);
-
- type = gfc_get_real_type (kinds[kind]);
- sprintf(name, PREFIX("pow_r%d_i%d"), kinds[kind], kinds[ikind]);
- gfor_fndecl_math_powi[kind][ikind].real =
- gfc_build_library_function_decl (get_identifier (name),
- type, 2, type, itype);
-
- type = gfc_get_complex_type (kinds[kind]);
- sprintf(name, PREFIX("pow_c%d_i%d"), kinds[kind], kinds[ikind]);
- gfor_fndecl_math_powi[kind][ikind].cmplx =
- gfc_build_library_function_decl (get_identifier (name),
- type, 2, type, itype);
+ rtype = gfc_get_real_type (rkinds[rkind]);
+ if (rtype && itype)
+ {
+ sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
+ ikinds[ikind]);
+ gfor_fndecl_math_powi[rkind][ikind].real =
+ gfc_build_library_function_decl (get_identifier (name),
+ rtype, 2, rtype, itype);
+ }
+
+ ctype = gfc_get_complex_type (rkinds[rkind]);
+ if (ctype && itype)
+ {
+ sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
+ ikinds[ikind]);
+ gfor_fndecl_math_powi[rkind][ikind].cmplx =
+ gfc_build_library_function_decl (get_identifier (name),
+ ctype, 2,ctype, itype);
+ }
}
}
+#undef NIKINDS
+#undef NRKINDS
}
gfor_fndecl_math_cpowf =
@@ -1828,6 +1857,17 @@ gfc_build_intrinsic_function_decls (void
gfc_build_library_function_decl (get_identifier ("cpow"),
gfc_complex8_type_node,
1, gfc_complex8_type_node);
+ if (gfc_complex10_type_node)
+ gfor_fndecl_math_cpowl10 =
+ gfc_build_library_function_decl (get_identifier ("cpowl"),
+ gfc_complex10_type_node, 1,
+ gfc_complex10_type_node);
+ if (gfc_complex16_type_node)
+ gfor_fndecl_math_cpowl16 =
+ gfc_build_library_function_decl (get_identifier ("cpowl"),
+ gfc_complex16_type_node, 1,
+ gfc_complex16_type_node);
+
gfor_fndecl_math_ishftc4 =
gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
gfc_int4_type_node,
@@ -1838,6 +1878,14 @@ gfc_build_intrinsic_function_decls (void
gfc_int8_type_node,
3, gfc_int8_type_node,
gfc_int8_type_node, gfc_int8_type_node);
+ if (gfc_int16_type_node)
+ gfor_fndecl_math_ishftc16 =
+ gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
+ gfc_int16_type_node, 3,
+ gfc_int16_type_node,
+ gfc_int16_type_node,
+ gfc_int16_type_node);
+
gfor_fndecl_math_exponent4 =
gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
gfc_int4_type_node,
@@ -1846,6 +1894,16 @@ gfc_build_intrinsic_function_decls (void
gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
gfc_int4_type_node,
1, gfc_real8_type_node);
+ if (gfc_real10_type_node)
+ gfor_fndecl_math_exponent10 =
+ gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
+ gfc_int4_type_node, 1,
+ gfc_real10_type_node);
+ if (gfc_real16_type_node)
+ gfor_fndecl_math_exponent16 =
+ gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
+ gfc_int4_type_node, 1,
+ gfc_real16_type_node);
/* Other functions. */
gfor_fndecl_size0 =
Index: gcc/fortran/trans-expr.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-expr.c,v
retrieving revision 1.53
diff -u -3 -p -r1.53 trans-expr.c
--- gcc/fortran/trans-expr.c 25 Jun 2005 00:40:36 -0000 1.53
+++ gcc/fortran/trans-expr.c 26 Jun 2005 15:05:47 -0000
@@ -687,6 +687,10 @@ gfc_conv_power_op (gfc_se * se, gfc_expr
ikind = 1;
break;
+ case 16:
+ ikind = 2;
+ break;
+
default:
gcc_unreachable ();
}
@@ -708,6 +712,14 @@ gfc_conv_power_op (gfc_se * se, gfc_expr
kind = 1;
break;
+ case 10:
+ kind = 2;
+ break;
+
+ case 16:
+ kind = 3;
+ break;
+
default:
gcc_unreachable ();
}
@@ -740,6 +752,10 @@ gfc_conv_power_op (gfc_se * se, gfc_expr
case 8:
fndecl = built_in_decls[BUILT_IN_POW];
break;
+ case 10:
+ case 16:
+ fndecl = built_in_decls[BUILT_IN_POWL];
+ break;
default:
gcc_unreachable ();
}
@@ -754,6 +770,12 @@ gfc_conv_power_op (gfc_se * se, gfc_expr
case 8:
fndecl = gfor_fndecl_math_cpow;
break;
+ case 10:
+ fndecl = gfor_fndecl_math_cpowl10;
+ break;
+ case 16:
+ fndecl = gfor_fndecl_math_cpowl16;
+ break;
default:
gcc_unreachable ();
}
Index: gcc/fortran/trans-intrinsic.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-intrinsic.c,v
retrieving revision 1.52
diff -u -3 -p -r1.52 trans-intrinsic.c
--- gcc/fortran/trans-intrinsic.c 25 Jun 2005 00:40:36 -0000 1.52
+++ gcc/fortran/trans-intrinsic.c 26 Jun 2005 15:05:47 -0000
@@ -56,10 +56,12 @@ typedef struct gfc_intrinsic_map_t GTY((
don't currently do anything with them. */
enum built_in_function code4;
enum built_in_function code8;
+ enum built_in_function code10;
+ enum built_in_function code16;
/* True if the naming pattern is to prepend "c" for complex and
append "f" for kind=4. False if the naming pattern is to
- prepend "_gfortran_" and append "[rc][48]". */
+ prepend "_gfortran_" and append "[rc](4|8|10|16)". */
bool libm_name;
/* True if a complex version of the function exists. */
@@ -74,8 +76,12 @@ typedef struct gfc_intrinsic_map_t GTY((
/* Cache decls created for the various operand types. */
tree real4_decl;
tree real8_decl;
+ tree real10_decl;
+ tree real16_decl;
tree complex4_decl;
tree complex8_decl;
+ tree complex10_decl;
+ tree complex16_decl;
}
gfc_intrinsic_map_t;
@@ -83,8 +89,10 @@ gfc_intrinsic_map_t;
defines complex variants of all of the entries in mathbuiltins.def
except for atan2. */
#define BUILT_IN_FUNCTION(ID, NAME, HAVE_COMPLEX) \
- { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, true, \
- HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
+ { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
+ BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, true, \
+ HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
+ NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
#define DEFINE_MATH_BUILTIN(id, name, argtype) \
BUILT_IN_FUNCTION (id, name, false)
@@ -94,12 +102,14 @@ gfc_intrinsic_map_t;
BUILT_IN_FUNCTION (id, name, true)
#define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
- { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, true, HAVE_COMPLEX, true, \
- NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
+ { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
+ true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
+ NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
#define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
- { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, false, HAVE_COMPLEX, true, \
- NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
+ { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
+ false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
+ NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
{
@@ -336,6 +346,11 @@ gfc_conv_intrinsic_aint (gfc_se * se, gf
case 8:
n = BUILT_IN_ROUND;
break;
+
+ case 10:
+ case 16:
+ n = BUILT_IN_ROUNDL;
+ break;
}
break;
@@ -349,6 +364,11 @@ gfc_conv_intrinsic_aint (gfc_se * se, gf
case 8:
n = BUILT_IN_TRUNC;
break;
+
+ case 10:
+ case 16:
+ n = BUILT_IN_TRUNCL;
+ break;
}
break;
@@ -473,6 +493,10 @@ gfc_build_intrinsic_lib_fndecls (void)
m->real4_decl = built_in_decls[m->code4];
if (m->code8 != END_BUILTINS)
m->real8_decl = built_in_decls[m->code8];
+ if (m->code10 != END_BUILTINS)
+ m->real10_decl = built_in_decls[m->code10];
+ if (m->code16 != END_BUILTINS)
+ m->real16_decl = built_in_decls[m->code16];
}
}
@@ -501,6 +525,12 @@ gfc_get_intrinsic_lib_fndecl (gfc_intrin
case 8:
pdecl = &m->real8_decl;
break;
+ case 10:
+ pdecl = &m->real10_decl;
+ break;
+ case 16:
+ pdecl = &m->real16_decl;
+ break;
default:
gcc_unreachable ();
}
@@ -517,6 +547,12 @@ gfc_get_intrinsic_lib_fndecl (gfc_intrin
case 8:
pdecl = &m->complex8_decl;
break;
+ case 10:
+ pdecl = &m->complex10_decl;
+ break;
+ case 16:
+ pdecl = &m->complex16_decl;
+ break;
default:
gcc_unreachable ();
}
@@ -529,7 +565,8 @@ gfc_get_intrinsic_lib_fndecl (gfc_intrin
if (m->libm_name)
{
- gcc_assert (ts->kind == 4 || ts->kind == 8);
+ gcc_assert (ts->kind == 4 || ts->kind == 8 || ts->kind == 10
+ || ts->kind == 16);
snprintf (name, sizeof (name), "%s%s%s",
ts->type == BT_COMPLEX ? "c" : "",
m->name,
@@ -615,6 +652,12 @@ gfc_conv_intrinsic_exponent (gfc_se * se
case 8:
fndecl = gfor_fndecl_math_exponent8;
break;
+ case 10:
+ fndecl = gfor_fndecl_math_exponent10;
+ break;
+ case 16:
+ fndecl = gfor_fndecl_math_exponent16;
+ break;
default:
gcc_unreachable ();
}
@@ -735,6 +778,10 @@ gfc_conv_intrinsic_abs (gfc_se * se, gfc
case 8:
n = BUILT_IN_CABS;
break;
+ case 10:
+ case 16:
+ n = BUILT_IN_CABSL;
+ break;
default:
gcc_unreachable ();
}
@@ -897,6 +944,10 @@ gfc_conv_intrinsic_sign (gfc_se * se, gf
case 8:
tmp = built_in_decls[BUILT_IN_COPYSIGN];
break;
+ case 10:
+ case 16:
+ tmp = built_in_decls[BUILT_IN_COPYSIGNL];
+ break;
default:
gcc_unreachable ();
}
@@ -1862,6 +1913,9 @@ gfc_conv_intrinsic_ishftc (gfc_se * se,
case 8:
tmp = gfor_fndecl_math_ishftc8;
break;
+ case 16:
+ tmp = gfor_fndecl_math_ishftc16;
+ break;
default:
gcc_unreachable ();
}
Index: gcc/fortran/trans-types.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-types.c,v
retrieving revision 1.48
diff -u -3 -p -r1.48 trans-types.c
--- gcc/fortran/trans-types.c 25 Jun 2005 00:40:36 -0000 1.48
+++ gcc/fortran/trans-types.c 26 Jun 2005 15:05:48 -0000
@@ -565,29 +565,29 @@ gfc_init_types (void)
tree
gfc_get_int_type (int kind)
{
- int index = gfc_validate_kind (BT_INTEGER, kind, false);
- return gfc_integer_types[index];
+ int index = gfc_validate_kind (BT_INTEGER, kind, true);
+ return index < 0 ? 0 : gfc_integer_types[index];
}
tree
gfc_get_real_type (int kind)
{
- int index = gfc_validate_kind (BT_REAL, kind, false);
- return gfc_real_types[index];
+ int index = gfc_validate_kind (BT_REAL, kind, true);
+ return index < 0 ? 0 : gfc_real_types[index];
}
tree
gfc_get_complex_type (int kind)
{
- int index = gfc_validate_kind (BT_COMPLEX, kind, false);
- return gfc_complex_types[index];
+ int index = gfc_validate_kind (BT_COMPLEX, kind, true);
+ return index < 0 ? 0 : gfc_complex_types[index];
}
tree
gfc_get_logical_type (int kind)
{
- int index = gfc_validate_kind (BT_LOGICAL, kind, false);
- return gfc_logical_types[index];
+ int index = gfc_validate_kind (BT_LOGICAL, kind, true);
+ return index < 0 ? 0 : gfc_logical_types[index];
}
/* Create a character type with the given kind and length. */
Index: gcc/fortran/trans.h
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans.h,v
retrieving revision 1.29
diff -u -3 -p -r1.29 trans.h
--- gcc/fortran/trans.h 25 Jun 2005 00:40:37 -0000 1.29
+++ gcc/fortran/trans.h 26 Jun 2005 15:05:48 -0000
@@ -476,10 +476,15 @@ gfc_powdecl_list;
extern GTY(()) gfc_powdecl_list gfor_fndecl_math_powi[3][2];
extern GTY(()) tree gfor_fndecl_math_cpowf;
extern GTY(()) tree gfor_fndecl_math_cpow;
+extern GTY(()) tree gfor_fndecl_math_cpowl10;
+extern GTY(()) tree gfor_fndecl_math_cpowl16;
extern GTY(()) tree gfor_fndecl_math_ishftc4;
extern GTY(()) tree gfor_fndecl_math_ishftc8;
+extern GTY(()) tree gfor_fndecl_math_ishftc16;
extern GTY(()) tree gfor_fndecl_math_exponent4;
extern GTY(()) tree gfor_fndecl_math_exponent8;
+extern GTY(()) tree gfor_fndecl_math_exponent10;
+extern GTY(()) tree gfor_fndecl_math_exponent16;
/* String functions. */
extern GTY(()) tree gfor_fndecl_copy_string;
Index: libgfortran/Makefile.am
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/Makefile.am,v
retrieving revision 1.38
diff -u -3 -p -r1.38 Makefile.am
--- libgfortran/Makefile.am 24 Jun 2005 23:07:13 -0000 1.38
+++ libgfortran/Makefile.am 26 Jun 2005 15:09:06 -0000
@@ -256,33 +256,62 @@ generated/in_unpack_c8.c
i_exponent_c = \
generated/exponent_r4.c \
-generated/exponent_r8.c
+generated/exponent_r8.c \
+generated/exponent_r10.c \
+generated/exponent_r16.c
i_fraction_c = \
generated/fraction_r4.c \
-generated/fraction_r8.c
+generated/fraction_r8.c \
+generated/fraction_r10.c \
+generated/fraction_r16.c
i_nearest_c = \
generated/nearest_r4.c \
-generated/nearest_r8.c
+generated/nearest_r8.c \
+generated/nearest_r10.c \
+generated/nearest_r16.c
i_set_exponent_c = \
generated/set_exponent_r4.c \
-generated/set_exponent_r8.c
+generated/set_exponent_r8.c \
+generated/set_exponent_r10.c \
+generated/set_exponent_r16.c
i_pow_c = \
generated/pow_i4_i4.c \
generated/pow_i8_i4.c \
+generated/pow_i16_i4.c \
generated/pow_r4_i4.c \
generated/pow_r8_i4.c \
+generated/pow_r10_i4.c \
+generated/pow_r16_i4.c \
generated/pow_c4_i4.c \
generated/pow_c8_i4.c \
+generated/pow_c10_i4.c \
+generated/pow_c16_i4.c \
generated/pow_i4_i8.c \
generated/pow_i8_i8.c \
+generated/pow_i16_i8.c \
generated/pow_r4_i8.c \
generated/pow_r8_i8.c \
+generated/pow_r10_i8.c \
+generated/pow_r16_i8.c \
generated/pow_c4_i8.c \
-generated/pow_c8_i8.c
+generated/pow_c8_i8.c \
+generated/pow_c10_i8.c \
+generated/pow_c16_i8.c \
+generated/pow_i4_i16.c \
+generated/pow_i8_i16.c \
+generated/pow_i16_i16.c \
+generated/pow_r4_i16.c \
+generated/pow_r8_i16.c \
+generated/pow_r10_i16.c \
+generated/pow_r16_i16.c \
+generated/pow_c4_i16.c \
+generated/pow_c8_i16.c \
+generated/pow_c10_i16.c \
+generated/pow_c16_i16.c
m4_files= m4/iparm.m4 m4/ifunction.m4 m4/iforeach.m4 m4/all.m4 \
m4/any.m4 m4/count.m4 m4/maxloc0.m4 m4/maxloc1.m4 m4/maxval.m4 \
@@ -340,8 +369,6 @@ generated/_log_r4.f90 \
generated/_log_r8.f90 \
generated/_log_c4.f90 \
generated/_log_c8.f90 \
-generated/_log10_r4.f90 \
-generated/_log10_r8.f90 \
generated/_sqrt_r4.f90 \
generated/_sqrt_r8.f90 \
generated/_sqrt_c4.f90 \
@@ -389,7 +416,7 @@ generated/_atan2_r8.f90 \
generated/_mod_i4.f90 \
generated/_mod_i8.f90 \
generated/_mod_r4.f90 \
-generated/_mod_r8.f90
+generated/_mod_r8.f90 \
#specific intrinsics requiring manal code
#gfor_specific_c= \
intrinsics/_aimag.c \
Index: libgfortran/m4/exponent.m4
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/m4/exponent.m4,v
retrieving revision 1.4
diff -u -3 -p -r1.4 exponent.m4
--- libgfortran/m4/exponent.m4 12 Jan 2005 21:27:31 -0000 1.4
+++ libgfortran/m4/exponent.m4 26 Jun 2005 15:09:06 -0000
@@ -32,6 +32,8 @@ Boston, MA 02111-1307, USA. */
include(`mtype.m4')dnl
+`#if defined (HAVE_'real_type`)'
+
extern GFC_INTEGER_4 exponent_r`'kind (real_type s);
export_proto(exponent_r`'kind);
@@ -42,3 +44,5 @@ exponent_r`'kind (real_type s)
frexp`'q (s, &ret);
return ret;
}
+
+#endif
Index: libgfortran/m4/fraction.m4
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/m4/fraction.m4,v
retrieving revision 1.4
diff -u -3 -p -r1.4 fraction.m4
--- libgfortran/m4/fraction.m4 12 Jan 2005 21:27:31 -0000 1.4
+++ libgfortran/m4/fraction.m4 26 Jun 2005 15:09:06 -0000
@@ -32,6 +32,8 @@ Boston, MA 02111-1307, USA. */
include(`mtype.m4')dnl
+`#if defined (HAVE_'real_type`)'
+
extern real_type fraction_r`'kind (real_type s);
export_proto(fraction_r`'kind);
@@ -41,3 +43,5 @@ fraction_r`'kind (real_type s)
int dummy_exp;
return frexp`'q (s, &dummy_exp);
}
+
+#endif
Index: libgfortran/m4/mtype.m4
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/m4/mtype.m4,v
retrieving revision 1.2
diff -u -3 -p -r1.2 mtype.m4
--- libgfortran/m4/mtype.m4 13 May 2004 06:41:03 -0000 1.2
+++ libgfortran/m4/mtype.m4 26 Jun 2005 15:09:06 -0000
@@ -2,4 +2,4 @@ dnl Get type kind from filename.
define(kind,regexp(file, `_.\([0-9]+\).c$', `\1'))dnl
define(complex_type, `GFC_COMPLEX_'kind)dnl
define(real_type, `GFC_REAL_'kind)dnl
-define(q,ifelse(kind,4,f,ifelse(kind,8,`',`_'kind)))dnl
+define(q,ifelse(kind,4,f,ifelse(kind,8,`',ifelse(kind,10,l,ifelse(kind,16,l,`_'kind)))))dnl
Index: libgfortran/m4/nearest.m4
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/m4/nearest.m4,v
retrieving revision 1.4
diff -u -3 -p -r1.4 nearest.m4
--- libgfortran/m4/nearest.m4 12 Jan 2005 21:27:31 -0000 1.4
+++ libgfortran/m4/nearest.m4 26 Jun 2005 15:09:06 -0000
@@ -33,6 +33,8 @@ Boston, MA 02111-1307, USA. */
include(`mtype.m4')dnl
+`#if defined (HAVE_'real_type`)'
+
extern real_type nearest_r`'kind (real_type s, real_type dir);
export_proto(nearest_r`'kind);
@@ -49,3 +51,5 @@ nearest_r`'kind (real_type s, real_type
else
return nextafter`'q (s, dir);
}
+
+#endif
Index: libgfortran/m4/pow.m4
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/m4/pow.m4,v
retrieving revision 1.3
diff -u -3 -p -r1.3 pow.m4
--- libgfortran/m4/pow.m4 12 Jan 2005 21:27:31 -0000 1.3
+++ libgfortran/m4/pow.m4 26 Jun 2005 15:09:06 -0000
@@ -37,6 +37,8 @@ include(iparm.m4)dnl
Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art
of Computer Programming", 3rd Edition, 1998. */
+`#if defined (HAVE_'rtype_name`) && defined (HAVE_'atype_name`)'
+
rtype_name `pow_'rtype_code`_'atype_code (rtype_name a, atype_name b);
export_proto(pow_`'rtype_code`_'atype_code);
@@ -78,3 +80,5 @@ ifelse(rtype_letter,i,`dnl
}
return pow;
}
+
+#endif
Index: libgfortran/m4/set_exponent.m4
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/m4/set_exponent.m4,v
retrieving revision 1.4
diff -u -3 -p -r1.4 set_exponent.m4
--- libgfortran/m4/set_exponent.m4 12 Jan 2005 21:27:31 -0000 1.4
+++ libgfortran/m4/set_exponent.m4 26 Jun 2005 15:09:06 -0000
@@ -32,6 +32,8 @@ Boston, MA 02111-1307, USA. */
include(`mtype.m4')dnl
+`#if defined (HAVE_'real_type`)'
+
extern real_type set_exponent_r`'kind (real_type s, GFC_INTEGER_4 i);
export_proto(set_exponent_r`'kind);
@@ -41,3 +43,5 @@ set_exponent_r`'kind (real_type s, GFC_I
int dummy_exp;
return scalbn`'q (frexp`'q (s, &dummy_exp), i);
}
+
+#endif
real(10) function f(x)
real(10),intent(in) :: x
f = sqrt(x)
end function f
real(10) x
x = 1
print *, x
x = 2 * x
print *, x
x = x**4
print *, x
x = sin(x)
write(*,'(F30.25)') x
x = abs(x)
write(*,'(F30.25)') x
x = fraction(x)
write(*,'(F30.25)') x
x = x ** x
write(*,'(F30.25)') x
x = f(x)
write(*,'(F30.25)') x
end