2010-04-06 Tobias Burnus <burnus@net-b.de>

[pf3gnuchains/gcc-fork.git] / gcc / fortran / module.c

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 666fd84..20e4836 100644 (file)
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -73,12 +73,13 @@ along with GCC; see the file COPYING3.  If not see
 #include "match.h"
 #include "parse.h" /* FIXME */
 #include "md5.h"
+#include "constructor.h"
 
 #define MODULE_EXTENSION ".mod"
 
 /* Don't put any single quote (') in MOD_VERSION, 
    if yout want it to be recognized.  */
-#define MOD_VERSION "4"
+#define MOD_VERSION "5"
 
 
 /* Structure that describes a position within a module file.  */
@@ -1672,7 +1673,8 @@ typedef enum
   AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
   AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
   AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
-  AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS
+  AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
+  AB_COARRAY_COMP, AB_VTYPE, AB_VTAB
 }
 ab_attribute;
 
@@ -1681,6 +1683,7 @@ static const mstring attr_bits[] =
     minit ("ALLOCATABLE", AB_ALLOCATABLE),
     minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
     minit ("DIMENSION", AB_DIMENSION),
+    minit ("CODIMENSION", AB_CODIMENSION),
     minit ("EXTERNAL", AB_EXTERNAL),
     minit ("INTRINSIC", AB_INTRINSIC),
     minit ("OPTIONAL", AB_OPTIONAL),
@@ -1708,6 +1711,7 @@ static const mstring attr_bits[] =
     minit ("IS_ISO_C", AB_IS_ISO_C),
     minit ("VALUE", AB_VALUE),
     minit ("ALLOC_COMP", AB_ALLOC_COMP),
+    minit ("COARRAY_COMP", AB_COARRAY_COMP),
     minit ("POINTER_COMP", AB_POINTER_COMP),
     minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
     minit ("ZERO_COMP", AB_ZERO_COMP),
@@ -1716,6 +1720,8 @@ static const mstring attr_bits[] =
     minit ("IS_CLASS", AB_IS_CLASS),
     minit ("PROCEDURE", AB_PROCEDURE),
     minit ("PROC_POINTER", AB_PROC_POINTER),
+    minit ("VTYPE", AB_VTYPE),
+    minit ("VTAB", AB_VTAB),
     minit (NULL, -1)
 };
 
@@ -1798,6 +1804,8 @@ mio_symbol_attribute (symbol_attribute *attr)
        MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
       if (attr->dimension)
        MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
+      if (attr->codimension)
+       MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
       if (attr->external)
        MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
       if (attr->intrinsic)
@@ -1864,6 +1872,8 @@ mio_symbol_attribute (symbol_attribute *attr)
        MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
       if (attr->private_comp)
        MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
+      if (attr->coarray_comp)
+       MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
       if (attr->zero_comp)
        MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
       if (attr->is_class)
@@ -1872,6 +1882,10 @@ mio_symbol_attribute (symbol_attribute *attr)
        MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
       if (attr->proc_pointer)
        MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
+      if (attr->vtype)
+       MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
+      if (attr->vtab)
+       MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
 
       mio_rparen ();
 
@@ -1897,6 +1911,9 @@ mio_symbol_attribute (symbol_attribute *attr)
            case AB_DIMENSION:
              attr->dimension = 1;
              break;
+           case AB_CODIMENSION:
+             attr->codimension = 1;
+             break;
            case AB_EXTERNAL:
              attr->external = 1;
              break;
@@ -1984,6 +2001,9 @@ mio_symbol_attribute (symbol_attribute *attr)
            case AB_ALLOC_COMP:
              attr->alloc_comp = 1;
              break;
+           case AB_COARRAY_COMP:
+             attr->coarray_comp = 1;
+             break;
            case AB_POINTER_COMP:
              attr->pointer_comp = 1;
              break;
@@ -2002,6 +2022,12 @@ mio_symbol_attribute (symbol_attribute *attr)
            case AB_PROC_POINTER:
              attr->proc_pointer = 1;
              break;
+           case AB_VTYPE:
+             attr->vtype = 1;
+             break;
+           case AB_VTAB:
+             attr->vtab = 1;
+             break;
            }
        }
     }
@@ -2131,9 +2157,10 @@ mio_array_spec (gfc_array_spec **asp)
     }
 
   mio_integer (&as->rank);
+  mio_integer (&as->corank);
   as->type = MIO_NAME (array_type) (as->type, array_spec_types);
 
-  for (i = 0; i < as->rank; i++)
+  for (i = 0; i < as->rank + as->corank; i++)
     {
       mio_expr (&as->lower[i]);
       mio_expr (&as->upper[i]);
@@ -2614,15 +2641,15 @@ done:
 
 
 static void
-mio_constructor (gfc_constructor **cp)
+mio_constructor (gfc_constructor_base *cp)
 {
-  gfc_constructor *c, *tail;
+  gfc_constructor *c;
 
   mio_lparen ();
 
   if (iomode == IO_OUTPUT)
     {
-      for (c = *cp; c; c = c->next)
+      for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c))
        {
          mio_lparen ();
          mio_expr (&c->expr);
@@ -2632,19 +2659,9 @@ mio_constructor (gfc_constructor **cp)
     }
   else
     {
-      *cp = NULL;
-      tail = NULL;
-
       while (peek_atom () != ATOM_RPAREN)
        {
-         c = gfc_get_constructor ();
-
-         if (tail == NULL)
-           *cp = c;
-         else
-           tail->next = c;
-
-         tail = c;
+         c = gfc_constructor_append_expr (cp, NULL, NULL);
 
          mio_lparen ();
          mio_expr (&c->expr);
@@ -4196,6 +4213,9 @@ check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
   if (st_sym == rsym)
     return false;
 
+  if (st_sym->attr.vtab || st_sym->attr.vtype)
+    return false;
+
   /* If the existing symbol is generic from a different module and
      the new symbol is generic there can be no ambiguity.  */
   if (st_sym->attr.generic
@@ -5329,7 +5349,7 @@ create_int_parameter (const char *name, int value, const char *modname,
   sym->attr.flavor = FL_PARAMETER;
   sym->ts.type = BT_INTEGER;
   sym->ts.kind = gfc_default_integer_kind;
-  sym->value = gfc_int_expr (value);
+  sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value);
   sym->attr.use_assoc = 1;
   sym->from_intmod = module;
   sym->intmod_sym_id = id;
@@ -5430,6 +5450,13 @@ use_iso_fortran_env_module (void)
                }
            }
 
+         if (u && gfc_notify_std (symbol[i].standard, "The symbol '%s', "
+                                  "referrenced at %C, is not in the selected "
+                                  "standard", symbol[i].name) == FAILURE)
+           continue;
+         else if ((gfc_option.allow_std & symbol[i].standard) == 0)
+           continue;
+
          if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
              && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
            gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "