OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/45290 ([F08] pointer initialization)

Browse Source 
2010-08-19  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45290
	* gfortran.h (gfc_add_save): Modified prototype.
	* decl.c (add_init_expr_to_sym): Defer checking of proc pointer init.
	(match_pointer_init): New function to match F08 pointer initialization.
	(variable_decl,match_procedure_decl,match_ppc_decl): Use
	'match_pointer_init'.
	(match_attr_spec): Module variables are implicitly SAVE.
	(gfc_match_save): Modified call to 'gfc_add_save'.
	* expr.c (gfc_check_assign_symbol): Extra checks for pointer
	initialization.
	* primary.c (gfc_variable_attr): Handle SAVE attribute.
	* resolve.c (resolve_structure_cons): Add new argument and do pointer
	initialization checks.
	(gfc_resolve_expr): Modified call to 'resolve_structure_cons'.
	(resolve_values): Call 'resolve_structure_cons' directly with init arg.
	(resolve_fl_variable): Handle SAVE_IMPLICIT.
	* symbol.c (gfc_add_save,gfc_copy_attr,save_symbol): Handle
	SAVE_IMPLICIT.
	* trans-decl.c (gfc_create_module_variable): Module variables with
	TARGET can already exist.
	* trans-expr.c (gfc_conv_variable): Check for 'current_function_decl'.
	(gfc_conv_initializer): Implement non-NULL pointer
	initialization.


2010-08-19  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45290
	* gfortran.dg/proc_ptr_comp_3.f90: Modified.
	* gfortran.dg/pointer_init_2.f90: New.
	* gfortran.dg/pointer_init_3.f90: New.
	* gfortran.dg/pointer_init_4.f90: New.

From-SVN: r163356
This commit is contained in:
Janus Weil 2010-08-19 00:32:22 +02:00
parent fbb12873f2
commit 80f9522847
14 changed files with 296 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
gcc/fortran/ChangeLog
View File

@ -1,3 +1,29 @@
2010-08-19 Janus Weil <janus@gcc.gnu.org>
PR fortran/45290
* gfortran.h (gfc_add_save): Modified prototype.
* decl.c (add_init_expr_to_sym): Defer checking of proc pointer init.
(match_pointer_init): New function to match F08 pointer initialization.
(variable_decl,match_procedure_decl,match_ppc_decl): Use
'match_pointer_init'.
(match_attr_spec): Module variables are implicitly SAVE.
(gfc_match_save): Modified call to 'gfc_add_save'.
* expr.c (gfc_check_assign_symbol): Extra checks for pointer
initialization.
* primary.c (gfc_variable_attr): Handle SAVE attribute.
* resolve.c (resolve_structure_cons): Add new argument and do pointer
initialization checks.
(gfc_resolve_expr): Modified call to 'resolve_structure_cons'.
(resolve_values): Call 'resolve_structure_cons' directly with init arg.
(resolve_fl_variable): Handle SAVE_IMPLICIT.
* symbol.c (gfc_add_save,gfc_copy_attr,save_symbol): Handle
SAVE_IMPLICIT.
* trans-decl.c (gfc_create_module_variable): Module variables with
TARGET can already exist.
* trans-expr.c (gfc_conv_variable): Check for 'current_function_decl'.
(gfc_conv_initializer): Implement non-NULL pointer
initialization.
2010-08-18 Tobias Burnus <burnus@net-b.de>
PR fortran/45295

99
gcc/fortran/decl.c
View File

