* expr.c (gfc_check_assign_symbol): Handle pointer assignments.
* trans-array.c (gfc_trans_auto_array_allocation): Remove
initialization code.
* trans-common.c (create_common): Use gfc_conv_initializer.
* trans-decl.c (gfc_get_symbol_decl): Use gfc_conv_initializer.
* trans-expr.c (gfc_conv_initializer): New function.
(gfc_conv_structure): Use it.
* trans.h (gfc_conv_initializer): Add prototype.
testsuite/
* gfortran.dg/pointer_init_1.f90: New test.
From-SVN: r84542
+2004-07-12 Paul Brook <paul@codesourcery.com>
+
+ * expr.c (gfc_check_assign_symbol): Handle pointer assignments.
+ * trans-array.c (gfc_trans_auto_array_allocation): Remove
+ initialization code.
+ * trans-common.c (create_common): Use gfc_conv_initializer.
+ * trans-decl.c (gfc_get_symbol_decl): Use gfc_conv_initializer.
+ * trans-expr.c (gfc_conv_initializer): New function.
+ (gfc_conv_structure): Use it.
+ * trans.h (gfc_conv_initializer): Add prototype.
+
2004-07-11 Paul Brook <paul@codesourcery.com>
PR fortran/15986
/* Relative of gfc_check_assign() except that the lvalue is a single
- symbol. */
+ symbol. Used for initialization assignments. */
try
gfc_check_assign_symbol (gfc_symbol * sym, gfc_expr * rvalue)
lvalue.symtree->n.sym = sym;
lvalue.where = sym->declared_at;
- r = gfc_check_assign (&lvalue, rvalue, 1);
+ if (sym->attr.pointer)
+ r = gfc_check_pointer_assign (&lvalue, rvalue);
+ else
+ r = gfc_check_assign (&lvalue, rvalue, 1);
gfc_free (lvalue.symtree);
assert (GFC_ARRAY_TYPE_P (type));
onstack = TREE_CODE (type) != POINTER_TYPE;
- /* We never generate initialization code of module variables. */
- if (fnbody == NULL_TREE)
- {
- assert (onstack);
-
- /* Generate static initializer. */
- if (sym->value)
- {
- DECL_INITIAL (decl) =
- gfc_conv_array_initializer (TREE_TYPE (decl), sym->value);
- }
- return fnbody;
- }
-
gfc_start_block (&block);
/* Evaluate character string length. */
if (onstack)
{
- if (sym->value)
- {
- DECL_INITIAL (decl) =
- gfc_conv_array_initializer (TREE_TYPE (decl), sym->value);
- }
-
gfc_add_expr_to_block (&block, fnbody);
return gfc_finish_block (&block);
}
if (is_init)
{
tree list, ctor, tmp;
- gfc_se se;
HOST_WIDE_INT offset = 0;
list = NULL_TREE;
We don't implement this yet, so bail out. */
gfc_todo_error ("Initialization of overlapping variables");
}
- if (s->sym->attr.dimension)
- {
- tmp = gfc_conv_array_initializer (TREE_TYPE (s->field),
- s->sym->value);
- list = tree_cons (s->field, tmp, list);
- }
- else
- {
- switch (s->sym->ts.type)
- {
- case BT_CHARACTER:
- se.expr = gfc_conv_string_init
- (s->sym->ts.cl->backend_decl, s->sym->value);
- break;
-
- case BT_DERIVED:
- gfc_init_se (&se, NULL);
- gfc_conv_structure (&se, s->sym->value, 1);
- break;
-
- default:
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, s->sym->value);
- break;
- }
- list = tree_cons (s->field, se.expr, list);
- }
+ /* Add the initializer for this field. */
+ tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
+ TREE_TYPE (s->field), s->sym->attr.dimension,
+ s->sym->attr.pointer || s->sym->attr.allocatable);
+ list = tree_cons (s->field, tmp, list);
offset = s->offset + s->length;
}
}
{
tree decl;
tree length = NULL_TREE;
- gfc_se se;
int byref;
assert (sym->attr.referenced);
DECL_INITIAL (length) = build_int_2 (-2, -1);
}
- /* TODO: Initialization of pointer variables. */
- switch (sym->ts.type)
+ if (sym->ts.type == BT_CHARACTER)
{
- case BT_CHARACTER:
/* Character variables need special handling. */
gfc_allocate_lang_decl (decl);
- if (TREE_CODE (length) == INTEGER_CST)
- {
- /* Static initializer for string scalars.
- Initialization of string arrays is handled elsewhere. */
- if (sym->value && sym->attr.dimension == 0)
- {
- assert (TREE_STATIC (decl));
- if (sym->attr.pointer)
- gfc_todo_error ("initialization of character pointers");
- DECL_INITIAL (decl) = gfc_conv_string_init (length, sym->value);
- }
- }
- else
+ if (TREE_CODE (length) != INTEGER_CST)
{
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
gfc_finish_var_decl (length, sym);
assert (!sym->value);
}
- break;
-
- case BT_DERIVED:
- if (sym->value && ! (sym->attr.use_assoc || sym->attr.dimension))
- {
- gfc_init_se (&se, NULL);
- gfc_conv_structure (&se, sym->value, 1);
- DECL_INITIAL (decl) = se.expr;
- }
- break;
-
- default:
- /* Static initializers for SAVEd variables. Arrays have already been
- remembered. Module variables are initialized when the module is
- loaded. */
- if (sym->value && ! (sym->attr.use_assoc || sym->attr.dimension))
- {
- assert (TREE_STATIC (decl));
- gfc_init_se (&se, NULL);
- gfc_conv_constant (&se, sym->value);
- DECL_INITIAL (decl) = se.expr;
- }
- break;
}
sym->backend_decl = decl;
+ if (TREE_STATIC (decl) && !sym->attr.use_assoc)
+ {
+ /* Add static initializer. */
+ DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
+ TREE_TYPE (decl), sym->attr.dimension,
+ sym->attr.pointer || sym->attr.allocatable);
+ }
+
return decl;
}
gfc_create_module_variable (gfc_symbol * sym)
{
tree decl;
- gfc_se se;
/* Only output symbols from this module. */
if (sym->ns != module_namespace)
/* Create the decl. */
decl = gfc_get_symbol_decl (sym);
- /* We want to allocate storage for this variable. */
- TREE_STATIC (decl) = 1;
-
- if (sym->attr.dimension)
- {
- assert (sym->attr.pointer || sym->attr.allocatable
- || GFC_ARRAY_TYPE_P (TREE_TYPE (sym->backend_decl)));
- if (sym->attr.pointer || sym->attr.allocatable)
- gfc_trans_static_array_pointer (sym);
- else
- gfc_trans_auto_array_allocation (sym->backend_decl, sym, NULL_TREE);
- }
- else if (sym->ts.type == BT_DERIVED)
- {
- if (sym->value)
- gfc_todo_error ("Initialization of derived type module variables");
- }
- else
- {
- if (sym->value)
- {
- gfc_init_se (&se, NULL);
- gfc_conv_constant (&se, sym->value);
- DECL_INITIAL (decl) = se.expr;
- }
- }
-
/* Create the variable. */
pushdecl (decl);
rest_of_decl_compilation (decl, NULL, 1, 0);
}
+/* Build a static initializer. EXPR is the expression for the initial value.
+ The other parameters describe the variable of component being initialized.
+ EXPR may be null. */
+tree
+gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
+ bool array, bool pointer)
+{
+ gfc_se se;
+
+ if (!(expr || pointer))
+ return NULL_TREE;
+
+ if (array)
+ {
+ /* Arrays need special handling. */
+ if (pointer)
+ return gfc_build_null_descriptor (type);
+ else
+ return gfc_conv_array_initializer (type, expr);
+ }
+ else if (pointer)
+ return fold_convert (type, null_pointer_node);
+ else
+ {
+ switch (ts->type)
+ {
+ case BT_DERIVED:
+ gfc_init_se (&se, NULL);
+ gfc_conv_structure (&se, expr, 1);
+ return se.expr;
+
+ case BT_CHARACTER:
+ return gfc_conv_string_init (ts->cl->backend_decl,expr);
+
+ default:
+ gfc_init_se (&se, NULL);
+ gfc_conv_constant (&se, expr);
+ return se.expr;
+ }
+ }
+}
+
/* Build an expression for a constructor. If init is nonzero then
this is part of a static variable initializer. */
/* Evaluate the expression for this component. */
if (init)
{
- if (cm->dimension)
- {
- tree arraytype;
- arraytype = TREE_TYPE (cm->backend_decl);
-
- /* Arrays need special handling. */
- if (cm->pointer)
- cse.expr = gfc_build_null_descriptor (arraytype);
- else
- cse.expr = gfc_conv_array_initializer (arraytype, c->expr);
- }
- else if (cm->pointer)
- {
- /* Pointer components may only be initialized to NULL. */
- assert (c->expr->expr_type == EXPR_NULL);
- cse.expr = fold_convert (TREE_TYPE (cm->backend_decl),
- null_pointer_node);
- }
- else if (cm->ts.type == BT_DERIVED)
- gfc_conv_structure (&cse, c->expr, 1);
- else
- gfc_conv_expr (&cse, c->expr);
+ cse.expr = gfc_conv_initializer (c->expr, &cm->ts,
+ TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
}
else
{
/* Return the variable decl for a symbol. */
tree gfc_get_symbol_decl (gfc_symbol *);
+/* Build a static initializer. */
+tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool);
+
/* Substitute a temporary variable in place of the real one. */
void gfc_shadow_sym (gfc_symbol *, tree, gfc_saved_var *);
+2004-07-12 Paul Brook <paul@codesourcery.com>
+
+ * gfortran.dg/pointer_init_1.f90: New test.
+
2004-07-11 Paul Brook <paul@codesourcery.com>
PR fortran/15986
--- /dev/null
+! Check that null initialization of pointer variable works.
+! { dg-do run }
+program pointer_init_1
+ type t
+ real x
+ end type
+ type(t), pointer :: a => NULL()
+ real, pointer :: b => NULL()
+ character, pointer :: c => NULL()
+ integer, pointer, dimension(:) :: d => NULL()
+ if (associated(a)) call abort()
+ if (associated(b)) call abort()
+ if (associated(c)) call abort()
+ if (associated(d)) call abort()
+end
projects / gcc.git / commitdiff