From: Andre Vehreschild <vehre@gmx.de>
To: GCC-Fortran-ML <fortran@gcc.gnu.org>,
GCC-Patches-ML <gcc-patches@gcc.gnu.org>,
Antony Lewis <antony@cosmologist.info>
Subject: [Patch 1/2, Fortran, pr60322] [OOP] Incorrect bounds on polymorphic dummy array
Date: Thu, 26 Feb 2015 17:19:00 -0000 [thread overview]
Message-ID: <20150226181717.480e282c@vepi2> (raw)
[-- Attachment #1: Type: text/plain, Size: 680 bytes --]
Hi all,
please find attached the first part of a two parts patch fixing pr/60322. This
first patch is only preparatory and does not change any of the semantics of
gfortran at all. It only modifies the compiler code to have the
symbol_attribute and the gfc_array_spec in a separate variable in the some
routines. The second part of the patch will then initialize these variables with
either the (sym.attr and sym.as) or (CLASS_DATA(sym).attr and
CLASS_DATA(sym).as), respectively, depending on whether the current symbol is
a regular array or a class array.
Bootstraps and regtests ok on x86_64-linux-gnu/F20.
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr60322_base_1.clog --]
[-- Type: application/octet-stream, Size: 413 bytes --]
gcc/fortran/ChangeLog:
2015-02-26 Andre Vehreschild <vehre@gmx.de>
* expr.c (gfc_lval_expr_from_sym): Added array_attr- and as-
pointer to address the class arrays and regular arrays.
* trans-array.c (gfc_trans_dummy_array_bias): Same.
* trans-decl.c (gfc_build_qualified_array): Same.
(gfc_build_dummy_array_decl): Same.
(gfc_trans_deferred_vars): Same.
* trans-types.c (gfc_is_nodesc_array): Same.
[-- Attachment #3: pr60322_base_1.patch --]
[-- Type: text/x-patch, Size: 11832 bytes --]
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index ab6f7a5..d28cf77 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4052,6 +4052,7 @@ gfc_expr *
gfc_lval_expr_from_sym (gfc_symbol *sym)
{
gfc_expr *lval;
+ gfc_array_spec *as;
lval = gfc_get_expr ();
lval->expr_type = EXPR_VARIABLE;
lval->where = sym->declared_at;
@@ -4059,10 +4060,10 @@ gfc_lval_expr_from_sym (gfc_symbol *sym)
lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
/* It will always be a full array. */
- lval->rank = sym->as ? sym->as->rank : 0;
+ as = sym->as;
+ lval->rank = as ? as->rank : 0;
if (lval->rank)
- gfc_add_full_array_ref (lval, sym->ts.type == BT_CLASS ?
- CLASS_DATA (sym)->as : sym->as);
+ gfc_add_full_array_ref (lval, as);
return lval;
}
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 642110d..0d4d7b2 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5898,6 +5898,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
int checkparm;
int no_repack;
bool optional_arg;
+ gfc_array_spec *as;
/* Do nothing for pointer and allocatable arrays. */
if (sym->attr.pointer || sym->attr.allocatable)
@@ -5917,13 +5918,14 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
gcc_assert (GFC_ARRAY_TYPE_P (type));
dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
+ as = sym->as;
gfc_start_block (&init);
if (sym->ts.type == BT_CHARACTER
&& TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
- checkparm = (sym->as->type == AS_EXPLICIT
+ checkparm = (as->type == AS_EXPLICIT
&& (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
@@ -5999,9 +6001,9 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
size = gfc_index_one_node;
/* Evaluate the bounds of the array. */
- for (n = 0; n < sym->as->rank; n++)
+ for (n = 0; n < as->rank; n++)
{
- if (checkparm || !sym->as->upper[n])
+ if (checkparm || !as->upper[n])
{
/* Get the bounds of the actual parameter. */
dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
@@ -6017,7 +6019,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
if (!INTEGER_CST_P (lbound))
{
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, sym->as->lower[n],
+ gfc_conv_expr_type (&se, as->lower[n],
gfc_array_index_type);
gfc_add_block_to_block (&init, &se.pre);
gfc_add_modify (&init, lbound, se.expr);
@@ -6025,13 +6027,13 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
/* Set the desired upper bound. */
- if (sym->as->upper[n])
+ if (as->upper[n])
{
/* We know what we want the upper bound to be. */
if (!INTEGER_CST_P (ubound))
{
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, sym->as->upper[n],
+ gfc_conv_expr_type (&se, as->upper[n],
gfc_array_index_type);
gfc_add_block_to_block (&init, &se.pre);
gfc_add_modify (&init, ubound, se.expr);
@@ -6084,7 +6086,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
gfc_array_index_type, offset, tmp);
/* The size of this dimension, and the stride of the next. */
- if (n + 1 < sym->as->rank)
+ if (n + 1 < as->rank)
{
stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 3664824..e571a17 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -811,8 +811,12 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
int dim;
int nest;
gfc_namespace* procns;
+ symbol_attribute *array_attr;
+ gfc_array_spec *as;
type = TREE_TYPE (decl);
+ array_attr = &sym->attr;
+ as = sym->as;
/* We just use the descriptor, if there is one. */
if (GFC_DESCRIPTOR_TYPE_P (type))
@@ -823,8 +827,8 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
nest = (procns->proc_name->backend_decl != current_function_decl)
&& !sym->attr.contained;
- if (sym->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB
- && sym->as->type != AS_ASSUMED_SHAPE
+ if (array_attr->codimension && flag_coarray == GFC_FCOARRAY_LIB
+ && as->type != AS_ASSUMED_SHAPE
&& GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
{
tree token;
@@ -877,8 +881,8 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
}
/* Don't try to use the unknown bound for assumed shape arrays. */
if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
- && (sym->as->type != AS_ASSUMED_SIZE
- || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
+ && (as->type != AS_ASSUMED_SIZE
+ || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
{
GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
@@ -919,7 +923,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
}
if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
- && sym->as->type != AS_ASSUMED_SIZE)
+ && as->type != AS_ASSUMED_SIZE)
{
GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
@@ -946,12 +950,12 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
}
if (TYPE_NAME (type) != NULL_TREE
- && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
- && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
+ && GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1) != NULL_TREE
+ && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1)) == VAR_DECL)
{
tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
- for (dim = 0; dim < sym->as->rank - 1; dim++)
+ for (dim = 0; dim < as->rank - 1; dim++)
{
gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
gtype = TREE_TYPE (gtype);
@@ -965,7 +969,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
{
tree gtype = TREE_TYPE (type), rtype, type_decl;
- for (dim = sym->as->rank - 1; dim >= 0; dim--)
+ for (dim = as->rank - 1; dim >= 0; dim--)
{
tree lbound, ubound;
lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
@@ -1013,16 +1017,24 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
tree decl;
tree type;
gfc_array_spec *as;
+ symbol_attribute *array_attr;
char *name;
gfc_packed packed;
int n;
bool known_size;
- if (sym->attr.pointer || sym->attr.allocatable
- || (sym->as && sym->as->type == AS_ASSUMED_RANK))
+ /* Use the array as and attr. */
+ as = sym->as;
+ array_attr = &sym->attr;
+
+ /* The pointer attribute is always set on a _data component, therefore check
+ the sym's attribute only. */
+ if (sym->attr.pointer || array_attr->allocatable
+ || (as && as->type == AS_ASSUMED_RANK))
return dummy;
- /* Add to list of variables if not a fake result variable. */
+ /* Add to list of variables if not a fake result variable.
+ These symbols are set on the symbol only, not on the class component. */
if (sym->attr.result || sym->attr.dummy)
gfc_defer_symbol_init (sym);
@@ -1047,7 +1059,6 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
if (GFC_DESCRIPTOR_TYPE_P (type))
{
/* Create a descriptorless array pointer. */
- as = sym->as;
packed = PACKED_NO;
/* Even when -frepack-arrays is used, symbols with TARGET attribute
@@ -1079,7 +1090,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
}
type = gfc_typenode_for_spec (&sym->ts);
- type = gfc_get_nodesc_array_type (type, sym->as, packed,
+ type = gfc_get_nodesc_array_type (type, as, packed,
!sym->attr.target);
}
else
@@ -1109,7 +1120,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
/* We should never get deferred shape arrays here. We used to because of
frontend bugs. */
- gcc_assert (sym->as->type != AS_DEFERRED);
+ gcc_assert (as->type != AS_DEFERRED);
if (packed == PACKED_PARTIAL)
GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
@@ -3973,16 +3984,25 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
}
else if (sym->attr.dimension || sym->attr.codimension)
{
- /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
- array_type tmp = sym->as->type;
- if (tmp == AS_ASSUMED_SIZE && sym->as->cp_was_assumed)
- tmp = AS_EXPLICIT;
- switch (tmp)
+ symbol_attribute *array_attr;
+ gfc_array_spec *as;
+ array_type tmp;
+
+ array_attr = &sym->attr;
+ as = sym->as;
+ /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
+ tmp = as->type;
+ if (tmp == AS_ASSUMED_SIZE && as->cp_was_assumed)
+ tmp = AS_EXPLICIT;
+ switch (tmp)
{
case AS_EXPLICIT:
if (sym->attr.dummy || sym->attr.result)
gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
- else if (sym->attr.pointer || sym->attr.allocatable)
+ /* In a class array the _data component always has the pointer
+ attribute set. Therefore only check for allocatable in the
+ array attributes and for pointer in the symbol. */
+ else if (sym->attr.pointer || array_attr->allocatable)
{
if (TREE_STATIC (sym->backend_decl))
{
@@ -3997,7 +4017,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_trans_deferred_array (sym, block);
}
}
- else if (sym->attr.codimension && TREE_STATIC (sym->backend_decl))
+ else if (sym->attr.codimension
+ && TREE_STATIC (sym->backend_decl))
{
gfc_init_block (&tmpblock);
gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
@@ -4036,7 +4057,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
case AS_ASSUMED_SIZE:
/* Must be a dummy parameter. */
- gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
+ gcc_assert (sym->attr.dummy || as->cp_was_assumed);
/* We should always pass assumed size arrays the g77 way. */
if (sym->attr.dummy)
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 53da053..bce4d24 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1288,25 +1288,32 @@ gfc_get_element_type (tree type)
int
gfc_is_nodesc_array (gfc_symbol * sym)
{
- gcc_assert (sym->attr.dimension || sym->attr.codimension);
+ symbol_attribute *array_attr;
+ gfc_array_spec *as;
+
+ array_attr = &sym->attr;
+ as = sym->as;
+
+ gcc_assert (array_attr->dimension || array_attr->codimension);
/* We only want local arrays. */
- if (sym->attr.pointer || sym->attr.allocatable)
+ if (sym->attr.pointer || array_attr->allocatable)
return 0;
/* We want a descriptor for associate-name arrays that do not have an
- explicitly known shape already. */
- if (sym->assoc && sym->as->type != AS_EXPLICIT)
+ explicitly known shape already. */
+ if (sym->assoc && as->type != AS_EXPLICIT)
return 0;
+ /* The dummy is stored in sym and not in the component. */
if (sym->attr.dummy)
- return sym->as->type != AS_ASSUMED_SHAPE
- && sym->as->type != AS_ASSUMED_RANK;
+ return as->type != AS_ASSUMED_SHAPE
+ && as->type != AS_ASSUMED_RANK;
if (sym->attr.result || sym->attr.function)
return 0;
- gcc_assert (sym->as->type == AS_EXPLICIT || sym->as->cp_was_assumed);
+ gcc_assert (as->type == AS_EXPLICIT || as->cp_was_assumed);
return 1;
}
next reply other threads:[~2015-02-26 17:18 UTC|newest]
Thread overview: 18+ messages / expand[flat|nested] mbox.gz Atom feed top
2015-02-26 17:19 Andre Vehreschild [this message]
2015-03-23 12:29 ` Mikael Morin
2015-03-23 12:44 ` Andre Vehreschild
2015-03-23 14:58 ` Mikael Morin
2015-03-23 15:49 ` Andre Vehreschild
2015-03-23 19:28 ` Mikael Morin
2015-03-24 10:13 ` Paul Richard Thomas
2015-03-24 17:06 ` [Patch, Fortran, pr60322] was: " Andre Vehreschild
2015-03-25 9:43 ` Dominique d'Humières
2015-03-25 16:57 ` Andre Vehreschild
2015-03-26 9:27 ` Dominique d'Humières
2015-03-27 12:48 ` Paul Richard Thomas
2015-04-05 9:13 ` Paul Richard Thomas
2015-04-09 12:37 ` Andre Vehreschild
2015-04-14 17:01 ` [Patch, Fortran, pr60322, addendum] " Andre Vehreschild
2015-04-16 19:13 ` Paul Richard Thomas
2015-04-23 11:34 ` [commited, Patch, " Andre Vehreschild
2015-04-27 17:43 ` Andre Vehreschild
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20150226181717.480e282c@vepi2 \
--to=vehre@gmx.de \
--cc=antony@cosmologist.info \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).