OSDN Git Service

2010-04-29 Janus Weil <janus@gcc.gnu.org>
authorpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Thu, 29 Apr 2010 19:10:48 +0000 (19:10 +0000)
committerMasaki Muranaka <monaka@monami-software.com>
Sun, 23 May 2010 05:37:08 +0000 (14:37 +0900)
PR fortran/43896
* symbol.c (add_proc_component,copy_vtab_proc_comps): Remove
initializers for PPC members of the vtabs.

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

PR fortran/42274
* symbol.c (add_proc_component,add_proc_comps): Correctly set the 'ppc'
attribute for all PPC members of the vtypes.
(copy_vtab_proc_comps): Copy the correct interface.
* trans.h (gfc_trans_assign_vtab_procs): Modified prototype.
* trans-expr.c (gfc_trans_assign_vtab_procs): Pass the derived type as
a dummy argument and make sure all PPC members of the vtab are
initialized correctly.
(gfc_conv_derived_to_class,gfc_trans_class_assign): Additional argument
in call to gfc_trans_assign_vtab_procs.
* trans-stmt.c (gfc_trans_allocate): Ditto.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

PR fortran/43326
* resolve.c (resolve_typebound_function): Renamed
resolve_class_compcall.Do all the detection of class references
here.
(resolve_typebound_subroutine): resolve_class_typebound_call
renamed. Otherwise same as resolve_typebound_function.
(gfc_resolve_expr): Call resolve_typebound_function.
(resolve_code): Call resolve_typebound_subroutine.

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

PR fortran/43492
* resolve.c (resolve_typebound_generic_call): For CLASS methods
pass back the specific symtree name, rather than the target
name.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

PR fortran/42353
* resolve.c (resolve_structure_cons): Make the initializer of
the vtab component 'extends' the same type as the component.

2010-04-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

PR fortran/42680
* interface.c (check_interface1): Pass symbol name rather than NULL to
gfc_compare_interfaces.(gfc_compare_interfaces): Add assert to
trap MULL. (gfc_compare_derived_types): Revert previous change
incorporated incorrectly during merge from trunk, r155778.
* resolve.c (check_generic_tbp_ambiguity): Pass symbol name rather
than NULL to gfc_compare_interfaces.
* symbol.c (add_generic_specifics): Likewise.

2010-02-29  Janus Weil  <janus@gcc.gnu.org>

PR fortran/42353
* interface.c (gfc_compare_derived_types): Add condition for vtype.
* symbol.c (gfc_find_derived_vtab): Sey access to private.
(gfc_find_derived_vtab): Likewise.
* module.c (ab_attribute): Add enumerator AB_VTAB.
(mio_symbol_attribute): Use new attribute, AB_VTAB.
(check_for_ambiguous): Likewise.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>
    Janus Weil  <janus@gcc.gnu.org>

PR fortran/41829
* trans-expr.c (select_class_proc): Remove function.
(conv_function_val): Delete reference to previous.
(gfc_conv_derived_to_class): Add second argument to the call to
gfc_find_derived_vtab.
(gfc_conv_structure): Exclude proc_pointer components when
accessing $data field of class objects.
(gfc_trans_assign_vtab_procs): New function.
(gfc_trans_class_assign): Add second argument to the call to
gfc_find_derived_vtab.
* symbol.c (gfc_build_class_symbol): Add delayed_vtab arg and
implement holding off searching for the vptr derived type.
(add_proc_component): New function.
(add_proc_comps): New function.
(add_procs_to_declared_vtab1): New function.
(copy_vtab_proc_comps): New function.
(add_procs_to_declared_vtab): New function.
(void add_generic_specifics): New function.
(add_generics_to_declared_vtab): New function.
(gfc_find_derived_vtab): Add second argument to the call to
gfc_find_derived_vtab. Add the calls to
add_procs_to_declared_vtab and add_generics_to_declared_vtab.
* decl.c (build_sym, build_struct): Use new arg in calls to
gfc_build_class_symbol.
* gfortran.h : Add vtype bitfield to symbol_attr. Remove the
definition of struct gfc_class_esym_list. Modify prototypes
of gfc_build_class_symbol and gfc_find_derived_vtab.
* trans-stmt.c (gfc_trans_allocate): Add second argument to the
call to gfc_find_derived_vtab.
* module.c : Add the vtype attribute.
* trans.h : Add prototype for gfc_trans_assign_vtab_procs.
* resolve.c (resolve_typebound_generic_call): Add second arg
to pass along the generic name for class methods.
(resolve_typebound_call): The same.
(resolve_compcall): Use the second arg to carry the generic
name from the above. Remove the reference to class_esym.
(check_members, check_class_members, resolve_class_esym,
hash_value_expr): Remove functions.
(resolve_class_compcall, resolve_class_typebound_call): Modify
to use vtable rather than member by member calls.
(gfc_resolve_expr): Modify second arg in call to
resolve_compcall.
(resolve_select_type): Add second arg in call to
gfc_find_derived_vtab.
(resolve_code): Add second arg in call resolve_typebound_call.
(resolve_fl_derived): Exclude vtypes from check for late
procedure definitions. Likewise for checking of explicit
interface and checking of pass arg.
* iresolve.c (gfc_resolve_extends_type_of): Add second arg in
calls to gfc_find_derived_vtab.
* match.c (select_type_set_tmp): Use new arg in call to
gfc_build_class_symbol.
* trans-decl.c (gfc_get_symbol_decl): Complete vtable if
necessary.
* parse.c (endType): Finish incomplete classes.

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

PR fortran/42274
* gfortran.dg/class_16.f03: New test.

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

PR fortran/42274
* gfortran.dg/class_15.f03: New.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

PR fortran/43326
* gfortran.dg/dynamic_dispatch_9.f03: New test.

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

PR fortran/43492
* gfortran.dg/generic_22.f03 : New test.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

PR fortran/42353
* gfortran.dg/class_14.f03: New test.

2010-04-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

PR fortran/42680
* gfortran.dg/interface_32.f90: New test.

2009-04-29  Paul Thomas  <pault@gcc.gnu.org>
    Janus Weil  <janus@gcc.gnu.org>

PR fortran/41829
* gfortran.dg/dynamic_dispatch_5.f03 : Change to "run".
* gfortran.dg/dynamic_dispatch_7.f03 : New test.
* gfortran.dg/dynamic_dispatch_8.f03 : New test.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158910 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/gfortran.h
gcc/fortran/module.c
gcc/fortran/resolve.c
gcc/fortran/symbol.c
gcc/fortran/trans-expr.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/dynamic_dispatch_7.f03

