iso-fortran-env.def: Define INT8, INT16, INT32, INT64, REAL32, REAL64 and REAL128.

[gcc.git] / gcc / fortran / trans-types.c

diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 9fc0dc9a06cb0869cccf66d113b1f669ede5e83c..b40af4111363ef567b2b2149ee566606a38aaf7d 100644 (file)
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1,5 +1,5 @@
 /* Backend support for Fortran 95 basic types and derived types.
 /* Backend support for Fortran 95 basic types and derived types.

-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009

    Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
    Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>


@@ -117,21 +117,7 @@ int gfc_numeric_storage_size;
 int gfc_character_storage_size;
 
 
 int gfc_character_storage_size;
 
 

-/* Validate that the f90_type of the given gfc_typespec is valid for
-   the type it represents.  The f90_type represents the Fortran types
-   this C kind can be used with.  For example, c_int has a f90_type of
-   BT_INTEGER and c_float has a f90_type of BT_REAL.  Returns FAILURE
-   if a mismatch occurs between ts->f90_type and ts->type; SUCCESS if
-   they match.  */
-
-try
-gfc_validate_c_kind (gfc_typespec *ts)
-{
-   return ((ts->type == ts->f90_type) ? SUCCESS : FAILURE);
-}
-
-
-try
+gfc_try

 gfc_check_any_c_kind (gfc_typespec *ts)
 {
   int i;
 gfc_check_any_c_kind (gfc_typespec *ts)
 {
   int i;


@@ -177,6 +163,96 @@ get_int_kind_from_node (tree type)
   return -1;
 }
 
   return -1;
 }
 

