+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
}
/* 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;
}
+/* 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
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)
{
break;
case DECL_SAVE:
- t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
+ t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
break;
case DECL_TARGET:
}
}
+ /* 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;
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;
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);
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;
gfc_free (lvalue.symtree);
- return r;
+ 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;
}
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 *);
attr.pointer = pointer;
attr.allocatable = allocatable;
attr.target = target;
+ attr.save = sym->attr.save;
return attr;
}
/* 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;
/* 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)
"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)
"pointer component '%s' at %L in PURE procedure",
comp->name, &cons->expr->where);
}
+
}
return t;
if (t == FAILURE)
break;
- t = resolve_structure_cons (e);
+ t = resolve_structure_cons (e, 0);
if (t == FAILURE)
break;
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);
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;
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",
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",
return FAILURE;
}
- attr->save = SAVE_EXPLICIT;
+ attr->save = s;
return check_conflict (attr, name, 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;
/* 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);
}
&& (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);
{
gfc_ref *ref;
gfc_symbol *sym;
- tree parent_decl;
+ tree parent_decl = NULL_TREE;
int parent_flag;
bool return_value;
bool alternate_entry;
entry_master = sym->attr.result
&& sym->ns->proc_name->attr.entry_master
&& !gfc_return_by_reference (sym->ns->proc_name);
- parent_decl = DECL_CONTEXT (current_function_decl);
+ if (current_function_decl)
+ parent_decl = DECL_CONTEXT (current_function_decl);
if ((se->expr == parent_decl && return_value)
|| (sym->ns && sym->ns->proc_name
return gfc_conv_array_initializer (type, expr);
}
else if (pointer)
- return fold_convert (type, null_pointer_node);
+ {
+ 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)
+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
--- /dev/null
+! { 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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
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" }
projects / platform / upstream / gcc.git / commitdiff