+2009-04-07 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/38920
+ * expr.c (gfc_check_pointer_assign): Enable interface check for
+ procedure pointers.
+ * gfortran.h: Add copy_formal_args_intr.
+ * interface.c (gfc_compare_interfaces): Call gfc_compare_intr_interfaces
+ if second argument is an intrinsic.
+ (compare_intr_interfaces): Correctly set attr.function, attr.subroutine
+ and ts.
+ (compare_parameter): Call gfc_compare_interfaces also for intrinsics.
+ * resolve.c (resolve_specific_f0,resolve_specific_s0): Don't resolve
+ intrinsic interfaces here. Must happen earlier.
+ (resolve_symbol): Resolution of intrinsic interfaces moved here from
+ resolve_specific_..., and formal args are now copied from intrinsic
+ interfaces.
+ * symbol.c (copy_formal_args_intr): New function to copy the formal
+ arguments from an intinsic procedure.
+
2009-04-06 Paul Thomas <pault@gcc.gnu.org>
PR fortran/38863
"in procedure pointer assignment at %L",
rvalue->symtree->name, &rvalue->where);
}
- /* TODO. See PR 38290.
if (rvalue->expr_type == EXPR_VARIABLE
&& lvalue->symtree->n.sym->attr.if_source != IFSRC_UNKNOWN
&& !gfc_compare_interfaces (lvalue->symtree->n.sym,
gfc_error ("Interfaces don't match "
"in procedure pointer assignment at %L", &rvalue->where);
return FAILURE;
- }*/
+ }
return SUCCESS;
}
gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool);
-void copy_formal_args (gfc_symbol *dest, gfc_symbol *src);
+void copy_formal_args (gfc_symbol *, gfc_symbol *);
+void copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */
{
gfc_formal_arglist *f1, *f2;
+ if (s2->attr.intrinsic)
+ return compare_intr_interfaces (s1, s2);
+
if (s1->attr.function != s2->attr.function
|| s1->attr.subroutine != s2->attr.subroutine)
return 0; /* Disagreement between function/subroutine. */
gfc_intrinsic_arg *fi, *f2;
gfc_intrinsic_sym *isym;
+ isym = gfc_find_function (s2->name);
+ if (isym)
+ {
+ if (!s2->attr.function)
+ gfc_add_function (&s2->attr, s2->name, &gfc_current_locus);
+ s2->ts = isym->ts;
+ }
+ else
+ {
+ isym = gfc_find_subroutine (s2->name);
+ gcc_assert (isym);
+ if (!s2->attr.subroutine)
+ gfc_add_subroutine (&s2->attr, s2->name, &gfc_current_locus);
+ }
+
if (s1->attr.function != s2->attr.function
|| s1->attr.subroutine != s2->attr.subroutine)
return 0; /* Disagreement between function/subroutine. */
return 1;
}
- isym = gfc_find_function (s2->name);
-
- /* This should already have been checked in
- resolve.c (resolve_actual_arglist). */
- gcc_assert (isym);
-
f1 = s1->formal;
f2 = isym->formal;
|| actual->symtree->n.sym->attr.external)
return 1; /* Assume match. */
- if (actual->symtree->n.sym->attr.intrinsic)
- {
- if (!compare_intr_interfaces (formal, actual->symtree->n.sym))
- goto proc_fail;
- }
- else if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0))
+ if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0))
goto proc_fail;
return 1;
{
match m;
- /* See if we have an intrinsic interface. */
-
- if (sym->ts.interface != NULL && sym->ts.interface->attr.intrinsic)
- {
- gfc_intrinsic_sym *isym;
- isym = gfc_find_function (sym->ts.interface->name);
-
- /* Existence of isym should be checked already. */
- gcc_assert (isym);
-
- sym->ts.type = isym->ts.type;
- sym->ts.kind = isym->ts.kind;
- sym->attr.function = 1;
- sym->attr.proc = PROC_EXTERNAL;
- goto found;
- }
-
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
{
if (sym->attr.dummy)
{
match m;
- /* See if we have an intrinsic interface. */
- if (sym->ts.interface != NULL && !sym->ts.interface->attr.abstract
- && !sym->ts.interface->attr.subroutine
- && sym->ts.interface->attr.intrinsic)
- {
- gfc_intrinsic_sym *isym;
-
- isym = gfc_find_function (sym->ts.interface->name);
-
- /* Existence of isym should be checked already. */
- gcc_assert (isym);
-
- sym->ts.type = isym->ts.type;
- sym->ts.kind = isym->ts.kind;
- sym->attr.subroutine = 1;
- goto found;
- }
-
if(sym->attr.is_iso_c)
{
m = gfc_iso_c_sub_interface (c,sym);
if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
{
gfc_symbol *ifc = sym->ts.interface;
- sym->ts = ifc->ts;
- sym->ts.interface = ifc;
- sym->attr.function = ifc->attr.function;
- sym->attr.subroutine = ifc->attr.subroutine;
+
+ if (ifc->attr.intrinsic)
+ {
+ gfc_intrinsic_sym *isym = gfc_find_function (sym->ts.interface->name);
+ if (isym)
+ {
+ sym->attr.function = 1;
+ sym->ts = isym->ts;
+ sym->ts.interface = ifc;
+ }
+ else
+ {
+ isym = gfc_find_subroutine (sym->ts.interface->name);
+ gcc_assert (isym);
+ sym->attr.subroutine = 1;
+ }
+ copy_formal_args_intr (sym, isym);
+ }
+ else
+ {
+ sym->ts = ifc->ts;
+ sym->ts.interface = ifc;
+ sym->attr.function = ifc->attr.function;
+ sym->attr.subroutine = ifc->attr.subroutine;
+ copy_formal_args (sym, ifc);
+ }
+
sym->attr.allocatable = ifc->attr.allocatable;
sym->attr.pointer = ifc->attr.pointer;
sym->attr.pure = ifc->attr.pure;
sym->attr.dimension = ifc->attr.dimension;
sym->attr.recursive = ifc->attr.recursive;
sym->attr.always_explicit = ifc->attr.always_explicit;
- copy_formal_args (sym, ifc);
/* Copy array spec. */
sym->as = gfc_copy_array_spec (ifc->as);
if (sym->as)
gfc_current_ns = parent_ns;
}
+void
+copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
+{
+ gfc_formal_arglist *head = NULL;
+ gfc_formal_arglist *tail = NULL;
+ gfc_formal_arglist *formal_arg = NULL;
+ gfc_intrinsic_arg *curr_arg = NULL;
+ gfc_formal_arglist *formal_prev = NULL;
+ /* Save current namespace so we can change it for formal args. */
+ gfc_namespace *parent_ns = gfc_current_ns;
+
+ /* Create a new namespace, which will be the formal ns (namespace
+ of the formal args). */
+ gfc_current_ns = gfc_get_namespace (parent_ns, 0);
+ gfc_current_ns->proc_name = dest;
+
+ for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
+ {
+ formal_arg = gfc_get_formal_arglist ();
+ gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
+
+ /* May need to copy more info for the symbol. */
+ formal_arg->sym->ts = curr_arg->ts;
+ formal_arg->sym->attr.optional = curr_arg->optional;
+ /*formal_arg->sym->attr = curr_arg->sym->attr;
+ formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
+ copy_formal_args (formal_arg->sym, curr_arg->sym);*/
+
+ /* If this isn't the first arg, set up the next ptr. For the
+ last arg built, the formal_arg->next will never get set to
+ anything other than NULL. */
+ if (formal_prev != NULL)
+ formal_prev->next = formal_arg;
+ else
+ formal_arg->next = NULL;
+
+ formal_prev = formal_arg;
+
+ /* Add arg to list of formal args. */
+ add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+ }
+
+ /* Add the interface to the symbol. */
+ add_proc_interface (dest, IFSRC_DECL, head);
+
+ /* Store the formal namespace information. */
+ if (dest->formal != NULL)
+ /* The current ns should be that for the dest proc. */
+ dest->formal_ns = gfc_current_ns;
+ /* Restore the current namespace to what it was on entry. */
+ gfc_current_ns = parent_ns;
+}
+
/* Builds the parameter list for the iso_c_binding procedure
c_f_pointer or c_f_procpointer. The old_sym typically refers to a
generic version of either the c_f_pointer or c_f_procpointer
+2009-04-07 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/38920
+ * gfortran.dg/proc_decl_1.f90: Modified.
+ * gfortran.dg/proc_ptr_11.f90: Extended.
+ * gfortran.dg/proc_ptr_13.f90: Modified.
+
2009-04-06 Jason Merrill <jason@redhat.com>
PR c++/35146
public:: h
procedure(),public:: h ! { dg-error "was already specified" }
-end module m
+contains
+ subroutine abc
+ procedure() :: abc2
+ entry abc2(x) ! { dg-error "PROCEDURE attribute conflicts with ENTRY attribute" }
+ real x
+ end subroutine
+
+end module m
program prog
end subroutine foo
end program
-
-
-subroutine abc
-
- procedure() :: abc2
-
-entry abc2(x) ! { dg-error "PROCEDURE attribute conflicts with ENTRY attribute" }
- real x
-
-end subroutine
procedure( up ) , pointer :: pptr
procedure(isign), pointer :: q
- ! TODO. See PR 38290.
- !pptr => add ! { "Interfaces don't match" }
+ procedure(iabs),pointer :: p1
+ procedure(f), pointer :: p2
+
+ pointer :: p3
+ interface
+ function p3(x)
+ real(8) :: p3,x
+ end function p3
+ end interface
+
+ pptr => add ! { dg-error "Interfaces don't match" }
q => add
print *, pptr() ! { dg-error "is not a function" }
+ p1 => iabs
+ p2 => iabs
+ p1 => f
+ p2 => f
+ p2 => p1
+ p1 => p2
+
+ p1 => abs ! { dg-error "Interfaces don't match" }
+ p2 => abs ! { dg-error "Interfaces don't match" }
+
+ p3 => dsin
+ p3 => sin ! { dg-error "Interfaces don't match" }
+
contains
function add( a, b )
add = a + b
end function add
+ integer function f(x)
+ integer :: x
+ f = 317 + x
+ end function
+
end program bsp
use myfortran_binding
-external foo
-error_handler => foo
+error_handler => error_stop
end
! { dg-final { cleanup-modules "myfortran_binding" } }
git://gcc.gnu.org / gcc.git / commitdiff