+/* Return a typenode for the "standard" C type with a given name.  */
+static tree
+get_typenode_from_name (const char *name)
+{
+  if (name == NULL || *name == '\0')
+    return NULL_TREE;
+
+  if (strcmp (name, "char") == 0)
+    return char_type_node;
+  if (strcmp (name, "unsigned char") == 0)
+    return unsigned_char_type_node;
+  if (strcmp (name, "signed char") == 0)
+    return signed_char_type_node;
+
+  if (strcmp (name, "short int") == 0)
+    return short_integer_type_node;
+  if (strcmp (name, "short unsigned int") == 0)
+    return short_unsigned_type_node;
+
+  if (strcmp (name, "int") == 0)
+    return integer_type_node;
+  if (strcmp (name, "unsigned int") == 0)
+    return unsigned_type_node;
+
+  if (strcmp (name, "long int") == 0)
+    return long_integer_type_node;
+  if (strcmp (name, "long unsigned int") == 0)
+    return long_unsigned_type_node;
+
+  if (strcmp (name, "long long int") == 0)
+    return long_long_integer_type_node;
+  if (strcmp (name, "long long unsigned int") == 0)
+    return long_long_unsigned_type_node;
+
+  gcc_unreachable ();
+}
+
+static int
+get_int_kind_from_name (const char *name)
+{
+  return get_int_kind_from_node (get_typenode_from_name (name));
+}
+
+
+/* Get the kind number corresponding to an integer of given size,
+   following the required return values for ISO_FORTRAN_ENV INT* constants:
+   -2 is returned if we support a kind of larger size, -1 otherwise.  */
+int
+gfc_get_int_kind_from_width_isofortranenv (int size)
+{
+  int i;
+
+  /* Look for a kind with matching storage size.  */
+  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+    if (gfc_integer_kinds[i].bit_size == size)
+      return gfc_integer_kinds[i].kind;
+
+  /* Look for a kind with larger storage size.  */
+  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+    if (gfc_integer_kinds[i].bit_size > size)
+      return -2;
+
+  return -1;
+}
+
+/* Get the kind number corresponding to a real of given storage size,
+   following the required return values for ISO_FORTRAN_ENV REAL* constants:
+   -2 is returned if we support a kind of larger size, -1 otherwise.  */
+int
+gfc_get_real_kind_from_width_isofortranenv (int size)
+{
+  int i;
+
+  size /= 8;
+
+  /* Look for a kind with matching storage size.  */
+  for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+    if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size)
+      return gfc_real_kinds[i].kind;
+
+  /* Look for a kind with larger storage size.  */
+  for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+    if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size)
+      return -2;
+
+  return -1;
+}
+
+
+

 static int
 get_int_kind_from_width (int size)
 {
 static int
 get_int_kind_from_width (int size)
 {


@@ -266,7 +342,7 @@ void init_c_interop_kinds (void)
 void
 gfc_init_kinds (void)
 {
 void
 gfc_init_kinds (void)
 {

-  enum machine_mode mode;
+  unsigned int mode;

   int i_index, r_index, kind;
   bool saw_i4 = false, saw_i8 = false;
   bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
   int i_index, r_index, kind;
   bool saw_i4 = false, saw_i8 = false;
   bool saw_r4 = false, saw_r8 = false, saw_r16 = false;


@@ -275,7 +351,7 @@ gfc_init_kinds (void)
     {
       int kind, bitsize;
 
     {
       int kind, bitsize;
 

-      if (!targetm.scalar_mode_supported_p (mode))
+      if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))

        continue;
 
       /* The middle end doesn't support constants larger than 2*HWI.
        continue;
 
       /* The middle end doesn't support constants larger than 2*HWI.


@@ -323,12 +399,13 @@ gfc_init_kinds (void)
 
   for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
     {
 
   for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
     {

-      const struct real_format *fmt = REAL_MODE_FORMAT (mode);
+      const struct real_format *fmt =
+       REAL_MODE_FORMAT ((enum machine_mode) mode);

       int kind;
 
       if (fmt == NULL)
        continue;
       int kind;
 
       if (fmt == NULL)
        continue;

-      if (!targetm.scalar_mode_supported_p (mode))
+      if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))

        continue;
 
       /* Only let float/double/long double go through because the fortran
        continue;
 
       /* Only let float/double/long double go through because the fortran


@@ -361,7 +438,7 @@ gfc_init_kinds (void)
       if (kind == 16)
        saw_r16 = true;
 
       if (kind == 16)
        saw_r16 = true;
 

-      /* Careful we don't stumble a wierd internal mode.  */
+      /* Careful we don't stumble a weird internal mode.  */

       gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
       /* Or have too many modes for the allocated space.  */
       gcc_assert (r_index != MAX_REAL_KINDS);
       gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
       /* Or have too many modes for the allocated space.  */
       gcc_assert (r_index != MAX_REAL_KINDS);


@@ -393,7 +470,7 @@ gfc_init_kinds (void)
       gfc_default_integer_kind = 8;
 
       /* Even if the user specified that the default integer kind be 8,
       gfc_default_integer_kind = 8;
 
       /* Even if the user specified that the default integer kind be 8,

-         the numerica storage size isn't 64.  In this case, a warning will
+         the numeric storage size isn't 64.  In this case, a warning will

         be issued when NUMERIC_STORAGE_SIZE is used.  */
       gfc_numeric_storage_size = 4 * 8;
     }
         be issued when NUMERIC_STORAGE_SIZE is used.  */
       gfc_numeric_storage_size = 4 * 8;
     }


@@ -693,6 +770,7 @@ gfc_build_logical_type (gfc_logical_info *info)
   return new_type;
 }
 
   return new_type;
 }
 

+

 #if 0
 /* Return the bit size of the C "size_t".  */
 
 #if 0
 /* Return the bit size of the C "size_t".  */
 


@@ -735,6 +813,9 @@ gfc_init_types (void)
   for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
     {
       type = gfc_build_int_type (&gfc_integer_kinds[index]);
   for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
     {
       type = gfc_build_int_type (&gfc_integer_kinds[index]);

+      /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set.  */
+      if (TYPE_STRING_FLAG (type))
+       type = make_signed_type (gfc_integer_kinds[index].bit_size);

       gfc_integer_types[index] = type;
       snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)",
                gfc_integer_kinds[index].kind);
       gfc_integer_types[index] = type;
       snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)",
                gfc_integer_kinds[index].kind);


@@ -1065,8 +1146,8 @@ gfc_get_element_type (tree type)
    ARRAYS comment.
 
    The data component points to the first element in the array.  The
    ARRAYS comment.
 
    The data component points to the first element in the array.  The

