Patchwork [Fortran] PR46484: Function-expressions are not variables

login
register
mail settings
Submitter Tobias Burnus
Date Nov. 15, 2010, 6:41 p.m.
Message ID <4CE17ED2.8000705@net-b.de>
Download mbox | patch
Permalink /patch/71267/
State New
Headers show

Comments

Tobias Burnus - Nov. 15, 2010, 6:41 p.m.
On 11/15/2010 05:41 PM, Tobias Burnus wrote:
> The following patch is kind of obvious - at least for Fortran 
> 90/95/2003: A function call is not a variable!*

While the old patch is OK, it does not sufficiently distinguish between 
function names and function results. With the old patch, all 
"allocated(f)" are accepted but only those where "f" is also a the 
result variable should be accepted. (Thanks to Steve for pointing out 
that there might be an issue with result variables.)

The attached patch fixes this. The check whether the usage is valid or 
not is extremely lengthy. One reason is that there is only a single 
gfc_symbol for both the valid and invalid case. Thus, looking at 
e->symtree->n.sym->* does not help.

Build on x86-64-linux - and currently regtesting.
OK for the trunk?

Tobias
Steve Kargl - Nov. 15, 2010, 6:53 p.m.
On Mon, Nov 15, 2010 at 07:41:22PM +0100, Tobias Burnus wrote:
> 
> Build on x86-64-linux - and currently regtesting.
> OK for the trunk?
> 

OK (if no regressions are found).

Patch

2010-11-15  Tobias Burnus  <burnus@net.b.de>

	PR fortran/46484
	* check.c (variable_check): Don't treat functions calls as variables;
	optionally accept function themselves.
	(gfc_check_all_any, gfc_check_loc, gfc_check_move_alloc,
	gfc_check_null, gfc_check_present, gfc_check_cpu_time,
	gfc_check_date_and_time, gfc_check_mvbits, gfc_check_random_number,
	gfc_check_random_seed, gfc_check_system_clock,
	gfc_check_dtime_etime, gfc_check_dtime_etime_sub,
	gfc_check_itime_idate,gfc_check_ltime_gmtime): Update call.

2010-11-15  Tobias Burnus  <burnus@net.b.de>

	PR fortran/46484
	* gfortran.dg/allocatable_scalar_11.f90: New.
	* gfortran.dg/allocatable_scalar_5.f90: Make test case standard conform.

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 51ea877..f22a8db 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -478,7 +478,7 @@  kind_value_check (gfc_expr *e, int n, int k)
 /* Make sure an expression is a variable.  */
 
 static gfc_try