index 5bde472..39368cb 100644 (file)
@@ -1,3 +1,127 @@
+2010-04-29  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/43896
+       * symbol.c (add_proc_component,copy_vtab_proc_comps): Remove
+       initializers for PPC members of the vtabs.
+
+2010-04-29  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/42274
+       * symbol.c (add_proc_component,add_proc_comps): Correctly set the 'ppc'
+       attribute for all PPC members of the vtypes.
+       (copy_vtab_proc_comps): Copy the correct interface.
+       * trans.h (gfc_trans_assign_vtab_procs): Modified prototype.
+       * trans-expr.c (gfc_trans_assign_vtab_procs): Pass the derived type as
+       a dummy argument and make sure all PPC members of the vtab are
+       initialized correctly.
+       (gfc_conv_derived_to_class,gfc_trans_class_assign): Additional argument
+       in call to gfc_trans_assign_vtab_procs.
+       * trans-stmt.c (gfc_trans_allocate): Ditto.
+
+2010-04-29  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/43326
+       * resolve.c (resolve_typebound_function): Renamed
+       resolve_class_compcall.Do all the detection of class references
+       here.
+       (resolve_typebound_subroutine): resolve_class_typebound_call
+       renamed. Otherwise same as resolve_typebound_function.
+       (gfc_resolve_expr): Call resolve_typebound_function.
+       (resolve_code): Call resolve_typebound_subroutine.
+
+2010-04-29  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/43492
+       * resolve.c (resolve_typebound_generic_call): For CLASS methods
+       pass back the specific symtree name, rather than the target
+       name.
+
+2010-04-29  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/42353
+       * resolve.c (resolve_structure_cons): Make the initializer of
+       the vtab component 'extends' the same type as the component.
+
+2010-04-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+       PR fortran/42680
+       * interface.c (check_interface1): Pass symbol name rather than NULL to
+       gfc_compare_interfaces.(gfc_compare_interfaces): Add assert to
+       trap MULL. (gfc_compare_derived_types): Revert previous change
+       incorporated incorrectly during merge from trunk, r155778.
+       * resolve.c (check_generic_tbp_ambiguity): Pass symbol name rather
+       than NULL to gfc_compare_interfaces.
+       * symbol.c (add_generic_specifics): Likewise.
+
+2010-02-29  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/42353
+       * interface.c (gfc_compare_derived_types): Add condition for vtype.
+       * symbol.c (gfc_find_derived_vtab): Sey access to private.
+       (gfc_find_derived_vtab): Likewise.
+       * module.c (ab_attribute): Add enumerator AB_VTAB.
+       (mio_symbol_attribute): Use new attribute, AB_VTAB.
+       (check_for_ambiguous): Likewise.
+
+2010-04-29  Paul Thomas  <pault@gcc.gnu.org>
+           Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/41829
+       * trans-expr.c (select_class_proc): Remove function.
+       (conv_function_val): Delete reference to previous.
+       (gfc_conv_derived_to_class): Add second argument to the call to
+       gfc_find_derived_vtab.
+       (gfc_conv_structure): Exclude proc_pointer components when
+       accessing $data field of class objects.
+       (gfc_trans_assign_vtab_procs): New function.
+       (gfc_trans_class_assign): Add second argument to the call to
+       gfc_find_derived_vtab.
+       * symbol.c (gfc_build_class_symbol): Add delayed_vtab arg and
+       implement holding off searching for the vptr derived type.
+       (add_proc_component): New function.
+       (add_proc_comps): New function.
+       (add_procs_to_declared_vtab1): New function.
+       (copy_vtab_proc_comps): New function.
+       (add_procs_to_declared_vtab): New function.
+       (void add_generic_specifics): New function.
+       (add_generics_to_declared_vtab): New function.
+       (gfc_find_derived_vtab): Add second argument to the call to
+       gfc_find_derived_vtab. Add the calls to
+       add_procs_to_declared_vtab and add_generics_to_declared_vtab.
+       * decl.c (build_sym, build_struct): Use new arg in calls to
+       gfc_build_class_symbol.
+       * gfortran.h : Add vtype bitfield to symbol_attr. Remove the
+       definition of struct gfc_class_esym_list. Modify prototypes
+       of gfc_build_class_symbol and gfc_find_derived_vtab.
+       * trans-stmt.c (gfc_trans_allocate): Add second argument to the
+       call to gfc_find_derived_vtab.
+       * module.c : Add the vtype attribute.
+       * trans.h : Add prototype for gfc_trans_assign_vtab_procs.
+       * resolve.c (resolve_typebound_generic_call): Add second arg
+       to pass along the generic name for class methods.
+       (resolve_typebound_call): The same.
+       (resolve_compcall): Use the second arg to carry the generic
+       name from the above. Remove the reference to class_esym.
+       (check_members, check_class_members, resolve_class_esym,
+       hash_value_expr): Remove functions.
+       (resolve_class_compcall, resolve_class_typebound_call): Modify
+       to use vtable rather than member by member calls.
+       (gfc_resolve_expr): Modify second arg in call to
+       resolve_compcall.
+       (resolve_select_type): Add second arg in call to
+       gfc_find_derived_vtab.
+       (resolve_code): Add second arg in call resolve_typebound_call.
+       (resolve_fl_derived): Exclude vtypes from check for late
+       procedure definitions. Likewise for checking of explicit
+       interface and checking of pass arg.
+       * iresolve.c (gfc_resolve_extends_type_of): Add second arg in
+       calls to gfc_find_derived_vtab.
+       * match.c (select_type_set_tmp): Use new arg in call to
+       gfc_build_class_symbol.
+       * trans-decl.c (gfc_get_symbol_decl): Complete vtable if
+       necessary.
+       * parse.c (endType): Finish incomplete classes.
+
 2010-04-28  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/18918
index e740e74..11ce974 100644 (file)
@@ -2312,7 +2312,7 @@ int get_c_kind (const char *, CInteropKind_t *);
 
 /* options.c */
 unsigned int gfc_init_options (unsigned int, const char **);
-int gfc_handle_option (size_t, const char *, int, int);
+int gfc_handle_option (size_t, const char *, int);
 bool gfc_post_options (const char **);
 
 /* f95-lang.c */
@@ -2514,11 +2514,22 @@ void gfc_free_dt_list (void);
 gfc_gsymbol *gfc_get_gsymbol (const char *);
 gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
 
+gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
+                               gfc_array_spec **, bool);
+gfc_symbol *gfc_find_derived_vtab (gfc_symbol *, bool);
 gfc_typebound_proc* gfc_get_typebound_proc (void);
 gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
 gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*);
 bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *);
 bool gfc_type_compatible (gfc_typespec *, gfc_typespec *);
+gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
+                                     const char*, bool, locus*);
+gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
+                                        const char*, bool, locus*);
+gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*,
+                                                    gfc_intrinsic_op, bool,
+                                                    locus*);
+gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
 
 void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *);
 void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
@@ -2528,8 +2539,8 @@ void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too  */
 
 gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus);
 
-/* intrinsic.c -- true if working in an init-expr, false otherwise.  */
-extern bool gfc_init_expr_flag;
+/* intrinsic.c */
+extern int gfc_init_expr;
 
 /* Given a symbol that we have decided is intrinsic, mark it as such
    by placing it into a special module that is otherwise impossible to
@@ -2584,6 +2595,7 @@ gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
 const char *gfc_extract_int (gfc_expr *, int *);
 bool is_subref_array (gfc_expr *);
 
+void gfc_add_component_ref (gfc_expr *, const char *);
 gfc_expr *gfc_build_conversion (gfc_expr *);
 void gfc_free_ref_list (gfc_ref *);
 void gfc_type_convert_binary (gfc_expr *, int);
@@ -2774,19 +2786,4 @@ int gfc_is_data_pointer (gfc_expr *);
 /* check.c */
 gfc_try gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*);
 
