re PR fortran/33162 (INTRINSIC functions as ACTUAL argument)

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.

From-SVN: r130168

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 27fc761d642d0a502a1c559d464e3fe6e1711b1c..3b3a2fdec1dbb594359f80f299d4d14339a0c298 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+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

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 74c655d0792156a1707c25fb7b4c9b481905e3b0..29b02ea4cfd41092b01c49b50cd86725d2ac00a8 100644 (file)
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -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);

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 7f6406a94e62cc0b605262c54dd1f836b60fd2a0..650cd217de3842b90c1eaf93f67b1b2fd91d1fcb 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -977,13 +977,25 @@ 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_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, gfc_symbol *s2)
 }
 
 
+/* 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_actual_arglist **ap, locus *where)
     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))

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 198fec791991e00be09b9e4681a96b3cd3027c1a..3f3ef03aba6aeee88143276a4bb6fe4c4ba0c43b 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1074,6 +1074,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
          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_arglist *arg, procedure_type ptype)
                  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, gfc_expr *expr)
 {
   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_symbol *sym)
 {
   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);