From 7fcafa718da6cb8e072bcadde5eab440df5898d0 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sun, 31 Dec 2006 06:55:16 +0000 Subject: re PR fortran/23060 (%VAL, %REF and %DESCR constructs not implemented) 2006-12-31 Paul Thomas PR fortran/23060 * intrinsic.c (compare_actual_formal ): Distinguish argument list functions from keywords. * intrinsic.c (sort_actual): If formal is NULL, the presence of an argument list function actual is an error. * trans-expr.c (conv_arglist_function) : New function to implement argument list functions %VAL, %REF and %LOC. (gfc_conv_function_call): Call it. * resolve.c (resolve_actual_arglist): Add arg ptype and check argument list functions. (resolve_function, resolve_call): Set value of ptype before calls to resolve_actual_arglist. * primary.c (match_arg_list_function): New function. (gfc_match_actual_arglist): Call it before trying for a keyword argument. 2006-12-31 Paul Thomas PR fortran/23060 * gfortran.dg/c_by_val.c: Called by c_by_val_1.f. * gfortran.dg/c_by_val_1.f: New test. * gfortran.dg/c_by_val_2.f: New test. * gfortran.dg/c_by_val_3.f: New test. From-SVN: r120295 --- gcc/fortran/resolve.c | 79 +++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 71 insertions(+), 8 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 2c71ae4..1b46a10 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -844,7 +844,7 @@ resolve_assumed_size_actual (gfc_expr *e) references. */ static try -resolve_actual_arglist (gfc_actual_arglist * arg) +resolve_actual_arglist (gfc_actual_arglist * arg, procedure_type ptype) { gfc_symbol *sym; gfc_symtree *parent_st; @@ -852,7 +852,6 @@ resolve_actual_arglist (gfc_actual_arglist * arg) for (; arg; arg = arg->next) { - e = arg->expr; if (e == NULL) { @@ -873,7 +872,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg) { if (gfc_resolve_expr (e) != SUCCESS) return FAILURE; - continue; + goto argument_list; } /* See if the expression node should really be a variable @@ -938,7 +937,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg) && sym->ns->parent->proc_name == sym))) goto got_variable; - continue; + goto argument_list; } /* See if the name is a module procedure in a parent unit. */ @@ -962,7 +961,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg) || sym->attr.intrinsic || sym->attr.external) { - continue; + goto argument_list; } got_variable: @@ -976,6 +975,62 @@ resolve_actual_arglist (gfc_actual_arglist * arg) e->ref->u.ar.type = AR_FULL; e->ref->u.ar.as = sym->as; } + + argument_list: + /* Check argument list functions %VAL, %LOC and %REF. There is + nothing to do for %REF. */ + if (arg->name && arg->name[0] == '%') + { + if (strncmp ("%VAL", arg->name, 4) == 0) + { + if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED) + { + gfc_error ("By-value argument at %L is not of numeric " + "type", &e->where); + return FAILURE; + } + + if (e->rank) + { + gfc_error ("By-value argument at %L cannot be an array or " + "an array section", &e->where); + return FAILURE; + } + + /* Intrinsics are still PROC_UNKNOWN here. However, + since same file external procedures are not resolvable + in gfortran, it is a good deal easier to leave them to + intrinsic.c. */ + if (ptype != PROC_UNKNOWN && ptype != PROC_EXTERNAL) + { + gfc_error ("By-value argument at %L is not allowed " + "in this context", &e->where); + return FAILURE; + } + + if (((e->ts.type == BT_REAL || e->ts.type == BT_COMPLEX) + && e->ts.kind > gfc_default_real_kind) + || (e->ts.kind > gfc_default_integer_kind)) + { + gfc_error ("Kind of by-value argument at %L is larger " + "than default kind", &e->where); + return FAILURE; + } + + } + + /* Statement functions have already been excluded above. */ + else if (strncmp ("%LOC", arg->name, 4) == 0 + && e->ts.type == BT_PROCEDURE) + { + if (e->symtree->n.sym->attr.proc == PROC_INTERNAL) + { + gfc_error ("Passing internal procedure at %L by location " + "not allowed", &e->where); + return FAILURE; + } + } + } } return SUCCESS; @@ -1451,6 +1506,7 @@ resolve_function (gfc_expr * expr) const char *name; try t; int temp; + procedure_type p = PROC_INTRINSIC; sym = NULL; if (expr->symtree) @@ -1467,8 +1523,11 @@ resolve_function (gfc_expr * expr) of procedure, once the procedure itself is resolved. */ need_full_assumed_size++; - if (resolve_actual_arglist (expr->value.function.actual) == FAILURE) - return FAILURE; + if (expr->symtree && expr->symtree->n.sym) + p = expr->symtree->n.sym->attr.proc; + + if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE) + return FAILURE; /* Resume assumed_size checking. */ need_full_assumed_size--; @@ -1848,6 +1907,7 @@ static try resolve_call (gfc_code * c) { try t; + procedure_type ptype = PROC_INTRINSIC; if (c->symtree && c->symtree->n.sym && c->symtree->n.sym->ts.type != BT_UNKNOWN) @@ -1894,7 +1954,10 @@ resolve_call (gfc_code * c) of procedure, once the procedure itself is resolved. */ need_full_assumed_size++; - if (resolve_actual_arglist (c->ext.actual) == FAILURE) + if (c->symtree && c->symtree->n.sym) + ptype = c->symtree->n.sym->attr.proc; + + if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE) return FAILURE; /* Resume assumed_size checking. */ -- cgit v1.1