Index: interface.c =================================================================== --- interface.c (revision 130085) +++ interface.c (working copy) @@ -977,13 +977,25 @@ compare_interfaces (gfc_symbol *s1, gfc_ static int compare_intr_interfaces (gfc_symbol *s1, gfc_symbol *s2) { - static gfc_formal_arglist *f, *f1; - static gfc_intrinsic_arg *fi, *f2; + gfc_formal_arglist *f, *f1; + 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. */ + + /* If the arguments are functions, check type and kind. */ + + if (s1->attr.dummy && s1->attr.function && s2->attr.function) + { + if (s1->ts.type != s2->ts.type) + return 0; + if (s1->ts.kind != s2->ts.kind) + return 0; + if (s1->attr.if_source == IFSRC_DECL) + return 1; + } isym = gfc_find_function (s2->name); @@ -1024,6 +1036,55 @@ compare_intr_interfaces (gfc_symbol *s1, } +/* Compare an actual argument list with an intrinsic argument list. */ + +static int +compare_actual_formal_intr (gfc_actual_arglist **ap, gfc_symbol *s2) +{ + gfc_actual_arglist *a; + gfc_intrinsic_arg *fi, *f2; + gfc_intrinsic_sym *isym; + + isym = gfc_find_function (s2->name); + + /* This should already have been checked in + resolve.c (resolve_actual_arglist). */ + gcc_assert (isym); + + f2 = isym->formal; + + /* Special case. */ + if (*ap == NULL && f2 == NULL) + return 1; + + /* First scan through the actual argument list and check the intrinsic. */ + fi = f2; + for (a = *ap; a; a = a->next) + { + if (fi == NULL) + return 0; + if ((fi->ts.type != a->expr->ts.type) + || (fi->ts.kind != a->expr->ts.kind)) + return 0; + fi = fi->next; + } + + /* Now scan through the intrinsic argument list and check the formal. */ + a = *ap; + for (fi = f2; fi; fi = fi->next) + { + if (a == NULL) + return 0; + if ((fi->ts.type != a->expr->ts.type) + || (fi->ts.kind != a->expr->ts.kind)) + return 0; + a = a->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. */ @@ -2225,6 +2286,20 @@ gfc_procedure_use (gfc_symbol *sym, gfc_ gfc_warning ("Procedure '%s' called with an implicit interface at %L", sym->name, where); + if (sym->interface && sym->interface->attr.intrinsic) + { + gfc_intrinsic_sym *isym; + isym = gfc_find_function (sym->interface->name); + if (isym != NULL) + { + if (compare_actual_formal_intr (ap, sym->interface)) + return; + gfc_error ("My Type/rank mismatch in argument '%s' at %L", + sym->name, where); + return; + } + } + if (sym->attr.if_source == IFSRC_UNKNOWN || !compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where)) Index: decl.c =================================================================== --- decl.c (revision 130085) +++ decl.c (working copy) @@ -3968,19 +3968,9 @@ match_procedure_decl (void) "in PROCEDURE statement at %C", proc_if->name); return MATCH_ERROR; } - /* TODO: Allow intrinsics with gfc_intrinsic_actual_ok - (proc_if->name, 0) after PR33162 is fixed. */ - if (proc_if->attr.intrinsic) - { - gfc_error ("Fortran 2003: Support for intrinsic procedure '%s' " - "in PROCEDURE statement at %C not yet implemented " - "in gfortran", proc_if->name); - return MATCH_ERROR; - } } got_ts: - if (gfc_match (" )") != MATCH_YES) { gfc_current_locus = entry_loc; @@ -3995,7 +3985,6 @@ got_ts: /* Get procedure symbols. */ for(num=1;;num++) { - m = gfc_match_symbol (&sym, 0); if (m == MATCH_NO) goto syntax; @@ -4040,7 +4029,10 @@ got_ts: /* Set interface. */ if (proc_if != NULL) - sym->interface = proc_if; + { + sym->interface = proc_if; + sym->attr.untyped = 1; + } else if (current_ts.type != BT_UNKNOWN) { sym->interface = gfc_new_symbol ("", gfc_current_ns); Index: ChangeLog =================================================================== --- ChangeLog (revision 130095) +++ ChangeLog (working copy) @@ -1,3 +1,17 @@ +2007-11-11 Jerry DeLisle + + PR fortran/33162 + * decl.c (match_procedure_decl): Remove TODO and allow intrinsics in + PROCEDURE declarations. Set attr.untyped to allow the interface to be + resolved later where the symbol type will be set. + * interface.c (compare_intr_interfaces): Remove static from pointer + declarations. Add type and kind checks for dummy function arguments. + (compare_actual_formal_intr): New function to compare an actual + argument with an intrinsic function. (gfc_procedures_use): Add check for + interface that points to an intrinsic function, use the new function. + * resolve.c (resolve_specific_f0): Resolve the intrinsic interface. + (resolve_specific_s0): Ditto. + 2007-11-10 Francois-Xavier Coudert * trans-common.c: Remove prototype for gfc_get_common. Index: resolve.c =================================================================== --- resolve.c (revision 130085) +++ resolve.c (working copy) @@ -1074,6 +1074,7 @@ resolve_actual_arglist (gfc_actual_argli if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic) { gfc_intrinsic_sym *isym; + isym = gfc_find_function (sym->name); if (isym == NULL || !isym->specific) { @@ -1083,6 +1084,7 @@ resolve_actual_arglist (gfc_actual_argli return FAILURE; } sym->ts = isym->ts; + sym->attr.intrinsic = 1; sym->attr.function = 1; } goto argument_list; @@ -1487,6 +1489,22 @@ resolve_specific_f0 (gfc_symbol *sym, gf { match m; + /* See if we have an intrinsic interface. */ + + if (sym->interface != NULL && sym->interface->attr.intrinsic) + { + gfc_intrinsic_sym *isym; + isym = gfc_find_function (sym->interface->name); + + /* Existance of isym should be checked already. */ + gcc_assert (isym); + + sym->ts = isym->ts; + sym->attr.function = 1; + sym->attr.proc = PROC_EXTERNAL; + goto found; + } + if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY) { if (sym->attr.dummy) @@ -2513,6 +2531,22 @@ resolve_specific_s0 (gfc_code *c, gfc_sy { match m; + /* See if we have an intrinsic interface. */ + if (sym->interface != NULL && !sym->interface->attr.abstract + && !sym->interface->attr.subroutine) + { + gfc_intrinsic_sym *isym; + + isym = gfc_find_function (sym->interface->name); + + /* Existance of isym should be checked already. */ + gcc_assert (isym); + + sym->ts = isym->ts; + sym->attr.function = 1; + goto found; + } + if(sym->attr.is_iso_c) { m = gfc_iso_c_sub_interface (c,sym);