Re: [Patch, fortran] PR fortran/101047/101048 Pointer explicit initialization

[José Rui Faustino de Sousa via Gcc-patches]

On 13/06/21 15:46, José Rui Faustino de Sousa wrote:

Hi All!

Proposed patch to:



And again I forgot to add the patch...

Sorry for the inconvenience.

Best regards,
José Rui

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 93118ad..5670d18 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -443,7 +443,7 @@ gfc_is_class_container_ref (gfc_expr *e)
component to the corresponding type (or the declared type, given by ts).  */
 
 gfc_expr *
-gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr)
+gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr, bool pointer)
 {
   gfc_expr *init;
   gfc_component *comp;
@@ -464,7 +464,10 @@ gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr)
   if (strcmp (comp->name, "_vptr") == 0 && vtab)
 	ctor->expr = gfc_lval_expr_from_sym (vtab);
   else if (init_expr && init_expr->expr_type != EXPR_NULL)
-	  ctor->expr = gfc_copy_expr (init_expr);
+	ctor->expr = gfc_copy_expr (init_expr);
+  else if (strcmp (comp->name, "_data") == 0 && pointer)
+	ctor->expr = (init_expr && init_expr->expr_type == EXPR_NULL)
+	  ? (gfc_get_null_expr (NULL)) : (NULL);
   else
 	ctor->expr = gfc_get_null_expr (NULL);
   gfc_constructor_append (>value.constructor, ctor);
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 956003e..32b2849 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4433,15 +4433,19 @@ bool
 gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue)
 {
   gfc_expr lvalue;
+  gfc_array_spec *as;
   bool r;
-  bool pointer, proc_pointer;
+  bool is_class, pointer, proc_pointer;
 
   memset (, '\0', sizeof (gfc_expr));
 
+  is_class = (sym->ts.type == BT_CLASS) && CLASS_DATA (sym);
+  as = is_class ? (CLASS_DATA (sym)->as) : (sym->as);
+  
   lvalue.expr_type = EXPR_VARIABLE;
   lvalue.ts = sym->ts;
-  if (sym->as)
-lvalue.rank = sym->as->rank;
+  if (as)
+lvalue.rank = as->rank;
   lvalue.symtree = XCNEW (gfc_symtree);
   lvalue.symtree->n.sym = sym;
   lvalue.where = sym->declared_at;
@@ -4461,7 +4465,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue)
 }
   else
 {
-  pointer = sym->ts.type == BT_CLASS &&  CLASS_DATA (sym)
+  pointer = is_class
 		? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
   proc_pointer = sym->attr.proc_pointer;
 }
@@ -4883,32 +4887,21 @@ get_union_initializer (gfc_symbol *union_type, gfc_component **map_p)
 }
 
 static bool