-/* class.c */
-void gfc_add_component_ref (gfc_expr *, const char *);
-gfc_expr *gfc_class_null_initializer (gfc_typespec *);
-gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
-                               gfc_array_spec **, bool);
-gfc_symbol *gfc_find_derived_vtab (gfc_symbol *, bool);
-gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
-                                     const char*, bool, locus*);
-gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
-                                        const char*, bool, locus*);
-gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*,
-                                                    gfc_intrinsic_op, bool,
-                                                    locus*);
-gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
-
 #endif /* GCC_GFORTRAN_H  */
index ff20491..a419d6b 100644 (file)
@@ -1674,7 +1674,7 @@ typedef enum
   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_CODIMENSION,
-  AB_COARRAY_COMP
+  AB_COARRAY_COMP, AB_VTYPE, AB_VTAB
 }
 ab_attribute;
 
index 12c694a..93c5b48 100644 (file)
@@ -1882,13 +1882,12 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
      
       /* Non-assumed length character functions.  */
       if (sym->attr.function && sym->ts.type == BT_CHARACTER
-           && gsym->ns->proc_name->ts.u.cl != NULL
-           && gsym->ns->proc_name->ts.u.cl->length != NULL)
+         && gsym->ns->proc_name->ts.u.cl->length != NULL)
        {
          gfc_charlen *cl = sym->ts.u.cl;
 
          if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
-                && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
+              && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
            {
               gfc_error ("Nonconstant character-length function '%s' at %L "
                         "must have an explicit interface", sym->name,
@@ -5254,7 +5253,7 @@ resolve_typebound_call (gfc_code* c, const char **name)
 
 /* Resolve a component-call expression.  */
 static gfc_try
-resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
+resolve_compcall (gfc_expr* e, const char **name)
 {
   gfc_actual_arglist* newactual;
   gfc_symtree* target;
@@ -5300,163 +5299,10 @@ resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
   e->ts = target->n.sym->ts;
   e->expr_type = EXPR_FUNCTION;
 
-  /* Resolution is not necessary when constructing component calls
-     for class members, since this must only be done for the
-     declared type, which is done afterwards.  */
-  return !class_members ? gfc_resolve_expr (e) : SUCCESS;
-}
-
-
-/* Resolve a typebound call for the members in a class.  This group of
-   functions implements dynamic dispatch in the provisional version
-   of f03 OOP.  As soon as vtables are in place and contain pointers
-   to methods, this will no longer be necessary.  */
-static gfc_expr *list_e;
-static gfc_try check_class_members (gfc_symbol *);
-static gfc_try class_try;
-static bool fcn_flag;
-
-
-static void
-check_members (gfc_symbol *derived)
-{
-  if (derived->attr.flavor == FL_DERIVED)
-    (void) check_class_members (derived);
-}
-
-
-static gfc_try 
-check_class_members (gfc_symbol *derived)
-{
-  gfc_expr *e;
-  gfc_symtree *tbp;
-  gfc_class_esym_list *etmp;
-
-  e = gfc_copy_expr (list_e);
-
-  tbp = gfc_find_typebound_proc (derived, &class_try,
-                                e->value.compcall.name,
-                                false, &e->where);
-
-  if (tbp == NULL)
-    {
-      gfc_error ("no typebound available procedure named '%s' at %L",
-                e->value.compcall.name, &e->where);
-      return FAILURE;
-    }
-
-  /* If we have to match a passed class member, force the actual
-      expression to have the correct type.  */
-  if (!tbp->n.tb->nopass)
-    {
-      if (e->value.compcall.base_object == NULL)
-       e->value.compcall.base_object = extract_compcall_passed_object (e);
-
-      if (e->value.compcall.base_object == NULL)
-       return FAILURE;
-
-      if (!derived->attr.abstract)
-       {
-         e->value.compcall.base_object->ts.type = BT_DERIVED;
-         e->value.compcall.base_object->ts.u.derived = derived;
-       }
-    }
-
-  e->value.compcall.tbp = tbp->n.tb;
-  e->value.compcall.name = tbp->name;
-
-  /* Let the original expresssion catch the assertion in
-     resolve_compcall, since this flag does not appear to be reset or
-     copied in some systems.  */
-  e->value.compcall.assign = 0;
-
-  /* Do the renaming, PASSing, generic => specific and other
-     good things for each class member.  */
-  class_try = (resolve_compcall (e, fcn_flag, true) == SUCCESS)
-                               ? class_try : FAILURE;
-
-  /* Now transfer the found symbol to the esym list.  */
-  if (class_try == SUCCESS)
-    {
-      etmp = list_e->value.function.class_esym;
-      list_e->value.function.class_esym
-               = gfc_get_class_esym_list();
-      list_e->value.function.class_esym->next = etmp;
-      list_e->value.function.class_esym->derived = derived;
-      list_e->value.function.class_esym->esym
-               = e->value.function.esym;
-    }
-
-  gfc_free_expr (e);
-  
-  /* Burrow down into grandchildren types.  */
-  if (derived->f2k_derived)
-    gfc_traverse_ns (derived->f2k_derived, check_members);
-
-  return SUCCESS;
-}
-
-
-/* Eliminate esym_lists where all the members point to the
-   typebound procedure of the declared type; ie. one where
-   type selection has no effect..  */
-static void
-resolve_class_esym (gfc_expr *e)
-{
-  gfc_class_esym_list *p, *q;
-  bool empty = true;
-
-  gcc_assert (e && e->expr_type == EXPR_FUNCTION);
-
-  p = e->value.function.class_esym;
-  if (p == NULL)
-    return;
-
-  for (; p; p = p->next)
-    empty = empty && (e->value.function.esym == p->esym);
-
-  if (empty)
-    {
-      p = e->value.function.class_esym;
-      for (; p; p = q)
-       {
-         q = p->next;
-         gfc_free (p);
-       }
-      e->value.function.class_esym = NULL;
-   }
-}
-
-
-/* Generate an expression for the hash value, given the reference to
-   the class of the final expression (class_ref), the base of the
-   full reference list (new_ref), the declared type and the class
-   object (st).  */
-static gfc_expr*
-hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st)
-{
-  gfc_expr *hash_value;
-
-  /* Build an expression for the correct hash_value; ie. that of the last
-     CLASS reference.  */
-  if (class_ref)
-    {
-      class_ref->next = NULL;
-    }
-  else
-    {
-      gfc_free_ref_list (new_ref);
-      new_ref = NULL;
-    }
-  hash_value = gfc_get_expr ();
-  hash_value->expr_type = EXPR_VARIABLE;
-  hash_value->symtree = st;
-  hash_value->symtree->n.sym->refs++;
-  hash_value->ref = new_ref;
-  gfc_add_component_ref (hash_value, "$vptr");
-  gfc_add_component_ref (hash_value, "$hash");
-
-  return hash_value;
+  /* Resolution is not necessary if this is a class subroutine; this
+     function only has to identify the specific proc. Resolution of
+     the call will be done next in resolve_typebound_call.  */
+  return gfc_resolve_expr (e);
 }
 
 
@@ -5496,11 +5342,6 @@ get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
 /* Resolve a typebound function, or 'method'. First separate all
    the non-CLASS references by calling resolve_compcall directly.  */
 
-/* Resolve a typebound function, or 'method'.  First separate all
-   the non-CLASS references by calling resolve_compcall directly.
-   Then treat the CLASS references by resolving for each of the class
-   members in turn.  */
-
 static gfc_try
 resolve_typebound_function (gfc_expr* e)
 {
@@ -5515,17 +5356,17 @@ resolve_typebound_function (gfc_expr* e)
 
   st = e->symtree;
   if (st == NULL)
-    return resolve_compcall (e, true, false);
+    return resolve_compcall (e, NULL);
 
   /* Get the CLASS declared type.  */
   declared = get_declared_from_expr (&class_ref, &new_ref, e);
 
   /* Weed out cases of the ultimate component being a derived type.  */
   if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
-       || (!class_ref && st->n.sym->ts.type != BT_CLASS))
+        || (!class_ref && st->n.sym->ts.type != BT_CLASS))
     {
       gfc_free_ref_list (new_ref);
-      return resolve_compcall (e, true, false);
+      return resolve_compcall (e, NULL);
     }
 
   c = gfc_find_component (declared, "$data", true, true);
@@ -5536,16 +5377,14 @@ resolve_typebound_function (gfc_expr* e)
   if (e->value.compcall.tbp->is_generic)
     genname = e->value.compcall.name;
 
-  /* Resolve the function call for each member of the class.  */
-  class_try = SUCCESS;
-  fcn_flag = true;
-  list_e = gfc_copy_expr (e);
+  /* Treat the call as if it is a typebound procedure, in order to roll
+     out the correct name for the specific function.  */
+  resolve_compcall (e, &name);
+  ts = e->ts;
 
-  if (check_class_members (derived) == FAILURE)
-    return FAILURE;
-
-  class_try = (resolve_compcall (e, true, false) == SUCCESS)
-                ? class_try : FAILURE;
+  /* Then convert the expression to a procedure pointer component call.  */
+  e->value.function.esym = NULL;
+  e->symtree = st;
 
   if (class_ref)  
     {
@@ -5574,10 +5413,9 @@ resolve_typebound_function (gfc_expr* e)
   return SUCCESS;
 }
 
-/* Resolve a typebound subroutine, or 'method'.  First separate all
-   the non-CLASS references by calling resolve_typebound_call directly.
-   Then treat the CLASS references by resolving for each of the class
-   members in turn.  */
+/* Resolve a typebound subroutine, or 'method'. First separate all
+   the non-CLASS references by calling resolve_typebound_call
+   directly.  */
 
 static gfc_try
 resolve_typebound_subroutine (gfc_code *code)
@@ -5593,14 +5431,14 @@ resolve_typebound_subroutine (gfc_code *code)
 
   st = code->expr1->symtree;
   if (st == NULL)
-    return resolve_typebound_call (code);
+    return resolve_typebound_call (code, NULL);
 
   /* Get the CLASS declared type.  */
   declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
 
   /* Weed out cases of the ultimate component being a derived type.  */
   if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
-       || (!class_ref && st->n.sym->ts.type != BT_CLASS))
+        || (!class_ref && st->n.sym->ts.type != BT_CLASS))
     {
       gfc_free_ref_list (new_ref);
       return resolve_typebound_call (code, NULL);
@@ -5614,12 +5452,8 @@ resolve_typebound_subroutine (gfc_code *code)
   if (code->expr1->value.compcall.tbp->is_generic)
     genname = code->expr1->value.compcall.name;
 
-  class_try = SUCCESS;
-  fcn_flag = false;
-  list_e = gfc_copy_expr (code->expr1);
-
-  if (check_class_members (derived) == FAILURE)
-    return FAILURE;
+  resolve_typebound_call (code, &name);
+  ts = code->expr1->ts;
 
   /* Then convert the expression to a procedure pointer component call.  */
   code->expr1->value.function.esym = NULL;
@@ -6562,23 +6396,7 @@ check_symbols:
                         "itself allocated", sym->name, &ar->where);
              goto failure;
            }
