This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [RFC] Constructor patch
- From: Tobias Burnus <burnus at net-b dot de>
- To: gfortran <fortran at gcc dot gnu dot org>
- Date: Thu, 28 Oct 2010 21:48:27 +0200
- Subject: Re: [RFC] Constructor patch
- References: <4CC7C36F.8060304@net-b.de>
Tobias Burnus wrote:
Attached you find a draft of a patch allowing "constructors" as one
knows them from object-oriented programming languages. In Fortran, it
just means that a generic name can be the same as the name of a
derived type. And if the interface matches, the specific function
belonging to that generic name is called instead of the structure
constructor.
Attached you find an updated patch, which now also includes some test cases.
The number of regressions is quite small - I get approximately the
following 12. (The exact result depends on some of the patches; if you
read the patch, you will find sections, where I mention that a change
will help with one test case - but causes problems with others; in those
cases I am not sure whether the patch is just insufficient or at the
wrong place.)
gfortran.dg/array_constructor_32.f90
gfortran.dg/class_8.f03
gfortran.dg/class_defined_operator_1.f03
gfortran.dg/dynamic_dispatch_6.f03
gfortran.dg/elemental_subroutine_2.f90
gfortran.dg/interface_16.f90
gfortran.dg/iso_c_binding_only.f03
gfortran.dg/nested_modules_3.f90
gfortran.dg/pr32801.f03
gfortran.dg/result_1.f90
gfortran.dg/structure_constructor_8.f03
gfortran.dg/used_types_3.f90
I am currently stuggling to really get them completely down. For
instance, explicitly writing (in module.c) the name of the derived type
with a capital letter fixes gfortran.dg/elemental_subroutine_2.f90's
assign.mod and thus the test case - but as a side effect the module
names in the PRIVATE error message of
gfortran.dg/structure_constructor_8.f03 are then complete garbage.
I would really appreciate some help as I got stuck with the debugging
the patch; frankly, I do not want to spend time digging around. On the
other hand, I really would like to have the patch still in 4.6 and the
number of failure is pretty low.
TODO:
- Reduce the number of test suite failures to zero
- Go through the patch and check whether the all parts of the patch make
sense.
- Write a changelog file
- celebrate
Tobias
PS: For diagnostic reasons, having the same sym->name for the derived
type and for the generic procedure is nice. However, for debugging it
makes it quite difficult and having a different symtree->name than the
symtree->n.sym->name feels also a bit quackish.
Index: gcc/testsuite/gfortran.dg/constructor_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/constructor_1.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/constructor_1.f90 (Revision 0)
@@ -0,0 +1,42 @@
+! { dg-do compile }
+!
+! PR fortran/39427
+!
+! Check constructor functionality.
+!
+! Contributed by Damian Rouson.
+!
+module mycomplex_module
+ private
+ public :: mycomplex
+ type mycomplex
+! private
+ real :: argument, modulus
+ end type
+ interface mycomplex
+ module procedure complex_to_mycomplex, two_reals_to_mycomplex
+ end interface
+! :
+ contains
+ type(mycomplex) function complex_to_mycomplex(c)
+ complex, intent(in) :: c
+! :
+ end function complex_to_mycomplex
+ type(mycomplex) function two_reals_to_mycomplex(x,y)
+ real, intent(in) :: x
+ real, intent(in), optional :: y
+! :
+ end function two_reals_to_mycomplex
+! :
+ end module mycomplex_module
+! :
+program myuse
+ use mycomplex_module
+ type(mycomplex) :: a, b, c
+! :
+ a = mycomplex(argument=5.6, modulus=1.0) ! The structure constructor
+ c = mycomplex(x=0.0, y=1.0) ! A function reference
+ c = mycomplex(0.0, 1.0) ! A function reference
+end program myuse
+
+! { dg-final { cleanup-modules "mycomplex_module" } }
Index: gcc/testsuite/gfortran.dg/constructor_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/constructor_3.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/constructor_3.f90 (Revision 0)
@@ -0,0 +1,47 @@
+! { dg-do run }
+!
+! PR fortran/39427
+!
+! Check constructor functionality.
+!
+!
+module m
+ interface cons
+ procedure cons42
+ end interface cons
+contains
+ integer function cons42()
+ cons42 = 42
+ end function cons42
+end module m
+
+
+module m2
+ type cons
+ integer :: j = -1
+ end type cons
+ interface cons
+ procedure consT
+ end interface cons
+contains
+ type(cons) function consT(k)
+ integer :: k
+ consT%j = k**2
+ end function consT
+end module m2
+
+
+use m
+use m2, only: cons
+implicit none
+type(cons) :: x
+integer :: k
+x = cons(3)
+k = cons()
+if (x%j /= 9) call abort ()
+if (k /= 42) call abort ()
+!print *, x%j
+!print *, k
+end
+
+! { dg-final { cleanup-modules "m m2" } }
Index: gcc/testsuite/gfortran.dg/structure_constructor_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/structure_constructor_3.f03 (Revision 166028)
+++ gcc/testsuite/gfortran.dg/structure_constructor_3.f03 (Arbeitskopie)
@@ -13,6 +13,6 @@ PROGRAM test
TYPE(basics_t) :: basics
- basics = basics_t (i=42, 1.5) ! { dg-error "without name after" }
+ basics = basics_t (i=42, 1.5) ! { dg-error "Missing keyword name" }
END PROGRAM test
Index: gcc/testsuite/gfortran.dg/constructor_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/constructor_2.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/constructor_2.f90 (Revision 0)
@@ -0,0 +1,73 @@
+! { dg-do run }
+!
+! PR fortran/39427
+!
+module foo_module
+ interface foo
+ procedure constructor
+ end interface
+
+ type foo
+ integer :: bar
+ end type
+contains
+ type(foo) function constructor()
+ constructor%bar = 1
+ end function
+
+ subroutine test_foo()
+ type(foo) :: f
+ f = foo()
+ if (f%bar /= 1) call abort ()
+ f = foo(2)
+ if (f%bar /= 2) call abort ()
+ end subroutine test_foo
+end module foo_module
+
+
+! Same as foo_module but order
+! of INTERFACE and TYPE reversed
+module bar_module
+ type bar
+ integer :: bar
+ end type
+
+ interface bar
+ procedure constructor
+ end interface
+contains
+ type(bar) function constructor()
+ constructor%bar = 3
+ end function
+
+ subroutine test_bar()
+ type(bar) :: f
+ f = bar()
+ if (f%bar /= 3) call abort ()
+ f = bar(4)
+ if (f%bar /= 4) call abort ()
+ end subroutine test_bar
+end module bar_module
+
+program main
+ use foo_module
+ use bar_module
+ implicit none
+
+ type(foo) :: f
+ type(bar) :: b
+
+ call test_foo()
+ f = foo()
+ if (f%bar /= 1) call abort ()
+ f = foo(2)
+ if (f%bar /= 2) call abort ()
+
+ call test_bar()
+ b = bar()
+ if (b%bar /= 3) call abort ()
+ b = bar(4)
+ if (b%bar /= 4) call abort ()
+end program main
+
+! { dg-final { cleanup-tree-dump "foo_module bar_module" } }
Index: gcc/testsuite/gfortran.dg/constructor_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/constructor_4.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/constructor_4.f90 (Revision 0)
@@ -0,0 +1,33 @@
+! { dg-do run }
+! { dg-options "-std=f95" }
+!
+! PR fortran/39427
+!
+! Check constructor functionality.
+!
+!
+module m
+ type t
+ integer :: x
+ end type t
+ interface t ! { dg-error "FIXME: Invalid F95 }
+ module procedure f
+ end interface t
+contains
+ function f()
+ type(t) :: f
+ end function
+end module
+
+module m2
+ interface t2
+ module procedure f2
+ end interface t2
+ type t2! { dg-error "FIXME: Invalid F95 }
+ integer :: x2
+ end type t2
+contains
+ function f2()
+ type(t2) :: f2
+ end function
+end module
Index: gcc/testsuite/gfortran.dg/result_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/result_1.f90 (Revision 166028)
+++ gcc/testsuite/gfortran.dg/result_1.f90 (Arbeitskopie)
@@ -15,4 +15,9 @@ end function
function h() result(t)
type t ! { dg-error "attribute conflicts" }
+end type t
end function
+
+function i() result(t)
+type t
+end function ! { dg-error "Expecting END TYPE statement" }
Index: gcc/testsuite/gfortran.dg/structure_constructor_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/structure_constructor_4.f03 (Revision 166028)
+++ gcc/testsuite/gfortran.dg/structure_constructor_4.f03 (Arbeitskopie)
@@ -14,6 +14,6 @@ PROGRAM test
TYPE(basics_t) :: basics
basics = basics_t (42, r=1.5, i=15) ! { dg-error "'i' is initialized twice" }
- basics = basics_t (42, r=1., r=-2.) ! { dg-error "'r' is initialized twice" }
+ basics = basics_t (42, r=1., r=-2.) ! { dg-error "has already appeared in the current argument list" }
END PROGRAM test
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (Revision 166028)
+++ gcc/fortran/interface.c (Arbeitskopie)
@@ -1101,8 +1101,9 @@ check_interface0 (gfc_interface *p, cons
/* Make sure all symbols in the interface have been defined as
functions or subroutines. */
for (; p; p = p->next)
- if ((!p->sym->attr.function && !p->sym->attr.subroutine)
- || !p->sym->attr.if_source)
+ if (((!p->sym->attr.function && !p->sym->attr.subroutine)
+ || !p->sym->attr.if_source)
+ && p->sym->attr.flavor != FL_DERIVED)
{
if (p->sym->attr.external)
gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
@@ -1159,8 +1160,10 @@ check_interface1 (gfc_interface *p, gfc_
if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue;
- if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag,
- 0, NULL, 0))
+ if (p->sym->attr.flavor != FL_DERIVED
+ && q->sym->attr.flavor != FL_DERIVED
+ && gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
+ generic_flag, 0, NULL, 0))
{
if (referenced)
gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
@@ -2761,6 +2764,8 @@ gfc_search_interface (gfc_interface *int
gfc_symbol *elem_sym = NULL;
for (; intr; intr = intr->next)
{
+ if (intr->sym->attr.flavor == FL_DERIVED)
+ continue;
if (sub_flag && intr->sym->attr.function)
continue;
if (!sub_flag && intr->sym->attr.subroutine)
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (Revision 166028)
+++ gcc/fortran/symbol.c (Arbeitskopie)
@@ -2921,7 +2921,12 @@ gfc_undo_symbols (void)
}
}
- gfc_delete_symtree (&p->ns->sym_root, p->name);
+ if (p->attr.flavor == FL_DERIVED)
+ gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s",
+ (char) TOUPPER ((unsigned char) p->name[0]),
+ &p->name[1]));
+ else
+ gfc_delete_symtree (&p->ns->sym_root, p->name);
gfc_release_symbol (p);
continue;
@@ -4325,9 +4330,6 @@ generate_isocbinding_symbol (const char
: c_interop_kinds_table[s].name;
gfc_symtree *tmp_symtree = NULL;
gfc_symbol *tmp_sym = NULL;
- gfc_dt_list **dt_list_ptr = NULL;
- gfc_component *tmp_comp = NULL;
- char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
int index;
if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
@@ -4336,7 +4338,9 @@ generate_isocbinding_symbol (const char
/* Already exists in this scope so don't re-add it.
TODO: we should probably check that it's really the same symbol. */
- if (tmp_symtree != NULL)
+ if (tmp_symtree != NULL
+ && (!tmp_symtree->n.sym->attr.generic
+ || gfc_find_dt_in_generic (tmp_symtree->n.sym)))
return;
/* Create the sym tree in the current ns. */
@@ -4430,64 +4434,112 @@ generate_isocbinding_symbol (const char
case ISOCBINDING_PTR:
case ISOCBINDING_FUNPTR:
-
- /* Initialize an integer constant expression node. */
- tmp_sym->attr.flavor = FL_DERIVED;
- tmp_sym->ts.is_c_interop = 1;
- tmp_sym->attr.is_c_interop = 1;
- tmp_sym->attr.is_iso_c = 1;
- tmp_sym->ts.is_iso_c = 1;
- tmp_sym->ts.type = BT_DERIVED;
-
- /* A derived type must have the bind attribute to be
- interoperable (J3/04-007, Section 15.2.3), even though
- the binding label is not used. */
- tmp_sym->attr.is_bind_c = 1;
-
- tmp_sym->attr.referenced = 1;
-
- tmp_sym->ts.u.derived = tmp_sym;
-
- /* Add the symbol created for the derived type to the current ns. */
- dt_list_ptr = &(gfc_derived_types);
- while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
- dt_list_ptr = &((*dt_list_ptr)->next);
-
- /* There is already at least one derived type in the list, so append
- the one we're currently building for c_ptr or c_funptr. */
- if (*dt_list_ptr != NULL)
- dt_list_ptr = &((*dt_list_ptr)->next);
- (*dt_list_ptr) = gfc_get_dt_list ();
- (*dt_list_ptr)->derived = tmp_sym;
- (*dt_list_ptr)->next = NULL;
-
- /* Set up the component of the derived type, which will be
- an integer with kind equal to c_ptr_size. Mangle the name of
- the field for the c_address to prevent the curious user from
- trying to access it from Fortran. */
- sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
- gfc_add_component (tmp_sym, comp_name, &tmp_comp);
- if (tmp_comp == NULL)
+ {
+ gfc_interface *intr, *head;
+ gfc_symbol *dt_sym;
+ const char *hidden_name;
+ gfc_dt_list **dt_list_ptr = NULL;
+ gfc_component *tmp_comp = NULL;
+ char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
+
+ hidden_name = gfc_get_string ("%c%s",
+ (char) TOUPPER ((unsigned char) tmp_sym->name[0]),
+ &tmp_sym->name[1]);
+
+ /* Generate real derived type. */
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
+ hidden_name);
+
+ if (tmp_symtree != NULL)
+ gcc_unreachable ();
+ gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
+ if (tmp_symtree)
+ dt_sym = tmp_symtree->n.sym;
+ else
+ gcc_unreachable ();
+
+ /* Generate an artificial generic function. */
+ dt_sym->name = gfc_get_string (tmp_sym->name);
+ head = tmp_sym->generic;
+ intr = gfc_get_interface ();
+ intr->sym = dt_sym;
+ intr->where = gfc_current_locus;
+ intr->next = head;
+ tmp_sym->generic = intr;
+
+ if (!tmp_sym->attr.generic
+ && gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)
+ == FAILURE)
+ return;
+
+ if (!tmp_sym->attr.function
+ && gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)
+ == FAILURE)
+ return;
+
+ /* Say what module this symbol belongs to. */
+ dt_sym->module = gfc_get_string (mod_name);
+ dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
+ dt_sym->intmod_sym_id = s;
+
+ /* Initialize an integer constant expression node. */
+ dt_sym->attr.flavor = FL_DERIVED;
+ dt_sym->ts.is_c_interop = 1;
+ dt_sym->attr.is_c_interop = 1;
+ dt_sym->attr.is_iso_c = 1;
+ dt_sym->ts.is_iso_c = 1;
+ dt_sym->ts.type = BT_DERIVED;
+
+ /* A derived type must have the bind attribute to be
+ interoperable (J3/04-007, Section 15.2.3), even though
+ the binding label is not used. */
+ dt_sym->attr.is_bind_c = 1;
+
+ dt_sym->attr.referenced = 1;
+ dt_sym->ts.u.derived = dt_sym;
+
+ /* Add the symbol created for the derived type to the current ns. */
+ dt_list_ptr = &(gfc_derived_types);
+ while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
+ dt_list_ptr = &((*dt_list_ptr)->next);
+
+ /* There is already at least one derived type in the list, so append
+ the one we're currently building for c_ptr or c_funptr. */
+ if (*dt_list_ptr != NULL)
+ dt_list_ptr = &((*dt_list_ptr)->next);
+ (*dt_list_ptr) = gfc_get_dt_list ();
+ (*dt_list_ptr)->derived = dt_sym;
+ (*dt_list_ptr)->next = NULL;
+
+ /* Set up the component of the derived type, which will be
+ an integer with kind equal to c_ptr_size. Mangle the name of
+ the field for the c_address to prevent the curious user from
+ trying to access it from Fortran. */
+ sprintf (comp_name, "__%s_%s", dt_sym->name, "c_address");
+ gfc_add_component (dt_sym, comp_name, &tmp_comp);
+ if (tmp_comp == NULL)
gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
"create component for c_address");
- tmp_comp->ts.type = BT_INTEGER;
+ tmp_comp->ts.type = BT_INTEGER;
- /* Set this because the module will need to read/write this field. */
- tmp_comp->ts.f90_type = BT_INTEGER;
+ /* Set this because the module will need to read/write this field. */
+ tmp_comp->ts.f90_type = BT_INTEGER;
- /* The kinds for c_ptr and c_funptr are the same. */
- index = get_c_kind ("c_ptr", c_interop_kinds_table);
- tmp_comp->ts.kind = c_interop_kinds_table[index].value;
+ /* The kinds for c_ptr and c_funptr are the same. */
+ index = get_c_kind ("c_ptr", c_interop_kinds_table);
+ tmp_comp->ts.kind = c_interop_kinds_table[index].value;
- tmp_comp->attr.pointer = 0;
- tmp_comp->attr.dimension = 0;
+ tmp_comp->attr.pointer = 0;
+ tmp_comp->attr.dimension = 0;
- /* Mark the component as C interoperable. */
- tmp_comp->ts.is_c_interop = 1;
+ /* Mark the component as C interoperable. */
+ tmp_comp->ts.is_c_interop = 1;
+
+ /* Make it use associated (iso_c_binding module). */
+ dt_sym->attr.use_assoc = 1;
+ }
- /* Make it use associated (iso_c_binding module). */
- tmp_sym->attr.use_assoc = 1;
break;
case ISOCBINDING_NULL_PTR:
@@ -4706,6 +4758,9 @@ gfc_get_derived_super_type (gfc_symbol*
gcc_assert (derived->components->ts.type == BT_DERIVED);
gcc_assert (derived->components->ts.u.derived);
+ if (derived->components->ts.u.derived->attr.generic)
+ return gfc_find_dt_in_generic (derived->components->ts.u.derived);
+
return derived->components->ts.u.derived;
}
@@ -4801,3 +4856,16 @@ gfc_is_associate_pointer (gfc_symbol* sy
return true;
}
+
+
+gfc_symbol *
+gfc_find_dt_in_generic (gfc_symbol *sym)
+{
+ gfc_interface *intr = NULL;
+
+ if (sym && sym->attr.generic)
+ for (intr = (sym ? sym->generic : NULL); intr; intr = intr->next)
+ if (intr->sym->attr.flavor == FL_DERIVED)
+ break;
+ return intr ? intr->sym : NULL;
+}
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (Revision 166028)
+++ gcc/fortran/decl.c (Arbeitskopie)
@@ -323,7 +323,7 @@ static match
match_data_constant (gfc_expr **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_symbol *sym;
+ gfc_symbol *sym, *dt_sym = NULL;
gfc_expr *expr;
match m;
locus old_loc;
@@ -366,15 +366,19 @@ match_data_constant (gfc_expr **result)
if (gfc_find_symbol (name, NULL, 1, &sym))
return MATCH_ERROR;
+ if (sym && sym->attr.generic)
+ dt_sym = gfc_find_dt_in_generic (sym);
+
if (sym == NULL
- || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
+ || (sym->attr.flavor != FL_PARAMETER
+ && (!dt_sym || dt_sym->attr.flavor != FL_DERIVED)))
{
gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
name);
return MATCH_ERROR;
}
- else if (sym->attr.flavor == FL_DERIVED)
- return gfc_match_structure_constructor (sym, result, false);
+ else if (dt_sym && dt_sym->attr.flavor == FL_DERIVED)
+ return gfc_match_structure_constructor (dt_sym, result, false);
/* Check to see if the value is an initialization array expression. */
if (sym->value->expr_type == EXPR_ARRAY)
@@ -1889,7 +1893,7 @@ variable_decl (int elem)
st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.u.derived->name);
if (!(current_ts.u.derived->attr.imported
&& st != NULL
- && st->n.sym == current_ts.u.derived)
+ && gfc_find_dt_in_generic (st->n.sym) == current_ts.u.derived)
&& !gfc_current_ns->has_import_set)
{
gfc_error ("the type of '%s' at %C has not been declared within the "
@@ -2441,7 +2445,7 @@ match
gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_symbol *sym;
+ gfc_symbol *sym, *dt_sym;
match m;
char c;
bool seen_deferred_kind, matched_type;
@@ -2598,7 +2602,10 @@ gfc_match_decl_type_spec (gfc_typespec *
ts->u.derived = NULL;
if (gfc_current_state () != COMP_INTERFACE
&& !gfc_find_symbol (name, NULL, 1, &sym) && sym)
- ts->u.derived = sym;
+ {
+ sym = gfc_find_dt_in_generic (sym);
+ ts->u.derived = sym;
+ }
return MATCH_YES;
}
@@ -2626,12 +2633,51 @@ gfc_match_decl_type_spec (gfc_typespec *
return MATCH_NO;
}
- if (sym->attr.flavor != FL_DERIVED
- && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
- return MATCH_ERROR;
gfc_set_sym_referenced (sym);
- ts->u.derived = sym;
+ if (sym->attr.flavor != FL_DERIVED)
+ {
+ if (!sym->attr.generic
+ && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
+ return MATCH_ERROR;
+
+ if (!sym->attr.function
+ && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
+ return MATCH_ERROR;
+
+ dt_sym = gfc_find_dt_in_generic (sym);
+ if (dt_sym)
+ gfc_set_sym_referenced (dt_sym);
+ }
+ else
+ dt_sym = sym;
+
+ if (!dt_sym)
+ {
+ gfc_interface *intr, *head;
+
+ /* Use upper case to save the actual derived-type symbol. */
+ gfc_get_symbol (gfc_get_string ("%c%s",
+ (char) TOUPPER ((unsigned char) sym->name[0]),
+ &sym->name[1]), NULL, &dt_sym);
+ gfc_set_sym_referenced (dt_sym);
+ dt_sym->name = gfc_get_string (sym->name);
+ head = sym->generic;
+ intr = gfc_get_interface ();
+ intr->sym = dt_sym;
+ intr->where = gfc_current_locus;
+ intr->next = head;
+ sym->generic = intr;
+ sym->attr.if_source = IFSRC_DECL;
+ }
+
+
+ if (dt_sym->attr.flavor != FL_DERIVED
+ && gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL)
+ == FAILURE)
+ return MATCH_ERROR;
+
+ ts->u.derived = dt_sym;
return MATCH_YES;
@@ -2982,6 +3028,17 @@ gfc_match_import (void)
sym->refs++;
sym->attr.imported = 1;
+ if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
+ {
+ st = gfc_new_symtree (&gfc_current_ns->sym_root,
+ gfc_get_string ("%c%s",
+ (char) TOUPPER ((unsigned char) sym->name[0]),
+ &sym->name[1]));
+ st->n.sym = sym;
+ sym->refs++;
+ sym->attr.imported = 1;
+ }
+
goto next_item;
case MATCH_NO:
@@ -6389,7 +6446,7 @@ access_attr_decl (gfc_statement st)
char name[GFC_MAX_SYMBOL_LEN + 1];
interface_type type;
gfc_user_op *uop;
- gfc_symbol *sym;
+ gfc_symbol *sym, *dt_sym;
gfc_intrinsic_op op;
match m;
@@ -6419,6 +6476,13 @@ access_attr_decl (gfc_statement st)
sym->name, NULL) == FAILURE)
return MATCH_ERROR;
+ if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
+ && gfc_add_access (&dt_sym->attr,
+ (st == ST_PUBLIC) ? ACCESS_PUBLIC
+ : ACCESS_PRIVATE,
+ sym->name, NULL) == FAILURE)
+ return MATCH_ERROR;
+
break;
case INTERFACE_INTRINSIC_OP:
@@ -7063,6 +7127,8 @@ check_extended_derived_type (char *name)
return NULL;
}
+ extended = gfc_find_dt_in_generic (extended);
+
if (extended->attr.flavor != FL_DERIVED)
{
gfc_error ("'%s' in EXTENDS expression at %C is not a "
@@ -7205,11 +7271,12 @@ gfc_match_derived_decl (void)
char name[GFC_MAX_SYMBOL_LEN + 1];
char parent[GFC_MAX_SYMBOL_LEN + 1];
symbol_attribute attr;
- gfc_symbol *sym;
+ gfc_symbol *sym, *gensym;
gfc_symbol *extended;
match m;
match is_type_attr_spec = MATCH_NO;
bool seen_attr = false;
+ gfc_interface *intr = NULL, *head;
if (gfc_current_state () == COMP_DERIVED)
return MATCH_NO;
@@ -7255,16 +7322,49 @@ gfc_match_derived_decl (void)
return MATCH_ERROR;
}
- if (gfc_get_symbol (name, NULL, &sym))
+ if (gfc_get_symbol (name, NULL, &gensym))
return MATCH_ERROR;
- if (sym->ts.type != BT_UNKNOWN)
+ if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
{
gfc_error ("Derived type name '%s' at %C already has a basic type "
- "of %s", sym->name, gfc_typename (&sym->ts));
+ "of %s", gensym->name, gfc_typename (&gensym->ts));
return MATCH_ERROR;
}
+ /* Check for derived type. */
+ if (gensym && gensym->attr.generic)
+ for (intr = (gensym ? gensym->generic : NULL); intr; intr = intr->next)
+ if (intr->sym->attr.flavor == FL_DERIVED)
+ break;
+
+ if (!gensym->attr.generic
+ && gfc_add_generic (&gensym->attr, gensym->name, NULL) == FAILURE)
+ return MATCH_ERROR;
+
+ if (!gensym->attr.function
+ && gfc_add_function (&gensym->attr, gensym->name, NULL) == FAILURE)
+ return MATCH_ERROR;
+
+ if (intr)
+ sym = intr->sym;
+ else
+ {
+ /* Use upper case to save the actual derived-type symbol. */
+ gfc_get_symbol (gfc_get_string ("%c%s",
+ (char) TOUPPER ((unsigned char) gensym->name[0]),
+ &gensym->name[1]), NULL, &sym);
+ sym->name = gfc_get_string (gensym->name);
+ head = gensym->generic;
+ intr = gfc_get_interface ();
+ intr->sym = sym;
+ intr->where = gfc_current_locus;
+ intr->sym->declared_at = gfc_current_locus;
+ intr->next = head;
+ gensym->generic = intr;
+ gensym->attr.if_source = IFSRC_DECL;
+ }
+
/* The symbol may already have the derived attribute without the
components. The ways this can happen is via a function
definition, an INTRINSIC statement or a subtype in another
@@ -7274,16 +7374,14 @@ gfc_match_derived_decl (void)
&& gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
- if (sym->components != NULL || sym->attr.zero_comp)
- {
- gfc_error ("Derived type definition of '%s' at %C has already been "
- "defined", sym->name);
- return MATCH_ERROR;
- }
-
if (attr.access != ACCESS_UNKNOWN
&& gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
+ else if (sym->attr.access == ACCESS_UNKNOWN
+ && gensym->attr.access != ACCESS_UNKNOWN
+ && gfc_add_access (&sym->attr, gensym->attr.access, sym->name, NULL)
+ == FAILURE)
+ return MATCH_ERROR;
/* See if the derived type was labeled as bind(c). */
if (attr.is_bind_c != 0)
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (Revision 166028)
+++ gcc/fortran/gfortran.h (Arbeitskopie)
@@ -2616,6 +2616,7 @@ gfc_try gfc_check_symbol_typed (gfc_symb
gfc_namespace* gfc_find_proc_namespace (gfc_namespace*);
bool gfc_is_associate_pointer (gfc_symbol*);
+gfc_symbol * gfc_find_dt_in_generic (gfc_symbol *);
/* intrinsic.c -- true if working in an init-expr, false otherwise. */
extern bool gfc_init_expr_flag;
@@ -2849,6 +2850,9 @@ match gfc_match_rvalue (gfc_expr **);
match gfc_match_varspec (gfc_expr*, int, bool, bool);
int gfc_check_digit (char, int);
bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *);
+gfc_try gfc_convert_to_structure_constructor (gfc_expr *, gfc_symbol *,
+ gfc_expr **,
+ gfc_actual_arglist **, bool);
/* trans.c */
void gfc_generate_code (gfc_namespace *);
Index: gcc/fortran/data.c
===================================================================
--- gcc/fortran/data.c (Revision 166028)
+++ gcc/fortran/data.c (Arbeitskopie)
@@ -301,6 +301,7 @@ gfc_assign_data_value (gfc_expr *lvalue,
/* Setup the expression to hold the constructor. */
expr->expr_type = EXPR_STRUCTURE;
expr->ts.type = BT_DERIVED;
+ gcc_assert (ref->u.c.sym->attr.flavor == FL_DERIVED);
expr->ts.u.derived = ref->u.c.sym;
}
else
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (Revision 166028)
+++ gcc/fortran/module.c (Arbeitskopie)
@@ -699,12 +699,21 @@ static const char *
find_use_name_n (const char *name, int *inst, bool interface)
{
gfc_use_rename *u;
+ char *low_name = NULL;
int i;
+ /* For derived types. */
+ if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
+ {
+ low_name = xstrdup (name);
+ low_name[0] = (char) TOLOWER ((unsigned char) name[0]);
+ }
+
i = 0;
for (u = gfc_rename_list; u; u = u->next)
{
- if (strcmp (u->use_name, name) != 0
+ if ((!low_name && strcmp (u->use_name, name) != 0)
+ || (low_name && strcmp (u->use_name, low_name) != 0)
|| (u->op == INTRINSIC_USER && !interface)
|| (u->op != INTRINSIC_USER && interface))
continue;
@@ -715,6 +724,8 @@ find_use_name_n (const char *name, int *
if (!*inst)
{
*inst = i;
+ if (low_name)
+ gfc_free (low_name);
return NULL;
}
@@ -723,6 +734,18 @@ find_use_name_n (const char *name, int *
u->found = 1;
+ if (low_name)
+ {
+/*FIXME: This section fixes some test but now
+gfortran.dg/dynamic_dispatch_6.f03 fails. */
+ gfc_free (low_name);
+ if (u->local_name[0] == '\0')
+ return name;
+ low_name = xstrdup (u->local_name);
+ low_name[0] = (char) TOUPPER ((unsigned char) name[0]);
+ return low_name;
+ }
+
return (u->local_name[0] != '\0') ? u->local_name : name;
}
@@ -4078,7 +4101,11 @@ load_derived_extensions (void)
continue;
}
- gcc_assert (derived->attr.flavor == FL_DERIVED);
+ if (derived->attr.generic) /* FIXME: DOES THIS MAKE SENSE AT ALL?
+ WITHOUT ASSERT FAILS, WITH a class.c assert fails for gfortran.dg/dynamic_dispatch_6.f03 */
+ derived = gfc_find_dt_in_generic (derived);
+
+ gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
if (derived->f2k_derived == NULL)
derived->f2k_derived = gfc_get_namespace (NULL, 0);
@@ -4759,7 +4786,7 @@ write_dt_extensions (gfc_symtree *st)
return;
mio_lparen ();
- mio_pool_string (&st->n.sym->name);
+ mio_pool_string (&st->name);
if (st->n.sym->module != NULL)
mio_pool_string (&st->n.sym->module);
else
@@ -4794,7 +4821,19 @@ write_symbol (int n, gfc_symbol *sym)
gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
mio_integer (&n);
- mio_pool_string (&sym->name);
+
+/* This change helps writing "Itype" in assign.mod of
+ gfortran.dg/elemental_subroutine_2.f90 but causes other tests to fail.
+ if (sym->attr.flavor == FL_DERIVED)
+ {
+ const char *name;
+ name = gfc_get_string ("%c%s",
+ (char) TOUPPER ((unsigned char) sym->name[0]),
+ name);
+ mio_pool_string (&name);
+ }
+ else*/
+ mio_pool_string (&sym->name);
mio_pool_string (&sym->module);
if (sym->attr.is_bind_c || sym->attr.is_iso_c)
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c (Revision 166028)
+++ gcc/fortran/trans-types.c (Arbeitskopie)
@@ -2021,6 +2021,10 @@ gfc_get_derived_type (gfc_symbol * deriv
gfc_symbol *s;
s = NULL;
gfc_find_symbol (derived->name, gsym->ns, 0, &s);
+ if (s->attr.generic)
+ s = gfc_find_dt_in_generic (s);
+ gcc_assert (s->attr.flavor == FL_DERIVED);
+
if (s)
{
if (!s->backend_decl)
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (Revision 166028)
+++ gcc/fortran/resolve.c (Arbeitskopie)
@@ -427,7 +427,8 @@ resolve_formal_arglist (gfc_symbol *proc
static void
find_arglists (gfc_symbol *sym)
{
- if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
+ if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
+ || sym->attr.flavor == FL_DERIVED)
return;
resolve_formal_arglist (sym);
@@ -2255,6 +2256,7 @@ resolve_generic_f (gfc_expr *expr)
{
gfc_symbol *sym;
match m;
+ gfc_interface *intr = NULL;
sym = expr->symtree->n.sym;
@@ -2267,6 +2269,11 @@ resolve_generic_f (gfc_expr *expr)
return FAILURE;
generic:
+ if (!intr)
+ for (intr = sym->generic; intr; intr = intr->next)
+ if (intr->sym->attr.flavor == FL_DERIVED)
+ break;
+
if (sym->ns->parent == NULL)
break;
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
@@ -2279,16 +2286,25 @@ generic:
/* Last ditch attempt. See if the reference is to an intrinsic
that possesses a matching interface. 14.1.2.4 */
- if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
+ if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
{
- gfc_error ("There is no specific function for the generic '%s' at %L",
- expr->symtree->n.sym->name, &expr->where);
+ gfc_error ("There is no specific function for the generic '%s' "
+ "at %L", expr->symtree->n.sym->name, &expr->where);
return FAILURE;
}
+ if (intr)
+ {
+ if (gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL,
+ false) != SUCCESS)
+ return FAILURE;
+ return resolve_structure_cons (expr, 0);
+ }
+
m = gfc_intrinsic_func_interface (expr, 0);
if (m == MATCH_YES)
return SUCCESS;
+
if (m == MATCH_NO)
gfc_error ("Generic function '%s' at %L is not consistent with a "
"specific intrinsic interface", expr->symtree->n.sym->name,
@@ -9761,6 +9777,9 @@ resolve_fl_variable_derived (gfc_symbol
{
gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
+/* if (sym->attr.generic)
+ sym = gfc_find_dt_in_generic (sym);*/
+
/* Check to see if a derived type is blocked from being host
associated by the presence of another class I symbol in the same
namespace. 14.6.1.3 of the standard and the discussion on
@@ -9770,6 +9789,8 @@ resolve_fl_variable_derived (gfc_symbol
{
gfc_symbol *s;
gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
+ if (s && s->attr.generic)
+ s = gfc_find_dt_in_generic (s);
if (s && s->attr.flavor != FL_DERIVED)
{
gfc_error ("The type '%s' cannot be host associated at %L "
@@ -11793,6 +11814,14 @@ resolve_symbol (gfc_symbol *sym)
if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
return;
+/* if (sym->attr.generic && sym->attr.function)
+ {
+ gfc_symbol *dt_sym = gfc_find_dt_in_generic (sym);
+ if (dt_sym)
+ dt_sym->ts.type = BT_UNKNOWN;
+ if (dt_sym && resolve_fl_derived (dt_sym) == FAILURE)
+ return;
+ }*/
/* Symbols that are module procedures with results (functions) have
the types and array specification copied for type checking in
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (Revision 166028)
+++ gcc/fortran/trans-decl.c (Arbeitskopie)
@@ -3697,7 +3697,18 @@ gfc_trans_use_stmts (gfc_namespace * ns)
st = gfc_find_symtree (ns->sym_root,
rent->local_name[0]
? rent->local_name : rent->use_name);
- gcc_assert (st);
+
+ /* The following can happen if a derived type is renamed. */
+ if (!st)
+ {
+ char *name;
+ name = xstrdup (rent->local_name[0]
+ ? rent->local_name : rent->use_name);
+ name[0] = (char) TOUPPER ((unsigned char) name[0]);
+ st = gfc_find_symtree (ns->sym_root, name);
+ gfc_free (name);
+ gcc_assert (st);
+ }
/* Sometimes, generic interfaces wind up being over-ruled by a
local symbol (see PR41062). */
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c (Revision 166028)
+++ gcc/fortran/match.c (Arbeitskopie)
@@ -2718,10 +2718,15 @@ match_derived_type_spec (gfc_typespec *t
if (gfc_match_symbol (&derived, 1) == MATCH_YES)
{
- if (derived->attr.flavor == FL_DERIVED)
+ gfc_symbol *sym = NULL;
+
+ if (derived->attr.generic)
+ sym = gfc_find_dt_in_generic (derived);
+
+ if (sym && sym->attr.flavor == FL_DERIVED)
{
ts->type = BT_DERIVED;
- ts->u.derived = derived;
+ ts->u.derived = sym;
return MATCH_YES;
}
else
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c (Revision 166028)
+++ gcc/fortran/primary.c (Arbeitskopie)
@@ -2265,6 +2265,209 @@ build_actual_constructor (gfc_structure_
return SUCCESS;
}
+
+gfc_try
+gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
+ gfc_actual_arglist **arglist,
+ bool parent)
+{
+ gfc_actual_arglist *actual;
+ gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
+ gfc_constructor_base ctor_head = NULL;
+ gfc_component *comp; /* Is set NULL when named component is first seen */
+ const char* last_name = NULL;
+ locus old_locus;
+ gfc_expr *expr;
+
+ expr = parent ? *cexpr : e;
+ old_locus = gfc_current_locus;
+ if (parent)
+ ; /* gfc_current_locus = *arglist->expr ? ->where;*/
+ else
+ gfc_current_locus = expr->where;
+
+ comp_tail = comp_head = NULL;
+
+ if (!parent && sym->attr.abstract)
+ {
+ gfc_error ("Can't construct ABSTRACT type '%s' at %L",
+ sym->name, &expr->where);
+ goto cleanup;
+ }
+
+ comp = sym->components;
+ actual = parent ? *arglist : expr->value.function.actual;
+ for ( ; actual; actual = actual->next)
+ {
+ gfc_component *this_comp = NULL;
+
+ if (!comp_head)
+ comp_tail = comp_head = gfc_get_structure_ctor_component ();
+ else
+ {
+ comp_tail->next = gfc_get_structure_ctor_component ();
+ comp_tail = comp_tail->next;
+ }
+ if (actual->name)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
+ " constructor with named arguments at %C")
+ == FAILURE)
+ goto cleanup;
+
+ comp_tail->name = xstrdup (actual->name); /*CONST_CAST (char *, actual->name);*/
+ last_name = comp_tail->name;
+ comp = NULL;
+ }
+ else
+ {
+ /* Components without name are not allowed after the first named
+ component initializer! */
+ if (!comp)
+ {
+ if (last_name)
+ gfc_error ("Component initializer without name after component"
+ " named %s at %L!", last_name,
+ actual->expr ? &actual->expr->where
+ : &gfc_current_locus);
+ else
+ gfc_error ("Too many components in structure constructor at "
+ "%L!", actual->expr ? &actual->expr->where
+ : &gfc_current_locus);
+ goto cleanup;
+ }
+
+ comp_tail->name = xstrdup (comp->name); /*CONST_CAST (char *, comp->name);*/
+ }
+
+ /* Find the current component in the structure definition and check
+ its access is not private. */
+ if (comp)
+ this_comp = gfc_find_component (sym, comp->name, false, false);
+ else
+ {
+ this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
+ false, false);
+ comp = NULL; /* Reset needed! */
+ }
+
+ /* Here we can check if a component name is given which does not
+ correspond to any component of the defined structure. */
+ if (!this_comp)
+ goto cleanup;
+
+ comp_tail->val = actual->expr;
+ if (actual->expr != NULL)
+ comp_tail->where = actual->expr->where;
+ actual->expr = NULL;
+
+ /* Check if this component is already given a value. */
+ for (comp_iter = comp_head; comp_iter != comp_tail;
+ comp_iter = comp_iter->next)
+ {
+ gcc_assert (comp_iter);
+ if (!strcmp (comp_iter->name, comp_tail->name))
+ {
+ gfc_error ("Component '%s' is initialized twice in the structure"
+ " constructor at %L!", comp_tail->name,
+ comp_tail->val ? &comp_tail->where
+ : &gfc_current_locus);
+ goto cleanup;
+ }
+ }
+
+ /* F2008, R457/C725, for PURE C1283. */
+ if (this_comp->attr.pointer && comp_tail->val
+ && gfc_is_coindexed (comp_tail->val))
+ {
+ gfc_error ("Coindexed expression to pointer component '%s' in "
+ "structure constructor at %L!", comp_tail->name,
+ &comp_tail->where);
+ goto cleanup;
+ }
+
+ /* If not explicitly a parent constructor, gather up the components
+ and build one. */
+ if (comp && comp == sym->components
+ && sym->attr.extension
+ && comp_tail->val
+ && (comp_tail->val->ts.type != BT_DERIVED
+ ||
+ comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
+ {
+ gfc_try m;
+ actual->expr = comp_tail->val;
+ comp_tail->val = NULL;
+
+ m = gfc_convert_to_structure_constructor (NULL,
+ comp->ts.u.derived,
+ &comp_tail->val,
+ &actual, true);
+ if (m == FAILURE)
+ goto cleanup;
+ }
+
+ if (comp)
+ comp = comp->next;
+ if (parent && !comp)
+ break;
+}
+
+ if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
+ goto cleanup;
+
+ /* No component should be left, as this should have caused an error in the
+ loop constructing the component-list (name that does not correspond to any
+ component in the structure definition). */
+ if (comp_head && sym->attr.extension)
+ {
+ for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
+ {
+ gfc_error ("component '%s' at %L has already been set by a "
+ "parent derived type constructor", comp_iter->name,
+ &comp_iter->where);
+ }
+ goto cleanup;
+ }
+ else
+ gcc_assert (!comp_head);
+
+ if (parent)
+ {
+ expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus);
+ expr->ts.u.derived = sym;
+ expr->value.constructor = ctor_head;
+ *cexpr = expr;
+ }
+ else
+ {
+ expr->ts.u.derived = sym;
+ expr->ts.kind = 0;
+ expr->ts.type = BT_DERIVED;
+ expr->value.constructor = ctor_head;
+ expr->expr_type = EXPR_STRUCTURE;
+ }
+
+ gfc_current_locus = old_locus;
+ if (parent)
+ *arglist = actual;
+ return SUCCESS;
+
+ cleanup:
+ gfc_current_locus = old_locus;
+
+ for (comp_iter = comp_head; comp_iter; )
+ {
+ gfc_structure_ctor_component *next = comp_iter->next;
+ gfc_free_structure_ctor_component (comp_iter);
+ comp_iter = next;
+ }
+/* gfc_constructor_free (ctor_head);*/
+
+ return FAILURE;
+}
+
+
match
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
bool parent)
@@ -2656,7 +2859,7 @@ gfc_match_rvalue (gfc_expr **result)
if (sym == NULL)
m = MATCH_ERROR;
else
- m = gfc_match_structure_constructor (sym, &e, false);
+ goto generic_function;
break;
/* If we're here, then the name is known to be the name of a
@@ -2930,6 +3133,12 @@ gfc_match_rvalue (gfc_expr **result)
e->symtree = symtree;
e->expr_type = EXPR_FUNCTION;
+ if (sym->attr.flavor == FL_DERIVED)
+ {
+ e->value.function.esym = sym;
+ e->symtree->n.sym->attr.generic = 1;
+ }
+
m = gfc_match_actual_arglist (0, &e->value.function.actual);
break;