From 26033479fb7d724061af07716f0077934032bbf9 Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Wed, 31 Oct 2007 14:26:57 +0000 Subject: [PATCH] re PR fortran/33162 (INTRINSIC functions as ACTUAL argument) 2007-10-31 Jerry DeLisle PR fortran/33162 * interface.c (compare_intr_interfaces): New function to check intrinsic function arguments against formal arguments. (compare_interfaces): Fix logic in comparison of function and subroutine attributes. (compare_parameter): Use new function for intrinsic as argument. * resolve.c (resolve_actual_arglist): Allow an intrinsic without function attribute to be checked further. Set function attribute if intrinsic symbol is found, return FAILURE if not. From-SVN: r129798 --- gcc/fortran/ChangeLog | 11 ++++++++ gcc/fortran/interface.c | 58 +++++++++++++++++++++++++++++++++++++++-- gcc/fortran/resolve.c | 5 ++-- 3 files changed, 70 insertions(+), 4 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 61c75bec6a4..96e7a73c884 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2007-10-31 Jerry DeLisle + + PR fortran/33162 + * interface.c (compare_intr_interfaces): New function to check intrinsic + function arguments against formal arguments. (compare_interfaces): Fix + logic in comparison of function and subroutine attributes. + (compare_parameter): Use new function for intrinsic as argument. + * resolve.c (resolve_actual_arglist): Allow an intrinsic without + function attribute to be checked further. Set function attribute if + intrinsic symbol is found, return FAILURE if not. + 2007-10-31 Paul Thomas PR fortran/33897 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 741bba57520..39f4e9283a2 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -468,6 +468,7 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2) static int compare_interfaces (gfc_symbol *, gfc_symbol *, int); +static int compare_intr_interfaces (gfc_symbol *, gfc_symbol *); /* Given two symbols that are formal arguments, compare their types and rank and their formal interfaces if they are both dummy @@ -942,7 +943,7 @@ compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag) gfc_formal_arglist *f1, *f2; if (s1->attr.function != s2->attr.function - && s1->attr.subroutine != s2->attr.subroutine) + || s1->attr.subroutine != s2->attr.subroutine) return 0; /* Disagreement between function/subroutine. */ f1 = s1->formal; @@ -973,6 +974,56 @@ compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag) } +static int +compare_intr_interfaces (gfc_symbol *s1, gfc_symbol *s2) +{ + static gfc_formal_arglist *f, *f1; + static gfc_intrinsic_arg *fi, *f2; + gfc_intrinsic_sym *isym; + + if (s1->attr.function != s2->attr.function + || s1->attr.subroutine != s2->attr.subroutine) + return 0; /* Disagreement between function/subroutine. */ + + isym = gfc_find_function (s2->name); + + /* This should already have been checked in + resolve.c (resolve_actual_arglist). */ + gcc_assert (isym); + + f1 = s1->formal; + f2 = isym->formal; + + /* Special case. */ + if (f1 == NULL && f2 == NULL) + return 1; + + /* First scan through the formal argument list and check the intrinsic. */ + fi = f2; + for (f = f1; f; f = f->next) + { + if (fi == NULL) + return 0; + if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind)) + return 0; + fi = fi->next; + } + + /* Now scan through the intrinsic argument list and check the formal. */ + f = f1; + for (fi = f2; fi; fi = fi->next) + { + if (f == NULL) + return 0; + if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind)) + return 0; + f = f->next; + } + + return 1; +} + + /* Given a pointer to an interface pointer, remove duplicate interfaces and make sure that all symbols are either functions or subroutines. Returns nonzero if something goes wrong. */ @@ -1323,7 +1374,10 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, || actual->symtree->n.sym->attr.external) return 1; /* Assume match. */ - return compare_interfaces (formal, actual->symtree->n.sym, 0); + if (actual->symtree->n.sym->attr.intrinsic) + return compare_intr_interfaces (formal, actual->symtree->n.sym); + else + return compare_interfaces (formal, actual->symtree->n.sym, 0); } if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 69d2c5179b2..3542b1e9c55 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1071,8 +1071,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype) goto got_variable; /* If all else fails, see if we have a specific intrinsic. */ - if (sym->attr.function - && sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic) + if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic) { gfc_intrinsic_sym *isym; isym = gfc_find_function (sym->name); @@ -1081,8 +1080,10 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype) gfc_error ("Unable to find a specific INTRINSIC procedure " "for the reference '%s' at %L", sym->name, &e->where); + return FAILURE; } sym->ts = isym->ts; + sym->attr.function = 1; } goto argument_list; }