-variable_check (gfc_expr *e, int n)
+variable_check (gfc_expr *e, int n, bool allow_proc)
 {
   if (e->expr_type == EXPR_VARIABLE
       && e->symtree->n.sym->attr.intent == INTENT_IN
@@ -491,10 +491,15 @@  variable_check (gfc_expr *e, int n)
       return FAILURE;
     }
 
-  if ((e->expr_type == EXPR_VARIABLE
-       && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
-      || (e->expr_type == EXPR_FUNCTION
-	  && e->symtree->n.sym->result == e->symtree->n.sym))
+  if (e->expr_type == EXPR_VARIABLE
+      && e->symtree->n.sym->attr.flavor != FL_PARAMETER
+      && (allow_proc
+	  || !e->symtree->n.sym->attr.function
+	  || (e->symtree->n.sym == e->symtree->n.sym->result
+	      && (e->symtree->n.sym == gfc_current_ns->proc_name
+		  || (gfc_current_ns->parent
+		      && e->symtree->n.sym
+			 == gfc_current_ns->parent->proc_name)))))
     return SUCCESS;
 
   gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
@@ -762,7 +767,7 @@  gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
 gfc_try
 gfc_check_allocated (gfc_expr *array)
 {
-  if (variable_check (array, 0) == FAILURE)
+  if (variable_check (array, 0, false) == FAILURE)
     return FAILURE;
   if (allocatable_check (array, 0) == FAILURE)
     return FAILURE;
@@ -2041,7 +2046,7 @@  gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status)
 gfc_try
 gfc_check_loc (gfc_expr *expr)
 {
-  return variable_check (expr, 0);
+  return variable_check (expr, 0, true);
 }
 
 
@@ -2516,12 +2521,12 @@  gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
 gfc_try
 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
 {
-  if (variable_check (from, 0) == FAILURE)
+  if (variable_check (from, 0, false) == FAILURE)
     return FAILURE;
   if (allocatable_check (from, 0) == FAILURE)
     return FAILURE;
 
-  if (variable_check (to, 1) == FAILURE)
+  if (variable_check (to, 1, false) == FAILURE)
     return FAILURE;
   if (allocatable_check (to, 1) == FAILURE)
     return FAILURE;
@@ -2598,7 +2603,7 @@  gfc_check_null (gfc_expr *mold)
   if (mold == NULL)
     return SUCCESS;
 
-  if (variable_check (mold, 0) == FAILURE)
+  if (variable_check (mold, 0, true) == FAILURE)
     return FAILURE;
 
   attr = gfc_variable_attr (mold, NULL);
@@ -2729,7 +2734,7 @@  gfc_check_present (gfc_expr *a)
 {
   gfc_symbol *sym;
 
-  if (variable_check (a, 0) == FAILURE)
+  if (variable_check (a, 0, true) == FAILURE)
     return FAILURE;
 
   sym = a->symtree->n.sym;
@@ -3914,7 +3919,7 @@  gfc_check_cpu_time (gfc_expr *time)
   if (type_check (time, 0, BT_REAL) == FAILURE)
     return FAILURE;
 
-  if (variable_check (time, 0) == FAILURE)
+  if (variable_check (time, 0, false) == FAILURE)
     return FAILURE;
 
   return SUCCESS;
@@ -3933,7 +3938,7 @@  gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
 	return FAILURE;
       if (scalar_check (date, 0) == FAILURE)
 	return FAILURE;
-      if (variable_check (date, 0) == FAILURE)
+      if (variable_check (date, 0, false) == FAILURE)
 	return FAILURE;
     }
 
@@ -3945,7 +3950,7 @@  gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
 	return FAILURE;
       if (scalar_check (time, 1) == FAILURE)
 	return FAILURE;
-      if (variable_check (time, 1) == FAILURE)
+      if (variable_check (time, 1, false) == FAILURE)
 	return FAILURE;
     }
 
@@ -3957,7 +3962,7 @@  gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
 	return FAILURE;
       if (scalar_check (zone, 2) == FAILURE)
 	return FAILURE;
-      if (variable_check (zone, 2) == FAILURE)
+      if (variable_check (zone, 2, false) == FAILURE)
 	return FAILURE;
     }
 
@@ -3969,7 +3974,7 @@  gfc_check_date_and_time (gfc_expr *date, gfc_expr *time,
 	return FAILURE;
       if (rank_check (values, 3, 1) == FAILURE)
 	return FAILURE;
-      if (variable_check (values, 3) == FAILURE)
+      if (variable_check (values, 3, false) == FAILURE)
 	return FAILURE;
     }
 
@@ -3993,7 +3998,7 @@  gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len,
   if (same_type_check (from, 0, to, 3) == FAILURE)
     return FAILURE;
 
-  if (variable_check (to, 3) == FAILURE)
+  if (variable_check (to, 3, false) == FAILURE)
     return FAILURE;
 
   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
@@ -4025,7 +4030,7 @@  gfc_check_random_number (gfc_expr *harvest)
   if (type_check (harvest, 0, BT_REAL) == FAILURE)
     return FAILURE;
 
-  if (variable_check (harvest, 0) == FAILURE)
+  if (variable_check (harvest, 0, false) == FAILURE)
     return FAILURE;
 
   return SUCCESS;
@@ -4058,7 +4063,7 @@  gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
       if (type_check (size, 0, BT_INTEGER) == FAILURE)
 	return FAILURE;
 
-      if (variable_check (size, 0) == FAILURE)
+      if (variable_check (size, 0, false) == FAILURE)
 	return FAILURE;
 
       if (kind_value_check (size, 0, gfc_default_integer_kind) == FAILURE)
@@ -4112,7 +4117,7 @@  gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
       if (type_check (get, 2, BT_INTEGER) == FAILURE)
 	return FAILURE;
 
-      if (variable_check (get, 2) == FAILURE)
+      if (variable_check (get, 2, false) == FAILURE)
 	return FAILURE;
 
       if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
@@ -4165,7 +4170,7 @@  gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
       if (type_check (count, 0, BT_INTEGER) == FAILURE)
 	return FAILURE;
 
-      if (variable_check (count, 0) == FAILURE)
+      if (variable_check (count, 0, false) == FAILURE)
 	return FAILURE;
     }
 
