diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 7 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.c | 1 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 91 |
3 files changed, 78 insertions, 21 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 77c5f61f533..3f3feec9243 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2009-07-09 Tobias Burnus <burnus@net-b.de> + + PR fortran/40604 + * intrinsic.c (gfc_convert_type_warn): Set sym->result. + * trans-expr.c (gfc_conv_procedure_call): Fix -fcheck=pointer + for optional arguments. + 2009-07-08 Tobias Burnus <burnus@net-b.de> PR fortran/40675 diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 7bb10ec245b..9402234b034 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -3994,6 +3994,7 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag) new_expr->shape = gfc_copy_shape (shape, rank); gfc_get_ha_sym_tree (sym->name, &new_expr->symtree); + new_expr->symtree->n.sym->result = new_expr->symtree->n.sym; new_expr->symtree->n.sym->ts = *ts; new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE; new_expr->symtree->n.sym->attr.function = 1; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index d4ee169d08e..fe33286a402 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2784,37 +2784,86 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Add argument checking of passing an unallocated/NULL actual to a nonallocatable/nonpointer dummy. */ - if (gfc_option.rtcheck & GFC_RTCHECK_POINTER) + if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL) { - gfc_symbol *sym; + symbol_attribute *attr; char *msg; tree cond; if (e->expr_type == EXPR_VARIABLE) - sym = e->symtree->n.sym; + attr = &e->symtree->n.sym->attr; else if (e->expr_type == EXPR_FUNCTION) - sym = e->symtree->n.sym->result; - else - goto end_pointer_check; + { + /* For intrinsic functions, the gfc_attr are not available. */ + if (e->symtree->n.sym->attr.generic && e->value.function.isym) + goto end_pointer_check; - if (sym->attr.allocatable - && (fsym == NULL || !fsym->attr.allocatable)) - asprintf (&msg, "Allocatable actual argument '%s' is not " - "allocated", sym->name); - else if (sym->attr.pointer - && (fsym == NULL || !fsym->attr.pointer)) - asprintf (&msg, "Pointer actual argument '%s' is not " - "associated", sym->name); - else if (sym->attr.proc_pointer - && (fsym == NULL || !fsym->attr.proc_pointer)) - asprintf (&msg, "Proc-pointer actual argument '%s' is not " - "associated", sym->name); + if (e->symtree->n.sym->attr.generic) + attr = &e->value.function.esym->attr; + else + attr = &e->symtree->n.sym->result->attr; + } else goto end_pointer_check; - cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr, - fold_convert (TREE_TYPE (parmse.expr), - null_pointer_node)); + if (attr->optional) + { + /* If the actual argument is an optional pointer/allocatable and + the formal argument takes an nonpointer optional value, + it is invalid to pass a non-present argument on, even + though there is no technical reason for this in gfortran. + See Fortran 2003, Section 12.4.1.6 item (7)+(8). */ + tree present, nullptr, type; + + if (attr->allocatable + && (fsym == NULL || !fsym->attr.allocatable)) + asprintf (&msg, "Allocatable actual argument '%s' is not " + "allocated or not present", e->symtree->n.sym->name); + else if (attr->pointer + && (fsym == NULL || !fsym->attr.pointer)) + asprintf (&msg, "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)) + asprintf (&msg, "Proc-pointer actual argument '%s' is not " + "associated or not present", + e->symtree->n.sym->name); + else + goto end_pointer_check; + + present = gfc_conv_expr_present (e->symtree->n.sym); + type = TREE_TYPE (present); + present = fold_build2 (EQ_EXPR, boolean_type_node, present, + fold_convert (type, null_pointer_node)); + type = TREE_TYPE (parmse.expr); + nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr, + fold_convert (type, null_pointer_node)); + cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, + present, nullptr); + } + else + { + if (attr->allocatable + && (fsym == NULL || !fsym->attr.allocatable)) + asprintf (&msg, "Allocatable actual argument '%s' is not " + "allocated", e->symtree->n.sym->name); + else if (attr->pointer + && (fsym == NULL || !fsym->attr.pointer)) + asprintf (&msg, "Pointer actual argument '%s' is not " + "associated", e->symtree->n.sym->name); + else if (attr->proc_pointer + && (fsym == NULL || !fsym->attr.proc_pointer)) + asprintf (&msg, "Proc-pointer actual argument '%s' is not " + "associated", e->symtree->n.sym->name); + else + goto end_pointer_check; + + + cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr, + fold_convert (TREE_TYPE (parmse.expr), + null_pointer_node)); + } gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where, msg); |
