[Patch, fortran] PR fortran/101047/101048 Pointer explicit initialization
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.
Re: [Patch, fortran] PR fortran/101047/101048 Pointer explicit initialization
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 (&init->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 (&lvalue, '\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_ze
[Patch, fortran] PR fortran/100948 - [12 Regression] ICE in gfc_conv_expr_val, at fortran/trans-expr.c:9069
Hi all!
Proposed partial patch to:
Bug 100948 - [12 Regression] ICE in gfc_conv_expr_val, at
fortran/trans-expr.c:9069
Patch tested only on x86_64-pc-linux-gnu.
Reuse previously calculated full string length to set string section
default upper bound.
This patch only fixes the ICE the code produced is still wrong.
Thank you very much.
Best regards,
José Rui
Fortran: Fix ICE.
gcc/fortran/ChangeLog:
PR fortran/100948
* trans-expr.c (gfc_get_expr_charlen): reuse previously calculated
full string length to set string section default upper bound.
gcc/testsuite/ChangeLog:
PR fortran/100948
* gfortran.dg/PR100948.f90: New test.
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index de406ad..1970cfc 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2152,17 +2152,25 @@ gfc_get_expr_charlen (gfc_expr *e)
break;
case REF_SUBSTRING:
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
- length = se.expr;
- gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
- length = fold_build2_loc (input_location, MINUS_EXPR,
-gfc_charlen_type_node,
-se.expr, length);
- length = fold_build2_loc (input_location, PLUS_EXPR,
-gfc_charlen_type_node, length,
-gfc_index_one_node);
- break;
+ {
+ tree start;
+
+ gfc_init_se (&se, NULL);
+ gcc_assert (r->u.ss.start);
+ gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
+ start = se.expr;
+ if (r->u.ss.end)
+ gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
+ else
+ se.expr = length;
+ length = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_charlen_type_node,
+ se.expr, start);
+ length = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_charlen_type_node, length,
+ gfc_index_one_node);
+ break;
+ }
default:
gcc_unreachable ();
diff --git a/gcc/testsuite/gfortran.dg/PR100948.f90 b/gcc/testsuite/gfortran.dg/PR100948.f90
new file mode 100644
index 000..c0e333f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR100948.f90
@@ -0,0 +1,218 @@
+! { dg-do run }
+!
+! Tests fix for PR100948
+!
+! Based on contribution by JG. Steinmetz
+!
+
+program dct_p
+
+ implicit none
+
+ integer, parameter :: n = 2
+ integer, parameter :: m = 3
+
+ character(len=*), parameter :: u(*) = ["abc", "uvw"]
+
+ type :: dca_t
+character(:), allocatable :: c(:)
+ end type dca_t
+
+ type :: dcp_t
+character(:), pointer :: c(:)
+ end type dcp_t
+
+ character(len=m), target :: a(n)
+
+ a = u
+ if (size(a)/=n)stop 1
+ if (len(a)/=m) stop 2
+ if (any(a/=u)) stop 3
+ call dcs0(a)
+ if (size(a)/=n)stop 4
+ if (len(a)/=m) stop 5
+ if (any(a/=u)) stop 6
+ a = u
+ call dcs1(a)
+ if (size(a)/=n)stop 7
+ if (len(a)/=m) stop 8
+ if (any(a/=u)) stop 9
+ a = u
+ call dcs2(a)
+ if (size(a)/=n)stop 10
+ if (len(a)/=m) stop 11
+ if (any(a/=u)) stop 12
+ a = u
+ call dcs3(a)
+ if (size(a)/=n)stop 13
+ if (len(a)/=m) stop 14
+ if (any(a/=u)) stop 15
+ a = u
+ call dcs4(a)
+ if (size(a)/=n)stop 16
+ if (len(a)/=m) stop 17
+ if (any(a/=u)) stop 18
+ a = u
+ call dcs5(a)
+ if (size(a)/=n)stop 19
+ if (len(a)/=m) stop 20
+ if (any(a/=u)) stop 21
+ a = u
+ call dcs6(a)
+ if (size(a)/=n)stop 22
+ if (len(a)/=m) stop 23
+ if (any(a/=u)) stop 24
+ a = u
+ call dcs7(a)
+ if (size(a)/=n)stop 25
+ if (len(a)/=m) stop 26
+ if (any(a/=u)) stop 27
+ stop
+
+contains
+
+ subroutine dcs0(a)
+character(len=*), intent(in) :: a(:)
+
+if (size(a)/=n) stop 28
+if (len(a)/=m) stop 29
+if (any(a/=u)) stop 30
+associate (q => a(:)(:))
+ if (size(q)/=n)stop 31
+ if (len(q)/=m) stop 32
+ if (any(q/=u)) stop 33
+end associate
+return
+ end subroutine dcs0
+
+ subroutine dcs1(a)
+character(len=*), intent(in) :: a(:)
+
+character(len=len(a)) :: b(size(a))
+
+b = a(:)(:)
+if (size(b)/=n) stop 34
+if (len(b)/=m) stop 35
+if (any(b/=u)) stop 36
+associate (q => b(:)(:))
+ if (size(q)/=n)stop 37
+ if (len(q)/=m) stop 38
+ if (any(q/=u)) stop 39
+end associate
+return
+ end subroutine dcs1
+
+ subroutine dcs2(a)
+character(len=*), target, intent(in) :: a(:)
+
+character(:), pointer :: p(:)
+
+p => a