-         break;
        }
-
-      if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
-         && ar->stride[i] == NULL)
-       break;
-
-      gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
-                &e->where);
-      goto failure;
-    }
-
-  if (codimension && ar->as->rank == 0)
-    {
-      gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
-                "at %L", &e->where);
-      goto failure;
     }
 
   for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
@@ -6929,9 +6747,8 @@ validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
       return FAILURE;
     }
 
-  /* Convert the case value kind to that of case expression kind,
-     if needed */
-
+  /* Convert the case value kind to that of case expression kind, if needed.
+     FIXME:  Should a warning be issued?  */
   if (e->ts.kind != case_expr->ts.kind)
     gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
 
@@ -7017,31 +6834,6 @@ resolve_select (gfc_code *code)
       return;
     }
 
-
-  /* Raise a warning if an INTEGER case value exceeds the range of
-     the case-expr. Later, all expressions will be promoted to the
-     largest kind of all case-labels.  */
-
-  if (type == BT_INTEGER)
-    for (body = code->block; body; body = body->block)
-      for (cp = body->ext.case_list; cp; cp = cp->next)
-       {
-         if (cp->low
-             && gfc_check_integer_range (cp->low->value.integer,
-                                         case_expr->ts.kind) != ARITH_OK)
-           gfc_warning ("Expression in CASE statement at %L is "
-                        "not in the range of %s", &cp->low->where,
-                        gfc_typename (&case_expr->ts));
-
-         if (cp->high
-             && cp->low != cp->high
-             && gfc_check_integer_range (cp->high->value.integer,
-                                         case_expr->ts.kind) != ARITH_OK)
-           gfc_warning ("Expression in CASE statement at %L is "
-                        "not in the range of %s", &cp->high->where,
-                        gfc_typename (&case_expr->ts));
-       }
-
   /* PR 19168 has a long discussion concerning a mismatch of the kinds
      of the SELECT CASE expression and its CASE values.  Walk the lists
      of case values, and if we find a mismatch, promote case_expr to
@@ -7064,6 +6856,7 @@ resolve_select (gfc_code *code)
                  && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0)
                continue;
 
+             /* FIXME: Should a warning be issued?  */
              if (cp->low != NULL
                  && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
                gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
@@ -7114,8 +6907,8 @@ resolve_select (gfc_code *code)
 
          /* Deal with single value cases and case ranges.  Errors are
             issued from the validation function.  */
-         if (validate_case_label_expr (cp->low, case_expr) != SUCCESS
-             || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
+         if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
+            || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
            {
              t = FAILURE;
              break;
@@ -7137,7 +6930,7 @@ resolve_select (gfc_code *code)
              value = cp->low->value.logical == 0 ? 2 : 1;
              if (value & seen_logical)
                {
-                 gfc_error ("Constant logical value in CASE statement "
+                 gfc_error ("constant logical value in CASE statement "
                             "is repeated at %L",
                             &cp->low->where);
                  t = FAILURE;
@@ -7285,21 +7078,8 @@ resolve_select_type (gfc_code *code)
   ns = code->ext.ns;
   gfc_resolve (ns);
 
-  /* Check for F03:C813.  */
-  if (code->expr1->ts.type != BT_CLASS
-      && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
-    {
-      gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
-                "at %L", &code->loc);
-      return;
-    }
-
   if (code->expr2)
-    {
-      if (code->expr1->symtree->n.sym->attr.untyped)
-       code->expr1->symtree->n.sym->ts = code->expr2->ts;
-      selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
-    }
+    selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
   else
     selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
 
@@ -9325,29 +9105,6 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
          return FAILURE;
         }
     }
-
-  /* Constraints on polymorphic variables.  */
-  if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
-    {
-      /* F03:C502.  */
-      if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
-       {
-         gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
-                    sym->ts.u.derived->components->ts.u.derived->name,
-                    sym->name, &sym->declared_at);
-         return FAILURE;
-       }
-
-      /* F03:C509.  */
-      /* Assume that use associated symbols were checked in the module ns.  */ 
-      if (!sym->attr.class_ok && !sym->attr.use_assoc)
-       {
-         gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
-                    "or pointer", sym->name, &sym->declared_at);
-         return FAILURE;
-       }
-    }
-    
   return SUCCESS;
 }
 
