mirror of
https://github.com/gcc-mirror/gcc.git
synced 2024-11-21 13:40:47 +00:00
trans-array.c (gfc_conv_descriptor_data_get): Rename from gfc_conv_descriptor_data.
* trans-array.c (gfc_conv_descriptor_data_get): Rename from gfc_conv_descriptor_data. Cast the result to the DATAPTR type. (gfc_conv_descriptor_data_set, gfc_conv_descriptor_data_addr): New. (gfc_trans_allocate_array_storage): Use them. (gfc_array_allocate, gfc_array_deallocate): Likewise. (gfc_trans_dummy_array_bias, gfc_conv_expr_descriptor): Likewise. (gfc_trans_deferred_array): Likewise. * trans-expr.c (gfc_conv_function_call): Likewise. (gfc_trans_subcomponent_assign): Likewise. (gfc_trans_pointer_assignment): Likewise. * trans-intrinsic.c (gfc_conv_allocated): Likewise. * trans-types.c (gfc_array_descriptor_base): New. (gfc_get_element_type): Use GFC_TYPE_ARRAY_DATAPTR_TYPE. (gfc_get_array_descriptor_base): Break out from ... (gfc_get_array_type_bounds): ... here. Create type variants. * trans-array.h (gfc_conv_descriptor_data_get): Declare. (gfc_conv_descriptor_data_set, gfc_conv_descriptor_data_addr): Declare. From-SVN: r100872
This commit is contained in:
parent
9204496d65
commit
4c73896d18
@ -1,3 +1,23 @@
|
||||
2005-06-12 Richard Henderson <rth@redhat.com>
|
||||
|
||||
* trans-array.c (gfc_conv_descriptor_data_get): Rename from
|
||||
gfc_conv_descriptor_data. Cast the result to the DATAPTR type.
|
||||
(gfc_conv_descriptor_data_set, gfc_conv_descriptor_data_addr): New.
|
||||
(gfc_trans_allocate_array_storage): Use them.
|
||||
(gfc_array_allocate, gfc_array_deallocate): Likewise.
|
||||
(gfc_trans_dummy_array_bias, gfc_conv_expr_descriptor): Likewise.
|
||||
(gfc_trans_deferred_array): Likewise.
|
||||
* trans-expr.c (gfc_conv_function_call): Likewise.
|
||||
(gfc_trans_subcomponent_assign): Likewise.
|
||||
(gfc_trans_pointer_assignment): Likewise.
|
||||
* trans-intrinsic.c (gfc_conv_allocated): Likewise.
|
||||
* trans-types.c (gfc_array_descriptor_base): New.
|
||||
(gfc_get_element_type): Use GFC_TYPE_ARRAY_DATAPTR_TYPE.
|
||||
(gfc_get_array_descriptor_base): Break out from ...
|
||||
(gfc_get_array_type_bounds): ... here. Create type variants.
|
||||
* trans-array.h (gfc_conv_descriptor_data_get): Declare.
|
||||
(gfc_conv_descriptor_data_set, gfc_conv_descriptor_data_addr): Declare.
|
||||
|
||||
2005-06-11 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de>
|
||||
|
||||
* trans-expr.c (gfc_conv_variable): POINTER results don't need f2c
|
||||
@ -7,7 +27,7 @@
|
||||
(gfc_return_by_reference): Always look at sym, never at sym->result.
|
||||
|
||||
2005-06-11 Steven G. Kargl <kargls@comcast.net>
|
||||
|
||||
|
||||
PR fortran/17792
|
||||
PR fortran/21375
|
||||
* trans-array.c (gfc_array_deallocate): pstat is new argument
|
||||
@ -154,7 +174,7 @@
|
||||
dereference the temporary upon return.
|
||||
|
||||
2005-05-29 Janne Blomqvist <jblomqvi@vipunen.hut.fi>
|
||||
Steven G. Kargl <kargls@comcast.net>
|
||||
Steven G. Kargl <kargls@comcast.net>
|
||||
|
||||
fortran/PR20846
|
||||
* io.c (gfc_match_inquire): Implement constraints on UNIT and FILE usage.
|
||||
@ -171,7 +191,7 @@
|
||||
(gfc_check_integer_range): Chop extra bits in subnormal numbers.
|
||||
|
||||
2005-05-28 Jerry DeLisle <jvdelisle@verizon.net>
|
||||
Steven G. Kargl <kargls@comcast.net>
|
||||
Steven G. Kargl <kargls@comcast.net>
|
||||
|
||||
* intrinsic.texi: added documentation for BIT_SIZE, BTEST, CHAR, CEILING
|
||||
and CMPLX
|
||||
@ -443,7 +463,7 @@
|
||||
* trans-const.c (gfc_conv_mpz_to_tree): Fix comment.
|
||||
|
||||
2005-04-19 Arnaud Desitter <arnaud.desitter@ouce.ox.ac.uk>
|
||||
Steven G. Kargl <kargls@comcast.net>
|
||||
Steven G. Kargl <kargls@comcast.net>
|
||||
|
||||
* invoke.texi: Update -Waliasing description
|
||||
|
||||
|
@ -134,22 +134,60 @@ gfc_array_dataptr_type (tree desc)
|
||||
#define LBOUND_SUBFIELD 1
|
||||
#define UBOUND_SUBFIELD 2
|
||||
|
||||
/* This provides READ-ONLY access to the data field. The field itself
|
||||
doesn't have the proper type. */
|
||||
|
||||
tree
|
||||
gfc_conv_descriptor_data (tree desc)
|
||||
gfc_conv_descriptor_data_get (tree desc)
|
||||
{
|
||||
tree field;
|
||||
tree type;
|
||||
tree field, type, t;
|
||||
|
||||
type = TREE_TYPE (desc);
|
||||
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
|
||||
|
||||
field = TYPE_FIELDS (type);
|
||||
gcc_assert (DATA_FIELD == 0);
|
||||
gcc_assert (field != NULL_TREE
|
||||
&& TREE_CODE (TREE_TYPE (field)) == POINTER_TYPE
|
||||
&& TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == ARRAY_TYPE);
|
||||
|
||||
return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
|
||||
t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
|
||||
t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
|
||||
|
||||
return t;
|
||||
}
|
||||
|
||||
/* This provides WRITE access to the data field. */
|
||||
|
||||
void
|
||||
gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
|
||||
{
|
||||
tree field, type, t;
|
||||
|
||||
type = TREE_TYPE (desc);
|
||||
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
|
||||
|
||||
field = TYPE_FIELDS (type);
|
||||
gcc_assert (DATA_FIELD == 0);
|
||||
|
||||
t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
|
||||
gfc_add_modify_expr (block, t, fold_convert (TREE_TYPE (field), value));
|
||||
}
|
||||
|
||||
|
||||
/* This provides address access to the data field. This should only be
|
||||
used by array allocation, passing this on to the runtime. */
|
||||
|
||||
tree
|
||||
gfc_conv_descriptor_data_addr (tree desc)
|
||||
{
|
||||
tree field, type, t;
|
||||
|
||||
type = TREE_TYPE (desc);
|
||||
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
|
||||
|
||||
field = TYPE_FIELDS (type);
|
||||
gcc_assert (DATA_FIELD == 0);
|
||||
|
||||
t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
|
||||
return gfc_build_addr_expr (NULL, t);
|
||||
}
|
||||
|
||||
tree
|
||||
@ -407,18 +445,14 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
|
||||
tree tmp;
|
||||
tree args;
|
||||
tree desc;
|
||||
tree data;
|
||||
bool onstack;
|
||||
|
||||
desc = info->descriptor;
|
||||
data = gfc_conv_descriptor_data (desc);
|
||||
info->offset = gfc_index_zero_node;
|
||||
if (size == NULL_TREE)
|
||||
{
|
||||
/* A callee allocated array. */
|
||||
gfc_add_modify_expr (&loop->pre, data, convert (TREE_TYPE (data),
|
||||
gfc_index_zero_node));
|
||||
info->data = data;
|
||||
info->offset = gfc_index_zero_node;
|
||||
gfc_conv_descriptor_data_set (&loop->pre, desc, null_pointer_node);
|
||||
onstack = FALSE;
|
||||
}
|
||||
else
|
||||
@ -436,11 +470,8 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
|
||||
tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
|
||||
tmp);
|
||||
tmp = gfc_create_var (tmp, "A");
|
||||
tmp = gfc_build_addr_expr (TREE_TYPE (data), tmp);
|
||||
gfc_add_modify_expr (&loop->pre, data, tmp);
|
||||
info->data = data;
|
||||
info->offset = gfc_index_zero_node;
|
||||
|
||||
tmp = gfc_build_addr_expr (NULL, tmp);
|
||||
gfc_conv_descriptor_data_set (&loop->pre, desc, tmp);
|
||||
}
|
||||
else
|
||||
{
|
||||
@ -454,13 +485,11 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
|
||||
else
|
||||
gcc_unreachable ();
|
||||
tmp = gfc_build_function_call (tmp, args);
|
||||
tmp = convert (TREE_TYPE (data), tmp);
|
||||
gfc_add_modify_expr (&loop->pre, data, tmp);
|
||||
|
||||
info->data = data;
|
||||
info->offset = gfc_index_zero_node;
|
||||
tmp = gfc_evaluate_now (tmp, &loop->pre);
|
||||
gfc_conv_descriptor_data_set (&loop->pre, desc, tmp);
|
||||
}
|
||||
}
|
||||
info->data = gfc_conv_descriptor_data_get (desc);
|
||||
|
||||
/* The offset is zero because we create temporaries with a zero
|
||||
lower bound. */
|
||||
@ -470,7 +499,8 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
|
||||
if (!onstack)
|
||||
{
|
||||
/* Free the temporary. */
|
||||
tmp = convert (pvoid_type_node, info->data);
|
||||
tmp = gfc_conv_descriptor_data_get (desc);
|
||||
tmp = fold_convert (pvoid_type_node, tmp);
|
||||
tmp = gfc_chainon_list (NULL_TREE, tmp);
|
||||
tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
|
||||
gfc_add_expr_to_block (&loop->post, tmp);
|
||||
@ -1308,7 +1338,7 @@ gfc_conv_array_data (tree descriptor)
|
||||
}
|
||||
}
|
||||
else
|
||||
return gfc_conv_descriptor_data (descriptor);
|
||||
return gfc_conv_descriptor_data_get (descriptor);
|
||||
}
|
||||
|
||||
|
||||
@ -2749,9 +2779,8 @@ gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
|
||||
lower, upper, &se->pre);
|
||||
|
||||
/* Allocate memory to store the data. */
|
||||
tmp = gfc_conv_descriptor_data (se->expr);
|
||||
pointer = gfc_build_addr_expr (NULL, tmp);
|
||||
pointer = gfc_evaluate_now (pointer, &se->pre);
|
||||
tmp = gfc_conv_descriptor_data_addr (se->expr);
|
||||
pointer = gfc_evaluate_now (tmp, &se->pre);
|
||||
|
||||
if (TYPE_PRECISION (gfc_array_index_type) == 32)
|
||||
allocate = gfor_fndecl_allocate;
|
||||
@ -2766,8 +2795,6 @@ gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
|
||||
tmp = gfc_build_function_call (allocate, tmp);
|
||||
gfc_add_expr_to_block (&se->pre, tmp);
|
||||
|
||||
pointer = gfc_conv_descriptor_data (se->expr);
|
||||
|
||||
tmp = gfc_conv_descriptor_offset (se->expr);
|
||||
gfc_add_modify_expr (&se->pre, tmp, offset);
|
||||
}
|
||||
@ -2786,10 +2813,8 @@ gfc_array_deallocate (tree descriptor, tree pstat)
|
||||
|
||||
gfc_start_block (&block);
|
||||
/* Get a pointer to the data. */
|
||||
tmp = gfc_conv_descriptor_data (descriptor);
|
||||
tmp = gfc_build_addr_expr (NULL, tmp);
|
||||
var = gfc_create_var (TREE_TYPE (tmp), "ptr");
|
||||
gfc_add_modify_expr (&block, var, tmp);
|
||||
tmp = gfc_conv_descriptor_data_addr (descriptor);
|
||||
var = gfc_evaluate_now (tmp, &block);
|
||||
|
||||
/* Parameter is the address of the data component. */
|
||||
tmp = gfc_chainon_list (NULL_TREE, var);
|
||||
@ -3253,7 +3278,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
|
||||
/* This is for the case where the array data is used directly without
|
||||
calling the repack function. */
|
||||
if (no_repack || partial != NULL_TREE)
|
||||
stmt_packed = gfc_conv_descriptor_data (dumdesc);
|
||||
stmt_packed = gfc_conv_descriptor_data_get (dumdesc);
|
||||
else
|
||||
stmt_packed = NULL_TREE;
|
||||
|
||||
@ -3420,7 +3445,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
|
||||
|
||||
/* Only do the cleanup if the array was repacked. */
|
||||
tmp = gfc_build_indirect_ref (dumdesc);
|
||||
tmp = gfc_conv_descriptor_data (tmp);
|
||||
tmp = gfc_conv_descriptor_data_get (tmp);
|
||||
tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
|
||||
stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
|
||||
|
||||
@ -3843,10 +3868,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
|
||||
tmp = gfc_build_indirect_ref (tmp);
|
||||
tmp = gfc_build_array_ref (tmp, offset);
|
||||
offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
|
||||
|
||||
tmp = gfc_conv_descriptor_data (parm);
|
||||
gfc_add_modify_expr (&loop.pre, tmp,
|
||||
fold_convert (TREE_TYPE (tmp), offset));
|
||||
gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
|
||||
|
||||
if (se->direct_byref)
|
||||
{
|
||||
@ -4013,9 +4035,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
|
||||
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
|
||||
|
||||
/* NULLIFY the data pointer. */
|
||||
tmp = gfc_conv_descriptor_data (descriptor);
|
||||
gfc_add_modify_expr (&fnblock, tmp,
|
||||
convert (TREE_TYPE (tmp), integer_zero_node));
|
||||
gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
|
||||
|
||||
gfc_add_expr_to_block (&fnblock, body);
|
||||
|
||||
@ -4028,7 +4048,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
|
||||
/* Deallocate if still allocated at the end of the procedure. */
|
||||
deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
|
||||
|
||||
tmp = gfc_conv_descriptor_data (descriptor);
|
||||
tmp = gfc_conv_descriptor_data_get (descriptor);
|
||||
tmp = build2 (NE_EXPR, boolean_type_node, tmp,
|
||||
build_int_cst (TREE_TYPE (tmp), 0));
|
||||
tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
|
||||
|
@ -96,7 +96,9 @@ tree gfc_conv_array_lbound (tree, int);
|
||||
tree gfc_conv_array_ubound (tree, int);
|
||||
|
||||
/* Build expressions for accessing components of an array descriptor. */
|
||||
tree gfc_conv_descriptor_data (tree);
|
||||
tree gfc_conv_descriptor_data_get (tree);
|
||||
void gfc_conv_descriptor_data_set (stmtblock_t *, tree, tree);
|
||||
tree gfc_conv_descriptor_data_addr (tree);
|
||||
tree gfc_conv_descriptor_offset (tree);
|
||||
tree gfc_conv_descriptor_dtype (tree);
|
||||
tree gfc_conv_descriptor_stride (tree, tree);
|
||||
|
@ -1353,7 +1353,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
||||
{
|
||||
/* Check the data pointer hasn't been modified. This would
|
||||
happen in a function returning a pointer. */
|
||||
tmp = gfc_conv_descriptor_data (info->descriptor);
|
||||
tmp = gfc_conv_descriptor_data_get (info->descriptor);
|
||||
tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
|
||||
gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
|
||||
}
|
||||
@ -1714,12 +1714,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
|
||||
{
|
||||
/* Array pointer. */
|
||||
if (expr->expr_type == EXPR_NULL)
|
||||
{
|
||||
dest = gfc_conv_descriptor_data (dest);
|
||||
tmp = fold_convert (TREE_TYPE (se.expr),
|
||||
null_pointer_node);
|
||||
gfc_add_modify_expr (&block, dest, tmp);
|
||||
}
|
||||
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
|
||||
else
|
||||
{
|
||||
rss = gfc_walk_expr (expr);
|
||||
@ -2065,11 +2060,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
|
||||
gfc_conv_expr_descriptor (&lse, expr1, lss);
|
||||
/* Implement Nullify. */
|
||||
if (expr2->expr_type == EXPR_NULL)
|
||||
{
|
||||
lse.expr = gfc_conv_descriptor_data (lse.expr);
|
||||
rse.expr = fold_convert (TREE_TYPE (lse.expr), null_pointer_node);
|
||||
gfc_add_modify_expr (&block, lse.expr, rse.expr);
|
||||
}
|
||||
gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node);
|
||||
else
|
||||
{
|
||||
lse.direct_byref = 1;
|
||||
|
@ -2189,7 +2189,7 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
|
||||
arg1se.descriptor_only = 1;
|
||||
gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
|
||||
|
||||
tmp = gfc_conv_descriptor_data (arg1se.expr);
|
||||
tmp = gfc_conv_descriptor_data_get (arg1se.expr);
|
||||
tmp = build2 (NE_EXPR, boolean_type_node, tmp,
|
||||
fold_convert (TREE_TYPE (tmp), null_pointer_node));
|
||||
se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
|
||||
@ -2235,7 +2235,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
|
||||
/* A pointer to an array. */
|
||||
arg1se.descriptor_only = 1;
|
||||
gfc_conv_expr_lhs (&arg1se, arg1->expr);
|
||||
tmp2 = gfc_conv_descriptor_data (arg1se.expr);
|
||||
tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
|
||||
}
|
||||
tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
|
||||
fold_convert (TREE_TYPE (tmp2), null_pointer_node));
|
||||
|
@ -59,6 +59,7 @@ tree gfc_charlen_type_node;
|
||||
|
||||
static GTY(()) tree gfc_desc_dim_type;
|
||||
static GTY(()) tree gfc_max_array_element_size;
|
||||
static GTY(()) tree gfc_array_descriptor_base[GFC_MAX_DIMENSIONS];
|
||||
|
||||
/* Arrays for all integral and real kinds. We'll fill this in at runtime
|
||||
after the target has a chance to process command-line options. */
|
||||
@ -688,7 +689,7 @@ gfc_get_element_type (tree type)
|
||||
else
|
||||
{
|
||||
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
|
||||
element = TREE_TYPE (TYPE_FIELDS (type));
|
||||
element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
|
||||
|
||||
gcc_assert (TREE_CODE (element) == POINTER_TYPE);
|
||||
element = TREE_TYPE (element);
|
||||
@ -1095,6 +1096,61 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
|
||||
return type;
|
||||
}
|
||||
|
||||
/* Return or create the base type for an array descriptor. */
|
||||
|
||||
static tree
|
||||
gfc_get_array_descriptor_base (int dimen)
|
||||
{
|
||||
tree fat_type, fieldlist, decl, arraytype;
|
||||
char name[16 + GFC_RANK_DIGITS + 1];
|
||||
|
||||
gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
|
||||
if (gfc_array_descriptor_base[dimen - 1])
|
||||
return gfc_array_descriptor_base[dimen - 1];
|
||||
|
||||
/* Build the type node. */
|
||||
fat_type = make_node (RECORD_TYPE);
|
||||
|
||||
sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen);
|
||||
TYPE_NAME (fat_type) = get_identifier (name);
|
||||
|
||||
/* Add the data member as the first element of the descriptor. */
|
||||
decl = build_decl (FIELD_DECL, get_identifier ("data"), ptr_type_node);
|
||||
|
||||
DECL_CONTEXT (decl) = fat_type;
|
||||
fieldlist = decl;
|
||||
|
||||
/* Add the base component. */
|
||||
decl = build_decl (FIELD_DECL, get_identifier ("offset"),
|
||||
gfc_array_index_type);
|
||||
DECL_CONTEXT (decl) = fat_type;
|
||||
fieldlist = chainon (fieldlist, decl);
|
||||
|
||||
/* Add the dtype component. */
|
||||
decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
|
||||
gfc_array_index_type);
|
||||
DECL_CONTEXT (decl) = fat_type;
|
||||
fieldlist = chainon (fieldlist, decl);
|
||||
|
||||
/* Build the array type for the stride and bound components. */
|
||||
arraytype =
|
||||
build_array_type (gfc_get_desc_dim_type (),
|
||||
build_range_type (gfc_array_index_type,
|
||||
gfc_index_zero_node,
|
||||
gfc_rank_cst[dimen - 1]));
|
||||
|
||||
decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
|
||||
DECL_CONTEXT (decl) = fat_type;
|
||||
fieldlist = chainon (fieldlist, decl);
|
||||
|
||||
/* Finish off the type. */
|
||||
TYPE_FIELDS (fat_type) = fieldlist;
|
||||
|
||||
gfc_finish_type (fat_type);
|
||||
|
||||
gfc_array_descriptor_base[dimen - 1] = fat_type;
|
||||
return fat_type;
|
||||
}
|
||||
|
||||
/* Build an array (descriptor) type with given bounds. */
|
||||
|
||||
@ -1102,25 +1158,13 @@ tree
|
||||
gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
|
||||
tree * ubound, int packed)
|
||||
{
|
||||
tree fat_type, fat_pointer_type;
|
||||
tree fieldlist;
|
||||
tree arraytype;
|
||||
tree decl;
|
||||
int n;
|
||||
char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
|
||||
tree fat_type, base_type, arraytype, lower, upper, stride, tmp;
|
||||
const char *typename;
|
||||
tree lower;
|
||||
tree upper;
|
||||
tree stride;
|
||||
tree tmp;
|
||||
int n;
|
||||
|
||||
/* Build the type node. */
|
||||
fat_type = make_node (RECORD_TYPE);
|
||||
GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
|
||||
TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
|
||||
ggc_alloc_cleared (sizeof (struct lang_type));
|
||||
GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
|
||||
GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
|
||||
base_type = gfc_get_array_descriptor_base (dimen);
|
||||
fat_type = build_variant_type_copy (base_type);
|
||||
|
||||
tmp = TYPE_NAME (etype);
|
||||
if (tmp && TREE_CODE (tmp) == TYPE_DECL)
|
||||
@ -1129,20 +1173,22 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
|
||||
typename = IDENTIFIER_POINTER (tmp);
|
||||
else
|
||||
typename = "unknown";
|
||||
|
||||
sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
|
||||
GFC_MAX_SYMBOL_LEN, typename);
|
||||
TYPE_NAME (fat_type) = get_identifier (name);
|
||||
TYPE_PACKED (fat_type) = 0;
|
||||
|
||||
fat_pointer_type = build_pointer_type (fat_type);
|
||||
GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
|
||||
TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
|
||||
ggc_alloc_cleared (sizeof (struct lang_type));
|
||||
|
||||
GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
|
||||
GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
|
||||
|
||||
/* Build an array descriptor record type. */
|
||||
if (packed != 0)
|
||||
stride = gfc_index_one_node;
|
||||
else
|
||||
stride = NULL_TREE;
|
||||
|
||||
for (n = 0; n < dimen; n++)
|
||||
{
|
||||
GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
|
||||
@ -1183,6 +1229,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
|
||||
stride = NULL_TREE;
|
||||
}
|
||||
GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
|
||||
|
||||
/* TODO: known offsets for descriptors. */
|
||||
GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
|
||||
|
||||
@ -1193,42 +1240,6 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
|
||||
arraytype = build_pointer_type (arraytype);
|
||||
GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
|
||||
|
||||
/* The pointer to the array data. */
|
||||
decl = build_decl (FIELD_DECL, get_identifier ("data"), arraytype);
|
||||
|
||||
DECL_CONTEXT (decl) = fat_type;
|
||||
/* Add the data member as the first element of the descriptor. */
|
||||
fieldlist = decl;
|
||||
|
||||
/* Add the base component. */
|
||||
decl = build_decl (FIELD_DECL, get_identifier ("offset"),
|
||||
gfc_array_index_type);
|
||||
DECL_CONTEXT (decl) = fat_type;
|
||||
fieldlist = chainon (fieldlist, decl);
|
||||
|
||||
/* Add the dtype component. */
|
||||
decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
|
||||
gfc_array_index_type);
|
||||
DECL_CONTEXT (decl) = fat_type;
|
||||
fieldlist = chainon (fieldlist, decl);
|
||||
|
||||
/* Build the array type for the stride and bound components. */
|
||||
arraytype =
|
||||
build_array_type (gfc_get_desc_dim_type (),
|
||||
build_range_type (gfc_array_index_type,
|
||||
gfc_index_zero_node,
|
||||
gfc_rank_cst[dimen - 1]));
|
||||
|
||||
decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
|
||||
DECL_CONTEXT (decl) = fat_type;
|
||||
DECL_INITIAL (decl) = NULL_TREE;
|
||||
fieldlist = chainon (fieldlist, decl);
|
||||
|
||||
/* Finish off the type. */
|
||||
TYPE_FIELDS (fat_type) = fieldlist;
|
||||
|
||||
gfc_finish_type (fat_type);
|
||||
|
||||
return fat_type;
|
||||
}
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user