gfortran.h (struct gfc_namespace): New member `implicit_loc'.

2008-09-02  Daniel Kraft  <d@domob.eu>

	* gfortran.h (struct gfc_namespace): New member `implicit_loc'.
	(gfc_add_abstract): New method.
	* decl.c (gfc_get_type_attr_spec): Match ABSTRACT attribute.
	(gfc_match_derived_decl): Copy abstract attribute in derived symbol.
	* dump-parse-tree.c (show_attr): Show ABSTRACT attribute as `ABSTRACT'
	only to allow for ABSTRACT types.
	* parse.c (parse_interface): Use new gfc_add_abstract.
	* primary.c (gfc_match_structure_constructor): Check that no ABSTRACT
	type is constructed.
	* resolve.c (resolve_typespec_used): New method.
	(resolve_fl_derived): Check type in respect to ABSTRACT attribute and
	check that no component is of an ABSTRACT type.
	(resolve_symbol): Check that no symbol is of an ABSTRACT type.
	(resolve_types): Check IMPLICIT declarations for ABSTRACT types.
	* symbol.c (gfc_merge_new_implicit): Remember loci of IMPLICIT's.
	(gfc_add_abstract): New method.

2008-09-02  Daniel Kraft  <d@domob.eu>

	* gfortran.dg/abstract_type_1.f90: New test.
	* gfortran.dg/abstract_type_2.f03: New test.
	* gfortran.dg/abstract_type_3.f03: New test.
	* gfortran.dg/abstract_type_4.f03: New test.

From-SVN: r139885

1 files changed, 59 insertions, 0 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 440461c..61053c3 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -82,6 +82,33 @@ gfc_is_formal_arg (void)
   return formal_arg_flag;
 }
 
+
+/* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
+   an ABSTRACT derived-type.  If where is not NULL, an error message with that
+   locus is printed, optionally using name.  */
+
+static gfc_try
+resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
+{
+  if (ts->type == BT_DERIVED && ts->derived->attr.abstract)
+    {
+      if (where)
+	{
+	  if (name)
+	    gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
+		       name, where, ts->derived->name);
+	  else
+	    gfc_error ("ABSTRACT type '%s' used at %L",
+		       ts->derived->name, where);
+	}
+
+      return FAILURE;
+    }
+
+  return SUCCESS;
+}
+
+
 /* Resolve types of formal argument lists.  These have to be done early so that
    the formal argument lists of module procedures can be copied to the
    containing module before the individual procedures are resolved
@@ -8420,8 +8447,21 @@ resolve_fl_derived (gfc_symbol *sym)
   if (super_type && resolve_fl_derived (super_type) == FAILURE)
     return FAILURE;
 
+  /* An ABSTRACT type must be extensible.  */
+  if (sym->attr.abstract && (sym->attr.is_bind_c || sym->attr.sequence))
+    {
+      gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
+		 sym->name, &sym->declared_at);
+      return FAILURE;
+    }
+
   for (c = sym->components; c != NULL; c = c->next)
     {
+      /* Check type-spec if this is not the parent-type component.  */
+      if ((!sym->attr.extension || c != sym->components)
+	  && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
+	return FAILURE;
+
       /* If this type is an extension, see if this component has the same name
 	 as an inherited type-bound procedure.  */
       if (super_type
@@ -9115,6 +9155,13 @@ resolve_symbol (gfc_symbol *sym)
 	  || (a->dummy && a->intent == INTENT_OUT))
 	apply_default_init (sym);
     }
+
+  /* If this symbol has a type-spec, check it.  */
+  if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
+      || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
+    if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
+	  == FAILURE)
+      return;
 }
 
 
@@ -10070,6 +10117,18 @@ resolve_types (gfc_namespace *ns)
 
   gfc_current_ns = ns;
 
+  /* Check that all IMPLICIT types are ok.  */
+  if (!ns->seen_implicit_none)
+    {
+      unsigned letter;
+      for (letter = 0; letter != GFC_LETTERS; ++letter)
+	if (ns->set_flag[letter]
+	    && resolve_typespec_used (&ns->default_type[letter],
+				      &ns->implicit_loc[letter],
+				      NULL) == FAILURE)
+	  return;
+    }
+
   resolve_entries (ns);
 
   resolve_common_vars (ns->blank_common.head, false);