@@ -9399,6 +9156,27 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
                         &sym->declared_at) == FAILURE)
     return FAILURE;
 
+  if (sym->ts.type == BT_CLASS)
+    {
+      /* C502.  */
+      if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
+       {
+         gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
+                    sym->ts.u.derived->components->ts.u.derived->name,
+                    sym->name, &sym->declared_at);
+         return FAILURE;
+       }
+
+      /* C509.  */
+      /* Assume that use associated symbols were checked in the module ns.  */ 
+      if (!sym->attr.class_ok && !sym->attr.use_assoc)
+       {
+         gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
+                    "or pointer", sym->name, &sym->declared_at);
+         return FAILURE;
+       }
+    }
+
   /* Assign default initializer.  */
   if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
       && (!no_init_flag || sym->attr.intent == INTENT_OUT))
@@ -11016,7 +10794,7 @@ resolve_fl_derived (gfc_symbol *sym)
       
       /* If this type is an extension, see if this component has the same name
         as an inherited type-bound procedure.  */
-      if (super_type && !sym->attr.is_class
+      if (super_type
          && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
        {
          gfc_error ("Component '%s' of '%s' at %L has the same name as an"
@@ -11063,7 +10841,7 @@ resolve_fl_derived (gfc_symbol *sym)
            }
        }
 
-      if (!sym->attr.is_class && c->ts.type == BT_DERIVED && c->attr.pointer
+      if (c->ts.type == BT_DERIVED && c->attr.pointer
          && c->ts.u.derived->components == NULL
          && !c->ts.u.derived->attr.zero_comp)
        {
@@ -11073,16 +10851,6 @@ resolve_fl_derived (gfc_symbol *sym)
          return FAILURE;
        }
 
-      if (c->ts.type == BT_CLASS && c->ts.u.derived->components->attr.pointer
-         && c->ts.u.derived->components->ts.u.derived->components == NULL
-         && !c->ts.u.derived->components->ts.u.derived->attr.zero_comp)
-       {
-         gfc_error ("The pointer component '%s' of '%s' at %L is a type "
-                    "that has not been declared", c->name, sym->name,
-                    &c->loc);
-         return FAILURE;
-       }
-
       /* C437.  */
       if (c->ts.type == BT_CLASS
          && !(c->ts.u.derived->components->attr.pointer
@@ -11314,10 +11082,6 @@ resolve_symbol (gfc_symbol *sym)
   gfc_namespace *ns;
   gfc_component *c;
 
-  /* Avoid double resolution of function result symbols.  */
-  if ((sym->result || sym->attr.result) && (sym->ns != gfc_current_ns))
-    return;
-  
   if (sym->attr.flavor == FL_UNKNOWN)
     {
 
@@ -12007,14 +11771,11 @@ check_data_variable (gfc_data_variable *var, locus *where)
              mpz_set_ui (size, 0);
            }
 
-         t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
-                                          offset, range);
+         gfc_assign_data_value_range (var->expr, values.vnode->expr,
+                                      offset, range);
 
          mpz_add (offset, offset, range);
          mpz_clear (range);
-
-         if (t == FAILURE)
-           break;
        }
 
       /* Assign initial value to symbol.  */
@@ -12063,7 +11824,6 @@ traverse_data_list (gfc_data_variable *var, locus *where)
   gfc_try retval = SUCCESS;
 
   mpz_init (frame.value);
-  mpz_init (trip);
 
   start = gfc_copy_expr (var->iter.start);
   end = gfc_copy_expr (var->iter.end);
@@ -12072,29 +11832,26 @@ traverse_data_list (gfc_data_variable *var, locus *where)
   if (gfc_simplify_expr (start, 1) == FAILURE
       || start->expr_type != EXPR_CONSTANT)
     {
-      gfc_error ("start of implied-do loop at %L could not be "
-                "simplified to a constant value", &start->where);
+      gfc_error ("iterator start at %L does not simplify", &start->where);
       retval = FAILURE;
       goto cleanup;
     }
   if (gfc_simplify_expr (end, 1) == FAILURE
       || end->expr_type != EXPR_CONSTANT)
     {
-      gfc_error ("end of implied-do loop at %L could not be "
-                "simplified to a constant value", &start->where);
+      gfc_error ("iterator end at %L does not simplify", &end->where);
       retval = FAILURE;
       goto cleanup;
     }
   if (gfc_simplify_expr (step, 1) == FAILURE
       || step->expr_type != EXPR_CONSTANT)
     {
-      gfc_error ("step of implied-do loop at %L could not be "
-                "simplified to a constant value", &start->where);
+      gfc_error ("iterator step at %L does not simplify", &step->where);
       retval = FAILURE;
       goto cleanup;
     }
 
-  mpz_set (trip, end->value.integer);
+  mpz_init_set (trip, end->value.integer);
   mpz_sub (trip, trip, start->value.integer);
   mpz_add (trip, trip, step->value.integer);
 
@@ -12110,6 +11867,7 @@ traverse_data_list (gfc_data_variable *var, locus *where)
     {
       if (traverse_data_var (var->list, where) == FAILURE)
        {
+         mpz_clear (trip);
          retval = FAILURE;
          goto cleanup;
        }
@@ -12118,6 +11876,7 @@ traverse_data_list (gfc_data_variable *var, locus *where)
       if (gfc_simplify_expr (e, 1) == FAILURE)
        {
          gfc_free_expr (e);
+         mpz_clear (trip);
          retval = FAILURE;
          goto cleanup;
        }
@@ -12127,9 +11886,9 @@ traverse_data_list (gfc_data_variable *var, locus *where)
       mpz_sub_ui (trip, trip, 1);
     }
 
+  mpz_clear (trip);
 cleanup:
   mpz_clear (frame.value);
-  mpz_clear (trip);
 
   gfc_free_expr (start);
   gfc_free_expr (end);
index 4356845..b19714c 100644 (file)
@@ -4708,7 +4708,7 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
 
 gfc_try
 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
-                       gfc_array_spec **as)
+                       gfc_array_spec **as, bool delayed_vtab)
 {
   char name[GFC_MAX_SYMBOL_LEN + 5];
   gfc_symbol *fclass;
@@ -4763,9 +4763,14 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
        return FAILURE;
       c->ts.type = BT_DERIVED;
-      vtab = gfc_find_derived_vtab (ts->u.derived);
-      gcc_assert (vtab);
-      c->ts.u.derived = vtab->ts.u.derived;
+      if (delayed_vtab)
+       c->ts.u.derived = NULL;
+      else
+       {
+         vtab = gfc_find_derived_vtab (ts->u.derived, false);
+         gcc_assert (vtab);
+         c->ts.u.derived = vtab->ts.u.derived;
+       }
       c->attr.pointer = 1;
     }
 
@@ -4787,10 +4792,344 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 }
 
 
-/* Find the symbol for a derived type's vtab.  */
+static void
+add_proc_component (gfc_component *c, gfc_symbol *vtype,
+                   gfc_symtree *st, gfc_symbol *specific,
+                   bool is_generic, bool is_generic_specific)
+{
+  /* Add procedure component.  */
+  if (is_generic)
+    {
+      if (gfc_add_component (vtype, specific->name, &c) == FAILURE)
+       return;
+      c->ts.interface = specific;
+    }
+  else if (c && is_generic_specific)
+    {
+      c->ts.interface = st->n.tb->u.specific->n.sym;
+    }
+  else
+    {
+      c = gfc_find_component (vtype, st->name, true, true);
+      if (!c && gfc_add_component (vtype, st->name, &c) == FAILURE)
+       return;
+      c->ts.interface = st->n.tb->u.specific->n.sym;
+    }
+
+  if (!c->tb)
+    c->tb = XCNEW (gfc_typebound_proc);
+  *c->tb = *st->n.tb;
+  c->tb->ppc = 1;
+  c->attr.procedure = 1;
+  c->attr.proc_pointer = 1;
+  c->attr.flavor = FL_PROCEDURE;
+  c->attr.access = ACCESS_PRIVATE;
+  c->attr.external = 1;
+  c->attr.untyped = 1;
+  c->attr.if_source = IFSRC_IFBODY;
+
+  /* A static initializer cannot be used here because the specific
+     function is not a constant; internal compiler error: in
+     output_constant, at varasm.c:4623  */
+  c->initializer = NULL;
+}
+
+
+static void
+add_proc_comps (gfc_component *c, gfc_symbol *vtype,
+               gfc_symtree *st, bool is_generic)
+{
+  if (c == NULL && !is_generic)
+    {
+      add_proc_component (c, vtype, st, NULL, false, false);
+    }
+  else if (is_generic && st->n.tb && vtype->components == NULL)
+    {
+      gfc_tbp_generic* g;
+      gfc_symbol * specific;
+      for (g = st->n.tb->u.generic; g; g = g->next)
+       {
+         if (!g->specific)
+           continue;
+         specific = g->specific->u.specific->n.sym;
+         add_proc_component (NULL, vtype, st, specific, true, false);
+       }
+    }
+  else if (c->attr.proc_pointer && c->tb)
+    {
+      *c->tb = *st->n.tb;
+      c->tb->ppc = 1;
+      c->ts.interface = st->n.tb->u.specific->n.sym;     
+    }
+}
+
+static void
+add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype,
+                            bool resolved)
+{
+  gfc_component *c;
+  gfc_symbol *generic;
+  char name[3 * GFC_MAX_SYMBOL_LEN + 10];
+
+  if (!st)
+    return;
+
+  if (st->left)
+    add_procs_to_declared_vtab1 (st->left, vtype, resolved);
+
+  if (st->right)
+    add_procs_to_declared_vtab1 (st->right, vtype, resolved);
+
+  if (!st->n.tb)
+    return;
+
+  if (!st->n.tb->is_generic && st->n.tb->u.specific)
+    {
+      c = gfc_find_component (vtype, st->name, true, true);
+      add_proc_comps (c, vtype, st, false);
+    }
+  else if (st->n.tb->is_generic)
+    {
+      c = gfc_find_component (vtype, st->name, true, true);
+
+      if (c == NULL)
+       {
+         /* Add derived type component with generic name.  */
+         if (gfc_add_component (vtype, st->name, &c) == FAILURE)
+           return;
+         c->ts.type = BT_DERIVED;
+         c->attr.flavor = FL_VARIABLE;
+         c->attr.pointer = 1;
+
+         /* Add a special empty derived type as a placeholder.  */
+         sprintf (name, "$empty");
+         gfc_find_symbol (name, vtype->ns, 0, &generic);
+         if (generic == NULL)
+           {
+             gfc_get_symbol (name, vtype->ns, &generic);
+             generic->attr.flavor = FL_DERIVED;
+             generic->refs++;
+             gfc_set_sym_referenced (generic);
+             generic->ts.type = BT_UNKNOWN;
+             generic->attr.zero_comp = 1;
+           }
+
+         c->ts.u.derived = generic;
+       }
+    }
+}
+
+
+static void
+copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype,
+                     bool resolved)
+{
+  gfc_component *c, *cmp;
+  gfc_symbol *vtab;
+
+  vtab = gfc_find_derived_vtab (declared, resolved);
+
+  for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
+    {
+      if (gfc_find_component (vtype, cmp->name, true, true))
+       continue;
+
+      if (gfc_add_component (vtype, cmp->name, &c) == FAILURE)
+       return;
+
+      if (cmp->ts.type == BT_DERIVED)
+       {
+         c->ts = cmp->ts;
+         c->ts.u.derived = cmp->ts.u.derived;
+         c->attr.flavor = FL_VARIABLE;
+         c->attr.pointer = 1;
+         c->initializer = NULL;
+         continue;
+       }
+
+      c->tb = XCNEW (gfc_typebound_proc);
+      *c->tb = *cmp->tb;
+      c->attr.procedure = 1;
+      c->attr.proc_pointer = 1;
+      c->attr.flavor = FL_PROCEDURE;
+      c->attr.access = ACCESS_PRIVATE;
+      c->attr.external = 1;
+      c->ts.interface = cmp->ts.interface;
+      c->attr.untyped = 1;
+      c->attr.if_source = IFSRC_IFBODY;
+      c->initializer = NULL;
+    }
+}
+
+static void
+add_procs_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
+                           gfc_symbol *derived, bool resolved)
+{
+  gfc_symbol* super_type;
+
+  super_type = gfc_get_derived_super_type (declared);
+
+  if (super_type && (super_type != declared))
+    add_procs_to_declared_vtab (super_type, vtype, derived, resolved);
+
+  if (declared != derived)
+    copy_vtab_proc_comps (declared, vtype, resolved);
+
+  if (declared->f2k_derived && declared->f2k_derived->tb_sym_root)
+    add_procs_to_declared_vtab1 (declared->f2k_derived->tb_sym_root,
+                                vtype, resolved);
+
+  if (declared->f2k_derived && declared->f2k_derived->tb_uop_root)
+    add_procs_to_declared_vtab1 (declared->f2k_derived->tb_uop_root,
+                                vtype, resolved);
+}
+
+
+static
+void add_generic_specifics (gfc_symbol *declared, gfc_symbol *vtab,
+                           const char *name)
+{
+  gfc_tbp_generic* g;
+  gfc_symbol * specific1;
+  gfc_symbol * specific2;
+  gfc_symtree *st = NULL;
+  gfc_component *c;
+
+  /* Find the generic procedure using the component name.  */
+  st = gfc_find_typebound_proc (declared, NULL, name, true, NULL);
+  if (st == NULL)
+    st = gfc_find_typebound_user_op (declared, NULL, name, true, NULL);
+
+  if (st == NULL)
+    return;
+
+  /* Add procedure pointer components for the specific procedures. */
+  for (g = st->n.tb->u.generic; g; g = g->next)
+    {
+      if (!g->specific)
+       continue;
+      specific1 = g->specific_st->n.tb->u.specific->n.sym;
+
+      c = vtab->ts.u.derived->components;
+      specific2 = NULL;
+
+      /* Override identical specific interface.  */
+      if (vtab->ts.u.derived->components)
+       {
+         for (; c; c= c->next)
+           {
+             specific2 = c->ts.interface;
+             if (gfc_compare_interfaces (specific2, specific1,
+                                         specific1->name, 0, 0, NULL, 0))
+               break;
+           }
+       }
+
+      add_proc_component (c, vtab->ts.u.derived, g->specific_st,
+                         NULL, false, true);
+      vtab->ts.u.derived->attr.zero_comp = 0;
+    }
+}
+
+
+static void
+add_generics_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
+                              gfc_symbol *derived, bool resolved)
+{
+  gfc_component *cmp;
+  gfc_symtree *st = NULL;
+  gfc_symbol * vtab;
+  char name[2 * GFC_MAX_SYMBOL_LEN + 8];
+  gfc_symbol* super_type;
+
+  gcc_assert (resolved);
+
+  for (cmp = vtype->components; cmp; cmp = cmp->next)
+    {
+      if (cmp->ts.type != BT_DERIVED)
+       continue;
+
+      /* The only derived type that does not represent a generic
+        procedure is the pointer to the parent vtab.  */
+      if (cmp->ts.u.derived
+           && strcmp (cmp->ts.u.derived->name, "$extends") == 0)
+       continue;
+
+      /* Find the generic procedure using the component name.  */
+      st = gfc_find_typebound_proc (declared, NULL, cmp->name,
+                                   true, NULL);
+      if (st == NULL)
+       st = gfc_find_typebound_user_op (declared, NULL, cmp->name,
+                                        true, NULL);
+
+      /* Should be an error but we pass on it for now.  */
+      if (st == NULL || !st->n.tb->is_generic)
+       continue;
+
+      vtab = NULL;
+
+      /* Build a vtab and a special vtype, with only the procedure
+        pointer fields, to carry the pointers to the specific
+        procedures.  Should this name ever be changed, the same
+        should be done in trans-expr.c(gfc_trans_assign_vtab_procs). */
+      sprintf (name, "vtab$%s$%s", vtype->name, cmp->name);
+      gfc_find_symbol (name, derived->ns, 0, &vtab);
+      if (vtab == NULL)
+       {
+         gfc_get_symbol (name, derived->ns, &vtab);
+         vtab->ts.type = BT_DERIVED;
+         vtab->attr.flavor = FL_VARIABLE;
+         vtab->attr.target = 1;
+         vtab->attr.save = SAVE_EXPLICIT;
+         vtab->attr.vtab = 1;
+         vtab->refs++;
+         gfc_set_sym_referenced (vtab);
+         sprintf (name, "%s$%s", vtype->name, cmp->name);
+         
+         gfc_find_symbol (name, derived->ns, 0, &cmp->ts.u.derived);
+         if (cmp->ts.u.derived == NULL
+               || (strcmp (cmp->ts.u.derived->name, "$empty") == 0))
+           {
+             gfc_get_symbol (name, derived->ns, &cmp->ts.u.derived);
+             if (gfc_add_flavor (&cmp->ts.u.derived->attr, FL_DERIVED,
+                                 NULL, &gfc_current_locus) == FAILURE)
+               return;
+             cmp->ts.u.derived->refs++;
+             gfc_set_sym_referenced (cmp->ts.u.derived);
+             cmp->ts.u.derived->attr.vtype = 1;
+             cmp->ts.u.derived->attr.zero_comp = 1;
+           }
+         vtab->ts.u.derived = cmp->ts.u.derived;
+       }
+
+      /* Store this for later use in setting the pointer.  */
+      cmp->ts.interface = vtab;
+
+      if (vtab->ts.u.derived->components)
+       continue;
+
+      super_type = gfc_get_derived_super_type (declared);
+
+      if (super_type && (super_type != declared))
+       add_generic_specifics (super_type, vtab, cmp->name);
+
+      add_generic_specifics (declared, vtab, cmp->name);
+    }
+}
+
+
+/* Find the symbol for a derived type's vtab.  A vtab has the following
+   fields:
+   $hash       a hash value used to identify the derived type
+   $size       the size in bytes of the derived type
+   $extends    a pointer to the vtable of the parent derived type
+   then:
+   procedure pointer components for the specific typebound procedures
+   structure pointers to reduced vtabs that contain procedure
+   pointers to the specific procedures.  */
 
 gfc_symbol *
