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.
@@ -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)
new file mode 100644
@@ -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
@@ -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