re PR fortran/26822 (Scalarization of non-elemental intrinsic: __logical_4_l4)

2006-04-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26822
	* intrinsic.c (add_functions): Mark LOGICAL as elemental.

	PR fortran/26787
	* expr.c (gfc_check_assign): Extend scope of error to include
	assignments to a procedure in the main program or, from a
	module or internal procedure that is not that represented by
	the lhs symbol. Use VARIABLE rather than l-value in message.

	PR fortran/27096
	* trans-array.c (gfc_trans_deferred_array): If the backend_decl
	is not a descriptor, dereference and then test and use the type.

	PR fortran/25597
	* trans-decl.c (gfc_trans_deferred_vars): Check if an array
	result, is also automatic character length.  If so, process
	the character length.

	PR fortran/18803
	PR fortran/25669
	PR fortran/26834
	* trans_intrinsic.c (gfc_walk_intrinsic_bound): Set
	data.info.dimen for bound intrinsics.
	* trans_array.c (gfc_conv_ss_startstride): Pick out LBOUND and
	UBOUND intrinsics and supply their shape information to the ss
	and the loop.

	PR fortran/27124
	* trans_expr.c (gfc_trans_function_call):  Add a new block, post,
	in to which all the argument post blocks are put.  Add this block
	to se->pre after a byref call or to se->post, otherwise.

2006-04-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26787
	* gfortran.dg/proc_assign_1.f90: New test.
	* gfortran.dg/procedure_lvalue.f90: Change message.
	* gfortran.dg/namelist_4.f90: Add new error.

	PR fortran/27096
	* gfortran.dg/auto_pointer_array_result_1.f90

	PR fortran/27089
	* gfortran.dg/specification_type_resolution_1.f90

	PR fortran/18803
	PR fortran/25669
	PR fortran/26834
	* gfortran.dg/bounds_temporaries_1.f90: New test.

	PR fortran/27124
	* gfortran.dg/array_return_value_1.f90: New test.

From-SVN: r112981

17 files changed, 427 insertions, 12 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index df5a576..24af5f6 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,37 @@
+2006-04-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/26822
+	* intrinsic.c (add_functions): Mark LOGICAL as elemental.
+
+	PR fortran/26787
+	* expr.c (gfc_check_assign): Extend scope of error to include
+	assignments to a procedure in the main program or, from a
+	module or internal procedure that is not that represented by
+	the lhs symbol. Use VARIABLE rather than l-value in message.
+
+	PR fortran/27096
+	* trans-array.c (gfc_trans_deferred_array): If the backend_decl
+	is not a descriptor, dereference and then test and use the type.
+
+	PR fortran/25597
+	* trans-decl.c (gfc_trans_deferred_vars): Check if an array
+	result, is also automatic character length.  If so, process
+	the character length.
+
+	PR fortran/18803
+	PR fortran/25669
+	PR fortran/26834
+	* trans_intrinsic.c (gfc_walk_intrinsic_bound): Set
+	data.info.dimen for bound intrinsics.
+	* trans_array.c (gfc_conv_ss_startstride): Pick out LBOUND and
+	UBOUND intrinsics and supply their shape information to the ss
+	and the loop.
+
+	PR fortran/27124
+	* trans_expr.c (gfc_trans_function_call):  Add a new block, post,
+	in to which all the argument post blocks are put.  Add this block
+	to se->pre after a byref call or to se->post, otherwise.
+
 2006-04-14  Roger Sayle  <roger@eyesopen.com>
 
 	* trans-io.c (set_string): Use fold_build2 and build_int_cst instead
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index dfbbed2..5ecc829 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -1863,13 +1863,49 @@ gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
       return FAILURE;
     }
 