@ -1312,9 +1312,10 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
}
/* Check if the assignment can happen. This has to be put off
until later for a derived type variable. */
until later for derived type variables and procedure pointers. */
if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
&& sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
&& !sym->attr.proc_pointer
&& gfc_check_assign_symbol (sym, init) == FAILURE)
return FAILURE;
@ -1652,6 +1653,48 @@ gfc_match_null (gfc_expr **result)
}
/* Match the initialization expr for a data pointer or procedure pointer. */
static match
match_pointer_init (gfc_expr **init, int procptr)
{
match m;
if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED)
{
gfc_error ("Initialization of pointer at %C is not allowed in "
"a PURE procedure");
return MATCH_ERROR;
}
/* Match NULL() initilization. */
m = gfc_match_null (init);
if (m != MATCH_NO)
return m;
/* Match non-NULL initialization. */
gfc_matching_procptr_assignment = procptr;
m = gfc_match_rvalue (init);
gfc_matching_procptr_assignment = 0;
if (m == MATCH_ERROR)
return MATCH_ERROR;
else if (m == MATCH_NO)
{
gfc_error ("Error in pointer initialization at %C");
return MATCH_ERROR;
}
if (!procptr)
gfc_resolve_expr (*init);
if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: non-NULL pointer "
"initialization at %C") == FAILURE)
return MATCH_ERROR;
return MATCH_YES;
}
/* Match a variable name with an optional initializer. When this
subroutine is called, a variable is expected to be parsed next.
Depending on what is happening at the moment, updates either the
@ -1899,23 +1942,9 @@ variable_decl (int elem)
goto cleanup;
}
m = gfc_match_null (&initializer);
if (m == MATCH_NO)
{
gfc_error ("Pointer initialization requires a NULL() at %C");
m = MATCH_ERROR;
}
if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED)
{
gfc_error ("Initialization of pointer at %C is not allowed in "
"a PURE procedure");
m = MATCH_ERROR;
}
m = match_pointer_init (&initializer, 0);
if (m != MATCH_YES)
goto cleanup;
}
else if (gfc_match_char ('=') == MATCH_YES)
{
@ -3511,7 +3540,7 @@ match_attr_spec (void)
break;
case DECL_SAVE:
t = gfc_add_save (&current_attr, NULL, &seen_at[d]);
t = gfc_add_save (&current_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
break;
case DECL_TARGET:
@ -3551,6 +3580,10 @@ match_attr_spec (void)
}
}
/* Module variables implicitly have the SAVE attribute. */
if (gfc_current_state () == COMP_MODULE && !current_attr.save)
current_attr.save = SAVE_IMPLICIT;
colon_seen = 1;
return MATCH_YES;
@ -4675,20 +4708,7 @@ match_procedure_decl (void)
goto cleanup;
}
m = gfc_match_null (&initializer);
if (m == MATCH_NO)
{
gfc_error ("Pointer initialization requires a NULL() at %C");
m = MATCH_ERROR;
}
if (gfc_pure (NULL))
{
gfc_error ("Initialization of pointer at %C is not allowed in "
"a PURE procedure");
m = MATCH_ERROR;
}
m = match_pointer_init (&initializer, 1);
if (m != MATCH_YES)
goto cleanup;
@ -4815,18 +4835,7 @@ match_ppc_decl (void)
if (gfc_match (" =>") == MATCH_YES)
{
m = gfc_match_null (&initializer);
if (m == MATCH_NO)
{
gfc_error ("Pointer initialization requires a NULL() at %C");
m = MATCH_ERROR;
}
if (gfc_pure (NULL))
{
gfc_error ("Initialization of pointer at %C is not allowed in "
"a PURE procedure");
m = MATCH_ERROR;
}
m = match_pointer_init (&initializer, 1);
if (m != MATCH_YES)
{
gfc_free_expr (initializer);
@ -6720,8 +6729,8 @@ gfc_match_save (void)
switch (m)
{
case MATCH_YES:
if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
== FAILURE)
if (gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
&gfc_current_locus) == FAILURE)
return MATCH_ERROR;
goto next_item;

28
gcc/fortran/expr.c
View File

@ -3552,7 +3552,35 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
gfc_free (lvalue.symtree);
if (r == FAILURE)
return r;
if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL)
{
/* F08:C461. Additional checks for pointer initialization. */
symbol_attribute attr;
attr = gfc_expr_attr (rvalue);
if (attr.allocatable)
{
gfc_error ("Pointer initialization target at %C "
"must not be ALLOCATABLE ");
return FAILURE;
}
if (!attr.target)
{
gfc_error ("Pointer initialization target at %C "
"must have the TARGET attribute");
return FAILURE;
}
if (!attr.save)
{
gfc_error ("Pointer initialization target at %C "
"must have the SAVE attribute");
return FAILURE;
}
}
return SUCCESS;
}

2
gcc/fortran/gfortran.h
View File

