diff options
| author | Paul Thomas <pault@gcc.gnu.org> | 2021-03-28 16:48:27 +0100 |
|---|---|---|
| committer | Paul Thomas <pault@gcc.gnu.org> | 2021-03-28 19:39:50 +0100 |
| commit | 297363774e6a5dca2f46a85ab086f1d9e59431ac (patch) | |
| tree | 396b7b7ff01733f9a5d5a51d9218d6ff67d433b1 /gcc/fortran | |
| parent | 5a5d23010ab8ecbefd443054d9a3ec227aceb976 (diff) | |
| download | gcc-297363774e6a5dca2f46a85ab086f1d9e59431ac.zip gcc-297363774e6a5dca2f46a85ab086f1d9e59431ac.tar.gz gcc-297363774e6a5dca2f46a85ab086f1d9e59431ac.tar.bz2 | |
Fortran: Fix problem with runtime pointer check [PR99602].
2021-03-28 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran/ChangeLog
PR fortran/99602
* trans-expr.c (gfc_conv_procedure_call): Use the _data attrs
for class expressions and detect proc pointer evaluations by
the non-null actual argument list.
gcc/testsuite/ChangeLog
PR fortran/99602
* gfortran.dg/pr99602.f90: New test.
* gfortran.dg/pr99602a.f90: New test.
* gfortran.dg/pr99602b.f90: New test.
* gfortran.dg/pr99602c.f90: New test.
* gfortran.dg/pr99602d.f90: New test.
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/trans-expr.c | 28 |
1 files changed, 20 insertions, 8 deletions
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index bffe080..2fa17b3 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -6663,6 +6663,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, char *msg; tree cond; tree tmp; + symbol_attribute fsym_attr; + + if (fsym) + { + if (fsym->ts.type == BT_CLASS) + { + fsym_attr = CLASS_DATA (fsym)->attr; + fsym_attr.pointer = fsym_attr.class_pointer; + } + else + fsym_attr = fsym->attr; + } if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION) attr = gfc_expr_attr (e); @@ -6685,17 +6697,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tree present, null_ptr, type; if (attr.allocatable - && (fsym == NULL || !fsym->attr.allocatable)) + && (fsym == NULL || !fsym_attr.allocatable)) msg = xasprintf ("Allocatable actual argument '%s' is not " "allocated or not present", e->symtree->n.sym->name); else if (attr.pointer - && (fsym == NULL || !fsym->attr.pointer)) + && (fsym == NULL || !fsym_attr.pointer)) msg = xasprintf ("Pointer actual argument '%s' is not " "associated or not present", e->symtree->n.sym->name); - else if (attr.proc_pointer - && (fsym == NULL || !fsym->attr.proc_pointer)) + else if (attr.proc_pointer && !e->value.function.actual + && (fsym == NULL || !fsym_attr.proc_pointer)) msg = xasprintf ("Proc-pointer actual argument '%s' is not " "associated or not present", e->symtree->n.sym->name); @@ -6719,15 +6731,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else { if (attr.allocatable - && (fsym == NULL || !fsym->attr.allocatable)) + && (fsym == NULL || !fsym_attr.allocatable)) msg = xasprintf ("Allocatable actual argument '%s' is not " "allocated", e->symtree->n.sym->name); else if (attr.pointer - && (fsym == NULL || !fsym->attr.pointer)) + && (fsym == NULL || !fsym_attr.pointer)) msg = xasprintf ("Pointer actual argument '%s' is not " "associated", e->symtree->n.sym->name); - else if (attr.proc_pointer - && (fsym == NULL || !fsym->attr.proc_pointer)) + else if (attr.proc_pointer && !e->value.function.actual + && (fsym == NULL || !fsym_attr.proc_pointer)) msg = xasprintf ("Proc-pointer actual argument '%s' is not " "associated", e->symtree->n.sym->name); else |