-class_allocatable (gfc_component *comp)
-{
-  return comp->ts.type == BT_CLASS && CLASS_DATA (comp)
-&& CLASS_DATA (comp)->attr.allocatable;
-}
-
-static bool
-class_pointer (gfc_component *comp)
-{
-  return comp->ts.type == BT_CLASS && CLASS_DATA (comp)
-&& CLASS_DATA (comp)->attr.pointer;
-}
-
-static bool
 comp_allocatable (gfc_component *comp)
 {
-  return comp->attr.allocatable || class_allocatable (comp);
+  if (comp->ts.type == BT_CLASS && CLASS_DATA (comp))
+return CLASS_DATA (comp)->attr.allocatable;
+  return comp->attr.allocatable;
 }
 
 static bool
 comp_pointer (gfc_component *comp)
 {
-  return comp->attr.pointer
-|| comp->attr.proc_pointer
-|| comp->attr.class_pointer
-|| class_pointer (comp);
+  if (comp->attr.proc_pointer)
+return true;
+  if (comp->ts.type == BT_CLASS && CLASS_DATA (comp))
+return CLASS_DATA (comp)->attr.class_pointer;
+  return comp->attr.pointer;
 }
 
 /* Fetch or generate an initializer for the given component.
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index cbc95d3..52a76bc 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3673,7 +3673,7 @@ void gfc_add_class_array_ref (gfc_expr *);
 bool gfc_is_class_array_ref (gfc_expr *, bool *);
 bool gfc_is_class_scalar_expr (gfc_expr *);
 bool gfc_is_class_container_ref (gfc_expr *e);
-gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *);
+gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *, bool);
 unsigned int gfc_hash_value (gfc_symbol *);
 gfc_expr *gfc_get_len_component (gfc_expr *e, int);
 bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index a6bcd2b..891f82a 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -406,20 +406,288 @@ gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
   gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
 }
 
+
+/* Create a new dtype constructor.  */
+
+static tree
+build_init_dtype (tree ctor, int rank)
+{
+  tree type;
+  tree field;
+  tree value;
+  tree init;
+  vec *vlst = NULL;
+
+  gcc_assert (TREE_CODE (ctor) == CONSTRUCTOR);
+  type = TREE_TYPE (ctor);
+
+  value = gfc_get_expr_from_ctor (ctor, 0);
+  if (value == NULL_TREE)
+value = integer_zero_node;
+  if (!TREE_CONSTANT (value) || TREE_SIDE_EFFECTS (value))
+value = (DECL_INITIAL (value))
+  ? (DECL_INITIAL (value)) : (integer_zero_node);
+

[Patch, fortran] PR fortran/101047/101048 Pointer explicit initialization

[José Rui Faustino de Sousa via Gcc-patches]

Hi All!

Proposed patch to:

Bug 101047 - Pointer explicit initialization fails
Bug 101048 - Class pointer explicit initialization refuses valid

Patch tested only on x86_64-pc-linux-gnu.

This patch deals with implementation of explicit initialization for 
pointer variables.


It basically relies on using "gfc_conv_expr_descriptor" to build a 
pointer assignment and re-parsing it back into a descriptor constructor.


It proceeds to implement the necessary differences between allocatable 
and pointer variables explicit initialization and to add, and correct, 
missing references to "CLASS_DATA" entities.


Thank you very much.

Best regards,
José Rui

Fortran: get pointer explicit initialization working.

gcc/fortran/ChangeLog:

PR fortran/10148
* class.c (gfc_class_initializer): only disassociate pointer if
explicitly requested.
PR fortran/10148
* expr.c (gfc_check_assign_symbol): get rank from CLASS_DATA if
necessary.
PR fortran/10147
* expr.c (class_allocatable): remove unnecessary auxiliary
function.
(class_pointer): remove unnecessary auxiliary function.
(comp_allocatable): consolidate allocatable attribute checking.
(comp_pointer): consolidate pointer attribute checking.
* gfortran.h (gfc_class_initializer): change prototype to reflect
the extra parameter.
* trans-array.c: new group of functions to re-parse a
"STATEMENT_LIST" back into a "CONSTRUCTOR".
(build_init_dtype): Create a new dtype constructor.
(build_init_desc_dtype): Find the old dtype constructor and create
a new one.
(append_init_dim): Append one of dim fields to vector.
(build_init_dim): Create a dim constructor.
(build_init_desc_dim): Create the dim array constructor.
(append_desc_field): Append a field to the constructor vector.
(build_init_descriptor): Create an array descriptor constructor.
(gfc_build_init_descriptor_dtype): new function to build a
descriptor containing only a dtype.
(gfc_build_null_descriptor): update function to nullify and add
the dtype.
(gfc_build_init_descriptor): new function to build a full array
descriptor constructor.
(gfc_trans_static_array_pointer): updated to take in consideration
the diferences between pointer and allocatable explicit
initialization and the initialization of entities containing
"CLASS_DATA".
(gfc_conv_array_initializer): change function calls to reflect
interface changes.
* trans-array.h (gfc_trans_static_array_pointer): add return
value.
(gfc_build_null_descriptor): add parameter to prototype.
(gfc_build_init_descriptor): new prototype.
* trans-common.c (create_common): change function call to reflect
interface changes.
* trans-decl.c (gfc_create_string_length): set initial deferred
character length to zero.
(gfc_get_symbol_decl): change function call to reflect interface
changes.
(get_proc_pointer_decl): change function call to reflect interface
changes.
(gfc_trans_deferred_vars): change function call to reflect
interface changes.
(gfc_emit_parameter_debug_info): get rank from CLASS_DATA if
necessary, change function call to reflect interface changes.
* trans-expr.c (gfc_class_unlimited_poly): new auxiliary function
to check if a tree representing a type is unlimited polymorphic.
(gfc_conv_initializer): renamed gfc_conv_initializer_common.
(gfc_conv_initializer_common): take in consideration differences
between pointers and allocatables in initialization.
(gfc_conv_sym_initializer): interface for initialization using
gfc_symbol.
(gfc_conv_comp_initializer): interface for initialization using
gfc_component.
(gfc_conv_expr_initializer): interface for initialization using
gfc_expr.
(gfc_trans_subcomponent_assign): change function call to reflect
interface changes.
(gfc_conv_union_initializer): change function call to reflect
interface changes.
(gfc_conv_structure): split in two divide between explicit
initialization default initialization.
(gfc_conv_structure_initializer): handles explicit initialization
of every component field.
(gfc_conv_expr): change function call to reflect interface
changes.
* trans-types.c (gfc_get_dtype_rank_type): if the "static_flag" is
set elem_len to the initial value, from "DECL_INITIAL", or zero.
* trans-types.h (gfc_get_dtype_rank_type): add parameter to
prototype.
* trans.c: new group of functions to extract a RHS from a
"CONSTRUCTOR" or a "STATEMENT_LIST" or a "MODIFY_EXPR".
(tree_ref_equal): simple tree equality check.