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

1 files changed, 41 insertions, 5 deletions

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)
     {