diff options
Diffstat (limited to 'gcc/fortran/trans-expr.c')
| -rw-r--r-- | gcc/fortran/trans-expr.c | 143 |
1 files changed, 143 insertions, 0 deletions
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 2ea09ce..f2ed474 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1444,6 +1444,149 @@ gfc_get_tree_for_caf_expr (gfc_expr *expr) } +/* Obtain the Coarray token - and optionally also the offset. */ + +void +gfc_get_caf_token_offset (tree *token, tree *offset, tree caf_decl, tree se_expr, + gfc_expr *expr) +{ + tree tmp; + + /* Coarray token. */ + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))) + { + gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) + == GFC_ARRAY_ALLOCATABLE + || expr->symtree->n.sym->attr.select_type_temporary); + *token = gfc_conv_descriptor_token (caf_decl); + } + else if (DECL_LANG_SPECIFIC (caf_decl) + && GFC_DECL_TOKEN (caf_decl) != NULL_TREE) + *token = GFC_DECL_TOKEN (caf_decl); + else + { + gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl)) + && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE); + *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)); + } + + if (offset == NULL) + return; + + /* Offset between the coarray base address and the address wanted. */ + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)) + && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE + || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER)) + *offset = build_int_cst (gfc_array_index_type, 0); + else if (DECL_LANG_SPECIFIC (caf_decl) + && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE) + *offset = GFC_DECL_CAF_OFFSET (caf_decl); + else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE) + *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)); + else + *offset = build_int_cst (gfc_array_index_type, 0); + + if (POINTER_TYPE_P (TREE_TYPE (se_expr)) + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr)))) + { + tmp = build_fold_indirect_ref_loc (input_location, se_expr); + tmp = gfc_conv_descriptor_data_get (tmp); + } + else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr))) + tmp = gfc_conv_descriptor_data_get (se_expr); + else + { + gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr))); + tmp = se_expr; + } + + *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + *offset, fold_convert (gfc_array_index_type, tmp)); + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))) + tmp = gfc_conv_descriptor_data_get (caf_decl); + else + { + gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl))); + tmp = caf_decl; + } + + *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + fold_convert (gfc_array_index_type, *offset), + fold_convert (gfc_array_index_type, tmp)); +} + + +/* Convert the coindex of a coarray into an image index; the result is + image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2)+1)*extent(1) + + (idx(3)-lcobound(3)+1)*extent(2) + ... */ + +tree +gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc) +{ + gfc_ref *ref; + tree lbound, ubound, extent, tmp, img_idx; + gfc_se se; + int i; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + break; + gcc_assert (ref != NULL); + + img_idx = integer_zero_node; + extent = integer_one_node; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) + for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, ref->u.ar.start[i], integer_type_node); + gfc_add_block_to_block (block, &se.pre); + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + integer_type_node, se.expr, + fold_convert(integer_type_node, lbound)); + tmp = fold_build2_loc (input_location, MULT_EXPR, integer_type_node, + extent, tmp); + img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, + img_idx, tmp); + if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1) + { + ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]); + extent = gfc_conv_array_extent_dim (lbound, ubound, NULL); + extent = fold_convert (integer_type_node, extent); + } + } + else + for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, ref->u.ar.start[i], integer_type_node); + gfc_add_block_to_block (block, &se.pre); + lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i); + lbound = fold_convert (integer_type_node, lbound); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + integer_type_node, se.expr, lbound); + tmp = fold_build2_loc (input_location, MULT_EXPR, integer_type_node, + extent, tmp); + img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, + img_idx, tmp); + if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1) + { + ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i); + ubound = fold_convert (integer_type_node, ubound); + extent = fold_build2_loc (input_location, MINUS_EXPR, + integer_type_node, ubound, lbound); + extent = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, + extent, integer_one_node); + } + } + img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, + img_idx, integer_one_node); + return img_idx; +} + + /* For each character array constructor subexpression without a ts.u.cl->length, replace it by its first element (if there aren't any elements, the length should already be set to zero). */ |