-gfc_find_derived_vtab (gfc_symbol *derived)
+gfc_find_derived_vtab (gfc_symbol *derived, bool resolved)
 {
   gfc_namespace *ns;
   gfc_symbol *vtab = NULL, *vtype = NULL;
@@ -4815,7 +5154,6 @@ gfc_find_derived_vtab (gfc_symbol *derived)
          vtab->attr.target = 1;
          vtab->attr.save = SAVE_EXPLICIT;
          vtab->attr.vtab = 1;
-         vtab->attr.access = ACCESS_PRIVATE;
          vtab->refs++;
          gfc_set_sym_referenced (vtab);
          sprintf (name, "vtype$%s", derived->name);
@@ -4832,7 +5170,6 @@ gfc_find_derived_vtab (gfc_symbol *derived)
                return NULL;
              vtype->refs++;
              gfc_set_sym_referenced (vtype);
-             vtype->attr.access = ACCESS_PRIVATE;
 
              /* Add component '$hash'.  */
              if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
@@ -4864,13 +5201,13 @@ gfc_find_derived_vtab (gfc_symbol *derived)
              parent = gfc_get_derived_super_type (derived);
              if (parent)
                {
-                 parent_vtab = gfc_find_derived_vtab (parent);
+                 parent_vtab = gfc_find_derived_vtab (parent, resolved);
                  c->ts.type = BT_DERIVED;
                  c->ts.u.derived = parent_vtab->ts.u.derived;
                  c->initializer = gfc_get_expr ();
                  c->initializer->expr_type = EXPR_VARIABLE;
-                 gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0,
-                                    &c->initializer->symtree);
+                 gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
+                                    0, &c->initializer->symtree);
                }
              else
                {
@@ -4878,13 +5215,25 @@ gfc_find_derived_vtab (gfc_symbol *derived)
                  c->ts.u.derived = vtype;
                  c->initializer = gfc_get_null_expr (NULL);
                }