@@ -4177,7 +4182,7 @@  gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
       if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
 	return FAILURE;
 
-      if (variable_check (count_rate, 1) == FAILURE)
+      if (variable_check (count_rate, 1, false) == FAILURE)
 	return FAILURE;
 
       if (count != NULL
@@ -4194,7 +4199,7 @@  gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
       if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
 	return FAILURE;
 
-      if (variable_check (count_max, 2) == FAILURE)
+      if (variable_check (count_max, 2, false) == FAILURE)
 	return FAILURE;
 
       if (count != NULL
@@ -4317,7 +4322,7 @@  gfc_check_dtime_etime (gfc_expr *x)
   if (rank_check (x, 0, 1) == FAILURE)
     return FAILURE;
 
-  if (variable_check (x, 0) == FAILURE)
+  if (variable_check (x, 0, false) == FAILURE)
     return FAILURE;
 
   if (type_check (x, 0, BT_REAL) == FAILURE)
@@ -4339,7 +4344,7 @@  gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time)
   if (rank_check (values, 0, 1) == FAILURE)
     return FAILURE;
 
-  if (variable_check (values, 0) == FAILURE)
+  if (variable_check (values, 0, false) == FAILURE)
     return FAILURE;
 
   if (type_check (values, 0, BT_REAL) == FAILURE)
@@ -4529,7 +4534,7 @@  gfc_check_itime_idate (gfc_expr *values)
   if (rank_check (values, 0, 1) == FAILURE)
     return FAILURE;
 
-  if (variable_check (values, 0) == FAILURE)
+  if (variable_check (values, 0, false) == FAILURE)
     return FAILURE;
 
   if (type_check (values, 0, BT_INTEGER) == FAILURE)
@@ -4560,7 +4565,7 @@  gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values)
   if (rank_check (values, 1, 1) == FAILURE)
     return FAILURE;
 
-  if (variable_check (values, 1) == FAILURE)
+  if (variable_check (values, 1, false) == FAILURE)
     return FAILURE;
 
   if (type_check (values, 1, BT_INTEGER) == FAILURE)
diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_11.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_11.f90
new file mode 100644
index 0000000..7f4d64d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_11.f90
@@ -0,0 +1,28 @@ 
+! { dg-compile }
+!
+! PR fortran/46484
+!
+
+function g()
+  implicit none
+  integer, allocatable :: g
+  call int()
+    print *, loc(g) ! OK
+contains
+  subroutine int()
+    print *, loc(g) ! OK
+    print *, allocated(g) ! OK
+  end subroutine int
+end function
+
+implicit none
+integer, allocatable :: x
+print *, allocated(f) ! { dg-error "must be a variable" }
+print *, loc(f) ! OK
+contains
+function f()
+  integer, allocatable :: f
+  print *, loc(f) ! OK
+  print *, allocated(f) ! OK
+end function
+end
diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_5.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_5.f90
index cee95a1..efa40e9 100644
--- a/gcc/testsuite/gfortran.dg/allocatable_scalar_5.f90
+++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_5.f90
@@ -1,7 +1,7 @@ 
 ! { dg-do run }
 ! { dg-options "-Wall -pedantic" }
 !
-! PR fortran/41872
+! PR fortran/41872; updated due to PR fortran/46484
 !
 !  More tests for allocatable scalars
 !
@@ -11,8 +11,6 @@  program test
   integer :: b
 
   if (allocated (a)) call abort ()
-  if (allocated (func (.false.))) call abort ()
-  if (.not.allocated (func (.true.))) call abort ()
   b = 7
   b = func(.true.)
   if (b /= 5332) call abort () 
@@ -28,7 +26,6 @@  program test
   call intout2 (a)
   if (allocated (a)) call abort ()
 
-  if (allocated (func2 ())) call abort ()
 contains
 
   function func (alloc)
@@ -41,10 +38,6 @@  contains
     end if
   end function func
 
-  function func2 ()
-    integer, allocatable ::  func2
-  end function func2
-
   subroutine intout (dum, alloc)
     implicit none
     integer, allocatable,intent(out) :: dum