-  if (sym->attr.flavor == FL_PROCEDURE && sym->attr.use_assoc)
+/* 12.5.2.2, Note 12.26: The result variable is very similar to any other
+   variable local to a function subprogram.  Its existence begins when
+   execution of the function is initiated and ends when execution of the
+   function is terminated.....
+   Therefore, the left hand side is no longer a varaiable, when it is:*/
+  if (sym->attr.flavor == FL_PROCEDURE
+	&& sym->attr.proc != PROC_ST_FUNCTION
+	&& !sym->attr.external)
     {
-      gfc_error ("'%s' in the assignment at %L cannot be an l-value "
-		 "since it is a procedure", sym->name, &lvalue->where);
-      return FAILURE;
-    }
+      bool bad_proc;
+      bad_proc = false;
+
+      /* (i) Use associated; */
+      if (sym->attr.use_assoc)
+	bad_proc = true;
+
+      /* (ii) The assignement is in the main program; or  */
+      if (gfc_current_ns->proc_name->attr.is_main_program)
+	bad_proc = true;
+
+      /* (iii) A module or internal procedure....  */
+      if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
+	     || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
+	  && gfc_current_ns->parent
+	  && (!(gfc_current_ns->parent->proc_name->attr.function
+		  || gfc_current_ns->parent->proc_name->attr.subroutine)
+	      || gfc_current_ns->parent->proc_name->attr.is_main_program))
+	{
+	  /* .... that is not a function.... */ 
+	  if (!gfc_current_ns->proc_name->attr.function)
+	    bad_proc = true;
+
+	  /* .... or is not an entry and has a different name.  */
+	  if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
+	    bad_proc = true;
+	}
 