+
+             add_procs_to_declared_vtab (derived, vtype, derived, resolved);
+             vtype->attr.vtype = 1;
            }
-         vtab->ts.u.derived = vtype;
 
+         vtab->ts.u.derived = vtype;
          vtab->value = gfc_default_initializer (&vtab->ts);
        }
     }
 
+  /* Catch the call just before the backend declarations are built, so that
+     the generic procedures have been resolved and the specific procedures
+     have formal interfaces that can be compared.  */
+  if (resolved
+       && vtab->ts.u.derived
+       && vtab->ts.u.derived->backend_decl == NULL)
+    add_generics_to_declared_vtab (derived, vtab->ts.u.derived,
+                                  derived, resolved);
+
   return vtab;
 }
 
index 5f53768..4d48c05 100644 (file)
@@ -4337,7 +4337,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
       if (!c->expr || cm->attr.allocatable)
         continue;
 
-      if (cm->ts.type == BT_CLASS)
+      if (cm->ts.type == BT_CLASS && !cm->attr.proc_pointer)
        {
          gfc_component *data;
          data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
@@ -5454,6 +5454,103 @@ gfc_trans_assign (gfc_code * code)
 }
 
 
+/* Generate code to assign typebound procedures to a derived vtab.  */
+void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt,
+                                 gfc_symbol *vtab)
+{
+  gfc_component *cmp;
+  tree vtb;
+  tree ctree;
+  tree proc;
+  tree cond = NULL_TREE;
+  stmtblock_t body;
+  bool seen_extends;
+
+  /* Point to the first procedure pointer.  */
+  cmp = gfc_find_component (vtab->ts.u.derived, "$extends", true, true);
+
+  seen_extends = (cmp != NULL);
+
+  vtb = gfc_get_symbol_decl (vtab);
+
+  if (seen_extends)
+    {
+      cmp = cmp->next;
+      if (!cmp)
+       return;
+      ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+                          vtb, cmp->backend_decl, NULL_TREE);
+      cond = fold_build2 (EQ_EXPR, boolean_type_node, ctree,
+                          build_int_cst (TREE_TYPE (ctree), 0));
+    }
+  else
+    {
+      cmp = vtab->ts.u.derived->components; 
+    }
+
+  gfc_init_block (&body);
+  for (; cmp; cmp = cmp->next)
+    {
+      gfc_symbol *target = NULL;
+      
+      /* Generic procedure - build its vtab.  */
+      if (cmp->ts.type == BT_DERIVED && !cmp->tb)
+       {
+         gfc_symbol *vt = cmp->ts.interface;
+
+         if (vt == NULL)
+           {
+             /* Use association loses the interface.  Obtain the vtab
+                by name instead.  */
+             char name[2 * GFC_MAX_SYMBOL_LEN + 8];
+             sprintf (name, "vtab$%s$%s", vtab->ts.u.derived->name,
+                      cmp->name);
+             gfc_find_symbol (name, vtab->ns, 0, &vt);
+             if (vt == NULL)
+               continue;
+           }
+
+         gfc_trans_assign_vtab_procs (&body, dt, vt);
+         ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+                              vtb, cmp->backend_decl, NULL_TREE);
+         proc = gfc_get_symbol_decl (vt);
+         proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
+         gfc_add_modify (&body, ctree, proc);
+         continue;
+       }
+
+      /* This is required when typebound generic procedures are called
+        with derived type targets.  The specific procedures do not get
+        added to the vtype, which remains "empty".  */
+      if (cmp->tb && cmp->tb->u.specific && cmp->tb->u.specific->n.sym)
+       target = cmp->tb->u.specific->n.sym;
+      else
+       {
+         gfc_symtree *st;
+         st = gfc_find_typebound_proc (dt, NULL, cmp->name, false, NULL);
+         if (st->n.tb && st->n.tb->u.specific)
+           target = st->n.tb->u.specific->n.sym;
+       }
+
+      if (!target)
+       continue;
+
+      ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+                          vtb, cmp->backend_decl, NULL_TREE);
+      proc = gfc_get_symbol_decl (target);
+      proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
+      gfc_add_modify (&body, ctree, proc);
+    }
+
+  proc = gfc_finish_block (&body);
+
+  if (seen_extends)
+    proc = build3_v (COND_EXPR, cond, proc, build_empty_stmt (input_location));
+
+  gfc_add_expr_to_block (block, proc);
+}
+
+
 /* Translate an assignment to a CLASS object
    (pointer or ordinary assignment).  */
 
