diff mbox

[Fortran] PR46484: Function-expressions are not variables

Message ID 4CE17ED2.8000705@net-b.de
State New
Headers show

Commit Message

Tobias Burnus Nov. 15, 2010, 6:41 p.m. UTC 
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

Comments

Steve Kargl Nov. 15, 2010, 6:53 p.m. UTC | #1 
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).
diff mbox

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