@ -2466,7 +2466,7 @@ gfc_try gfc_add_cray_pointee (symbol_attribute *, locus *);
match gfc_mod_pointee_as (gfc_array_spec *);
gfc_try gfc_add_protected (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_result (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_save (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_save (symbol_attribute *, save_state, const char *, locus *);
gfc_try gfc_add_threadprivate (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_saved_common (symbol_attribute *, locus *);
gfc_try gfc_add_target (symbol_attribute *, locus *);

1
gcc/fortran/primary.c
View File

@ -2088,6 +2088,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
attr.pointer = pointer;
attr.allocatable = allocatable;
attr.target = target;
attr.save = sym->attr.save;
return attr;
}

39
gcc/fortran/resolve.c
View File

@ -833,10 +833,11 @@ resolve_contained_functions (gfc_namespace *ns)
/* Resolve all of the elements of a structure constructor and make sure that
the types are correct. */
the types are correct. The 'init' flag indicates that the given
constructor is an initializer. */
static gfc_try
resolve_structure_cons (gfc_expr *expr)
resolve_structure_cons (gfc_expr *expr, int init)
{
gfc_constructor *cons;
gfc_component *comp;
@ -896,7 +897,8 @@ resolve_structure_cons (gfc_expr *expr)
/* If we don't have the right type, try to convert it. */
if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
if (!comp->attr.proc_pointer &&
!gfc_compare_types (&cons->expr->ts, &comp->ts))
{
t = FAILURE;
if (strcmp (comp->name, "$extends") == 0)
@ -1005,6 +1007,23 @@ resolve_structure_cons (gfc_expr *expr)
"a TARGET", &cons->expr->where, comp->name);
}
if (init)
{
/* F08:C461. Additional checks for pointer initialization. */
if (a.allocatable)
{
t = FAILURE;
gfc_error ("Pointer initialization target at %L "
"must not be ALLOCATABLE ", &cons->expr->where);
}
if (!a.save)
{
t = FAILURE;
gfc_error ("Pointer initialization target at %L "
"must have the SAVE attribute", &cons->expr->where);
}
}
/* F2003, C1272 (3). */
if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
&& (gfc_impure_variable (cons->expr->symtree->n.sym)
@ -1015,6 +1034,7 @@ resolve_structure_cons (gfc_expr *expr)
"pointer component '%s' at %L in PURE procedure",
comp->name, &cons->expr->where);
}
}
return t;
@ -5977,7 +5997,7 @@ gfc_resolve_expr (gfc_expr *e)
if (t == FAILURE)
break;
t = resolve_structure_cons (e);
t = resolve_structure_cons (e, 0);
if (t == FAILURE)
break;
@ -8924,10 +8944,17 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
static void
resolve_values (gfc_symbol *sym)
{
gfc_try t;
if (sym->value == NULL)
return;
if (gfc_resolve_expr (sym->value) == FAILURE)
if (sym->value->expr_type == EXPR_STRUCTURE)
t= resolve_structure_cons (sym->value, 1);
else
t = gfc_resolve_expr (sym->value);
if (t == FAILURE)
return;
gfc_check_assign_symbol (sym, sym->value);
@ -9636,7 +9663,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
return FAILURE;
}
if (e && sym->attr.save && !gfc_is_constant_expr (e))
if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
{
gfc_error (auto_save_msg, sym->name, &sym->declared_at);
return FAILURE;

13
gcc/fortran/symbol.c
View File

@ -1095,13 +1095,14 @@ gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
gfc_try
gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
locus *where)
{
if (check_used (attr, name, where))
return FAILURE;
if (gfc_pure (NULL))
if (s == SAVE_EXPLICIT && gfc_pure (NULL))
{
gfc_error
("SAVE attribute at %L cannot be specified in a PURE procedure",
@ -1109,7 +1110,7 @@ gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
return FAILURE;
}
if (attr->save == SAVE_EXPLICIT && !attr->vtab)
if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT)
{
if (gfc_notify_std (GFC_STD_LEGACY,
"Duplicate SAVE attribute specified at %L",
@ -1118,7 +1119,7 @@ gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
return FAILURE;
}
attr->save = SAVE_EXPLICIT;
attr->save = s;
return check_conflict (attr, name, where);
}
@ -1740,7 +1741,7 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
goto fail;
if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
goto fail;
if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
if (src->save && gfc_add_save (dest, src->save, NULL, where) == FAILURE)
goto fail;
if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
goto fail;
@ -3430,7 +3431,7 @@ save_symbol (gfc_symbol *sym)
/* Automatic objects are not saved. */
if (gfc_is_var_automatic (sym))
return;
gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
}

2
gcc/fortran/trans-decl.c
View File

@ -3587,7 +3587,7 @@ gfc_create_module_variable (gfc_symbol * sym)
&& (sym->equiv_built || sym->attr.in_equivalence))
return;
if (sym->backend_decl && !sym->attr.vtab)
if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
internal_error ("backend decl for module variable %s already exists",
sym->name);

13
gcc/fortran/trans-expr.c
View File

@ -556,7 +556,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
{
gfc_ref *ref;
gfc_symbol *sym;
tree parent_decl;
tree parent_decl = NULL_TREE;
int parent_flag;
bool return_value;
bool alternate_entry;
@ -590,6 +590,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
entry_master = sym->attr.result
&& sym->ns->proc_name->attr.entry_master
&& !gfc_return_by_reference (sym->ns->proc_name);
if (current_function_decl)
parent_decl = DECL_CONTEXT (current_function_decl);
if ((se->expr == parent_decl && return_value)
@ -3983,7 +3984,17 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
return gfc_conv_array_initializer (type, expr);
}
else if (pointer)
{
if (!expr || expr->expr_type == EXPR_NULL)
return fold_convert (type, null_pointer_node);
else
{
gfc_init_se (&se, NULL);
se.want_pointer = 1;
gfc_conv_expr (&se, expr);
return se.expr;
}
}
else
{
switch (ts->type)

8
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,11 @@
2010-08-19 Janus Weil <janus@gcc.gnu.org>
PR fortran/45290
* gfortran.dg/proc_ptr_comp_3.f90: Modified.
* gfortran.dg/pointer_init_2.f90: New.
* gfortran.dg/pointer_init_3.f90: New.
* gfortran.dg/pointer_init_4.f90: New.
2010-08-18 Nathan Froyd <froydnj@codesourcery.com>
PR c++/45049

36
gcc/testsuite/gfortran.dg/pointer_init_2.f90 Normal file
View File

@ -0,0 +1,36 @@
! { dg-do compile }
!
! PR 45290: [F08] pointer initialization
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
subroutine sub
implicit none
real, target, save :: r
integer, target, save, dimension(1:3) :: v
integer, save :: i
integer, target :: j
integer, target, save, allocatable :: a
integer, pointer :: dp0 => 13 ! { dg-error "Error in pointer initialization" }
integer, pointer :: dp1 => r ! { dg-error "Different types in pointer assignment" }
integer, pointer :: dp2 => v ! { dg-error "Different ranks in pointer assignment" }
integer, pointer :: dp3 => i ! { dg-error "is neither TARGET nor POINTER" }
integer, pointer :: dp4 => j ! { dg-error "must have the SAVE attribute" }
integer, pointer :: dp5 => a ! { dg-error "must not be ALLOCATABLE" }
type :: t
integer, pointer :: dpc0 => 13 ! { dg-error "Error in pointer initialization" }
integer, pointer :: dpc1 => r ! { dg-error "is REAL but should be INTEGER" }
integer, pointer :: dpc2 => v ! { dg-error "rank of the element.*does not match" }
integer, pointer :: dpc3 => i ! { dg-error "should be a POINTER or a TARGET" }
integer, pointer :: dpc4 => j ! { dg-error "must have the SAVE attribute" }
integer, pointer :: dpc5 => a ! { dg-error "must not be ALLOCATABLE" }
end type
type(t) ::u
end subroutine

44
gcc/testsuite/gfortran.dg/pointer_init_3.f90 Normal file
View File

@ -0,0 +1,44 @@
! { dg-do run }
!
! PR 45290: [F08] pointer initialization
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
module m
integer, target :: t1 ! SAVE is implicit
integer, pointer :: p1 => t1
end module m
use m
implicit none
integer,target :: i0 = 2
integer,target,dimension(1:3) :: vec = 1
type :: t
integer, pointer :: dpc => i0
integer :: i = 0
end type
type (t), save, target :: u
integer, pointer :: dp => i0
integer, pointer :: dp2 => vec(2)
integer, pointer :: dp3 => u%i
dp = 5
if (i0/=5) call abort()
u%dpc = 6
if (i0/=6) call abort()
dp2 = 3
if (vec(2)/=3) call abort()
dp3 = 4
if (u%i/=4) call abort()
end
! { dg-final { cleanup-modules "m" } }

42
gcc/testsuite/gfortran.dg/pointer_init_4.f90 Normal file
View File

@ -0,0 +1,42 @@
! { dg-do run }
!
! PR 45290: [F08] pointer initialization
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
module m
implicit none
contains
integer function f1()
f1 = 42
end function
integer function f2()
f2 = 43
end function
end module
program test_ptr_init
use m
implicit none
procedure(f1), pointer :: pp => f1
type :: t
procedure(f2), pointer, nopass :: ppc => f2
end type
type (t) :: u
if (pp()/=42) call abort()
if (u%ppc()/=43) call abort()
end
! { dg-final { cleanup-modules "m" } }

1
gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90
View File

@ -22,7 +22,6 @@ type :: t
procedure(), pointer, nopass ptr4 ! { dg-error "Expected '::'" }
procedure(), pointer, nopass, pointer :: ptr5 ! { dg-error "Duplicate" }
procedure, pointer, nopass :: ptr6 ! { dg-error "Syntax error" }
procedure(), pointer, nopass :: ptr7 => ptr2 ! { dg-error "requires a NULL" }
procedure(), nopass :: ptr8 ! { dg-error "POINTER attribute is required" }
procedure(pp), pointer, nopass :: ptr9 ! { dg-error "declared in a later PROCEDURE statement" }
procedure(aaargh), pointer, nopass :: ptr10 ! { dg-error "must be explicit" }