index 4acfb11..f6527d5 100644 (file)
@@ -1,3 +1,41 @@
+2010-04-29  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/42274
+       * gfortran.dg/class_16.f03: New test.
+
+2010-04-29  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/42274
+       * gfortran.dg/class_15.f03: New.
+
+2010-04-29  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/43326
+       * gfortran.dg/dynamic_dispatch_9.f03: New test.
+
+2010-04-29  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/43492
+       * gfortran.dg/generic_22.f03 : New test.
+
+2010-04-29  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/42353
+       * gfortran.dg/class_14.f03: New test.
+
+2010-04-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+       PR fortran/42680
+       * gfortran.dg/interface_32.f90: New test.
+
+2009-04-29  Paul Thomas  <pault@gcc.gnu.org>
+           Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/41829
+       * gfortran.dg/dynamic_dispatch_5.f03 : Change to "run".
+       * gfortran.dg/dynamic_dispatch_7.f03 : New test.
+       * gfortran.dg/dynamic_dispatch_8.f03 : New test.
+
 2010-04-28  Mike Stump  <mikestump@comcast.net>
 
        * g++.dg/uninit-pred-1_b.C: Use dg-message instead of
index a84d9f9..3cd0510 100644 (file)
@@ -7,8 +7,8 @@
 ! Contributed by Janus Weil <janus@gcc.gnu.org>
 !
 module m1
-  type  :: t1
-  contains 
+  type :: t1
+  contains
     procedure :: sizeof
   end type
 contains
@@ -17,11 +17,10 @@ contains
     sizeof = 1
   end function sizeof
 end module
-
-
+       
 module m2
   use m1
-  type, extends(t1) :: t2    
+  type, extends(t1) :: t2
   contains
     procedure :: sizeof => sizeof2
   end type
@@ -32,19 +31,18 @@ contains
   end function
 end module
 
-
 module m3
   use m2
   type :: t3
-    class(t1), pointer  :: a 
+  class(t1), pointer :: a
   contains
     procedure :: sizeof => sizeof3
   end type
-contains 
+contains
   integer function sizeof3(a)
     class(t3) :: a
     sizeof3 = a%a%sizeof()
-  end function 
+  end function
 end module
 
   use m1
@@ -57,8 +55,7 @@ end module
   if ((z%sizeof() .ne. 1) .or. (z%a%sizeof() .ne. 1)) call abort
   z%a => y
   if ((z%sizeof() .ne. 2) .or. (z%a%sizeof() .ne. 2)) call abort
-
 end
 
 ! { dg-final { cleanup-modules "m1 m2 m3" } }
-
+