[rfc] add real*12 and real*16
Richard Henderson
rth@redhat.com
Tue Aug 24 18:34:00 GMT 2004
Well, basically revamp how a lot of builtin type stuff happens.
Of note are:
(1) Real kinds come from formats found from machine modes and real.c.
We're now polling the actual format, rather than hard-coding IEEE.
(2) That means we find XFmode and TFmode, if the target mentions them.
Note that this is not quite 100% the same as *supporting* them.
A good example here is i386, which doesn't support TFmode, but the
compiler is built with amd64 support, which does use TFmode. We
need a bit better information from the backend to fix this.
I arbitrarily chose real*12 for IEEE extended format.
(3) Lots of cleanup in trans-types.c. IMO there's lots more to be
done as well. We ought to do something similar for integer types.
For instance, c4x doesn't support 8-bit types, so we shouldn't
advertise that we have one.
I'm running out of time this morning, so this is just a dump of the
patch so far. It does work, as far as it goes, just needs a bit of
cleanup. And the extra info from the backend that I mentioned.
Comments?
r~
Index: gcc/fortran/Make-lang.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/Make-lang.in,v
retrieving revision 1.8
diff -c -p -d -r1.8 Make-lang.in
*** gcc/fortran/Make-lang.in 4 Jul 2004 09:01:40 -0000 1.8
--- gcc/fortran/Make-lang.in 24 Aug 2004 18:23:26 -0000
*************** $(F95_PARSER_OBJS): fortran/gfortran.h f
*** 275,284 ****
$(RTL_H) $(TREE_H) $(TREE_DUMP_H) $(GGC_H) $(EXPR_H) \
flags.h output.h diagnostic.h errors.h function.h
! GFORTRAN_TRANS_DEPS = fortran/gfortran.h fortran/intrinsic.h fortran/trans-array.h \
fortran/trans-const.h fortran/trans-const.h fortran/trans.h \
fortran/trans-stmt.h fortran/trans-types.h \
! $(CONFIG_H) $(SYSTEM_H) $(TREE_H) $(TM_H) coretypes.h
fortran/f95-lang.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \
gt-fortran-f95-lang.h gtype-fortran.h cgraph.h
--- 275,286 ----
$(RTL_H) $(TREE_H) $(TREE_DUMP_H) $(GGC_H) $(EXPR_H) \
flags.h output.h diagnostic.h errors.h function.h
! GFORTRAN_TRANS_DEPS = fortran/gfortran.h fortran/intrinsic.h \
! fortran/trans-array.h \
fortran/trans-const.h fortran/trans-const.h fortran/trans.h \
fortran/trans-stmt.h fortran/trans-types.h \
! $(CONFIG_H) $(SYSTEM_H) $(TREE_H) $(TM_H) $(MACHMODE_H) coretypes.h \
! defaults.h real.h
fortran/f95-lang.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \
gt-fortran-f95-lang.h gtype-fortran.h cgraph.h
Index: gcc/fortran/arith.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/arith.c,v
retrieving revision 1.11
diff -c -p -d -r1.11 arith.c
*** gcc/fortran/arith.c 6 Aug 2004 20:36:04 -0000 1.11
--- gcc/fortran/arith.c 24 Aug 2004 18:23:26 -0000
*************** Software Foundation, 59 Temple Place - S
*** 26,36 ****
and this file provides the interface. */
#include "config.h"
!
! #include <string.h>
!
#include "gfortran.h"
#include "arith.h"
/* The gfc_(integer|real)_kinds[] structures have everything the front
end needs to know about integers and real numbers on the target.
--- 26,40 ----
and this file provides the interface. */
#include "config.h"
! #include "system.h"
! #include "coretypes.h"
! #include "tree.h"
! #include "machmode.h"
! #include "tm.h"
#include "gfortran.h"
#include "arith.h"
+ #include "real.h"
+ #include "defaults.h"
/* The gfc_(integer|real)_kinds[] structures have everything the front
end needs to know about integers and real numbers on the target.
*************** Software Foundation, 59 Temple Place - S
*** 47,56 ****
#define DEF_GFC_LOGICAL_KIND(KIND,BIT_SIZE) \
{KIND, BIT_SIZE}
- #define DEF_GFC_REAL_KIND(KIND,RADIX,DIGITS,MIN_EXP, MAX_EXP) \
- {KIND, RADIX, DIGITS, MIN_EXP, MAX_EXP, \
- 0, 0, MPF_NULL, MPF_NULL, MPF_NULL}
-
gfc_integer_info gfc_integer_kinds[] = {
DEF_GFC_INTEGER_KIND (4, 2, 31, 32),
DEF_GFC_INTEGER_KIND (8, 2, 63, 64),
--- 51,56 ----
*************** gfc_logical_info gfc_logical_kinds[] = {
*** 67,105 ****
DEF_GFC_LOGICAL_KIND (0, 0)
};
! /* IEEE-754 uses 1.xEe representation whereas the fortran standard
! uses 0.xEe representation. Hence the exponents below are biased
! by one. */
! #define GFC_SP_KIND 4
! #define GFC_SP_PREC 24 /* p = 24, IEEE-754 */
! #define GFC_SP_EMIN -125 /* emin = -126, IEEE-754 */
! #define GFC_SP_EMAX 128 /* emin = 127, IEEE-754 */
! /* Double precision model numbers. */
! #define GFC_DP_KIND 8
! #define GFC_DP_PREC 53 /* p = 53, IEEE-754 */
! #define GFC_DP_EMIN -1021 /* emin = -1022, IEEE-754 */
! #define GFC_DP_EMAX 1024 /* emin = 1023, IEEE-754 */
! /* Quad precision model numbers. Not used. */
! #define GFC_QP_KIND 16
! #define GFC_QP_PREC 113 /* p = 113, IEEE-754 */
! #define GFC_QP_EMIN -16381 /* emin = -16382, IEEE-754 */
! #define GFC_QP_EMAX 16384 /* emin = 16383, IEEE-754 */
- gfc_real_info gfc_real_kinds[] = {
- DEF_GFC_REAL_KIND (GFC_SP_KIND, 2, GFC_SP_PREC, GFC_SP_EMIN, GFC_SP_EMAX),
- DEF_GFC_REAL_KIND (GFC_DP_KIND, 2, GFC_DP_PREC, GFC_DP_EMIN, GFC_DP_EMAX),
- DEF_GFC_REAL_KIND (0, 0, 0, 0, 0)
- };
! /* The integer kind to use for array indices. This will be set to the
! proper value based on target information from the backend. */
! int gfc_index_integer_kind;
/* MPFR does not have a direct replacement for mpz_set_f() from GMP.
--- 67,130 ----
DEF_GFC_LOGICAL_KIND (0, 0)
};
+ /* This array will be filled in from target information from the backend. */
! #define MAX_REAL_KINDS 4
! gfc_real_info gfc_real_kinds[MAX_REAL_KINDS+1];
! /* The integer kind to use for array indices. This will be set to the
! proper value based on target information from the backend. */
! int gfc_index_integer_kind;
+ /* Make sure that a valid kind is present. Returns an index into the
+ gfc_integer_kinds array, -1 if the kind is not present. */
! static int
! validate_integer (int kind)
! {
! int i;
! for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
! if (gfc_integer_kinds[i].kind == kind)
! return i;
!
! return -1;
! }
!
! static int
! validate_real (int kind)
! {
! int i;
!
! for (i = 0; gfc_real_kinds[i].kind != 0; i++)
! if (gfc_real_kinds[i].kind == kind)
! return i;
!
! return -1;
! }
!
! static int
! validate_logical (int kind)
! {
! int i;
!
! for (i = 0; gfc_logical_kinds[i].kind != 0; i++)
! if (gfc_logical_kinds[i].kind == kind)
! return i;
!
! return -1;
! }
!
! static int
! validate_character (int kind)
! {
! if (kind == gfc_default_character_kind ())
! return 0;
! return -1;
! }
/* MPFR does not have a direct replacement for mpz_set_f() from GMP.
*************** gfc_mpfr_to_mpz(mpz_t z, mpfr_t x)
*** 125,144 ****
void
gfc_set_model_kind (int kind)
{
! switch (kind)
! {
! case GFC_SP_KIND:
! mpfr_set_default_prec (GFC_SP_PREC);
! break;
! case GFC_DP_KIND:
! mpfr_set_default_prec (GFC_DP_PREC);
! break;
! case GFC_QP_KIND:
! mpfr_set_default_prec (GFC_QP_PREC);
! break;
! default:
! gfc_internal_error ("gfc_set_model_kind(): Bad model number");
! }
}
--- 150,169 ----
void
gfc_set_model_kind (int kind)
{
! int i;
!
! for (i = 0; gfc_real_kinds[i].kind != 0; i++)
! if (kind == gfc_real_kinds[i].kind)
! {
! int base2prec = gfc_real_kinds[i].digits;
! if (gfc_real_kinds[i].radix != 2)
! base2prec *= gfc_real_kinds[i].radix / 2;
! mpfr_set_default_prec (base2prec);
! return;
! }
!
! gfc_internal_error ("gfc_set_model_kind(): Bad model number");
!
}
*************** gfc_set_model_kind (int kind)
*** 147,166 ****
void
gfc_set_model (mpfr_t x)
{
! switch (mpfr_get_prec (x))
! {
! case GFC_SP_PREC:
! mpfr_set_default_prec (GFC_SP_PREC);
! break;
! case GFC_DP_PREC:
! mpfr_set_default_prec (GFC_DP_PREC);
! break;
! case GFC_QP_PREC:
! mpfr_set_default_prec (GFC_QP_PREC);
! break;
! default:
! gfc_internal_error ("gfc_set_model(): Bad model number");
! }
}
/* Calculate atan2 (y, x)
--- 172,178 ----
void
gfc_set_model (mpfr_t x)
{
! mpfr_set_default_prec (mpfr_get_prec (x));
}
/* Calculate atan2 (y, x)
*************** arctangent2 (mpfr_t y, mpfr_t x, mpfr_t
*** 197,204 ****
if (mpfr_sgn (y) < 0)
mpfr_neg (result, result, GFC_RND_MODE);
}
! else
! {
if (mpfr_sgn (y) == 0)
mpfr_set_ui (result, 0, GFC_RND_MODE);
else
--- 209,216 ----
if (mpfr_sgn (y) < 0)
mpfr_neg (result, result, GFC_RND_MODE);
}
! else
! {
if (mpfr_sgn (y) == 0)
mpfr_set_ui (result, 0, GFC_RND_MODE);
else
*************** arctangent2 (mpfr_t y, mpfr_t x, mpfr_t
*** 211,217 ****
}
mpfr_clear (t);
-
}
--- 223,228 ----
*************** gfc_arith_init_1 (void)
*** 264,272 ****
mpfr_t a, b, c;
mpz_t r;
int i;
! gfc_set_model_kind (GFC_QP_KIND);
!
mpfr_init (a);
mpz_init (r);
--- 275,283 ----
mpfr_t a, b, c;
mpz_t r;
int i;
+ enum machine_mode mode;
! mpfr_set_default_prec (128);
mpfr_init (a);
mpz_init (r);
*************** gfc_arith_init_1 (void)
*** 304,312 ****
mpfr_clear (a);
! for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
{
! gfc_set_model_kind (real_info->kind);
mpfr_init (a);
mpfr_init (b);
--- 315,353 ----
mpfr_clear (a);
! /* Examine real.c data structures for supported floating-point formats. */
! real_info = gfc_real_kinds;
! for (mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
{
! const struct real_format *fmt = REAL_MODE_FORMAT (mode);
! int kind;
!
! if (fmt == NULL)
! continue;
!
! /* As a first approximation, let kind equal 8-bit byte size. Which
! lets us get kind==4 for single-precision on 32-bit byte targets.
! Where we wish this to be different is for the IEEE extended formats.
! There, size may equal 16, but it's got 6 bytes of padding. Force
! this format to be kind==12. */
! kind = GET_MODE_BITSIZE (mode) / 8;
! if (GET_MODE_PRECISION (mode) == 80)
! kind = 12;
!
! /* Careful we don't stumble a wierd internal mode. */
! if (validate_real (kind) >= 0)
! abort ();
! if (real_info == &gfc_real_kinds[MAX_REAL_KINDS])
! abort ();
!
! real_info->kind = kind;
! real_info->radix = fmt->b;
! real_info->digits = fmt->p;
! real_info->min_exponent = fmt->emin;
! real_info->max_exponent = fmt->emax;
! real_info->mode_precision = GET_MODE_PRECISION (mode);
!
! gfc_set_model_kind (kind);
mpfr_init (a);
mpfr_init (b);
*************** gfc_arith_init_1 (void)
*** 376,381 ****
--- 417,424 ----
mpfr_clear (a);
mpfr_clear (b);
mpfr_clear (c);
+
+ real_info++;
}
mpz_clear (r);
*************** gfc_default_complex_kind (void)
*** 445,523 ****
}
- /* Make sure that a valid kind is present. Returns an index into the
- gfc_integer_kinds array, -1 if the kind is not present. */
-
- static int
- validate_integer (int kind)
- {
- int i;
-
- for (i = 0;; i++)
- {
- if (gfc_integer_kinds[i].kind == 0)
- {
- i = -1;
- break;
- }
- if (gfc_integer_kinds[i].kind == kind)
- break;
- }
-
- return i;
- }
-
-
- static int
- validate_real (int kind)
- {
- int i;
-
- for (i = 0;; i++)
- {
- if (gfc_real_kinds[i].kind == 0)
- {
- i = -1;
- break;
- }
- if (gfc_real_kinds[i].kind == kind)
- break;
- }
-
- return i;
- }
-
-
- static int
- validate_logical (int kind)
- {
- int i;
-
- for (i = 0;; i++)
- {
- if (gfc_logical_kinds[i].kind == 0)
- {
- i = -1;
- break;
- }
- if (gfc_logical_kinds[i].kind == kind)
- break;
- }
-
- return i;
- }
-
-
- static int
- validate_character (int kind)
- {
-
- if (kind == gfc_default_character_kind ())
- return 0;
- return -1;
- }
-
-
/* Validate a kind given a basic type. The return value is the same
for the child functions, with -1 indicating nonexistence of the
type. */
--- 488,493 ----
Index: gcc/fortran/f95-lang.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/f95-lang.c,v
retrieving revision 1.13
diff -c -p -d -r1.13 f95-lang.c
*** gcc/fortran/f95-lang.c 24 Aug 2004 16:39:34 -0000 1.13
--- gcc/fortran/f95-lang.c 24 Aug 2004 18:23:26 -0000
*************** gfc_init_decl_processing (void)
*** 575,580 ****
--- 575,583 ----
set_sizetype (long_unsigned_type_node);
build_common_tree_nodes_2 (0);
+ /* Set up F95 type kinds. */
+ gfc_arith_init_1 ();
+
/* Set up F95 type nodes. */
gfc_init_types ();
}
Index: gcc/fortran/gfortran.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.26
diff -c -p -d -r1.26 gfortran.h
*** gcc/fortran/gfortran.h 23 Aug 2004 21:53:14 -0000 1.26
--- gcc/fortran/gfortran.h 24 Aug 2004 18:23:26 -0000
*************** extern gfc_integer_info gfc_integer_kind
*** 1087,1093 ****
typedef struct
{
int kind, bit_size;
-
}
gfc_logical_info;
--- 1087,1092 ----
*************** extern gfc_logical_info gfc_logical_kind
*** 1097,1104 ****
typedef struct
{
int kind, radix, digits, min_exponent, max_exponent;
-
int range, precision;
mpfr_t epsilon, huge, tiny;
}
gfc_real_info;
--- 1096,1103 ----
typedef struct
{
int kind, radix, digits, min_exponent, max_exponent;
int range, precision;
+ int mode_precision;
mpfr_t epsilon, huge, tiny;
}
gfc_real_info;
Index: gcc/fortran/misc.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/misc.c,v
retrieving revision 1.4
diff -c -p -d -r1.4 misc.c
*** gcc/fortran/misc.c 6 Aug 2004 20:36:05 -0000 1.4
--- gcc/fortran/misc.c 24 Aug 2004 18:23:26 -0000
*************** gfc_init_1 (void)
*** 281,287 ****
gfc_error_init_1 ();
gfc_scanner_init_1 ();
- gfc_arith_init_1 ();
gfc_intrinsic_init_1 ();
gfc_iresolve_init_1 ();
gfc_simplify_init_1 ();
--- 281,286 ----
Index: gcc/fortran/trans-types.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-types.c,v
retrieving revision 1.13
diff -c -p -d -r1.13 trans-types.c
*** gcc/fortran/trans-types.c 24 Aug 2004 16:25:16 -0000 1.13
--- gcc/fortran/trans-types.c 24 Aug 2004 18:23:26 -0000
*************** Software Foundation, 59 Temple Place - S
*** 26,34 ****
#include "system.h"
#include "coretypes.h"
#include "tree.h"
! #include <stdio.h>
#include "ggc.h"
#include "toplev.h"
#include <assert.h>
#include "gfortran.h"
#include "trans.h"
--- 26,35 ----
#include "system.h"
#include "coretypes.h"
#include "tree.h"
! #include "tm.h"
#include "ggc.h"
#include "toplev.h"
+ #include "defaults.h"
#include <assert.h>
#include "gfortran.h"
#include "trans.h"
*************** static GTY(()) tree gfc_desc_dim_type =
*** 59,64 ****
--- 60,161 ----
static GTY(()) tree gfc_max_array_element_size;
+ /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
+ Reuse common type nodes where possible. */
+
+ static tree
+ gfc_build_int_type (int kind)
+ {
+ int index = gfc_validate_kind (BT_INTEGER, kind);
+ int mode_precision;
+
+ if (index < 0)
+ return NULL;
+
+ mode_precision = gfc_integer_kinds[index].bit_size;
+
+ if (TYPE_PRECISION (intQI_type_node) == mode_precision)
+ return intQI_type_node;
+ if (TYPE_PRECISION (intHI_type_node) == mode_precision)
+ return intHI_type_node;
+ if (TYPE_PRECISION (intSI_type_node) == mode_precision)
+ return intSI_type_node;
+ if (TYPE_PRECISION (intDI_type_node) == mode_precision)
+ return intDI_type_node;
+ if (TYPE_PRECISION (intTI_type_node) == mode_precision)
+ return intTI_type_node;
+
+ return make_signed_type (mode_precision);
+ }
+
+ static tree
+ gfc_build_float_type (int kind)
+ {
+ int index = gfc_validate_kind (BT_REAL, kind);
+ int mode_precision;
+ tree new_type;
+
+ if (index < 0)
+ return NULL;
+
+ mode_precision = gfc_real_kinds[index].mode_precision;
+
+ if (TYPE_PRECISION (float_type_node) == mode_precision)
+ return float_type_node;
+ if (TYPE_PRECISION (double_type_node) == mode_precision)
+ return double_type_node;
+ if (TYPE_PRECISION (long_double_type_node) == mode_precision)
+ return long_double_type_node;
+
+ new_type = make_node (REAL_TYPE);
+ TYPE_PRECISION (new_type) = mode_precision;
+ layout_type (new_type);
+ return new_type;
+ }
+
+ static tree
+ gfc_build_complex_type (tree scalar_type)
+ {
+ tree new_type;
+
+ if (scalar_type == NULL)
+ return NULL;
+ if (scalar_type == float_type_node)
+ return complex_float_type_node;
+ if (scalar_type == double_type_node)
+ return complex_double_type_node;
+ if (scalar_type == long_double_type_node)
+ return complex_long_double_type_node;
+
+ new_type = make_node (COMPLEX_TYPE);
+ TREE_TYPE (new_type) = scalar_type;
+ layout_type (new_type);
+ return new_type;
+ }
+
+ static tree
+ gfc_build_logical_type (int kind)
+ {
+ int index = gfc_validate_kind (BT_LOGICAL, kind);
+ int bit_size;
+ tree new_type;
+
+ if (index < 0)
+ return NULL;
+
+ bit_size = gfc_logical_kinds[index].bit_size;
+
+ if (bit_size == BOOL_TYPE_SIZE)
+ return boolean_type_node;
+
+ new_type = make_unsigned_type (bit_size);
+ TREE_SET_CODE (new_type, BOOLEAN_TYPE);
+ TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1, 0);
+ TYPE_PRECISION (new_type) = 1;
+
+ return new_type;
+ }
+
/* Create the backend type nodes. We map them to their
equivalent C type, at least for now. We also give
names to the types here, and we push them in the
*************** gfc_init_types (void)
*** 73,135 ****
/* Name the types. */
#define PUSH_TYPE(name, node) \
! pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
! gfc_int1_type_node = signed_char_type_node;
PUSH_TYPE ("int1", gfc_int1_type_node);
! gfc_int2_type_node = short_integer_type_node;
PUSH_TYPE ("int2", gfc_int2_type_node);
! gfc_int4_type_node = gfc_type_for_size (32, 0 /*unsigned */ );
PUSH_TYPE ("int4", gfc_int4_type_node);
! gfc_int8_type_node = gfc_type_for_size (64, 0 /*unsigned */ );
PUSH_TYPE ("int8", gfc_int8_type_node);
! #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
! gfc_int16_type_node = gfc_type_for_size (128, 0 /*unsigned */ );
PUSH_TYPE ("int16", gfc_int16_type_node);
- #endif
! gfc_real4_type_node = float_type_node;
PUSH_TYPE ("real4", gfc_real4_type_node);
! gfc_real8_type_node = double_type_node;
PUSH_TYPE ("real8", gfc_real8_type_node);
! #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
! /* Hmm, this will not work. Ref. g77 */
! gfc_real16_type_node = long_double_type_node;
PUSH_TYPE ("real16", gfc_real16_type_node);
- #endif
! gfc_complex4_type_node = complex_float_type_node;
PUSH_TYPE ("complex4", gfc_complex4_type_node);
! gfc_complex8_type_node = complex_double_type_node;
PUSH_TYPE ("complex8", gfc_complex8_type_node);
! #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
! /* Hmm, this will not work. Ref. g77 */
! gfc_complex16_type_node = complex_long_double_type_node;
PUSH_TYPE ("complex16", gfc_complex16_type_node);
- #endif
! gfc_logical1_type_node = make_node (BOOLEAN_TYPE);
! TYPE_PRECISION (gfc_logical1_type_node) = 8;
! fixup_unsigned_type (gfc_logical1_type_node);
PUSH_TYPE ("logical1", gfc_logical1_type_node);
! gfc_logical2_type_node = make_node (BOOLEAN_TYPE);
! TYPE_PRECISION (gfc_logical2_type_node) = 16;
! fixup_unsigned_type (gfc_logical2_type_node);
PUSH_TYPE ("logical2", gfc_logical2_type_node);
! gfc_logical4_type_node = make_node (BOOLEAN_TYPE);
! TYPE_PRECISION (gfc_logical4_type_node) = 32;
! fixup_unsigned_type (gfc_logical4_type_node);
PUSH_TYPE ("logical4", gfc_logical4_type_node);
! gfc_logical8_type_node = make_node (BOOLEAN_TYPE);
! TYPE_PRECISION (gfc_logical8_type_node) = 64;
! fixup_unsigned_type (gfc_logical8_type_node);
PUSH_TYPE ("logical8", gfc_logical8_type_node);
! #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
! gfc_logical16_type_node = make_node (BOOLEAN_TYPE);
! TYPE_PRECISION (gfc_logical16_type_node) = 128;
! fixup_unsigned_type (gfc_logical16_type_node);
PUSH_TYPE ("logical16", gfc_logical16_type_node);
- #endif
gfc_character1_type_node = build_type_variant (signed_char_type_node, 0, 0);
PUSH_TYPE ("char", gfc_character1_type_node);
--- 170,216 ----
/* Name the types. */
#define PUSH_TYPE(name, node) \
! if (node) pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
! gfc_int1_type_node = gfc_build_int_type (1);
PUSH_TYPE ("int1", gfc_int1_type_node);
! gfc_int2_type_node = gfc_build_int_type (2);
PUSH_TYPE ("int2", gfc_int2_type_node);
! gfc_int4_type_node = gfc_build_int_type (4);
PUSH_TYPE ("int4", gfc_int4_type_node);
! gfc_int8_type_node = gfc_build_int_type (8);
PUSH_TYPE ("int8", gfc_int8_type_node);
! gfc_int16_type_node = gfc_build_int_type (16);
PUSH_TYPE ("int16", gfc_int16_type_node);
! gfc_real4_type_node = gfc_build_float_type (4);
PUSH_TYPE ("real4", gfc_real4_type_node);
! gfc_real8_type_node = gfc_build_float_type (8);
PUSH_TYPE ("real8", gfc_real8_type_node);
! gfc_real12_type_node = gfc_build_float_type (12);
! PUSH_TYPE ("real12", gfc_real12_type_node);
! gfc_real16_type_node = gfc_build_float_type (16);
PUSH_TYPE ("real16", gfc_real16_type_node);
! gfc_complex4_type_node = gfc_build_complex_type (gfc_real4_type_node);
PUSH_TYPE ("complex4", gfc_complex4_type_node);
! gfc_complex8_type_node = gfc_build_complex_type (gfc_real8_type_node);
PUSH_TYPE ("complex8", gfc_complex8_type_node);
! gfc_complex12_type_node = gfc_build_complex_type (gfc_real12_type_node);
! PUSH_TYPE ("complex12", gfc_complex12_type_node);
! gfc_complex16_type_node = gfc_build_complex_type (gfc_real16_type_node);
PUSH_TYPE ("complex16", gfc_complex16_type_node);
! gfc_logical1_type_node = gfc_build_logical_type (1);
PUSH_TYPE ("logical1", gfc_logical1_type_node);
! gfc_logical2_type_node = gfc_build_logical_type (2);
PUSH_TYPE ("logical2", gfc_logical2_type_node);
! gfc_logical4_type_node = gfc_build_logical_type (4);
PUSH_TYPE ("logical4", gfc_logical4_type_node);
! gfc_logical8_type_node = gfc_build_logical_type (8);
PUSH_TYPE ("logical8", gfc_logical8_type_node);
! gfc_logical16_type_node = gfc_build_logical_type (16);
PUSH_TYPE ("logical16", gfc_logical16_type_node);
gfc_character1_type_node = build_type_variant (signed_char_type_node, 0, 0);
PUSH_TYPE ("char", gfc_character1_type_node);
*************** gfc_init_types (void)
*** 177,204 ****
boolean_false_node = build_int_cst (boolean_type_node, 0, 0);
}
! /* Get a type node for an integer kind. */
tree
gfc_get_int_type (int kind)
{
switch (kind)
{
case 1:
! return (gfc_int1_type_node);
case 2:
! return (gfc_int2_type_node);
case 4:
! return (gfc_int4_type_node);
case 8:
! return (gfc_int8_type_node);
! #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
case 16:
! return (95 _int16_type_node);
! #endif
! default:
! fatal_error ("integer kind=%d not available", kind);
}
}
/* Get a type node for a real kind. */
--- 258,293 ----
boolean_false_node = build_int_cst (boolean_type_node, 0, 0);
}
! /* Get a type node for an integer kind */
! /* ??? Woudn't it be better to store the type node in the kind data struct? */
tree
gfc_get_int_type (int kind)
{
+ tree ret = NULL;
+
switch (kind)
{
case 1:
! ret = gfc_int1_type_node;
! break;
case 2:
! ret = gfc_int2_type_node;
! break;
case 4:
! ret = gfc_int4_type_node;
! break;
case 8:
! ret = gfc_int8_type_node;
! break;
case 16:
! ret = gfc_int16_type_node;
! break;
}
+
+ if (ret == NULL)
+ fatal_error ("integer kind=%d not available", kind);
+ return ret;
}
/* Get a type node for a real kind. */
*************** gfc_get_int_type (int kind)
*** 206,224 ****
tree
gfc_get_real_type (int kind)
{
switch (kind)
{
case 4:
! return (gfc_real4_type_node);
case 8:
! return (gfc_real8_type_node);
! #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
case 16:
! return (gfc_real16_type_node);
! #endif
! default:
! fatal_error ("real kind=%d not available", kind);
}
}
/* Get a type node for a complex kind. */
--- 295,321 ----
tree
gfc_get_real_type (int kind)
{
+ tree ret = NULL;
+
switch (kind)
{
case 4:
! ret = gfc_real4_type_node;
! break;
case 8:
! ret = gfc_real8_type_node;
! break;
! case 12:
! ret = gfc_real12_type_node;
! break;
case 16:
! ret = gfc_real16_type_node;
! break;
}
+
+ if (ret == NULL)
+ fatal_error ("real kind=%d not available", kind);
+ return ret;
}
/* Get a type node for a complex kind. */
*************** gfc_get_real_type (int kind)
*** 226,245 ****
tree
gfc_get_complex_type (int kind)
{
switch (kind)
{
case 4:
! return (gfc_complex4_type_node);
case 8:
! return (gfc_complex8_type_node);
! #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
case 16:
! return (gfc_complex16_type_node);
! #endif
! default:
! fatal_error ("complex kind=%d not available", kind);
}
}
/* Get a type node for a logical kind. */
--- 323,349 ----
tree
gfc_get_complex_type (int kind)
{
+ tree ret = NULL;
switch (kind)
{
case 4:
! ret = gfc_complex4_type_node;
! break;
case 8:
! ret = gfc_complex8_type_node;
! break;
! case 12:
! ret = gfc_complex12_type_node;
! break;
case 16:
! ret = gfc_complex16_type_node;
! break;
}
+
+ if (ret == NULL)
+ fatal_error ("complex kind=%d not available", kind);
+ return ret;
}
/* Get a type node for a logical kind. */
*************** gfc_get_complex_type (int kind)
*** 247,269 ****
tree
gfc_get_logical_type (int kind)
{
switch (kind)
{
case 1:
! return (gfc_logical1_type_node);
case 2:
! return (gfc_logical2_type_node);
case 4:
! return (gfc_logical4_type_node);
case 8:
! return (gfc_logical8_type_node);
! #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
case 16:
! return (gfc_logical16_type_node);
! #endif
! default:
! fatal_error ("logical kind=%d not available", kind);
}
}
/* Get a type node for a character kind. */
--- 351,380 ----
tree
gfc_get_logical_type (int kind)
{
+ tree ret = NULL;
+
switch (kind)
{
case 1:
! ret = gfc_logical1_type_node;
! break;
case 2:
! ret = gfc_logical2_type_node;
! break;
case 4:
! ret = gfc_logical4_type_node;
! break;
case 8:
! ret = gfc_logical8_type_node;
! break;
case 16:
! ret = gfc_logical16_type_node;
! break;
}
+
+ if (ret == NULL)
+ fatal_error ("logical kind=%d not available", kind);
+ return ret;
}
/* Get a type node for a character kind. */
*************** gfc_get_function_type (gfc_symbol * sym)
*** 1264,1300 ****
tree
gfc_type_for_size (unsigned bits, int unsignedp)
{
! if (bits == TYPE_PRECISION (integer_type_node))
! return unsignedp ? unsigned_type_node : integer_type_node;
!
! if (bits == TYPE_PRECISION (signed_char_type_node))
! return unsignedp ? unsigned_char_type_node : signed_char_type_node;
!
! if (bits == TYPE_PRECISION (short_integer_type_node))
! return unsignedp ? short_unsigned_type_node : short_integer_type_node;
!
! if (bits == TYPE_PRECISION (long_integer_type_node))
! return unsignedp ? long_unsigned_type_node : long_integer_type_node;
!
! if (bits == TYPE_PRECISION (long_long_integer_type_node))
! return (unsignedp ? long_long_unsigned_type_node
! : long_long_integer_type_node);
! /*TODO: We currently don't initialise this...
! if (bits == TYPE_PRECISION (widest_integer_literal_type_node))
! return (unsignedp ? widest_unsigned_literal_type_node
! : widest_integer_literal_type_node);*/
!
! if (bits <= TYPE_PRECISION (intQI_type_node))
! return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
!
! if (bits <= TYPE_PRECISION (intHI_type_node))
! return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
!
! if (bits <= TYPE_PRECISION (intSI_type_node))
! return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
!
! if (bits <= TYPE_PRECISION (intDI_type_node))
! return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
return 0;
}
--- 1375,1400 ----
tree
gfc_type_for_size (unsigned bits, int unsignedp)
{
! if (!unsignedp)
! {
! int i;
! for (i = F95_INT1_TYPE; i <= F95_INT16_TYPE; i++)
! if (gfc_type_nodes[i] && bits == TYPE_PRECISION (gfc_type_nodes[i]))
! return gfc_type_nodes[i];
! }
! else
! {
! if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
! return unsigned_intQI_type_node;
! if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
! return unsigned_intHI_type_node;
! if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
! return unsigned_intSI_type_node;
! if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
! return unsigned_intDI_type_node;
! if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
! return unsigned_intTI_type_node;
! }
return 0;
}
*************** gfc_type_for_size (unsigned bits, int un
*** 1306,1372 ****
tree
gfc_type_for_mode (enum machine_mode mode, int unsignedp)
{
! if (mode == TYPE_MODE (integer_type_node))
! return unsignedp ? unsigned_type_node : integer_type_node;
!
! if (mode == TYPE_MODE (signed_char_type_node))
! return unsignedp ? unsigned_char_type_node : signed_char_type_node;
!
! if (mode == TYPE_MODE (short_integer_type_node))
! return unsignedp ? short_unsigned_type_node : short_integer_type_node;
!
! if (mode == TYPE_MODE (long_integer_type_node))
! return unsignedp ? long_unsigned_type_node : long_integer_type_node;
!
! if (mode == TYPE_MODE (long_long_integer_type_node))
! return unsignedp ? long_long_unsigned_type_node :
! long_long_integer_type_node;
!
! /*TODO: see above
! if (mode == TYPE_MODE (widest_integer_literal_type_node))
! return unsignedp ? widest_unsigned_literal_type_node
! : widest_integer_literal_type_node;
! */
!
! if (mode == QImode)
! return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
!
! if (mode == HImode)
! return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
!
! if (mode == SImode)
! return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
!
! if (mode == DImode)
! return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
!
! #if HOST_BITS_PER_WIDE_INT >= 64
! if (mode == TYPE_MODE (intTI_type_node))
! return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
! #endif
!
! if (mode == TYPE_MODE (float_type_node))
! return float_type_node;
!
! if (mode == TYPE_MODE (double_type_node))
! return double_type_node;
!
! if (mode == TYPE_MODE (long_double_type_node))
! return long_double_type_node;
!
! if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
! return build_pointer_type (char_type_node);
!
! if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
! return build_pointer_type (integer_type_node);
! if (VECTOR_MODE_P (mode))
{
enum machine_mode inner_mode = GET_MODE_INNER (mode);
tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
if (inner_type != NULL_TREE)
return build_vector_type_for_mode (inner_type, mode);
}
return 0;
}
--- 1406,1433 ----
tree
gfc_type_for_mode (enum machine_mode mode, int unsignedp)
{
! int i, min, max;
! if (GET_MODE_CLASS (mode) == MODE_FLOAT)
! min = F95_REAL4_TYPE, max = F95_REAL16_TYPE;
! else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
! min = F95_COMPLEX4_TYPE, max = F95_COMPLEX16_TYPE;
! else if (SCALAR_INT_MODE_P (mode))
! return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
! else if (VECTOR_MODE_P (mode))
{
enum machine_mode inner_mode = GET_MODE_INNER (mode);
tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
if (inner_type != NULL_TREE)
return build_vector_type_for_mode (inner_type, mode);
+ return 0;
}
+ else
+ abort ();
+
+ for (i = min; i <= max; ++i)
+ if (gfc_type_nodes[i] && mode == TYPE_MODE (gfc_type_nodes[i]))
+ return gfc_type_nodes[i];
return 0;
}
*************** gfc_type_for_mode (enum machine_mode mod
*** 1376,1409 ****
tree
gfc_unsigned_type (tree type)
{
- tree type1 = TYPE_MAIN_VARIANT (type);
- if (type1 == signed_char_type_node || type1 == char_type_node)
- return unsigned_char_type_node;
- if (type1 == integer_type_node)
- return unsigned_type_node;
- if (type1 == short_integer_type_node)
- return short_unsigned_type_node;
- if (type1 == long_integer_type_node)
- return long_unsigned_type_node;
- if (type1 == long_long_integer_type_node)
- return long_long_unsigned_type_node;
- /*TODO :see others
- if (type1 == widest_integer_literal_type_node)
- return widest_unsigned_literal_type_node;
- */
- #if HOST_BITS_PER_WIDE_INT >= 64
- if (type1 == intTI_type_node)
- return unsigned_intTI_type_node;
- #endif
- if (type1 == intDI_type_node)
- return unsigned_intDI_type_node;
- if (type1 == intSI_type_node)
- return unsigned_intSI_type_node;
- if (type1 == intHI_type_node)
- return unsigned_intHI_type_node;
- if (type1 == intQI_type_node)
- return unsigned_intQI_type_node;
-
return gfc_signed_or_unsigned_type (1, type);
}
--- 1437,1442 ----
*************** gfc_unsigned_type (tree type)
*** 1412,1445 ****
tree
gfc_signed_type (tree type)
{
- tree type1 = TYPE_MAIN_VARIANT (type);
- if (type1 == unsigned_char_type_node || type1 == char_type_node)
- return signed_char_type_node;
- if (type1 == unsigned_type_node)
- return integer_type_node;
- if (type1 == short_unsigned_type_node)
- return short_integer_type_node;
- if (type1 == long_unsigned_type_node)
- return long_integer_type_node;
- if (type1 == long_long_unsigned_type_node)
- return long_long_integer_type_node;
- /*TODO: see others
- if (type1 == widest_unsigned_literal_type_node)
- return widest_integer_literal_type_node;
- */
- #if HOST_BITS_PER_WIDE_INT >= 64
- if (type1 == unsigned_intTI_type_node)
- return intTI_type_node;
- #endif
- if (type1 == unsigned_intDI_type_node)
- return intDI_type_node;
- if (type1 == unsigned_intSI_type_node)
- return intSI_type_node;
- if (type1 == unsigned_intHI_type_node)
- return intHI_type_node;
- if (type1 == unsigned_intQI_type_node)
- return intQI_type_node;
-
return gfc_signed_or_unsigned_type (0, type);
}
--- 1445,1450 ----
*************** gfc_signed_type (tree type)
*** 1449,1487 ****
tree
gfc_signed_or_unsigned_type (int unsignedp, tree type)
{
! if (!INTEGRAL_TYPE_P (type) || TYPE_UNSIGNED (type) == unsignedp)
return type;
!
! if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
! return unsignedp ? unsigned_char_type_node : signed_char_type_node;
! if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
! return unsignedp ? unsigned_type_node : integer_type_node;
! if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
! return unsignedp ? short_unsigned_type_node : short_integer_type_node;
! if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
! return unsignedp ? long_unsigned_type_node : long_integer_type_node;
! if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
! return (unsignedp ? long_long_unsigned_type_node
! : long_long_integer_type_node);
! /*TODO: see others
! if (TYPE_PRECISION (type) == TYPE_PRECISION (widest_integer_literal_type_node))
! return (unsignedp ? widest_unsigned_literal_type_node
! : widest_integer_literal_type_node);
! */
! #if HOST_BITS_PER_WIDE_INT >= 64
! if (TYPE_PRECISION (type) == TYPE_PRECISION (intTI_type_node))
! return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
! #endif
! if (TYPE_PRECISION (type) == TYPE_PRECISION (intDI_type_node))
! return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
! if (TYPE_PRECISION (type) == TYPE_PRECISION (intSI_type_node))
! return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
! if (TYPE_PRECISION (type) == TYPE_PRECISION (intHI_type_node))
! return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
! if (TYPE_PRECISION (type) == TYPE_PRECISION (intQI_type_node))
! return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
!
! return type;
}
#include "gt-fortran-trans-types.h"
--- 1454,1463 ----
tree
gfc_signed_or_unsigned_type (int unsignedp, tree type)
{
! if (TREE_CODE (type) != INTEGER_TYPE || TYPE_UNSIGNED (type) == unsignedp)
return type;
! else
! return gfc_type_for_size (TYPE_PRECISION (type), unsignedp);
}
#include "gt-fortran-trans-types.h"
Index: gcc/fortran/trans-types.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-types.h,v
retrieving revision 1.3
diff -c -p -d -r1.3 trans-types.h
*** gcc/fortran/trans-types.h 14 May 2004 13:00:04 -0000 1.3
--- gcc/fortran/trans-types.h 24 Aug 2004 18:23:26 -0000
*************** enum
*** 33,41 ****
F95_INT16_TYPE,
F95_REAL4_TYPE,
F95_REAL8_TYPE,
! F95_REAl16_TYPE,
F95_COMPLEX4_TYPE,
F95_COMPLEX8_TYPE,
F95_COMPLEX16_TYPE,
F95_LOGICAL1_TYPE,
F95_LOGICAL2_TYPE,
--- 33,43 ----
F95_INT16_TYPE,
F95_REAL4_TYPE,
F95_REAL8_TYPE,
! F95_REAL12_TYPE,
! F95_REAL16_TYPE,
F95_COMPLEX4_TYPE,
F95_COMPLEX8_TYPE,
+ F95_COMPLEX12_TYPE,
F95_COMPLEX16_TYPE,
F95_LOGICAL1_TYPE,
F95_LOGICAL2_TYPE,
*************** extern GTY(()) tree pchar_type_node;
*** 77,86 ****
--- 79,90 ----
#define gfc_real4_type_node gfc_type_nodes[F95_REAL4_TYPE]
#define gfc_real8_type_node gfc_type_nodes[F95_REAL8_TYPE]
+ #define gfc_real12_type_node gfc_type_nodes[F95_REAL12_TYPE]
#define gfc_real16_type_node gfc_type_nodes[F95_REAL16_TYPE]
#define gfc_complex4_type_node gfc_type_nodes[F95_COMPLEX4_TYPE]
#define gfc_complex8_type_node gfc_type_nodes[F95_COMPLEX8_TYPE]
+ #define gfc_complex12_type_node gfc_type_nodes[F95_COMPLEX12_TYPE]
#define gfc_complex16_type_node gfc_type_nodes[F95_COMPLEX16_TYPE]
#define gfc_logical1_type_node gfc_type_nodes[F95_LOGICAL1_TYPE]
Index: libgfortran/Makefile.am
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/Makefile.am,v
retrieving revision 1.14
diff -c -p -d -r1.14 Makefile.am
*** libgfortran/Makefile.am 24 Aug 2004 15:20:52 -0000 1.14
--- libgfortran/Makefile.am 24 Aug 2004 18:23:26 -0000
*************** intrinsics/rand.c \
*** 56,62 ****
intrinsics/random.c \
intrinsics/reshape_generic.c \
intrinsics/reshape_packed.c \
! intrinsics/selected_kind.f90 \
intrinsics/system_clock.c \
intrinsics/transpose_generic.c \
intrinsics/unpack_generic.c \
--- 56,63 ----
intrinsics/random.c \
intrinsics/reshape_generic.c \
intrinsics/reshape_packed.c \
! intrinsics/selected_int_kind.f90 \
! intrinsics/selected_real_kind.f90 \
intrinsics/system_clock.c \
intrinsics/transpose_generic.c \
intrinsics/unpack_generic.c \
*************** gfor_built_src= $(i_all_c) $(i_any_c) $(
*** 261,267 ****
$(i_matmul_c) $(i_matmull_c) $(i_transpose_c) $(i_shape_c) $(i_eoshift1_c) \
$(i_eoshift3_c) $(i_cshift1_c) $(i_reshape_c) $(in_pack_c) $(in_unpack_c) \
$(i_exponent_c) $(i_fraction_c) $(i_nearest_c) $(i_set_exponent_c) \
! $(i_pow_c)
# We only use these if libm doesn't contain complex math functions.
--- 262,269 ----
$(i_matmul_c) $(i_matmull_c) $(i_transpose_c) $(i_shape_c) $(i_eoshift1_c) \
$(i_eoshift3_c) $(i_cshift1_c) $(i_reshape_c) $(in_pack_c) $(in_unpack_c) \
$(i_exponent_c) $(i_fraction_c) $(i_nearest_c) $(i_set_exponent_c) \
! $(i_pow_c) \
! selected_real_kind.inc
# We only use these if libm doesn't contain complex math functions.
*************** I_M4_DEPS=m4/iparm.m4
*** 380,385 ****
--- 382,390 ----
I_M4_DEPS0=$(I_M4_DEPS) m4/iforeach.m4
I_M4_DEPS1=$(I_M4_DEPS) m4/ifunction.m4
+ selected_real_kind.inc:
+ $(SHELL) $(srcdir)/mk-srk-inc.sh '$(F77COMPILE)' > $@
+
## A 'normal' build shouldn't need to regenerate these
## so we only include them in maintainer mode
Index: libgfortran/Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/Makefile.in,v
retrieving revision 1.14
diff -c -p -d -r1.14 Makefile.in
*** libgfortran/Makefile.in 24 Aug 2004 15:20:52 -0000 1.14
--- libgfortran/Makefile.in 24 Aug 2004 18:23:26 -0000
***************
*** 1,4 ****
! # Makefile.in generated by automake 1.8.5 from Makefile.am.
# @configure_input@
# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
--- 1,4 ----
! # Makefile.in generated by automake 1.8.3 from Makefile.am.
# @configure_input@
# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
*************** am__objects_33 = associated.lo abort.lo
*** 122,130 ****
cpu_time.lo cshift0.lo date_and_time.lo env.lo eoshift0.lo \
eoshift2.lo etime.lo ishftc.lo pack_generic.lo size.lo \
spread_generic.lo string_intrinsics.lo rand.lo random.lo \
! reshape_generic.lo reshape_packed.lo selected_kind.lo \
! system_clock.lo transpose_generic.lo unpack_generic.lo \
! in_pack_generic.lo in_unpack_generic.lo normalize.lo
am__objects_34 =
am__objects_35 = _abs_c4.lo _abs_c8.lo _abs_i4.lo _abs_i8.lo \
_abs_r4.lo _abs_r8.lo _exp_r4.lo _exp_r8.lo _exp_c4.lo \
--- 122,131 ----
cpu_time.lo cshift0.lo date_and_time.lo env.lo eoshift0.lo \
eoshift2.lo etime.lo ishftc.lo pack_generic.lo size.lo \
spread_generic.lo string_intrinsics.lo rand.lo random.lo \
! reshape_generic.lo reshape_packed.lo selected_int_kind.lo \
! selected_real_kind.lo system_clock.lo transpose_generic.lo \
! unpack_generic.lo in_pack_generic.lo in_unpack_generic.lo \
! normalize.lo
am__objects_34 =
am__objects_35 = _abs_c4.lo _abs_c8.lo _abs_i4.lo _abs_i8.lo \
_abs_r4.lo _abs_r8.lo _exp_r4.lo _exp_r8.lo _exp_c4.lo \
*************** intrinsics/rand.c \
*** 327,333 ****
intrinsics/random.c \
intrinsics/reshape_generic.c \
intrinsics/reshape_packed.c \
! intrinsics/selected_kind.f90 \
intrinsics/system_clock.c \
intrinsics/transpose_generic.c \
intrinsics/unpack_generic.c \
--- 328,335 ----
intrinsics/random.c \
intrinsics/reshape_generic.c \
intrinsics/reshape_packed.c \
! intrinsics/selected_int_kind.f90 \
! intrinsics/selected_real_kind.f90 \
intrinsics/system_clock.c \
intrinsics/transpose_generic.c \
intrinsics/unpack_generic.c \
*************** gfor_built_src = $(i_all_c) $(i_any_c) $
*** 532,538 ****
$(i_matmul_c) $(i_matmull_c) $(i_transpose_c) $(i_shape_c) $(i_eoshift1_c) \
$(i_eoshift3_c) $(i_cshift1_c) $(i_reshape_c) $(in_pack_c) $(in_unpack_c) \
$(i_exponent_c) $(i_fraction_c) $(i_nearest_c) $(i_set_exponent_c) \
! $(i_pow_c)
# We only use these if libm doesn't contain complex math functions.
--- 534,541 ----
$(i_matmul_c) $(i_matmull_c) $(i_transpose_c) $(i_shape_c) $(i_eoshift1_c) \
$(i_eoshift3_c) $(i_cshift1_c) $(i_reshape_c) $(in_pack_c) $(in_unpack_c) \
$(i_exponent_c) $(i_fraction_c) $(i_nearest_c) $(i_set_exponent_c) \
! $(i_pow_c) \
! selected_real_kind.inc
# We only use these if libm doesn't contain complex math functions.
*************** clean-toolexeclibLTLIBRARIES:
*** 733,739 ****
-test -z "$(toolexeclib_LTLIBRARIES)" || rm -f $(toolexeclib_LTLIBRARIES)
@list='$(toolexeclib_LTLIBRARIES)'; for p in $$list; do \
dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \
! test "$$dir" != "$$p" || dir=.; \
echo "rm -f \"$${dir}/so_locations\""; \
rm -f "$${dir}/so_locations"; \
done
--- 736,742 ----
-test -z "$(toolexeclib_LTLIBRARIES)" || rm -f $(toolexeclib_LTLIBRARIES)
@list='$(toolexeclib_LTLIBRARIES)'; for p in $$list; do \
dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \
! test "$$dir" = "$$p" && dir=.; \
echo "rm -f \"$${dir}/so_locations\""; \
rm -f "$${dir}/so_locations"; \
done
*************** hyp_c8.lo: generated/hyp_c8.c
*** 2260,2273 ****
.f90.lo:
$(LTF77COMPILE) -c -o $@ $<
! selected_kind.o: intrinsics/selected_kind.f90
! $(F77) $(AM_FFLAGS) $(FFLAGS) -c -o selected_kind.o `test -f 'intrinsics/selected_kind.f90' || echo '$(srcdir)/'`intrinsics/selected_kind.f90
! selected_kind.obj: intrinsics/selected_kind.f90
! $(F77) $(AM_FFLAGS) $(FFLAGS) -c -o selected_kind.obj `if test -f 'intrinsics/selected_kind.f90'; then $(CYGPATH_W) 'intrinsics/selected_kind.f90'; else $(CYGPATH_W) '$(srcdir)/intrinsics/selected_kind.f90'; fi`
! selected_kind.lo: intrinsics/selected_kind.f90
! $(LIBTOOL) --mode=compile $(F77) $(AM_FFLAGS) $(FFLAGS) -c -o selected_kind.lo `test -f 'intrinsics/selected_kind.f90' || echo '$(srcdir)/'`intrinsics/selected_kind.f90
_abs_c4.o: generated/_abs_c4.f90
$(F77) $(AM_FFLAGS) $(FFLAGS) -c -o _abs_c4.o `test -f 'generated/_abs_c4.f90' || echo '$(srcdir)/'`generated/_abs_c4.f90
--- 2263,2285 ----
.f90.lo:
$(LTF77COMPILE) -c -o $@ $<
! selected_int_kind.o: intrinsics/selected_int_kind.f90
! $(F77) $(AM_FFLAGS) $(FFLAGS) -c -o selected_int_kind.o `test -f 'intrinsics/selected_int_kind.f90' || echo '$(srcdir)/'`intrinsics/selected_int_kind.f90
! selected_int_kind.obj: intrinsics/selected_int_kind.f90
! $(F77) $(AM_FFLAGS) $(FFLAGS) -c -o selected_int_kind.obj `if test -f 'intrinsics/selected_int_kind.f90'; then $(CYGPATH_W) 'intrinsics/selected_int_kind.f90'; else $(CYGPATH_W) '$(srcdir)/intrinsics/selected_int_kind.f90'; fi`
! selected_int_kind.lo: intrinsics/selected_int_kind.f90
! $(LIBTOOL) --mode=compile $(F77) $(AM_FFLAGS) $(FFLAGS) -c -o selected_int_kind.lo `test -f 'intrinsics/selected_int_kind.f90' || echo '$(srcdir)/'`intrinsics/selected_int_kind.f90
!
! selected_real_kind.o: intrinsics/selected_real_kind.f90
! $(F77) $(AM_FFLAGS) $(FFLAGS) -c -o selected_real_kind.o `test -f 'intrinsics/selected_real_kind.f90' || echo '$(srcdir)/'`intrinsics/selected_real_kind.f90
!
! selected_real_kind.obj: intrinsics/selected_real_kind.f90
! $(F77) $(AM_FFLAGS) $(FFLAGS) -c -o selected_real_kind.obj `if test -f 'intrinsics/selected_real_kind.f90'; then $(CYGPATH_W) 'intrinsics/selected_real_kind.f90'; else $(CYGPATH_W) '$(srcdir)/intrinsics/selected_real_kind.f90'; fi`
!
! selected_real_kind.lo: intrinsics/selected_real_kind.f90
! $(LIBTOOL) --mode=compile $(F77) $(AM_FFLAGS) $(FFLAGS) -c -o selected_real_kind.lo `test -f 'intrinsics/selected_real_kind.f90' || echo '$(srcdir)/'`intrinsics/selected_real_kind.f90
_abs_c4.o: generated/_abs_c4.f90
$(F77) $(AM_FFLAGS) $(FFLAGS) -c -o _abs_c4.o `test -f 'generated/_abs_c4.f90' || echo '$(srcdir)/'`generated/_abs_c4.f90
*************** TAGS: $(HEADERS) $(SOURCES) config.h.in
*** 2880,2890 ****
done | \
$(AWK) ' { files[$$0] = 1; } \
END { for (i in files) print i; }'`; \
! if test -z "$(ETAGS_ARGS)$$tags$$unique"; then :; else \
! test -n "$$unique" || unique=$$empty_fix; \
! $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
! $$tags $$unique; \
! fi
ctags: CTAGS
CTAGS: $(HEADERS) $(SOURCES) config.h.in $(TAGS_DEPENDENCIES) \
$(TAGS_FILES) $(LISP)
--- 2892,2900 ----
done | \
$(AWK) ' { files[$$0] = 1; } \
END { for (i in files) print i; }'`; \
! test -z "$(ETAGS_ARGS)$$tags$$unique" \
! || $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
! $$tags $$unique
ctags: CTAGS
CTAGS: $(HEADERS) $(SOURCES) config.h.in $(TAGS_DEPENDENCIES) \
$(TAGS_FILES) $(LISP)
*************** distcheck: dist
*** 2980,2986 ****
*.tar.Z*) \
uncompress -c $(distdir).tar.Z | $(AMTAR) xf - ;;\
*.shar.gz*) \
! GZIP=$(GZIP_ENV) gunzip -c $(distdir).shar.gz | unshar ;;\
*.zip*) \
unzip $(distdir).zip ;;\
esac
--- 2990,2996 ----
*.tar.Z*) \
uncompress -c $(distdir).tar.Z | $(AMTAR) xf - ;;\
*.shar.gz*) \
! GZIP=$(GZIP_ENV) gunzip -c $(distdir).tar.gz | unshar ;;\
*.zip*) \
unzip $(distdir).zip ;;\
esac
*************** uninstall-am: uninstall-info-am uninstal
*** 3139,3144 ****
--- 3149,3157 ----
uninstall-toolexeclibLTLIBRARIES
+ selected_real_kind.inc:
+ $(SHELL) $(srcdir)/mk-srk-inc.sh '$(F77COMPILE)' > $@
+
@MAINTAINER_MODE_TRUE@$(i_all_c): m4/all.m4 $(I_M4_DEPS1)
@MAINTAINER_MODE_TRUE@ m4 -Dfile=$@ -I$(srcdir)/m4 all.m4 > $@
Index: libgfortran/mk-srk-inc.sh
===================================================================
RCS file: libgfortran/mk-srk-inc.sh
diff -N libgfortran/mk-srk-inc.sh
*** /dev/null 1 Jan 1970 00:00:00 -0000
--- libgfortran/mk-srk-inc.sh 24 Aug 2004 18:23:26 -0000
***************
*** 0 ****
--- 1,32 ----
+ #!/bin/sh
+
+ compile="$1"
+ kinds=""
+ possible_kinds="4 8 12 16"
+ c=0
+
+ for k in $possible_kinds; do
+ echo " real (kind=$k) :: x" > tmp$$.f90
+ echo " end" >> tmp$$.f90
+ if $compile -c tmp$$.f90 > /dev/null 2>&1; then
+ kinds="$kinds $k"
+ c=`expr $c + 1`
+ fi
+ rm -f tmp$$.*
+ done
+
+ echo " integer, parameter :: c = $c"
+ echo " type (real_info), parameter :: real_infos(c) = (/ &"
+
+ i=0
+ for k in $kinds; do
+ echo -n " real_info ($k, precision(0.0_$k), range(0.0_$k))"
+ i=`expr $i + 1`
+ if [ $i -lt $c ]; then
+ echo ", &"
+ else
+ echo " /)"
+ fi
+ done
+
+ exit 0
Index: libgfortran/intrinsics/selected_int_kind.f90
===================================================================
RCS file: libgfortran/intrinsics/selected_int_kind.f90
diff -N libgfortran/intrinsics/selected_int_kind.f90
*** /dev/null 1 Jan 1970 00:00:00 -0000
--- libgfortran/intrinsics/selected_int_kind.f90 24 Aug 2004 18:23:27 -0000
***************
*** 0 ****
--- 1,47 ----
+ ! Copyright 2003 Free Software Foundation, Inc.
+ ! Contributed by Kejia Zhao <kejia_zh@yahoo.com.cn>
+ !
+ !This file is part of the GNU Fortran 95 runtime library (libgfor).
+ !
+ !GNU libgfor is free software; you can redistribute it and/or
+ !modify it under the terms of the GNU Lesser General Public
+ !License as published by the Free Software Foundation; either
+ !version 2.1 of the License, or (at your option) any later version.
+ !
+ !GNU libgfor is distributed in the hope that it will be useful,
+ !but WITHOUT ANY WARRANTY; without even the implied warranty of
+ !MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ !GNU Lesser General Public License for more details.
+ !
+ !You should have received a copy of the GNU Lesser General Public
+ !License along with libgfor; see the file COPYING. If not,
+ !write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ !Boston, MA 02111-1307, USA.
+ !
+
+ function selected_int_kind (r)
+ implicit none
+ integer, intent (in) :: r
+ integer :: selected_int_kind
+ integer :: i
+ ! Integer kind_range table
+ integer, parameter :: c = 4
+ type :: int_info
+ integer :: kind
+ integer :: range
+ end type int_info
+ type (int_info), parameter :: int_infos (c) = &
+ (/int_info (1, range (0_1)), &
+ int_info (2, range (0_2)), &
+ int_info (4, range (0_4)), &
+ int_info (8, range (0_8))/)
+
+ do i = 1, c
+ if (r <= int_infos (i) % range) then
+ selected_int_kind = int_infos (i) % kind
+ return
+ end if
+ end do
+ selected_int_kind = -1
+ return
+ end function
Index: libgfortran/intrinsics/selected_kind.f90
===================================================================
RCS file: libgfortran/intrinsics/selected_kind.f90
diff -N libgfortran/intrinsics/selected_kind.f90
*** libgfortran/intrinsics/selected_kind.f90 13 May 2004 06:41:02 -0000 1.2
--- /dev/null 1 Jan 1970 00:00:00 -0000
***************
*** 1,90 ****
- ! Copyright 2003 Free Software Foundation, Inc.
- ! Contributed by Kejia Zhao <kejia_zh@yahoo.com.cn>
- !
- !This file is part of the GNU Fortran 95 runtime library (libgfor).
- !
- !GNU libgfor is free software; you can redistribute it and/or
- !modify it under the terms of the GNU Lesser General Public
- !License as published by the Free Software Foundation; either
- !version 2.1 of the License, or (at your option) any later version.
- !
- !GNU libgfor is distributed in the hope that it will be useful,
- !but WITHOUT ANY WARRANTY; without even the implied warranty of
- !MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- !GNU Lesser General Public License for more details.
- !
- !You should have received a copy of the GNU Lesser General Public
- !License along with libgfor; see the file COPYING. If not,
- !write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
- !Boston, MA 02111-1307, USA.
- !
-
- function selected_int_kind (r)
- implicit none
- integer, intent (in) :: r
- integer :: selected_int_kind
- integer :: i
- ! Integer kind_range table
- integer, parameter :: c = 4
- type :: int_info
- integer :: kind
- integer :: range
- end type int_info
- type (int_info), parameter :: int_infos (c) = &
- (/int_info (1, range (0_1)), &
- int_info (2, range (0_2)), &
- int_info (4, range (0_4)), &
- int_info (8, range (0_8))/)
-
- do i = 1, c
- if (r <= int_infos (i) % range) then
- selected_int_kind = int_infos (i) % kind
- return
- end if
- end do
- selected_int_kind = -1
- return
- end function
-
- function selected_real_kind (p, r)
- implicit none
- integer, optional, intent (in) :: p, r
- integer :: selected_real_kind
- integer :: i, p2, r2
- logical :: found_p, found_r
- ! Real kind_precision_range table
- integer, parameter :: c = 2
- type :: real_info
- integer :: kind
- integer :: precision
- integer :: range
- end type real_info
- type (real_info) :: real_infos (c) = &
- (/real_info (4, precision (0.0_4), range (0.0_4)), &
- real_info (8, precision (0.0_8), range (0.0_8))/)
-
- selected_real_kind = 0
- p2 = 0
- r2 = 0
- found_p = .false.
- found_r = .false.
-
- if (present (p)) p2 = p
- if (present (r)) r2 = r
-
- ! Assumes each type has a greater precision and range than previous one.
-
- do i = 1, c
- if (p2 <= real_infos (i) % precision) found_p = .true.
- if (r2 <= real_infos (i) % range) found_r = .true.
- if (found_p .and. found_r) then
- selected_real_kind = real_infos (i) % kind
- return
- end if
- end do
-
- if (.not. (found_p)) selected_real_kind = selected_real_kind - 1
- if (.not. (found_r)) selected_real_kind = selected_real_kind - 2
-
- return
- end function
--- 0 ----
Index: libgfortran/intrinsics/selected_real_kind.f90
===================================================================
RCS file: libgfortran/intrinsics/selected_real_kind.f90
diff -N libgfortran/intrinsics/selected_real_kind.f90
*** /dev/null 1 Jan 1970 00:00:00 -0000
--- libgfortran/intrinsics/selected_real_kind.f90 24 Aug 2004 18:23:27 -0000
***************
*** 0 ****
--- 1,61 ----
+ ! Copyright 2003, 2004 Free Software Foundation, Inc.
+ ! Contributed by Kejia Zhao <kejia_zh@yahoo.com.cn>
+ !
+ !This file is part of the GNU Fortran 95 runtime library (libgfor).
+ !
+ !GNU libgfor is free software; you can redistribute it and/or
+ !modify it under the terms of the GNU Lesser General Public
+ !License as published by the Free Software Foundation; either
+ !version 2.1 of the License, or (at your option) any later version.
+ !
+ !GNU libgfor is distributed in the hope that it will be useful,
+ !but WITHOUT ANY WARRANTY; without even the implied warranty of
+ !MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ !GNU Lesser General Public License for more details.
+ !
+ !You should have received a copy of the GNU Lesser General Public
+ !License along with libgfor; see the file COPYING. If not,
+ !write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ !Boston, MA 02111-1307, USA.
+ !
+
+ function selected_real_kind (p, r)
+ implicit none
+ integer, optional, intent (in) :: p, r
+ integer :: selected_real_kind
+ integer :: i, p2, r2
+ logical :: found_p, found_r
+ ! Real kind_precision_range table
+ type :: real_info
+ integer :: kind
+ integer :: precision
+ integer :: range
+ end type real_info
+
+ include "selected_real_kind.inc"
+
+ selected_real_kind = 0
+ p2 = 0
+ r2 = 0
+ found_p = .false.
+ found_r = .false.
+
+ if (present (p)) p2 = p
+ if (present (r)) r2 = r
+
+ ! Assumes each type has a greater precision and range than previous one.
+
+ do i = 1, c
+ if (p2 <= real_infos (i) % precision) found_p = .true.
+ if (r2 <= real_infos (i) % range) found_r = .true.
+ if (found_p .and. found_r) then
+ selected_real_kind = real_infos (i) % kind
+ return
+ end if
+ end do
+
+ if (.not. (found_p)) selected_real_kind = selected_real_kind - 1
+ if (.not. (found_r)) selected_real_kind = selected_real_kind - 2
+
+ return
+ end function
Index: gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sr_kind.f90
===================================================================
RCS file: /cvs/gcc/gcc/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sr_kind.f90,v
retrieving revision 1.2
diff -c -p -d -r1.2 intrinsic_sr_kind.f90
*** gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sr_kind.f90 13 May 2004 06:40:53 -0000 1.2
--- gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_sr_kind.f90 24 Aug 2004 18:23:32 -0000
*************** Program test_sr_kind
*** 18,25 ****
res = selected_real_kind (r = i8)
if (res .ne. 8) call abort
! res = selected_real_kind (r = (i8 + 1))
! if (res .ne. -2) call abort
res = selected_real_kind (p = precision (r4))
if (res .ne. 4) call abort
--- 18,26 ----
res = selected_real_kind (r = i8)
if (res .ne. 8) call abort
! ! We can in fact have kinds wider than r8. How do we want to check?
! ! res = selected_real_kind (r = (i8 + 1))
! ! if (res .ne. -2) call abort
res = selected_real_kind (p = precision (r4))
if (res .ne. 4) call abort
*************** Program test_sr_kind
*** 30,37 ****
res = selected_real_kind (p = precision (r4), r = i8)
if (res .ne. 8) call abort
! res = selected_real_kind (p = precision (r4), r = i8 + 1)
! if (res .ne. -2) call abort
res = selected_real_kind (p = precision (r8))
if (res .ne. 8) call abort
--- 31,38 ----
res = selected_real_kind (p = precision (r4), r = i8)
if (res .ne. 8) call abort
! ! res = selected_real_kind (p = precision (r4), r = i8 + 1)
! ! if (res .ne. -2) call abort
res = selected_real_kind (p = precision (r8))
if (res .ne. 8) call abort
*************** Program test_sr_kind
*** 42,61 ****
res = selected_real_kind (p = precision (r8), r = i8)
if (res .ne. 8) call abort
! res = selected_real_kind (p = precision (r8), r = i8 + 1)
! if (res .ne. -2) call abort
! res = selected_real_kind (p = (precision (r8) + 1))
! if (res .ne. -1) call abort
! res = selected_real_kind (p = (precision (r8) + 1), r = i4)
! if (res .ne. -1) call abort
! res = selected_real_kind (p = (precision (r8) + 1), r = i8)
! if (res .ne. -1) call abort
! res = selected_real_kind (p = (precision (r8) + 1), r = i8 + 1)
! if (res .ne. -3) call abort
end
--- 43,62 ----
res = selected_real_kind (p = precision (r8), r = i8)
if (res .ne. 8) call abort
! ! res = selected_real_kind (p = precision (r8), r = i8 + 1)
! ! if (res .ne. -2) call abort
! ! res = selected_real_kind (p = (precision (r8) + 1))
! ! if (res .ne. -1) call abort
! ! res = selected_real_kind (p = (precision (r8) + 1), r = i4)
! ! if (res .ne. -1) call abort
! ! res = selected_real_kind (p = (precision (r8) + 1), r = i8)
! ! if (res .ne. -1) call abort
! ! res = selected_real_kind (p = (precision (r8) + 1), r = i8 + 1)
! ! if (res .ne. -3) call abort
end
More information about the Fortran
mailing list