Fortran: Allow external function from in an associate block [PR87127]

2023-03-20  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/87127
	* resolve.cc (check_host_association): If an external function
	is typed but not declared explicitly to be external, change the
	old symbol from a variable to an external function.

gcc/testsuite/
	PR fortran/87127
	* gfortran.dg/external_procedures_4.f90: New test.

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index f3f3051..1d973d1 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -6079,11 +6079,14 @@ resolve_procedure:
 
 
 /* Checks to see that the correct symbol has been host associated.
-   The only situation where this arises is that in which a twice
-   contained function is parsed after the host association is made.
-   Therefore, on detecting this, change the symbol in the expression
-   and convert the array reference into an actual arglist if the old
-   symbol is a variable.  */
+   The only situations where this arises are:
+       (i)  That in which a twice contained function is parsed after
+            the host association is made. On detecting this, change
+            the symbol in the expression and convert the array reference
+            into an actual arglist if the old symbol is a variable; or
+       (ii) That in which an external function is typed but not declared
+            explcitly to be external. Here, the old symbol is changed
+            from a variable to an external function.  */
 static bool
 check_host_association (gfc_expr *e)
 {
@@ -6185,6 +6188,27 @@ check_host_association (gfc_expr *e)
          gfc_resolve_expr (e);
          sym->refs++;
        }
+      /* This case corresponds to a call, from a block or a contained
+        procedure, to an external function, which has not been declared
+        as being external in the main program but has been typed.  */
+      else if (sym && old_sym != sym
+              && !e->ref
+              && sym->ts.type == BT_UNKNOWN
+              && old_sym->ts.type != BT_UNKNOWN
+              && sym->attr.flavor == FL_PROCEDURE
+              && old_sym->attr.flavor == FL_VARIABLE
+              && sym->ns->parent == old_sym->ns
+              && sym->ns->proc_name
+              && sym->ns->proc_name->attr.proc != PROC_MODULE
+              && (sym->ns->proc_name->attr.flavor == FL_LABEL
+                  || sym->ns->proc_name->attr.flavor == FL_PROCEDURE))
+       {
+         old_sym->attr.flavor = FL_PROCEDURE;
+         old_sym->attr.external = 1;
+         old_sym->attr.function = 1;
+         old_sym->result = old_sym;
+         gfc_resolve_expr (e);
+       }
     }
   /* This might have changed!  */
   return e->expr_type == EXPR_FUNCTION;

diff --git a/gcc/testsuite/gfortran.dg/external_procedures_4.f90 b/gcc/testsuite/gfortran.dg/external_procedures_4.f90
new file mode 100644 (file)
index 0000000..252bae5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/external_procedures_4.f90
@@ -0,0 +1,28 @@
+! { dg-do run }
+!
+! Test the fix for PR87127 in which the references to exfunc cause
+! the error "exfunc at (1) is not a function".
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+function exfunc(i)
+  implicit none
+  integer :: exfunc,i
+  exfunc = 2*i
+end function
+
+! contents of test.f90
+program test
+  implicit none
+  integer :: exfunc,i
+  integer,parameter :: array(2)=[6,7]
+  associate(i=>array(2))            ! Original bug
+    if (exfunc(i) .ne. 2*i) stop 1
+  end associate
+  i = 99
+  call foo
+contains
+  subroutine foo()                  ! Comment #3
+    if (exfunc(i) .ne. 2*i) stop 2
+  end subroutine foo
+end program