Skip to content

R
riscv-gcc-1
Commit 3afadac3 by Janus Weil
Options

re PR other/38920 (dw2 exceptions don't work.) 

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-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.

From-SVN: r145651
parent 44509946
Showing with 166 additions and 70 deletions
gcc/fortran/ChangeLog
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
......
gcc/fortran/expr.c
......@@ -3142,7 +3142,6 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
"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,
......@@ -3151,7 +3150,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
gfc_error ("Interfaces don't match "
"in procedure pointer assignment at %L", &rvalue->where);
return FAILURE;
}*/
}
return SUCCESS;
}
......
gcc/fortran/gfortran.h
......@@ -2369,7 +2369,8 @@ gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
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 */
......
gcc/fortran/interface.c
......@@ -967,6 +967,9 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
{
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. */
......@@ -1006,6 +1009,21 @@ compare_intr_interfaces (gfc_symbol *s1, gfc_symbol *s2)
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. */
......@@ -1022,12 +1040,6 @@ compare_intr_interfaces (gfc_symbol *s1, gfc_symbol *s2)
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;
......@@ -1463,12 +1475,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
|| 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;
......
gcc/fortran/resolve.c
......@@ -1742,23 +1742,6 @@ resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
{
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)
......@@ -2795,24 +2778,6 @@ resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
{
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);
......@@ -9201,10 +9166,33 @@ resolve_symbol (gfc_symbol *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;
......@@ -9212,7 +9200,6 @@ resolve_symbol (gfc_symbol *sym)
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)
......
gcc/fortran/symbol.c
......@@ -3839,6 +3839,59 @@ copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
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
......
gcc/testsuite/ChangeLog
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
......
gcc/testsuite/gfortran.dg/proc_decl_1.f90
......@@ -19,8 +19,15 @@ module m
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
......@@ -68,13 +75,3 @@ contains
end subroutine foo
end program
subroutine abc
procedure() :: abc2
entry abc2(x) ! { dg-error "PROCEDURE attribute conflicts with ENTRY attribute" }
real x
end subroutine
gcc/testsuite/gfortran.dg/proc_ptr_11.f90
......@@ -16,13 +16,35 @@ program bsp
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 )
......@@ -31,4 +53,9 @@ program bsp
add = a + b
end function add
integer function f(x)
integer :: x
f = 317 + x
end function
end program bsp
gcc/testsuite/gfortran.dg/proc_ptr_13.f90
......@@ -22,8 +22,7 @@ END MODULE myfortran_binding
use myfortran_binding
external foo
error_handler => foo
error_handler => error_stop
end
! { dg-final { cleanup-modules "myfortran_binding" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment