+2007-11-11 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ 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-13 Paul Thomas <pault@gcc.gnu.org>
PR fortran/34080
"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;
/* Get procedure symbols. */
for(num=1;;num++)
{
-
m = gfc_match_symbol (&sym, 0);
if (m == MATCH_NO)
goto syntax;
/* 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);
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);
}
+/* 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. */
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 ("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))
if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
{
gfc_intrinsic_sym *isym;
+
isym = gfc_find_function (sym->name);
if (isym == NULL || !isym->specific)
{
return FAILURE;
}
sym->ts = isym->ts;
+ sym->attr.intrinsic = 1;
sym->attr.function = 1;
}
goto argument_list;
{
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)
{
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);