From b01b9ca1c131e7443f66b67b3b3a80ab07b97e4f Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sat, 6 Jan 2007 14:13:20 +0000 Subject: [PATCH] Bug fixes from trunk 2007-01-06 Paul Thomas Bug fixes from trunk PR fortran/30034 * resolve.c (resolve_formal_arglist): Exclude the test for pointers and procedures for subroutine arguments as well as functions. PR fortran/30237 * intrinsic.c (remove_nullargs): Do not pass up arguments with a label. If the actual has a label and the formal has a type then emit an error. PR fortran/25135 * module.c (load_generic_interfaces): If the symbol is present and is not generic it is ambiguous. 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. PR fortran/27900 * resolve.c (resolve_actual_arglist): If all else fails and a procedure actual argument has no type, see if a specific intrinsic matches. PR fortran/24325 * resolve.c (resolve_function): If the function reference is FL_VARIABLE this is an error. 2007-01-06 Paul Thomas PR fortran/30034 * gfortran.dg/pure_formal_proc_1.f90: New test. PR fortran/30237 * gfortran.dg/intrinsic_actual_3.f90: New test. PR fortran/25135 * gfortran.dg/generic_11.f90: New test. * gfortran.dg/interface_7.f90: Remove name clash between module name and procedure 'x' referenced in the interface. 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. PR fortran/27900 * gfortran.dg/intrinsic_actual_4.f90: New test. PR fortran/24325 * gfortran.dg/func_decl_3.f90: New test. From-SVN: r120525 --- gcc/fortran/ChangeLog | 41 +++++ gcc/fortran/interface.c | 18 +-- gcc/fortran/intrinsic.c | 14 +- gcc/fortran/module.c | 10 ++ gcc/fortran/primary.c | 91 ++++++++++- gcc/fortran/resolve.c | 147 ++++++++++++++---- gcc/fortran/trans-expr.c | 78 ++++++++-- gcc/testsuite/ChangeLog | 25 +++ gcc/testsuite/gfortran.dg/c_by_val.c | 41 +++++ gcc/testsuite/gfortran.dg/c_by_val_1.f | 31 ++++ gcc/testsuite/gfortran.dg/c_by_val_2.f90 | 29 ++++ gcc/testsuite/gfortran.dg/c_by_val_3.f90 | 7 + .../gfortran.dg/dummy_procedure_1.f90 | 2 +- gcc/testsuite/gfortran.dg/func_decl_3.f90 | 15 ++ gcc/testsuite/gfortran.dg/generic_11.f90 | 31 ++++ gcc/testsuite/gfortran.dg/interface_7.f90 | 6 +- .../gfortran.dg/intrinsic_actual_3.f90 | 24 +++ .../gfortran.dg/intrinsic_actual_4.f90 | 18 +++ .../gfortran.dg/pure_formal_proc_1.f90 | 16 ++ 19 files changed, 580 insertions(+), 64 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/c_by_val.c create mode 100644 gcc/testsuite/gfortran.dg/c_by_val_1.f create mode 100644 gcc/testsuite/gfortran.dg/c_by_val_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c_by_val_3.f90 create mode 100644 gcc/testsuite/gfortran.dg/func_decl_3.f90 create mode 100644 gcc/testsuite/gfortran.dg/generic_11.f90 create mode 100644 gcc/testsuite/gfortran.dg/intrinsic_actual_3.f90 create mode 100644 gcc/testsuite/gfortran.dg/intrinsic_actual_4.f90 create mode 100644 gcc/testsuite/gfortran.dg/pure_formal_proc_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0bd26e4a8b7b..2a2d7d5f211c 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,44 @@ +2007-01-06 Paul Thomas + + PR fortran/30034 + * resolve.c (resolve_formal_arglist): Exclude the test for + pointers and procedures for subroutine arguments as well as + functions. + + PR fortran/30237 + * intrinsic.c (remove_nullargs): Do not pass up arguments with + a label. If the actual has a label and the formal has a type + then emit an error. + + PR fortran/25135 + * module.c (load_generic_interfaces): If the symbol is present + and is not generic it is ambiguous. + + 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. + + PR fortran/27900 + * resolve.c (resolve_actual_arglist): If all else fails and a + procedure actual argument has no type, see if a specific + intrinsic matches. + + PR fortran/24325 + * resolve.c (resolve_function): If the function reference is + FL_VARIABLE this is an error. + 2007-01-03 Paul Thomas PR fortran/25818 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index ea15acb6586d..f0b612e6e886 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1232,7 +1232,6 @@ compare_actual_formal (gfc_actual_arglist ** ap, { gfc_actual_arglist **new, *a, *actual, temp; gfc_formal_arglist *f; - gfc_gsymbol *gsym; int i, n, na; bool rank_check; @@ -1256,7 +1255,8 @@ compare_actual_formal (gfc_actual_arglist ** ap, for (a = actual; a; a = a->next, f = f->next) { - if (a->name != NULL) + /* Look for keywords but ignore g77 extensions like %VAL. */ + if (a->name != NULL && a->name[0] != '%') { i = 0; for (f = formal; f; f = f->next, i++) @@ -1338,16 +1338,10 @@ compare_actual_formal (gfc_actual_arglist ** ap, && a->expr->expr_type == EXPR_VARIABLE && f->sym->attr.flavor == FL_PROCEDURE) { - gsym = gfc_find_gsymbol (gfc_gsym_root, - a->expr->symtree->n.sym->name); - if (gsym == NULL || (gsym->type != GSYM_FUNCTION - && gsym->type != GSYM_SUBROUTINE)) - { - if (where) - gfc_error ("Expected a procedure for argument '%s' at %L", - f->sym->name, &a->expr->where); - return 0; - } + if (where) + gfc_error ("Expected a procedure for argument '%s' at %L", + f->sym->name, &a->expr->where); + return 0; } if (f->sym->attr.flavor == FL_PROCEDURE diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 80123ab2ae14..05d1a1ae8c1e 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -2782,7 +2782,7 @@ remove_nullargs (gfc_actual_arglist ** ap) { next = head->next; - if (head->expr == NULL) + if (head->expr == NULL && !head->label) { head->next = NULL; gfc_free_actual_arglist (head); @@ -2864,7 +2864,11 @@ keywords: if (f == NULL) { - gfc_error ("Can't find keyword named '%s' in call to '%s' at %L", + if (a->name[0] == '%') + gfc_error ("Argument list function at %L is not allowed in this " + "context", where); + else + gfc_error ("Can't find keyword named '%s' in call to '%s' at %L", a->name, name, where); return FAILURE; } @@ -2898,6 +2902,12 @@ do_sort: for (f = formal; f; f = f->next) { + if (f->actual && f->actual->label != NULL && f->ts.type) + { + gfc_error ("ALTERNATE RETURN not permitted at %L", where); + return FAILURE; + } + if (f->actual == NULL) { a = gfc_get_actual_arglist (); diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 54aeb4b4bcad..cf4b86e146f6 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -3016,6 +3016,16 @@ load_generic_interfaces (void) sym->attr.generic = 1; sym->attr.use_assoc = 1; } + else + { + /* Unless sym is a generic interface, this reference + is ambiguous. */ + gfc_symtree *st; + p = p ? p : name; + st = gfc_find_symtree (gfc_current_ns->sym_root, p); + st->ambiguous = sym->attr.generic ? 0 : 1; + } + if (i == 1) { mio_interface_rest (&sym->generic); diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 1b918b3202fe..1c374e2eda25 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1429,6 +1429,80 @@ cleanup: } +/* Match an argument list function, such as %VAL. */ + +static match +match_arg_list_function (gfc_actual_arglist *result) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + locus old_locus; + match m; + + old_locus = gfc_current_locus; + + if (gfc_match_char ('%') != MATCH_YES) + { + m = MATCH_NO; + goto cleanup; + } + + m = gfc_match ("%n (", name); + if (m != MATCH_YES) + goto cleanup; + + if (name[0] != '\0') + { + switch (name[0]) + { + case 'l': + if (strncmp(name, "loc", 3) == 0) + { + result->name = "%LOC"; + break; + } + case 'r': + if (strncmp(name, "ref", 3) == 0) + { + result->name = "%REF"; + break; + } + case 'v': + if (strncmp(name, "val", 3) == 0) + { + result->name = "%VAL"; + break; + } + default: + m = MATCH_ERROR; + goto cleanup; + } + } + + if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list " + "function at %C") == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } + + m = match_actual_arg (&result->expr); + if (m != MATCH_YES) + goto cleanup; + + if (gfc_match_char (')') != MATCH_YES) + { + m = MATCH_NO; + goto cleanup; + } + + return MATCH_YES; + +cleanup: + gfc_current_locus = old_locus; + return m; +} + + /* Matches an actual argument list of a function or subroutine, from the opening parenthesis to the closing parenthesis. The argument list is assumed to allow keyword arguments because we don't know if @@ -1497,13 +1571,21 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp) } else { - /* See if we have the first keyword argument. */ - m = match_keyword_arg (tail, head); - if (m == MATCH_YES) - seen_keyword = 1; + /* Try an argument list function, like %VAL. */ + m = match_arg_list_function (tail); if (m == MATCH_ERROR) goto cleanup; + /* See if we have the first keyword argument. */ + if (m == MATCH_NO) + { + m = match_keyword_arg (tail, head); + if (m == MATCH_YES) + seen_keyword = 1; + if (m == MATCH_ERROR) + goto cleanup; + } + if (m == MATCH_NO) { /* Try for a non-keyword argument. */ @@ -1515,6 +1597,7 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp) } } + next: if (gfc_match_char (')') == MATCH_YES) break; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 78209b3dd90b..a0e7bd03fa7c 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -140,6 +140,21 @@ resolve_formal_arglist (gfc_symbol * proc) continue; } + if (sym->attr.function + && sym->ts.type == BT_UNKNOWN + && sym->attr.intrinsic) + { + gfc_intrinsic_sym *isym; + isym = gfc_find_function (sym->name); + if (isym == NULL || !isym->specific) + { + gfc_error ("Unable to find a specific INTRINSIC procedure " + "for the reference '%s' at %L", sym->name, + &sym->declared_at); + } + sym->ts = isym->ts; + } + continue; } @@ -173,26 +188,20 @@ resolve_formal_arglist (gfc_symbol * proc) if (sym->attr.flavor == FL_UNKNOWN) gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at); - if (gfc_pure (proc)) + if (gfc_pure (proc) && !sym->attr.pointer + && sym->attr.flavor != FL_PROCEDURE) { - if (proc->attr.function && !sym->attr.pointer - && sym->attr.flavor != FL_PROCEDURE - && sym->attr.intent != INTENT_IN) - + if (proc->attr.function && sym->attr.intent != INTENT_IN) gfc_error ("Argument '%s' of pure function '%s' at %L must be " "INTENT(IN)", sym->name, proc->name, &sym->declared_at); - if (proc->attr.subroutine && !sym->attr.pointer - && sym->attr.intent == INTENT_UNKNOWN) - - gfc_error - ("Argument '%s' of pure subroutine '%s' at %L must have " - "its INTENT specified", sym->name, proc->name, - &sym->declared_at); + if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN) + gfc_error ("Argument '%s' of pure subroutine '%s' at %L must " + "have its INTENT specified", sym->name, proc->name, + &sym->declared_at); } - if (gfc_elemental (proc)) { if (sym->as != NULL) @@ -850,7 +859,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; @@ -858,7 +867,6 @@ resolve_actual_arglist (gfc_actual_arglist * arg) for (; arg; arg = arg->next) { - e = arg->expr; if (e == NULL) { @@ -879,7 +887,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 @@ -944,7 +952,22 @@ resolve_actual_arglist (gfc_actual_arglist * arg) && sym->ns->parent->proc_name == sym))) goto got_variable; - continue; + /* If all else fails, see if we have a specific intrinsic. */ + if (sym->attr.function + && sym->ts.type == BT_UNKNOWN + && sym->attr.intrinsic) + { + gfc_intrinsic_sym *isym; + isym = gfc_find_function (sym->name); + if (isym == NULL || !isym->specific) + { + gfc_error ("Unable to find a specific INTRINSIC procedure " + "for the reference '%s' at %L", sym->name, + &e->where); + } + sym->ts = isym->ts; + } + goto argument_list; } /* See if the name is a module procedure in a parent unit. */ @@ -968,7 +991,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg) || sym->attr.intrinsic || sym->attr.external) { - continue; + goto argument_list; } got_variable: @@ -982,6 +1005,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; @@ -1457,11 +1536,19 @@ resolve_function (gfc_expr * expr) const char *name; try t; int temp; + procedure_type p = PROC_INTRINSIC; sym = NULL; if (expr->symtree) sym = expr->symtree->n.sym; + if (sym && sym->attr.flavor == FL_VARIABLE) + { + gfc_error ("'%s' at %L is not a function", + sym->name, &expr->where); + return FAILURE; + } + /* If the procedure is not internal, a statement function or a module procedure,it must be external and should be checked for usage. */ if (sym && !sym->attr.dummy && !sym->attr.contained @@ -1473,8 +1560,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--; @@ -1854,6 +1944,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) @@ -1900,7 +1991,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. */ @@ -5560,7 +5654,6 @@ static try resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { gfc_formal_arglist *arg; - gfc_symtree *st; if (sym->attr.ambiguous_interfaces && !sym->attr.referenced) gfc_warning ("Although not referenced, '%s' at %L has ambiguous " @@ -5570,16 +5663,6 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE) return FAILURE; - st = gfc_find_symtree (gfc_current_ns->sym_root, sym->name); - if (st && st->ambiguous - && sym->attr.referenced - && !sym->attr.generic) - { - gfc_error ("Procedure %s at %L is ambiguous", - sym->name, &sym->declared_at); - return FAILURE; - } - if (sym->ts.type == BT_CHARACTER) { gfc_charlen *cl = sym->ts.cl; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 1af827a9dbe8..240d22d49f28 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1862,6 +1862,57 @@ is_aliased_array (gfc_expr * e) return false; } +/* Generate the code for argument list functions. */ + +static void +conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name) +{ + tree type = NULL_TREE; + /* Pass by value for g77 %VAL(arg), pass the address + indirectly for %LOC, else by reference. Thus %REF + is a "do-nothing" and %LOC is the same as an F95 + pointer. */ + if (strncmp (name, "%VAL", 4) == 0) + { + gfc_conv_expr (se, expr); + /* %VAL converts argument to default kind. */ + switch (expr->ts.type) + { + case BT_REAL: + type = gfc_get_real_type (gfc_default_real_kind); + se->expr = fold_convert (type, se->expr); + break; + case BT_COMPLEX: + type = gfc_get_complex_type (gfc_default_complex_kind); + se->expr = fold_convert (type, se->expr); + break; + case BT_INTEGER: + type = gfc_get_int_type (gfc_default_integer_kind); + se->expr = fold_convert (type, se->expr); + break; + case BT_LOGICAL: + type = gfc_get_logical_type (gfc_default_logical_kind); + se->expr = fold_convert (type, se->expr); + break; + /* This should have been resolved away. */ + case BT_UNKNOWN: case BT_CHARACTER: case BT_DERIVED: + case BT_PROCEDURE: case BT_HOLLERITH: + gfc_internal_error ("Bad type in conv_arglist_function"); + } + + } + else if (strncmp (name, "%LOC", 4) == 0) + { + gfc_conv_expr_reference (se, expr); + se->expr = gfc_build_addr_expr (NULL, se->expr); + } + else if (strncmp (name, "%REF", 4) == 0) + gfc_conv_expr_reference (se, expr); + else + gfc_error ("Unknown argument list function at %L", &expr->where); +} + + /* Generate code for a procedure call. Note can return se->post != NULL. If se->direct_byref is set then se->expr contains the return parameter. Return nonzero, if the call has alternate specifiers. */ @@ -1975,17 +2026,24 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, if (argss == gfc_ss_terminator) { - gfc_conv_expr_reference (&parmse, e); parm_kind = SCALAR; - if (fsym && fsym->attr.pointer - && e->expr_type != EXPR_NULL) - { - /* Scalar pointer dummy args require an extra level of - indirection. The null pointer already contains - this level of indirection. */ - parm_kind = SCALAR_POINTER; - parmse.expr = build_fold_addr_expr (parmse.expr); - } + if (arg->name && arg->name[0] == '%') + /* Argument list functions %VAL, %LOC and %REF are signalled + through arg->name. */ + conv_arglist_function (&parmse, arg->expr, arg->name); + else + { + gfc_conv_expr_reference (&parmse, e); + if (fsym && fsym->attr.pointer + && e->expr_type != EXPR_NULL) + { + /* Scalar pointer dummy args require an extra level of + indirection. The null pointer already contains + this level of indirection. */ + parm_kind = SCALAR_POINTER; + parmse.expr = build_fold_addr_expr (parmse.expr); + } + } } else { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8a49e0718603..4d5e36da3024 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,28 @@ +2007-01-06 Paul Thomas + + PR fortran/30034 + * gfortran.dg/pure_formal_proc_1.f90: New test. + + PR fortran/30237 + * gfortran.dg/intrinsic_actual_3.f90: New test. + + PR fortran/25135 + * gfortran.dg/generic_11.f90: New test. + * gfortran.dg/interface_7.f90: Remove name clash between module + name and procedure 'x' referenced in the interface. + + 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. + + PR fortran/27900 + * gfortran.dg/intrinsic_actual_4.f90: New test. + + PR fortran/24325 + * gfortran.dg/func_decl_3.f90: New test. + 2007-01-05 Richard Guenther PR middle-end/27826 diff --git a/gcc/testsuite/gfortran.dg/c_by_val.c b/gcc/testsuite/gfortran.dg/c_by_val.c new file mode 100644 index 000000000000..daba6d2c52dc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_by_val.c @@ -0,0 +1,41 @@ +/* Passing from fortran to C by value, using %VAL. */ + +typedef struct { float r, i; } complex; +extern void f_to_f__ (float*, float, float*, float**); +extern void i_to_i__ (int*, int, int*, int**); +extern void c_to_c__ (complex*, complex, complex*, complex**); +extern void abort (void); + +void +f_to_f__(float *retval, float a1, float *a2, float **a3) +{ + if ( a1 != *a2 ) abort(); + if ( a1 != **a3 ) abort(); + a1 = 0.0; + *retval = *a2 * 2.0; + return; +} + +void +i_to_i__(int *retval, int i1, int *i2, int **i3) +{ + if ( i1 != *i2 ) abort(); + if ( i1 != **i3 ) abort(); + i1 = 0; + *retval = *i2 * 3; + return; +} + +void +c_to_c__(complex *retval, complex c1, complex *c2, complex **c3) +{ + if ( c1.r != c2->r ) abort(); + if ( c1.i != c2->i ) abort(); + if ( c1.r != (*c3)->r ) abort(); + if ( c1.i != (*c3)->i ) abort(); + c1.r = 0.0; + c1.i = 0.0; + retval->r = c2->r * 4.0; + retval->i = c2->i * 4.0; + return; +} diff --git a/gcc/testsuite/gfortran.dg/c_by_val_1.f b/gcc/testsuite/gfortran.dg/c_by_val_1.f new file mode 100644 index 000000000000..133cc55e173d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_by_val_1.f @@ -0,0 +1,31 @@ +C { dg-do run } +C { dg-additional-sources c_by_val.c } +C { dg-options "-ff2c -w -O0" } + + program c_by_val_1 + external f_to_f, i_to_i, c_to_c + real a, b, c + integer*4 i, j, k + complex u, v, w, c_to_c + + a = 42.0 + b = 0.0 + c = a + call f_to_f (b, %VAL (a), %REF (c), %LOC (c)) + if ((2.0 * a).ne.b) call abort () + + i = 99 + j = 0 + k = i + call i_to_i (j, %VAL (i), %REF (k), %LOC (k)) + if ((3 * i).ne.j) call abort () + + u = (-1.0, 2.0) + v = (1.0, -2.0) + w = u + v = c_to_c (%VAL (u), %REF (w), %LOC (w)) + if ((4.0 * u).ne.v) call abort () + + stop + end + diff --git a/gcc/testsuite/gfortran.dg/c_by_val_2.f90 b/gcc/testsuite/gfortran.dg/c_by_val_2.f90 new file mode 100644 index 000000000000..6aadd9834261 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_by_val_2.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-w" } + +program c_by_val_2 + external bar + real (4) :: bar, ar(2) = (/1.0,2.0/) + type :: mytype + integer :: i + end type mytype + type(mytype) :: z + character(8) :: c = "blooey" + print *, sin (%VAL(2.0)) ! { dg-error "not allowed in this context" } + print *, foo (%VAL(1.0)) ! { dg-error "not allowed in this context" } + call foobar (%VAL(0.5)) ! { dg-error "not allowed in this context" } + print *, bar (%VAL(z)) ! { dg-error "not of numeric type" } + print *, bar (%VAL(c)) ! { dg-error "not of numeric type" } + print *, bar (%VAL(ar)) ! { dg-error "cannot be an array" } + print *, bar (%VAL(0.0)) +contains + function foo (a) + real(4) :: a, foo + foo = cos (a) + end function foo + subroutine foobar (a) + real(4) :: a + print *, a + end subroutine foobar +end program c_by_val_2 + diff --git a/gcc/testsuite/gfortran.dg/c_by_val_3.f90 b/gcc/testsuite/gfortran.dg/c_by_val_3.f90 new file mode 100644 index 000000000000..bf7aedf8ba4a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_by_val_3.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +program c_by_val_3 + external bar + real (4) :: bar + print *, bar (%VAL(0.0)) ! { dg-error "argument list function" } +end program c_by_val_3 diff --git a/gcc/testsuite/gfortran.dg/dummy_procedure_1.f90 b/gcc/testsuite/gfortran.dg/dummy_procedure_1.f90 index 66aca21e3d03..6d681436125b 100644 --- a/gcc/testsuite/gfortran.dg/dummy_procedure_1.f90 +++ b/gcc/testsuite/gfortran.dg/dummy_procedure_1.f90 @@ -37,7 +37,7 @@ end module m1 call s1(w) ! { dg-error "not allowed as an actual argument" } call s1(x) ! explicit interface call s1(y) ! declared external - call s1(z) ! already compiled + call s1(z) ! { dg-error "Expected a procedure for argument" } contains integer function w() w = 1 diff --git a/gcc/testsuite/gfortran.dg/func_decl_3.f90 b/gcc/testsuite/gfortran.dg/func_decl_3.f90 new file mode 100644 index 000000000000..4e458f47d88e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/func_decl_3.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! Tests the fix for PR24325 in which the lack of any declaration +! that foo is a function or even a procedure was not detected. +! +! Contributed by Jakub Jelinek +! + integer foo + call test +contains + subroutine test + integer :: i + i = foo () ! { dg-error "is not a function" } + end subroutine test +end + diff --git a/gcc/testsuite/gfortran.dg/generic_11.f90 b/gcc/testsuite/gfortran.dg/generic_11.f90 new file mode 100644 index 000000000000..7547a43da76f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/generic_11.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! Test the fix for PR25135 in which the ambiguity between subroutine +! foo in m_foo and interface foo in m_bar was not recognised. +! +!Contributed by Yusuke IGUCHI +! +module m_foo +contains + subroutine foo + print *, "foo" + end subroutine +end module + +module m_bar + interface foo + module procedure bar + end interface +contains + subroutine bar + print *, "bar" + end subroutine +end module + +use m_foo +use m_bar + +call foo ! { dg-error "is an ambiguous reference" } +end +! { dg-final { cleanup-modules "m_foo m_bar" } } + + diff --git a/gcc/testsuite/gfortran.dg/interface_7.f90 b/gcc/testsuite/gfortran.dg/interface_7.f90 index 9c6103ff81c2..f8f85778d8f9 100644 --- a/gcc/testsuite/gfortran.dg/interface_7.f90 +++ b/gcc/testsuite/gfortran.dg/interface_7.f90 @@ -6,7 +6,7 @@ ! standard explicitly does not require recursion into the formal ! arguments of procedures that themselves are interface arguments. ! -module x +module xx INTERFACE BAD9 SUBROUTINE S9A(X) REAL :: X @@ -27,6 +27,6 @@ module x END INTERFACE END SUBROUTINE S9C ! { dg-error "Ambiguous interfaces" } END INTERFACE BAD9 -end module x +end module xx -! { dg-final { cleanup-modules "x" } } +! { dg-final { cleanup-modules "xx" } } diff --git a/gcc/testsuite/gfortran.dg/intrinsic_actual_3.f90 b/gcc/testsuite/gfortran.dg/intrinsic_actual_3.f90 new file mode 100644 index 000000000000..c2dd07cda5ae --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intrinsic_actual_3.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! Tests the fix for PR30237 in which alternate returns in intrinsic +! actual arglists were quietly ignored. +! +! Contributed by Brooks Moses +! +program ar1 + interface random_seed + subroutine x (a, *) + integer a + end subroutine x + end interface random_seed + + real t1(2) + call cpu_time(*20) ! { dg-error "not permitted" } + call cpu_time(*20, t1(1)) ! { dg-error "Too many arguments" } +! This specific version is permitted by the generic interface. + call random_seed(i, *20) +! The new error gets overwritten but the diagnostic is clear enough. + call random_seed(i, *20, *30) ! { dg-error "not consistent" } + stop +20 write(*,*) t1 +30 stop +end diff --git a/gcc/testsuite/gfortran.dg/intrinsic_actual_4.f90 b/gcc/testsuite/gfortran.dg/intrinsic_actual_4.f90 new file mode 100644 index 000000000000..4ba4b79c72d0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intrinsic_actual_4.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! Tests the fix for PR27900, in which an ICE would be caused because +! the actual argument LEN had no type. +! +! Contributed by Klaus Ramstöck +! + subroutine sub (proc, chr) + external proc + integer proc + character*(*) chr + if (proc (chr) .ne. 6) call abort () + end subroutine sub + + implicit none + integer i + i = len ("123") + call sub (len, "abcdef") + end diff --git a/gcc/testsuite/gfortran.dg/pure_formal_proc_1.f90 b/gcc/testsuite/gfortran.dg/pure_formal_proc_1.f90 new file mode 100644 index 000000000000..4a55563c878e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pure_formal_proc_1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! Test fix for PR30034 in which the legal, pure procedure formal +! argument was rejected as an error. +! +! Contgributed by Troban Trumsko +! + pure subroutine s_one ( anum, afun ) + integer, intent(in) :: anum + interface + pure function afun (k) result (l) + implicit none + integer, intent(in) :: k + integer :: l + end function afun + end interface +end subroutine s_one