aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/ChangeLog13
-rw-r--r--gcc/fortran/expr.c39
-rw-r--r--gcc/fortran/gfortran.h3
-rw-r--r--gcc/fortran/interface.c23
-rw-r--r--gcc/fortran/resolve.c2
-rw-r--r--gcc/testsuite/ChangeLog5
-rw-r--r--gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f9049
7 files changed, 110 insertions, 24 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 23dce57..223f88c 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+2009-08-27 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/40869
+ * expr.c (gfc_check_pointer_assign): Enable interface check for
+ pointer assignments involving procedure pointer components.
+ * gfortran.h (gfc_compare_interfaces): Modified prototype.
+ * interface.c (gfc_compare_interfaces): Add argument 'name2', to be
+ used instead of s2->name. Don't rely on the proc_pointer attribute,
+ but instead on the flags handed to this function.
+ (check_interface1,compare_parameter): Add argument for
+ gfc_compare_interfaces.
+ * resolve.c (check_generic_tbp_ambiguity): Ditto.
+
2009-08-27 Daniel Kraft <d@domob.eu>
PR fortran/37425
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 57582a9..970c259 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3149,6 +3149,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
if (proc_pointer)
{
char err[200];
+ gfc_symbol *s1,*s2;
+ gfc_component *comp;
+ const char *name;
+
attr = gfc_expr_attr (rvalue);
if (!((rvalue->expr_type == EXPR_NULL)
|| (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
@@ -3208,22 +3212,35 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
}
}
- /* TODO: Enable interface check for PPCs. */
- if (gfc_is_proc_ptr_comp (rvalue, NULL))
- return SUCCESS;
- if ((rvalue->expr_type == EXPR_VARIABLE
- && !gfc_compare_interfaces (lvalue->symtree->n.sym,
- rvalue->symtree->n.sym, 0, 1, err,
- sizeof(err)))
- || (rvalue->expr_type == EXPR_FUNCTION
- && !gfc_compare_interfaces (lvalue->symtree->n.sym,
- rvalue->symtree->n.sym->result, 0, 1,
- err, sizeof(err))))
+ if (gfc_is_proc_ptr_comp (lvalue, &comp))
+ s1 = comp->ts.interface;
+ else
+ s1 = lvalue->symtree->n.sym;
+
+ if (gfc_is_proc_ptr_comp (rvalue, &comp))
+ {
+ s2 = comp->ts.interface;
+ name = comp->name;
+ }
+ else if (rvalue->expr_type == EXPR_FUNCTION)
+ {
+ s2 = rvalue->symtree->n.sym->result;
+ name = rvalue->symtree->n.sym->result->name;
+ }
+ else
+ {
+ s2 = rvalue->symtree->n.sym;
+ name = rvalue->symtree->n.sym->name;
+ }
+
+ if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
+ err, sizeof(err)))
{
gfc_error ("Interface mismatch in procedure pointer assignment "
"at %L: %s", &rvalue->where, err);
return FAILURE;
}
+
return SUCCESS;
}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 16c596b..514cc80 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2650,7 +2650,8 @@ gfc_try gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *);
void gfc_free_interface (gfc_interface *);
int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
int gfc_compare_types (gfc_typespec *, gfc_typespec *);
-int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int, int, char *, int);
+int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, const char *, int, int,
+ char *, int);
void gfc_check_interfaces (gfc_namespace *);
void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
void gfc_ppc_use (gfc_component *, gfc_actual_arglist **, locus *);
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 6d16fe1..132f10a 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -943,31 +943,31 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
required to match, which is not the case for ambiguity checks.*/
int
-gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
- int intent_flag, char *errmsg, int err_len)
+gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
+ int generic_flag, int intent_flag,
+ char *errmsg, int err_len)
{
gfc_formal_arglist *f1, *f2;
if (s1->attr.function && (s2->attr.subroutine
|| (!s2->attr.function && s2->ts.type == BT_UNKNOWN
- && gfc_get_default_type (s2->name, s2->ns)->type == BT_UNKNOWN)))
+ && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
{
if (errmsg != NULL)
- snprintf (errmsg, err_len, "'%s' is not a function", s2->name);
+ snprintf (errmsg, err_len, "'%s' is not a function", name2);
return 0;
}
if (s1->attr.subroutine && s2->attr.function)
{
if (errmsg != NULL)
- snprintf (errmsg, err_len, "'%s' is not a subroutine", s2->name);
+ snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
return 0;
}
/* If the arguments are functions, check type and kind
(only for dummy procedures and procedure pointer assignments). */
- if ((s1->attr.dummy || s1->attr.proc_pointer)
- && s1->attr.function && s2->attr.function)
+ if (!generic_flag && intent_flag && s1->attr.function && s2->attr.function)
{
if (s1->ts.type == BT_UNKNOWN)
return 1;
@@ -975,7 +975,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
{
if (errmsg != NULL)
snprintf (errmsg, err_len, "Type/kind mismatch in return value "
- "of '%s'", s2->name);
+ "of '%s'", name2);
return 0;
}
}
@@ -1012,7 +1012,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
{
if (errmsg != NULL)
snprintf (errmsg, err_len, "'%s' has the wrong number of "
- "arguments", s2->name);
+ "arguments", name2);
return 0;
}
@@ -1120,7 +1120,8 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue;
- if (gfc_compare_interfaces (p->sym, q->sym, generic_flag, 0, NULL, 0))
+ if (gfc_compare_interfaces (p->sym, q->sym, NULL, generic_flag, 0,
+ NULL, 0))
{
if (referenced)
{
@@ -1403,7 +1404,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
return 0;
}
- if (!gfc_compare_interfaces (formal, act_sym, 0, 1, err,
+ if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
sizeof(err)))
{
if (where)
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index e1c931b..f10a412 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8851,7 +8851,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
}
/* Compare the interfaces. */
- if (gfc_compare_interfaces (sym1, sym2, 1, 0, NULL, 0))
+ if (gfc_compare_interfaces (sym1, sym2, NULL, 1, 0, NULL, 0))
{
gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
sym1->name, sym2->name, generic_name, &where);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c9979ca..3b29417 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2009-08-27 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/40869
+ * gfortran.dg/proc_ptr_comp_20.f90: New.
+
2009-08-27 Janne Blomqvist <jb@gcc.gnu.org>
PR libfortran/39667
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90
new file mode 100644
index 0000000..d477368
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90
@@ -0,0 +1,49 @@
+! { dg-do compile }
+!
+! PR 40869: [F03] PPC assignment checking
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+implicit none
+
+interface func
+ procedure f1,f2 ! { dg-error "Ambiguous interfaces" }
+end interface
+
+interface operator(.op.)
+ procedure f1,f2 ! { dg-error "Ambiguous interfaces" }
+end interface
+
+type :: t1
+ procedure(integer), pointer, nopass :: ppc
+end type
+
+type :: t2
+ procedure(real), pointer, nopass :: ppc
+end type
+
+type(t1) :: o1
+type(t2) :: o2
+procedure(logical),pointer :: pp1
+procedure(complex),pointer :: pp2
+
+pp1 => pp2 ! { dg-error "Type/kind mismatch" }
+pp2 => o2%ppc ! { dg-error "Type/kind mismatch" }
+
+o1%ppc => pp1 ! { dg-error "Type/kind mismatch" }
+o1%ppc => o2%ppc ! { dg-error "Type/kind mismatch" }
+
+contains
+
+ real function f1(a,b)
+ real,intent(in) :: a,b
+ f1 = a + b
+ end function
+
+ integer function f2(a,b)
+ real,intent(in) :: a,b
+ f2 = a - b
+ end function
+
+end
+
generated by cgit v1.1 at 2025-05-15 23:43:13 +0000