-   offset field is the position of the origin of the array (ie element
-   (0, 0 ...)).  This may be outsite the bounds of the array.
+   offset field is the position of the origin of the array (i.e. element
+   (0, 0 ...)).  This may be outside the bounds of the array.

 
    An element is accessed by
     data[offset + index0*stride0 + index1*stride1 + index2*stride2]
 
    An element is accessed by
     data[offset + index0*stride0 + index1*stride1 + index2*stride2]


@@ -1078,7 +1159,7 @@ gfc_get_element_type (tree type)
    elements of the origin (2^63 on 64-bit machines).  For example
     integer, dimension (80000:90000, 80000:90000, 2) :: array
    may not work properly on 32-bit machines because 80000*80000 >
    elements of the origin (2^63 on 64-bit machines).  For example
     integer, dimension (80000:90000, 80000:90000, 2) :: array
    may not work properly on 32-bit machines because 80000*80000 >

-   2^31, so the calculation for stride02 would overflow.  This may
+   2^31, so the calculation for stride2 would overflow.  This may

    still work, but I haven't checked, and it relies on the overflow
    doing the right thing.
 
    still work, but I haven't checked, and it relies on the overflow
    doing the right thing.
 


@@ -1415,10 +1496,10 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
   mpz_clear (stride);
   mpz_clear (delta);
 
   mpz_clear (stride);
   mpz_clear (delta);
 