+      if (bad_proc)
+	{
+	  gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
+	  return FAILURE;
+	}
+    }
 
   if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
     {
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 707fe5b..7828922 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -1670,7 +1670,7 @@ add_functions (void)
 
   make_generic ("log10", GFC_ISYM_LOG10, GFC_STD_F77);
 
-  add_sym_2 ("logical", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
+  add_sym_2 ("logical", 1, 1, BT_LOGICAL, dl, GFC_STD_F95,
 	     gfc_check_logical, gfc_simplify_logical, gfc_resolve_logical,
 	     l, BT_LOGICAL, dl, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index bde11a5..f7acb73 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -952,9 +952,17 @@ resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
 	{
 	  expr->value.function.name = s->name;
 	  expr->value.function.esym = s;
-	  expr->ts = s->ts;
+
+	  if (s->ts.type != BT_UNKNOWN)
+	    expr->ts = s->ts;
+	  else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
+	    expr->ts = s->result->ts;
+
 	  if (s->as != NULL)
 	    expr->rank = s->as->rank;
+	  else if (s->result != NULL && s->result->as != NULL)
+	    expr->rank = s->result->as->rank;
+
 	  return MATCH_YES;
 	}
 
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 4bdc784..fe8d13c 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2393,6 +2393,18 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
 	  loop->dimen = ss->data.info.dimen;
 	  break;
 
+	/* As usual, lbound and ubound are exceptions!.  */
+	case GFC_SS_INTRINSIC:
+	  switch (ss->expr->value.function.isym->generic_id)
+	    {
+	    case GFC_ISYM_LBOUND:
+	    case GFC_ISYM_UBOUND:
+	      loop->dimen = ss->data.info.dimen;
+
+	    default:
+	      break;
+	    }
+
 	default:
 	  break;
 	}
@@ -2418,6 +2430,17 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
 	    gfc_conv_section_startstride (loop, ss, n);
 	  break;
 
+	case GFC_SS_INTRINSIC:
+	  switch (ss->expr->value.function.isym->generic_id)
+	    {
+	    /* Fall through to supply start and stride.  */
+	    case GFC_ISYM_LBOUND:
+	    case GFC_ISYM_UBOUND:
+	      break;
+	    default:
+	      continue;
+	    }
+
 	case GFC_SS_CONSTRUCTOR:
 	case GFC_SS_FUNCTION:
 	  for (n = 0; n < ss->data.info.dimen; n++)
@@ -4391,7 +4414,14 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
 
   /* Get the descriptor type.  */
   type = TREE_TYPE (sym->backend_decl);
-  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+  if (!GFC_DESCRIPTOR_TYPE_P (type))
+    {
+      /* If the backend_decl is not a descriptor, we must have a pointer
+	 to one.  */
+      descriptor = build_fold_indirect_ref (sym->backend_decl);
+      type = TREE_TYPE (descriptor);
+      gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+    }
 
   /* NULLIFY the data pointer.  */
   gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 2a9c0db..4efe4bd 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -2536,6 +2536,12 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 	{
 	  tree result = TREE_VALUE (current_fake_result_decl);
 	  fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
+
+	  /* An automatic character length, pointer array result.  */
+	  if (proc_sym->ts.type == BT_CHARACTER
+		&& TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
+	    fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
+						fnbody);
 	}
       else if (proc_sym->ts.type == BT_CHARACTER)
 	{
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 81e0a7c..4eceab6 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1832,6 +1832,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   gfc_charlen cl;
   gfc_expr *e;
   gfc_symbol *fsym;
+  stmtblock_t post;
 
   arglist = NULL_TREE;
   retargs = NULL_TREE;
@@ -1861,6 +1862,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   else
     info = NULL;
 
+  gfc_init_block (&post);
   gfc_init_interface_mapping (&mapping);
   need_interface_mapping = ((sym->ts.type == BT_CHARACTER
 				  && sym->ts.cl->length
@@ -1970,7 +1972,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	gfc_add_interface_mapping (&mapping, fsym, &parmse);
 
       gfc_add_block_to_block (&se->pre, &parmse.pre);
-      gfc_add_block_to_block (&se->post, &parmse.post);
+      gfc_add_block_to_block (&post, &parmse.post);
 
       /* Character strings are passed as two parameters, a length and a
          pointer.  */
@@ -2177,6 +2179,12 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	}
     }
 
+  /* Follow the function call with the argument post block.  */
+  if (byref)
+    gfc_add_block_to_block (&se->pre, &post);
+  else
+    gfc_add_block_to_block (&se->post, &post);
+
   return has_alternate_specifier;
 }
 
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index b69ffef..1abc79a 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -3710,6 +3710,7 @@ gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
   newss->type = GFC_SS_INTRINSIC;
   newss->expr = expr;
   newss->next = ss;
+  newss->data.info.dimen = 1;
 
   return newss;
 }
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index f8f2c51..d02f439 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,25 @@
+2006-04-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/26787
+	* gfortran.dg/proc_assign_1.f90: New test.
+	* gfortran.dg/procedure_lvalue.f90: Change message.
+	* gfortran.dg/namelist_4.f90: Add new error.
+
+	PR fortran/25597
+	PR fortran/27096
+	* gfortran.dg/auto_pointer_array_result_1.f90
+
+	PR fortran/27089
+	* gfortran.dg/specification_type_resolution_1.f90
+
+	PR fortran/18803
+	PR fortran/25669
+	PR fortran/26834
+	* gfortran.dg/bounds_temporaries_1.f90: New test.
+
+	PR fortran/27124
+	* gfortran.dg/array_return_value_1.f90: New test.
+
 2006-04-15  Jerry DeLisle <jvdelisle@gcc.gnu.org>
 
 	PR fortran/25336
diff --git a/gcc/testsuite/gfortran.dg/array_return_value_1.f90 b/gcc/testsuite/gfortran.dg/array_return_value_1.f90
new file mode 100644
index 0000000..45699ff
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/array_return_value_1.f90
@@ -0,0 +1,24 @@
+! { dg-do run }
+! Tests the fix for PR27124 in which the unpacking of argument
+! temporaries and of array result temporaries occurred in the
+! incorrect order.
+! 
+! Test is based on the original example, provided by
+! Philippe Schaffnit <P.Schaffnit@access.rwth-aachen.de>
+!
+  PROGRAM Test
+    INTEGER :: Array(2, 3) = reshape ((/1,4,2,5,3,6/),(/2,3/))
+    integer :: Brray(2, 3) = 0
+    Brray(1,:) = Function_Test (Array(1,:))
+    if (any(reshape (Brray, (/6/)) .ne. (/11, 0, 12, 0, 13, 0/))) call abort ()
+    Array(1,:) = Function_Test (Array(1,:))
+    if (any(reshape (Array, (/6/)) .ne. (/11, 4, 12, 5, 13, 6/))) call abort ()
+
+  contains
+      FUNCTION Function_Test (Input)
+          INTEGER, INTENT(IN) :: Input(1:3)
+          INTEGER :: Function_Test(1:3)
+          Function_Test = Input + 10
+      END FUNCTION Function_Test
+  END PROGRAM Test
+
diff --git a/gcc/testsuite/gfortran.dg/auto_char_pointer_array_result_1.f90 b/gcc/testsuite/gfortran.dg/auto_char_pointer_array_result_1.f90
new file mode 100644
index 0000000..8e3eb94
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/auto_char_pointer_array_result_1.f90
@@ -0,0 +1,36 @@
+! { dg-do run }
+! Tests the fixes for PR25597 and PR27096.
+!
+! This test combines the PR testcases.
+!
+  character(10), dimension (2) :: implicit_result
+  character(10), dimension (2) :: explicit_result
+  character(10), dimension (2) :: source
+  source = "abcdefghij"
+  explicit_result = join_1(source)
+  if (any (explicit_result .ne. source)) call abort () 
+
+  implicit_result = reallocate_hnv (source, size(source, 1), LEN (source))
+  if (any (implicit_result .ne. source)) call abort () 
+
+contains
+
+! This function would cause an ICE in gfc_trans_deferred_array.
+  function join_1(self) result(res)
+    character(len=*), dimension(:) :: self
+    character(len=len(self)), dimension(:), pointer :: res
+    allocate (res(2))
+    res = self
+  end function
+
+! This function originally ICEd and latterly caused a runtime error.
+  FUNCTION reallocate_hnv(p, n, LEN)
+    CHARACTER(LEN=LEN), DIMENSION(:), POINTER :: reallocate_hnv
+    character(*), dimension(:) :: p
+    ALLOCATE (reallocate_hnv(n))
+    reallocate_hnv = p
+  END FUNCTION reallocate_hnv
+
+end
+
+ 
diff --git a/gcc/testsuite/gfortran.dg/auto_pointer_array_result_1.f90 b/gcc/testsuite/gfortran.dg/auto_pointer_array_result_1.f90
new file mode 100644
index 0000000..7e7cde5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/auto_pointer_array_result_1.f90
@@ -0,0 +1,36 @@
+! { dg-do run }
+! Tests the fixes for PR25597 and PR27096.
+!
+! This test combines the PR testcases.
+!
+  character(10), dimension (2) :: implicit_result
+  character(10), dimension (2) :: explicit_result
+  character(10), dimension (2) :: source
+  source = "abcdefghij"
+  explicit_result = join_1(source)
+  if (any (explicit_result .ne. source)) call abort () 
+
+  implicit_result = reallocate_hnv (source, size(source, 1), LEN (source))
+  if (any (implicit_result .ne. source)) call abort () 
+
+contains
+
+! This function would cause an ICE in gfc_trans_deferred_array.
+  function join_1(self) result(res)
+    character(len=*), dimension(:) :: self
+    character(len=len(self)), dimension(:), pointer :: res
+    allocate (res(2))
+    res = self
+  end function
+
+! This function originally ICEd and latterly caused a runtime error.
+  FUNCTION reallocate_hnv(p, n, LEN)
+    CHARACTER(LEN=LEN), DIMENSION(:), POINTER :: reallocate_hnv
+    character(*), dimension(:) :: p
+    ALLOCATE (reallocate_hnv(n))
+    reallocate_hnv = p
+  END FUNCTION reallocate_hnv
+
+end
+
+
diff --git a/gcc/testsuite/gfortran.dg/bounds_temporaries_1.f90 b/gcc/testsuite/gfortran.dg/bounds_temporaries_1.f90
new file mode 100644
index 0000000..a277566
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bounds_temporaries_1.f90
@@ -0,0 +1,64 @@
+! { dg-do compile }
+! This tests the fix for PRs 26834, 25669 and 18803, in which
+! shape information for the lbound and ubound intrinsics was not
+! transferred to the scalarizer.  For this reason, an ICE would
+! ensue, whenever these functions were used in temporaries.
+!
+! The tests are lifted from the PRs and some further checks are
+! done to make sure that nothing is broken.
+!
+! This is PR26834
+subroutine gfcbug34 ()
+  implicit none
+  type t
+     integer, pointer :: i (:) => NULL ()
+  end type t
+  type(t), save :: gf
+  allocate (gf%i(20))
+  write(*,*) 'ubound:', ubound (gf% i)
+  write(*,*) 'lbound:', lbound (gf% i)
+end subroutine gfcbug34
+
+! This is PR25669
+subroutine foo (a)
+  real a(*)
+  call bar (a, LBOUND(a),2)
+end subroutine foo
+subroutine bar (b, i, j)
+  real b(i:j)
+  print *, i, j
+  print *, b(i:j)
+end subroutine bar
+
+! This is PR18003
+subroutine io_bug()
+  integer :: a(10)
+  print *, ubound(a)
+end subroutine io_bug
+
+! This checks that lbound and ubound are OK in  temporary
+! expressions.
+subroutine io_bug_plus()
+  integer :: a(10, 10), b(2)
+  print *, ubound(a)*(/1,2/)
+  print *, (/1,2/)*ubound(a)
+end subroutine io_bug_plus
+
+  character(4) :: ch(2), ech(2) = (/'ABCD', 'EFGH'/)
+  real(4) :: a(2)
+  equivalence (ech,a)  ! { dg-warning "default CHARACTER EQUIVALENCE statement" }
+  integer(1) :: i(8) = (/(j, j = 1,8)/)
+
+! Check that the bugs have gone
+  call io_bug ()
+  call io_bug_plus ()
+  call foo ((/1.0,2.0,3.0/))
+  call gfcbug34 ()
+
+! Check that we have not broken other intrinsics.
+  print *, cos ((/1.0,2.0/))
+  print *, transfer (a, ch)
+  print *, i(1:4) * transfer (a, i, 4) * 2
+end
+
+
diff --git a/gcc/testsuite/gfortran.dg/namelist_4.f90 b/gcc/testsuite/gfortran.dg/namelist_4.f90
index 9e62a1f..52a5bc9 100644
--- a/gcc/testsuite/gfortran.dg/namelist_4.f90
+++ b/gcc/testsuite/gfortran.dg/namelist_4.f90
@@ -28,8 +28,9 @@ program P1
 CONTAINS

 ! This has the additional wrinkle of a reference to the object.

   INTEGER FUNCTION F1()

-    NAMELIST /NML3/ F2 ! { dg-error "PROCEDURE attribute conflicts" }

-    f2 = 1     ! Used to ICE here

+    NAMELIST /NML3/ F2 ! { dg-error "PROCEDURE attribute conflicts" }
+! Used to ICE here

+    f2 = 1             ! { dg-error "is not a VALUE" }

     F1=1

   END FUNCTION

   INTEGER FUNCTION F2()

diff --git a/gcc/testsuite/gfortran.dg/proc_assign_1.f90 b/gcc/testsuite/gfortran.dg/proc_assign_1.f90
new file mode 100644
index 0000000..a0f7250
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_assign_1.f90
@@ -0,0 +1,78 @@
+! { dg-do compile }

+! This tests the patch for PR26787 in which it was found that setting

+! the result of one module procedure from within another produced an

+! ICE rather than an error.

+!

+! This is an "elaborated" version of the original testcase from

+! Joshua Cogliati  <jjcogliati-r1@yahoo.com>

+!

+function ext1 ()

+    integer ext1, ext2, arg

+    ext1 = 1

+    entry ext2 (arg)

+    ext2 = arg

+contains

+    subroutine int_1 ()

+        ext1 = arg * arg     ! OK - host associated.

+    end subroutine int_1

+end function ext1

+

+module simple

+    implicit none

+contains

+    integer function foo () 

+         foo = 10            ! OK - function result

+         call foobar ()

+    contains

+        subroutine foobar ()

+            integer z

+            foo = 20         ! OK - host associated.

+        end subroutine foobar

+    end function foo

+    subroutine bar()         ! This was the original bug.

+        foo = 10             ! { dg-error "is not a VALUE" }

+    end subroutine bar

+    integer function oh_no ()

+        oh_no = 1

+        foo = 5              ! { dg-error "is not a VALUE" }

+    end function oh_no

+end module simple

+

+module simpler

+    implicit none

+contains

+    integer function foo_er () 

+         foo_er = 10         ! OK - function result

+    end function foo_er

+end module simpler

+

+    use simpler

+    real w, stmt_fcn

+    interface

+	function ext1 ()

+	    integer ext1

+	end function ext1

+	function ext2 (arg)

+	    integer ext2, arg

+	end function ext2

+    end interface

+    stmt_fcn (w) = sin (w)     

+    call x (y ())

+    x = 10                   ! { dg-error "Expected VARIABLE" }

+    y = 20                   ! { dg-error "is not a VALUE" }

+    foo_er = 8               ! { dg-error "is not a VALUE" }

+    ext1 = 99                ! { dg-error "is not a VALUE" }

+    ext2 = 99                ! { dg-error "is not a VALUE" }

+    stmt_fcn = 1.0           ! { dg-error "Expected VARIABLE" }

+    w = stmt_fcn (1.0)

+contains

+    subroutine x (i)

+        integer i

+        y = i                ! { dg-error "is not a VALUE" }

+    end subroutine x

+    function y ()

+        integer y

+        y = 2                ! OK - function result

+    end function y

+end

+! { dg-final { cleanup-modules "simple simpler" } }
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/procedure_lvalue.f90 b/gcc/testsuite/gfortran.dg/procedure_lvalue.f90
index 2a2c355..634eaca 100644
--- a/gcc/testsuite/gfortran.dg/procedure_lvalue.f90
+++ b/gcc/testsuite/gfortran.dg/procedure_lvalue.f90
@@ -14,7 +14,7 @@ end module t
 
 subroutine r
   use t
-  b = 1.       ! { dg-error "l-value since it is a procedure" }
+  b = 1.       ! { dg-error "is not a VALUE" }
   y = a(1.)
 end subroutine r
 
diff --git a/gcc/testsuite/gfortran.dg/specification_type_resolution_1.f90 b/gcc/testsuite/gfortran.dg/specification_type_resolution_1.f90
new file mode 100644
index 0000000..b830b5d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/specification_type_resolution_1.f90
@@ -0,0 +1,31 @@
+! { dg-do compile }
+! Test of the fix of PR27089, where gfortran was unable to resolve the
+! type of n_elements_uncommon_with_ in the specification expression on
+! line 21.
+!
+! Test extracted from vec{int}.F90 of tonto.
+!
+module test
+   public    n_elements_uncommon_with_
+   interface n_elements_uncommon_with_
+      module procedure n_elements_uncommon_with
+   end interface
+contains
+   pure function n_elements_uncommon_with(x) result(res)
+      integer(4), dimension(:), intent(in) :: x
+      integer(4) :: res
+      res = size (x, 1)
+   end function
+   pure function elements_uncommon_with(x) result(res)
+      integer(4), dimension(:), intent(in) :: x
+      integer(4), dimension(n_elements_uncommon_with_(x)) :: res
+      res = x
+   end function
+end module test
+   use test
+   integer(4) :: z(4)
+   z = 1
+   print *, elements_uncommon_with (z)
+   print *, n_elements_uncommon_with_ (z)
+end
+! { dg-final { cleanup-modules "test" } }