diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 10 | ||||
| -rw-r--r-- | gcc/fortran/decl.cc | 36 | ||||
| -rw-r--r-- | gcc/fortran/primary.cc | 17 | ||||
| -rw-r--r-- | gcc/fortran/resolve.cc | 7 | ||||
| -rw-r--r-- | gcc/fortran/simplify.cc | 16 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.cc | 24 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.cc | 22 |
7 files changed, 102 insertions, 30 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7ca0cb0..bf5bcd63 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2025-10-25 Harald Anlauf <anlauf@gmx.de> + + PR fortran/114023 + * trans-expr.cc (gfc_trans_pointer_assignment): Always set dtype + when remapping a pointer. For unlimited polymorphic LHS use + elem_len from RHS. + * trans-intrinsic.cc (gfc_conv_is_contiguous_expr): Extend inline + generated code for IS_CONTIGUOUS for pointer arguments to detect + when span differs from the element size. + 2025-10-24 Harald Anlauf <anlauf@gmx.de> PR fortran/122386 diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 5da3c26..569786a 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -3101,7 +3101,16 @@ variable_decl (int elem) goto cleanup; } - m = gfc_match_init_expr (&initializer); + if (gfc_comp_struct (gfc_current_state ()) + && gfc_current_block ()->attr.pdt_template) + { + m = gfc_match_expr (&initializer); + if (initializer && initializer->ts.type == BT_UNKNOWN) + initializer->ts = current_ts; + } + else + m = gfc_match_init_expr (&initializer); + if (m == MATCH_NO) { gfc_error ("Expected an initialization expression at %C"); @@ -3179,7 +3188,7 @@ variable_decl (int elem) gfc_error ("BOZ literal constant at %L cannot appear as an " "initializer", &initializer->where); m = MATCH_ERROR; - goto cleanup; + goto cleanup; } param->value = gfc_copy_expr (initializer); } @@ -4035,8 +4044,8 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, gfc_insert_parameter_exprs (kind_expr, type_param_spec_list); ok = gfc_simplify_expr (kind_expr, 1); - /* Variable expressions seem to default to BT_PROCEDURE. - TODO find out why this is and fix it. */ + /* Variable expressions default to BT_PROCEDURE in the absence of an + initializer so allow for this. */ if (kind_expr->ts.type != BT_INTEGER && kind_expr->ts.type != BT_PROCEDURE) { @@ -4271,6 +4280,9 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, if (!c2->initializer && c1->initializer) c2->initializer = gfc_copy_expr (c1->initializer); + + if (c2->initializer) + gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list); } /* Copy the array spec. */ @@ -4374,7 +4386,21 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, } else if (!(c2->attr.pdt_kind || c2->attr.pdt_len || c2->attr.pdt_string || c2->attr.pdt_array) && c1->initializer) - c2->initializer = gfc_copy_expr (c1->initializer); + { + c2->initializer = gfc_copy_expr (c1->initializer); + if (c2->initializer->ts.type == BT_UNKNOWN) + c2->initializer->ts = c2->ts; + gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list); + /* The template initializers are parsed using gfc_match_expr rather + than gfc_match_init_expr. Apply the missing reduction to the + PDT instance initializers. */ + if (!gfc_reduce_init_expr (c2->initializer)) + { + gfc_free_expr (c2->initializer); + goto error_return; + } + gfc_simplify_expr (c2->initializer, 1); + } } if (alloc_seen) diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index cba4208..2d2c664 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -2071,6 +2071,23 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt) } } + /* PDT kind expressions are acceptable as initialization expressions. + However, intrinsics with a KIND argument reject them. Convert the + expression now by use of the component initializer. */ + if (tail->expr + && tail->expr->expr_type == EXPR_VARIABLE + && gfc_expr_attr (tail->expr).pdt_kind) + { + gfc_ref *ref; + gfc_expr *tmp = NULL; + for (ref = tail->expr->ref; ref; ref = ref->next) + if (!ref->next && ref->type == REF_COMPONENT + && ref->u.c.component->attr.pdt_kind + && ref->u.c.component->initializer) + tmp = gfc_copy_expr (ref->u.c.component->initializer); + if (tmp) + gfc_replace_expr (tail->expr, tmp); + } next: if (gfc_match_char (')') == MATCH_YES) diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 1c49ccf..0d54448 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -16077,10 +16077,13 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, /* Preempt 'gfc_check_new_interface' for submodules, where the mechanism for handling module procedures winds up resolving - operator interfaces twice and would otherwise cause an error. */ + operator interfaces twice and would otherwise cause an error. + Likewise, new instances of PDTs can cause the operator inter- + faces to be resolved multiple times. */ for (intr = derived->ns->op[op]; intr; intr = intr->next) if (intr->sym == target_proc - && target_proc->attr.used_in_submodule) + && (target_proc->attr.used_in_submodule + || derived->attr.pdt_type)) return true; if (!gfc_check_new_interface (derived->ns->op[op], diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc index 00b02f3..b25cd2c 100644 --- a/gcc/fortran/simplify.cc +++ b/gcc/fortran/simplify.cc @@ -120,26 +120,10 @@ static int get_kind (bt type, gfc_expr *k, const char *name, int default_kind) { int kind; - gfc_expr *tmp; if (k == NULL) return default_kind; - if (k->expr_type == EXPR_VARIABLE - && k->symtree->n.sym->ts.type == BT_DERIVED - && k->symtree->n.sym->ts.u.derived->attr.pdt_type) - { - gfc_ref *ref; - for (ref = k->ref; ref; ref = ref->next) - if (!ref->next && ref->type == REF_COMPONENT - && ref->u.c.component->attr.pdt_kind - && ref->u.c.component->initializer) - { - tmp = gfc_copy_expr (ref->u.c.component->initializer); - gfc_replace_expr (k, tmp); - } - } - if (k->expr_type != EXPR_CONSTANT) { gfc_error ("KIND parameter of %s at %L must be an initialization " diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 21f256b..67b60c7 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -11344,21 +11344,33 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) int dim; gcc_assert (remap->u.ar.dimen == expr1->rank); + /* Always set dtype. */ + tree dtype = gfc_conv_descriptor_dtype (desc); + tmp = gfc_get_dtype (TREE_TYPE (desc)); + gfc_add_modify (&block, dtype, tmp); + + /* For unlimited polymorphic LHS use elem_len from RHS. */ + if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS) + { + tree elem_len; + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts)); + elem_len = fold_convert (gfc_array_index_type, tmp); + elem_len = gfc_evaluate_now (elem_len, &block); + tmp = gfc_conv_descriptor_elem_len (desc); + gfc_add_modify (&block, tmp, + fold_convert (TREE_TYPE (tmp), elem_len)); + } + if (rank_remap) { /* Do rank remapping. We already have the RHS's descriptor converted in rse and now have to build the correct LHS descriptor for it. */ - tree dtype, data, span; + tree data, span; tree offs, stride; tree lbound, ubound; - /* Set dtype. */ - dtype = gfc_conv_descriptor_dtype (desc); - tmp = gfc_get_dtype (TREE_TYPE (desc)); - gfc_add_modify (&block, dtype, tmp); - /* Copy data pointer. */ data = gfc_conv_descriptor_data_get (rse.expr); gfc_conv_descriptor_data_set (&block, desc, data); diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 05017d0..89a03d8 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -2316,10 +2316,14 @@ gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg) int i; tree fncall0; gfc_array_spec *as; + gfc_symbol *sym = NULL; if (arg->ts.type == BT_CLASS) gfc_add_class_array_ref (arg); + if (arg->expr_type == EXPR_VARIABLE) + sym = arg->symtree->n.sym; + ss = gfc_walk_expr (arg); gcc_assert (ss != gfc_ss_terminator); gfc_init_se (&argse, NULL); @@ -2342,7 +2346,7 @@ gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg) fncall0 = build_call_expr_loc (input_location, gfor_fndecl_is_contiguous0, 1, desc); se->expr = fncall0; - se->expr = convert (logical_type_node, se->expr); + se->expr = convert (boolean_type_node, se->expr); } else { @@ -2374,6 +2378,22 @@ gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg) } se->expr = cond; } + + /* A pointer that does not have the CONTIGUOUS attribute needs to be checked + if it points to an array whose span differs from the element size. */ + if (as && sym && IS_POINTER(sym) && !sym->attr.contiguous) + { + tree span = gfc_conv_descriptor_span_get (desc); + tmp = fold_convert (TREE_TYPE (span), + gfc_conv_descriptor_elem_len (desc)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + span, tmp); + se->expr = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond, + convert (boolean_type_node, se->expr)); + } + + gfc_free_ss_chain (ss); } |