-  /* In debug info represent packed arrays as multi-dimensional
-     if they have rank > 1 and with proper bounds, instead of flat
-     arrays.  */
-  if (known_offset && write_symbols != NO_DEBUG)
+  /* Represent packed arrays as multi-dimensional if they have rank >
+     1 and with proper bounds, instead of flat arrays.  This makes for
+     better debug info.  */
+  if (known_offset)

     {
       tree gtype = etype, rtype, type_decl;
 
     {
       tree gtype = etype, rtype, type_decl;
 


@@ -1627,6 +1708,16 @@ gfc_sym_type (gfc_symbol * sym)
   tree type;
   int byref;
 
   tree type;
   int byref;
 

+  /* Procedure Pointers inside COMMON blocks.  */
+  if (sym->attr.proc_pointer && sym->attr.in_common)
+    {
+      /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type.  */
+      sym->attr.proc_pointer = 0;
+      type = build_pointer_type (gfc_get_function_type (sym));
+      sym->attr.proc_pointer = 1;
+      return type;
+    }
+

   if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
     return void_type_node;
 
   if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
     return void_type_node;
 


@@ -1636,8 +1727,11 @@ gfc_sym_type (gfc_symbol * sym)
   if (sym->backend_decl && !sym->attr.function)
     return TREE_TYPE (sym->backend_decl);
 
   if (sym->backend_decl && !sym->attr.function)
     return TREE_TYPE (sym->backend_decl);
 

-  if (sym->ts.type == BT_CHARACTER && sym->attr.is_bind_c
-      && (sym->attr.function || sym->attr.result))
+  if (sym->ts.type == BT_CHARACTER
+      && ((sym->attr.function && sym->attr.is_bind_c)
+         || (sym->attr.result
+             && sym->ns->proc_name
+             && sym->ns->proc_name->attr.is_bind_c)))

     type = gfc_character1_type_node;
   else
     type = gfc_typenode_for_spec (&sym->ts);
     type = gfc_character1_type_node;
   else
     type = gfc_typenode_for_spec (&sym->ts);


@@ -1764,7 +1858,7 @@ copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
   for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
     {
       to_cm->backend_decl = from_cm->backend_decl;
   for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
     {
       to_cm->backend_decl = from_cm->backend_decl;

-      if (!from_cm->pointer && from_cm->ts.type == BT_DERIVED)
+      if (!from_cm->attr.pointer && from_cm->ts.type == BT_DERIVED)

        gfc_get_derived_type (to_cm->ts.derived);
 
       else if (from_cm->ts.type == BT_CHARACTER)
        gfc_get_derived_type (to_cm->ts.derived);
 
       else if (from_cm->ts.type == BT_CHARACTER)


@@ -1775,6 +1869,21 @@ copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
 }
 
 
 }
 
 

+/* Build a tree node for a procedure pointer component.  */
+
+tree
+gfc_get_ppc_type (gfc_component* c)
+{
+  tree t;
+  if (c->attr.function)
+    t = gfc_typenode_for_spec (&c->ts);
+  else
+    t = void_type_node;
+  /* TODO: Build argument list.  */
+  return build_pointer_type (build_function_type (t, NULL_TREE));
+}
+
+

 /* Build a tree node for a derived type.  If there are equal
    derived types, with different local names, these are built
    at the same time.  If an equal derived type has been built
 /* Build a tree node for a derived type.  If there are equal
    derived types, with different local names, these are built
    at the same time.  If an equal derived type has been built


@@ -1821,16 +1930,9 @@ gfc_get_derived_type (gfc_symbol * derived)
   /* derived->backend_decl != 0 means we saw it before, but its
      components' backend_decl may have not been built.  */
   if (derived->backend_decl)
   /* derived->backend_decl != 0 means we saw it before, but its
      components' backend_decl may have not been built.  */
   if (derived->backend_decl)

-    {
-      /* Its components' backend_decl have been built.  */
-      if (TYPE_FIELDS (derived->backend_decl))
-        return derived->backend_decl;
-      else
-        typenode = derived->backend_decl;
-    }
+    return derived->backend_decl;

   else
     {
   else
     {

-

       /* We see this derived type first time, so build the type node.  */
       typenode = make_node (RECORD_TYPE);
       TYPE_NAME (typenode) = get_identifier (derived->name);
       /* We see this derived type first time, so build the type node.  */
       typenode = make_node (RECORD_TYPE);
       TYPE_NAME (typenode) = get_identifier (derived->name);


@@ -1848,7 +1950,7 @@ gfc_get_derived_type (gfc_symbol * derived)
       if (c->ts.type != BT_DERIVED)
        continue;
 
       if (c->ts.type != BT_DERIVED)
        continue;
 

-      if (!c->pointer || c->ts.derived->backend_decl == NULL)
+      if (!c->attr.pointer || c->ts.derived->backend_decl == NULL)

        c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
 
       if (c->ts.derived && c->ts.derived->attr.is_iso_c)
        c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
 
       if (c->ts.derived && c->ts.derived->attr.is_iso_c)


@@ -1879,6 +1981,8 @@ gfc_get_derived_type (gfc_symbol * derived)
     {
       if (c->ts.type == BT_DERIVED)
         field_type = c->ts.derived->backend_decl;
     {
       if (c->ts.type == BT_DERIVED)
         field_type = c->ts.derived->backend_decl;

+      else if (c->attr.proc_pointer)
+       field_type = gfc_get_ppc_type (c);

       else
        {
          if (c->ts.type == BT_CHARACTER)
       else
        {
          if (c->ts.type == BT_CHARACTER)


@@ -1893,12 +1997,12 @@ gfc_get_derived_type (gfc_symbol * derived)
 
       /* This returns an array descriptor type.  Initialization may be
          required.  */
 
       /* This returns an array descriptor type.  Initialization may be
          required.  */

-      if (c->dimension)
+      if (c->attr.dimension)

        {
        {

-         if (c->pointer || c->allocatable)
+         if (c->attr.pointer || c->attr.allocatable)

            {
              enum gfc_array_kind akind;
            {
              enum gfc_array_kind akind;

-             if (c->pointer)
+             if (c->attr.pointer)

                akind = GFC_ARRAY_POINTER;
              else
                akind = GFC_ARRAY_ALLOCATABLE;
                akind = GFC_ARRAY_POINTER;
              else
                akind = GFC_ARRAY_ALLOCATABLE;


@@ -1910,7 +2014,7 @@ gfc_get_derived_type (gfc_symbol * derived)
            field_type = gfc_get_nodesc_array_type (field_type, c->as,
                                                    PACKED_STATIC);
        }
            field_type = gfc_get_nodesc_array_type (field_type, c->as,
                                                    PACKED_STATIC);
        }

-      else if (c->pointer)
+      else if (c->attr.pointer)

        field_type = build_pointer_type (field_type);
 
       field = gfc_add_field_to_struct (&fieldlist, typenode,
        field_type = build_pointer_type (field_type);
 
       field = gfc_add_field_to_struct (&fieldlist, typenode,


@@ -1934,12 +2038,24 @@ gfc_get_derived_type (gfc_symbol * derived)
 
   gfc_finish_type (typenode);
   gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
 
   gfc_finish_type (typenode);
   gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);

+  if (derived->module && derived->ns->proc_name
+      && derived->ns->proc_name->attr.flavor == FL_MODULE)
+    {
+      if (derived->ns->proc_name->backend_decl
+         && TREE_CODE (derived->ns->proc_name->backend_decl)
+            == NAMESPACE_DECL)
+       {
+         TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl;
+         DECL_CONTEXT (TYPE_STUB_DECL (typenode))
+           = derived->ns->proc_name->backend_decl;
+       }
+    }

 
   derived->backend_decl = typenode;
 
 
   derived->backend_decl = typenode;
 

-    /* Add this backend_decl to all the other, equal derived types.  */
-    for (dt = gfc_derived_types; dt; dt = dt->next)
-      copy_dt_decls_ifequal (derived, dt->derived);
+  /* Add this backend_decl to all the other, equal derived types.  */
+  for (dt = gfc_derived_types; dt; dt = dt->next)
+    copy_dt_decls_ifequal (derived, dt->derived);

 
   return derived->backend_decl;
 }
 
   return derived->backend_decl;
 }


@@ -1954,7 +2070,11 @@ gfc_return_by_reference (gfc_symbol * sym)
   if (sym->attr.dimension)
     return 1;
 
   if (sym->attr.dimension)
     return 1;
 

-  if (sym->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
+  if (sym->ts.type == BT_CHARACTER
+      && !sym->attr.is_bind_c
+      && (!sym->attr.result
+         || !sym->ns->proc_name
+         || !sym->ns->proc_name->attr.is_bind_c))

     return 1;
 
   /* Possibly return complex numbers by reference for g77 compatibility.
     return 1;
 
   /* Possibly return complex numbers by reference for g77 compatibility.


@@ -2136,6 +2256,20 @@ gfc_get_function_type (gfc_symbol * sym)
       type = gfc_typenode_for_spec (&sym->ts);
       sym->ts.kind = gfc_default_real_kind;
     }
       type = gfc_typenode_for_spec (&sym->ts);
       sym->ts.kind = gfc_default_real_kind;
     }

+  else if (sym->result && sym->result->attr.proc_pointer)
+    /* Procedure pointer return values.  */
+    {
+      if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0)
+       {
+         /* Unset proc_pointer as gfc_get_function_type
+            is called recursively.  */
+         sym->result->attr.proc_pointer = 0;
+         type = build_pointer_type (gfc_get_function_type (sym->result));
+         sym->result->attr.proc_pointer = 1;
+       }
+      else
+       type = gfc_sym_type (sym->result);
+    }

   else
     type = gfc_sym_type (sym);
 
   else
     type = gfc_sym_type (sym);
 


@@ -2163,7 +2297,7 @@ gfc_type_for_size (unsigned bits, int unsignedp)
        }
 
       /* Handle TImode as a special case because it is used by some backends
        }
 
       /* Handle TImode as a special case because it is used by some backends

-         (eg. ARM) even though it is not available for normal use.  */
+         (e.g. ARM) even though it is not available for normal use.  */

 #if HOST_BITS_PER_WIDE_INT >= 64
       if (bits == TYPE_PRECISION (intTI_type_node))
        return intTI_type_node;
 #if HOST_BITS_PER_WIDE_INT >= 64
       if (bits == TYPE_PRECISION (intTI_type_node))
        return intTI_type_node;


@@ -2278,7 +2412,10 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
   else
     info->base_decl = base_decl = build_decl (VAR_DECL, NULL_TREE, ptype);
 
   else
     info->base_decl = base_decl = build_decl (VAR_DECL, NULL_TREE, ptype);
 

-  elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
+  if (GFC_TYPE_ARRAY_SPAN (type))
+    elem_size = GFC_TYPE_ARRAY_SPAN (type);
+  else
+    elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));

   field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type));
   data_off = byte_position (field);
   field = TREE_CHAIN (field);
   field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type));
   data_off = byte_position (field);
   field = TREE_CHAIN (field);