diff options
Diffstat (limited to 'gcc/fortran/trans-array.c')
| -rw-r--r-- | gcc/fortran/trans-array.c | 119 |
1 files changed, 100 insertions, 19 deletions
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 5ea9aec..e9174ae 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4998,7 +4998,8 @@ static tree gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, stmtblock_t * descriptor_block, tree * overflow, - tree expr3_elem_size, tree *nelems, gfc_expr *expr3) + tree expr3_elem_size, tree *nelems, gfc_expr *expr3, + tree expr3_desc, bool e3_is_array_constr) { tree type; tree tmp; @@ -5041,7 +5042,18 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, /* Set lower bound. */ gfc_init_se (&se, NULL); - if (lower == NULL) + if (expr3_desc != NULL_TREE) + { + if (e3_is_array_constr) + /* The lbound of a constant array [] starts at zero, but when + allocating it, the standard expects the array to start at + one. */ + se.expr = gfc_index_one_node; + else + se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, + gfc_rank_cst[n]); + } + else if (lower == NULL) se.expr = gfc_index_one_node; else { @@ -5069,10 +5081,35 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, /* Set upper bound. */ gfc_init_se (&se, NULL); - gcc_assert (ubound); - gfc_conv_expr_type (&se, ubound, gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - + if (expr3_desc != NULL_TREE) + { + if (e3_is_array_constr) + { + /* The lbound of a constant array [] starts at zero, but when + allocating it, the standard expects the array to start at + one. Therefore fix the upper bound to be + (desc.ubound - desc.lbound)+ 1. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_conv_descriptor_ubound_get ( + expr3_desc, gfc_rank_cst[n]), + gfc_conv_descriptor_lbound_get ( + expr3_desc, gfc_rank_cst[n])); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, + gfc_index_one_node); + se.expr = gfc_evaluate_now (tmp, pblock); + } + else + se.expr = gfc_conv_descriptor_ubound_get (expr3_desc, + gfc_rank_cst[n]); + } + else + { + gcc_assert (ubound); + gfc_conv_expr_type (&se, ubound, gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + } gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, gfc_rank_cst[n], se.expr); conv_ubound = se.expr; @@ -5242,6 +5279,33 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, } +/* Retrieve the last ref from the chain. This routine is specific to + gfc_array_allocate ()'s needs. */ + +bool +retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in) +{ + gfc_ref *ref, *prev_ref; + + ref = *ref_in; + /* Prevent warnings for uninitialized variables. */ + prev_ref = *prev_ref_in; + while (ref && ref->next != NULL) + { + gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT + || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0)); + prev_ref = ref; + ref = ref->next; + } + + if (ref == NULL || ref->type != REF_ARRAY) + return false; + + *ref_in = ref; + *prev_ref_in = prev_ref; + return true; +} + /* Initializes the descriptor and generates a call to _gfor_allocate. Does the work for an ALLOCATE statement. */ /*GCC ARRAYS*/ @@ -5249,7 +5313,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, bool gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, tree errlen, tree label_finish, tree expr3_elem_size, - tree *nelems, gfc_expr *expr3) + tree *nelems, gfc_expr *expr3, tree e3_arr_desc, + bool e3_is_array_constr) { tree tmp; tree pointer; @@ -5267,21 +5332,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, gfc_expr **lower; gfc_expr **upper; gfc_ref *ref, *prev_ref = NULL; - bool allocatable, coarray, dimension; + bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false; ref = expr->ref; /* Find the last reference in the chain. */ - while (ref && ref->next != NULL) + if (!retrieve_last_ref (&ref, &prev_ref)) + return false; + + if (ref->u.ar.type == AR_FULL && expr3 != NULL) { - gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT - || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0)); - prev_ref = ref; - ref = ref->next; - } + /* F08:C633: Array shape from expr3. */ + ref = expr3->ref; - if (ref == NULL || ref->type != REF_ARRAY) - return false; + /* Find the last reference in the chain. */ + if (!retrieve_last_ref (&ref, &prev_ref)) + return false; + alloc_w_e3_arr_spec = true; + } if (!prev_ref) { @@ -5317,7 +5385,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, break; case AR_FULL: - gcc_assert (ref->u.ar.as->type == AS_EXPLICIT); + gcc_assert (ref->u.ar.as->type == AS_EXPLICIT + || alloc_w_e3_arr_spec); lower = ref->u.ar.as->lower; upper = ref->u.ar.as->upper; @@ -5331,10 +5400,12 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, overflow = integer_zero_node; gfc_init_block (&set_descriptor_block); - size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, + size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank + : ref->u.ar.as->rank, ref->u.ar.as->corank, &offset, lower, upper, &se->pre, &set_descriptor_block, &overflow, - expr3_elem_size, nelems, expr3); + expr3_elem_size, nelems, expr3, e3_arr_desc, + e3_is_array_constr); if (dimension) { @@ -7073,6 +7144,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) desc = parm; } + /* For class arrays add the class tree into the saved descriptor to + enable getting of _vptr and the like. */ + if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc) + && IS_CLASS_ARRAY (expr->symtree->n.sym) + && DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl)) + { + gfc_allocate_lang_decl (desc); + GFC_DECL_SAVED_DESCRIPTOR (desc) = + GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl); + } if (!se->direct_byref || se->byref_noassign) { /* Get a pointer to the new descriptor. */ |