Hello All, This patch was rather long in the making, largely because of incompetence on my part:-( Jerry was very helpful by identifying a bug in the penultimate version and providing an analysis that led directly to a fix. Thanks!
As well as fixing PR82649, which I thought previously would require a change in PDT representation, but it fixes bug3-allocate-star-ice.f90 and bug15-allocate-len-error-condition.f90 from the attachment to comment #10 in PR82173. (i) bug15-allocate-len-error-condition.f90 is different from the other two but required work in the same part of gfc_trans_allocate: If a LEN parameter is different from an explicit value in the allocate expression, the new function trans-decl.cc(check_PDT_parameters) emits either STAT (and ERRMSG), if code->expr1 (and code->expr2) is available, or a runtime error if -fcheck is set to any value. If neither of these options are available, the processor continues quietly with the allocation. The wrong code works, in the sense that the allocation succeeds and appropriate space is allocated for parameterized arrays and strings. However it violates the standard by changing the value of an explicitly declared LEN value. QUESTION: Should the runtime error be emitted unconditionally if STAT does not appear? I am beginning to think that this should be the case. Constant parameter values could and should be compared in resolve.cc. I will work on this after the last two pending patches in the series are done and dusted. (ii) PR82649 and bug3-allocate-star-ice.f90 both involve allocating dummies with assumed LEN parameters in the type specs for both the dummy declaration and the allocate statement. LEN parameters in these cases should be determined by the values of the actual argument: Previously, the allocation resulted in an ICE. I had thought until very recently that PR82649 could only be fixed by changing the representation of PDTs; such as carrying the values of the LEN parameters in a descriptor. However, a light bulb moment occurred, when I realised that a scalar PDT with the LEN parameters set could be passed as a hidden parameter, in the same way as character lengths. Most of the patch is devoted to this. The first chunk in trans-decl.cc creates the hidden dummy for the function decl. Passing of the hidden dummy is done by the chunk in trans-expr.cc. Note that for both PDTs and class PDTs a scalar PDT is passed. In the case of class PDTs, the type is the declared type of the formal argument. The chunk in trans-types.cc sets the type of the hidden argument. The new function expr.cc (gfc_pdt_requires_hidden_arg) provides the criteria for creating and using the hidden argument. With these changes, the hidden argument is created and passed but does nothing. The new function trans-stamt.cc(check_PDT_parameters) does most of the heavy lifting by updating the parameter list used to allocate the parameterized arrays and strings, by replacing the assumed parameters with explicit ones. To handle class PDT allocations correctly, the allocate type spec type_param_spec_list is copied into a new field in gfc_code, code->ext.alloc.param_list, in match.cc(gfc_match_allocate). Note that this parameter list is deallocated at the end of gfc_trans_allocate since it is not needed and longer. Finally, trans-decl.cc(gfc_trans_deferred_vars) has been updated to ensure that optional dummy PDTs and class PDTs are handled correctly. This is tested in pdt_bug3.f90. (iii) A final wrinkle was noticed when testing the full PDT testsuite in waiting. This fixed in the chunk in resolve.cc. It has nothing to do with the main bugs but increments the ref count of rejected final routine to prevent an ICE during cleanup of the namespace. The patch passes regression testing on FC44/x86_64. OK for mainline? Paul
From f27e196b42f11edd232c98ca2d61e9e49fff22e9 Mon Sep 17 00:00:00 2001 From: Paul Thomas <[email protected]> Date: Thu, 5 Nov 2026 16:24:48 +0000 Subject: [PATCH] Fortran: [PDT] (9/16) Parameterized derived type errors [PR82173] 2026-11-05 Paul Thomas <[email protected]> gcc/fortran PR fortran/82173 * expr.cc (gfc_pdt_requires_hidden_arg): New function to determine if a dummy PDT needs an accompanying hidden argument. * gfortran.h : Add prototype for gfc_pdt_requires_hidden_arg. Add new fields 'hidden_pdt_dummy_decl' field to gfc_symbol and 'param_list' to gfc_code. * match.cc (gfc_match_allocate): Copy the type_param_spec_list from the typespec parsing and transfer it to the new field in gfc_code. * resolve.cc (gfc_resolve_finalizers): If finalizers clash void an ICE by incrementing the refs for the offending finalizer. * trans-decl.cc (create_function_arglist): A hidden scalar PDT dummy is created for PDTs that return true for the new function gfc_pdt_requires_hidden_arg. (gfc_trans_deferred_vars): Clean up handling of PDT and class PDT dummies, especially where optional. * trans-expr.cc (gfc_conv_procedure_call): Pass a hidden PDT scalar, if gfc_pdt_requires_hidden_arg is true, to pass the callee's parameter values. Handle passing optional dummies if the parameter list is not explicit. Pass NULL_TREE if the arg is not explicit or optional. * trans-stmt.cc (fixup_assumed_PDT_parameters): New function than uses the hidden PDT dummy to supply values for assumed dummy parameters. (check_PDT_parameters): New function to verify that actual and ALLOCATE LEN parameters are consistent. If 'stat' is present it is set if they are inconsistent and 'errmsg' filled as well. If 'stat' is not present but 'rtcheck' is set to any value, a runtime error is emitted. Otherwise, the compilation is allowed to proceed. (gfc_trans_allocate): Put all the error messages at the top. 'label_finish' is now referenced unconditionally and so its TREE_USED field should not be set to zero. If the allocate expr is a dummy and gfc_pdt_requires_hidden_arg return true, skip the first branch and proceed to the second. Use the allocate tyespec derived type and parameter list when there is a hidden PDT dummy and use it to fix up assumed PDT parameters in the allocate typespec. Call the new function check_PDT_parameters to ensure that the PDT LEN parameters are consistent between the allocate values and those of the the expression to be allocated. Insert a label to jump to if the fixup of assumed parameters does not work. Handle the new error stat and errmsg by deallocating the object and emitting the values as required. When done, if required, free the typespec parameter list. * trans_types.cc (gfc_get_function_type): Generate the type for hidden PDT dummies. gcc/testsuite/ PR fortran/82173 * gfortran.dg/coarray_lib_alloc_1.f90: Update the tree dump check to cope with the change in the stat name. * gfortran.dg/coarray_lib_alloc_2.f90: Likewise. * gfortran.dg/coarray_lib_alloc_3.f90: Likewise. * gfortran.dg/pdt_bug3.f90: New test. * gfortran.dg/pdt_bug15.f90: New test. --- gcc/fortran/expr.cc | 18 ++ gcc/fortran/gfortran.h | 4 + gcc/fortran/match.cc | 5 + gcc/fortran/resolve.cc | 1 + gcc/fortran/trans-decl.cc | 117 ++++++-- gcc/fortran/trans-expr.cc | 49 ++++ gcc/fortran/trans-stmt.cc | 260 +++++++++++++++++- gcc/fortran/trans-types.cc | 10 + .../gfortran.dg/coarray_lib_alloc_1.f90 | 4 +- .../gfortran.dg/coarray_lib_alloc_2.f90 | 4 +- .../gfortran.dg/coarray_lib_alloc_3.f90 | 4 +- gcc/testsuite/gfortran.dg/pdt_bug15.f90 | 41 +++ gcc/testsuite/gfortran.dg/pdt_bug3.f90 | 195 +++++++++++++ 13 files changed, 678 insertions(+), 34 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pdt_bug15.f90 create mode 100644 gcc/testsuite/gfortran.dg/pdt_bug3.f90 diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index a525bf4ce9c..a88cd9a8c1f 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -4007,6 +4007,24 @@ gfc_check_type_spec_parms (gfc_expr *expr1, gfc_expr *expr2, } +/* Used by the backend to decide when and where a hidden PDT should be + passed to a PDT dummy. */ + +bool gfc_pdt_requires_hidden_arg (gfc_symbol *arg) +{ + if (IS_PDT (arg) + && (arg->attr.allocatable || arg->attr.pointer)) + return true; + + if (IS_CLASS_PDT (arg) + && (CLASS_DATA (arg)->attr.allocatable + || CLASS_DATA (arg)->attr.pointer)) + return true; + + return false; +} + + /* Given an assignable expression and an arbitrary expression, make sure that the assignment can take place. Only add a call to the intrinsic conversion routines, when allow_convert is set. When this assign is a diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 87c20fa7699..49ba791c378 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2080,6 +2080,8 @@ typedef struct gfc_symbol /* List of PDT parameter expressions */ struct gfc_actual_arglist *param_list; struct gfc_symbol *template_sym; + /* Used for allocatable PDT dummies to carry type information. */ + tree hidden_pdt_dummy_decl; struct gfc_expr *value; /* Parameter/Initializer value */ gfc_array_spec *as; @@ -3396,6 +3398,7 @@ typedef struct gfc_code { gfc_typespec ts; gfc_alloc *list; + gfc_actual_arglist *param_list; /* Take the array specification from expr3 to allocate arrays without an explicit array specification. */ unsigned arr_spec_from_expr3:1; @@ -4151,6 +4154,7 @@ int gfc_kind_max (gfc_expr *, gfc_expr *); bool gfc_check_conformance (gfc_expr *, gfc_expr *, const char *, ...) ATTRIBUTE_PRINTF_3; bool gfc_check_type_spec_parms (gfc_expr *, gfc_expr *, const char *); +bool gfc_pdt_requires_hidden_arg (gfc_symbol *); bool gfc_check_assign (gfc_expr *, gfc_expr *, int, bool c = true); bool gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, bool suppres_type_test = false, diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 14e38b452f7..df7aa685403 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -5214,6 +5214,7 @@ gfc_match_allocate (void) gfc_alloc *head, *tail; gfc_expr *stat, *errmsg, *tmp, *source, *mold; gfc_typespec ts; + gfc_actual_arglist *ts_param_list = NULL; gfc_symbol *sym; gfc_ref *ref; match m; @@ -5281,6 +5282,9 @@ gfc_match_allocate (void) "%L cannot contain DEFERRED parameters", &old_locus); goto cleanup; } + + ts_param_list = gfc_copy_actual_arglist (type_param_spec_list); + } else { @@ -5660,6 +5664,7 @@ alloc_opt_list: new_st.expr3 = mold; new_st.ext.alloc.list = head; new_st.ext.alloc.ts = ts; + new_st.ext.alloc.param_list = ts_param_list; if (type_param_spec_list) gfc_free_actual_arglist (type_param_spec_list); diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 514263c1bc5..5a8099ad132 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -16960,6 +16960,7 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) " rank (%d) as %qs", list->proc_sym->name, &list->where, my_rank, i->proc_sym->name); + list->proc_sym->refs++; goto error; } } diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index c8261d88b21..f015e26fd2c 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -2980,6 +2980,29 @@ create_function_arglist (gfc_symbol * sym) type = gfc_sym_type (f->sym); } } + + else if (gfc_pdt_requires_hidden_arg (f->sym) && f->sym->param_list) + { + tree pdt_type, hidden_pdt_dummy_decl; + pdt_type = TREE_VALUE (hidden_typelist); + gcc_assert (POINTER_TYPE_P (pdt_type)); + + strcpy (&name[1], f->sym->name); + name[0] = '_'; + hidden_pdt_dummy_decl = build_decl (input_location, + PARM_DECL, get_identifier (name), pdt_type); + + hidden_arglist = chainon (hidden_arglist, hidden_pdt_dummy_decl); + DECL_CONTEXT (hidden_pdt_dummy_decl) = fndecl; + DECL_ARTIFICIAL (hidden_pdt_dummy_decl) = 1; + DECL_ARG_TYPE (hidden_pdt_dummy_decl) = pdt_type; + TREE_READONLY (hidden_pdt_dummy_decl) = 1; + gfc_finish_decl (hidden_pdt_dummy_decl); + f->sym->hidden_pdt_dummy_decl = hidden_pdt_dummy_decl; + + hidden_typelist = TREE_CHAIN (hidden_typelist); + } + /* For scalar intrinsic types or derived types, VALUE passes the value, hence, the optional status cannot be transferred via a NULL pointer. Thus, we will use a hidden argument in that case. */ @@ -5208,29 +5231,48 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) } else if (sym->attr.dummy) { + gfc_actual_arglist *parms = sym->param_list; bool intent_out = false; + bool all_explicit = true; + gfc_component *c = sym->ts.u.derived->components; + tree present = NULL_TREE; /* F2023 19.6.5(24) */ if (sym->attr.intent == INTENT_OUT) intent_out = true; - tmp = gfc_check_pdt_dummy (sym->ts.u.derived, - sym->backend_decl, - sym->as ? sym->as->rank : 0, - sym->param_list, intent_out); - if (sym->attr.optional) - { - present = gfc_conv_expr_present (sym, false); - tmp = build3_loc (input_location, COND_EXPR, void_type_node, - present, tmp, - build_empty_stmt (input_location)); - } - gfc_add_expr_to_block (&tmpblock, tmp); + for (; sym->attr.allocatable && c && parms; + c = c->next, parms = parms->next) + if (!c->attr.pdt_len) + continue; + else if (parms->spec_type == SPEC_ASSUMED) + all_explicit = false; + + /* Allocatable PDTs with assumed LEN parameters need special + treatment in gfc_trans_allocate. */ + if (all_explicit + && !(sym->attr.pointer + || sym->attr.allocatable)) + { + tmp = gfc_check_pdt_dummy (sym->ts.u.derived, + sym->backend_decl, + sym->as ? sym->as->rank : 0, + sym->param_list, intent_out); + if (sym->attr.optional) + { + present = gfc_conv_expr_present (sym, false); + tmp = build3_loc (input_location, COND_EXPR, + void_type_node, present, tmp, + build_empty_stmt (input_location)); + } - gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL); + gfc_add_expr_to_block (&tmpblock, tmp); + tmp = gfc_finish_block (&tmpblock); + gfc_add_init_cleanup (block, tmp, NULL); + } } } - else if (IS_CLASS_PDT (sym)) + else if (IS_CLASS_PDT (sym) && !CLASS_DATA (sym)->attr.pointer) { gfc_component *data = CLASS_DATA (sym); is_pdt_type = true; @@ -5254,12 +5296,47 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) } else if (sym->attr.dummy) { - tmp = gfc_class_data_get (sym->backend_decl); - tmp = gfc_check_pdt_dummy (data->ts.u.derived, tmp, - data->as ? data->as->rank : 0, - sym->param_list); - gfc_add_expr_to_block (&tmpblock, tmp); - gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL); + gfc_actual_arglist *parms = sym->param_list; + bool intent_out = false; + bool all_explicit = true; + gfc_component *class_data = sym->ts.u.derived->components; + gfc_symbol *declared = class_data->ts.u.derived; + gfc_component *c = declared->components; + + tree present = NULL_TREE; + /* F2023 19.6.5(24) */ + if (sym->attr.intent == INTENT_OUT) + intent_out = true; + + + for (; class_data->attr.allocatable && c && parms; + c = c->next, parms = parms->next) + if (!c->attr.pdt_len) + continue; + else if (parms->spec_type == SPEC_ASSUMED) + all_explicit = false; + + /* Allocatable PDTs with assumed LEN parameters need special + treatment in gfc_trans_allocate. */ + if (all_explicit) + { + tmp = gfc_class_data_get (sym->backend_decl); + tmp = gfc_check_pdt_dummy (declared, tmp, + class_data->as ? + class_data->as->rank : 0, + sym->param_list, intent_out); + if (sym->attr.optional) + { + present = gfc_conv_expr_present (sym, false); + tmp = build3_loc (input_location, COND_EXPR, + void_type_node, present, tmp, + build_empty_stmt (input_location)); + } + + gfc_add_expr_to_block (&tmpblock, tmp); + tmp = gfc_finish_block (&tmpblock); + gfc_add_init_cleanup (block, tmp, NULL); + } } } diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 289ae0311fa..a11c3d680a0 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -8937,7 +8937,56 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, vec_safe_push (stringargs, offset); } + else if (e && gfc_pdt_requires_hidden_arg (fsym)) + { + gfc_actual_arglist *parms; + tree hidden_pdt; + gfc_symbol *derived; + /* Build a temporary of the declared type. */ + if (IS_CLASS_PDT (e)) + { + tmp = gfc_typenode_for_spec (&CLASS_DATA (e)->ts); + hidden_pdt = gfc_create_var (tmp, "pdt"); + derived = CLASS_DATA (e)->ts.u.derived; + } + else + { + tmp = gfc_typenode_for_spec (&e->ts); + hidden_pdt = gfc_create_var (tmp, "pdt"); + derived = e->ts.u.derived; + } + + /* Obtain the PDT parameter list. */ + parms = e->param_list ? e->param_list : + e->symtree->n.sym->param_list; + + if (gfc_spec_list_type (parms, derived) == SPEC_EXPLICIT) + { + /* If all the parameters are explcit, build the hidden PDT... */ + tmp = gfc_allocate_pdt_comp (derived, hidden_pdt, + 0, parms); + gfc_add_expr_to_block (&se->pre, tmp); + tmp = gfc_build_addr_expr (NULL_TREE, hidden_pdt); + vec_safe_push (stringargs, tmp); + /* ...and deallocate it after the calls. */ + tmp = gfc_deallocate_pdt_comp (derived, + hidden_pdt, 0); + gfc_add_expr_to_block (&se->post, tmp); + } + else if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.dummy + && e->symtree->n.sym->hidden_pdt_dummy_decl != NULL_TREE) + /* Otherwise hope that this was a dummy with a hidden arg. */ + vec_safe_push (stringargs, + e->symtree->n.sym->hidden_pdt_dummy_decl); + else + { + /* Or else just add it without the parameter set here. */ + tmp = gfc_build_addr_expr (NULL_TREE, hidden_pdt); + vec_safe_push (stringargs, tmp); + } + } vec_safe_push (arglist, parmse.expr); } diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index d51b89aa73e..9ec80771a1f 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -6712,6 +6712,187 @@ allocate_get_initializer (gfc_code * code, gfc_expr * expr) return NULL; } + +static bool +fixup_assumed_PDT_parameters (stmtblock_t *block, gfc_code *code, + gfc_actual_arglist *param_list, gfc_expr *expr) +{ + gfc_actual_arglist *parm; + gfc_component *c; + gfc_symbol *derived = NULL; + tree tmp, var = NULL_TREE; + + if (expr->symtree->n.sym->attr.dummy) + { + var = expr->symtree->n.sym->hidden_pdt_dummy_decl; + if (var != NULL_TREE) + var = build_fold_indirect_ref_loc (input_location, var); + } + + derived = IS_CLASS_PDT (expr) ? CLASS_DATA (expr)->ts.u.derived : + expr->ts.u.derived; + + parm = param_list; + for (; derived && parm; parm = parm->next) + { + tree cdecl, ctype, comp; + c = gfc_find_component (derived, parm->name, false, true, NULL); + + if (!c || !c->attr.pdt_len || parm->expr != NULL + || parm->spec_type == SPEC_DEFERRED) + continue; + + if (var != NULL_TREE && c->backend_decl) + { + char *name = xasprintf ("_%s_%s", expr->symtree->n.sym->name, + c->name); + gfc_symbol *s; + cdecl = c->backend_decl; + ctype = TREE_TYPE (cdecl); + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + var, cdecl, NULL_TREE); + gcc_assert (TREE_CODE (comp) != ERROR_MARK); + tmp = gfc_create_var (ctype, "prm"); + TREE_STATIC (tmp) = 1; + DECL_CONTEXT (tmp) = current_function_decl; + gfc_add_modify (block, tmp, comp); + gfc_get_symbol (name, expr->symtree->n.sym->ns, &s, &expr->where); + s->ts.type = BT_INTEGER; + s->ts.kind = c->ts.kind; + s->attr.referenced = 1; + s->attr.temporary = 1; + s->backend_decl = tmp; + gfc_get_symbol_decl (s); + gfc_expr *p = gfc_lval_expr_from_sym (s); + parm->expr = p; + parm->spec_type = SPEC_EXPLICIT; + } + else if (c->initializer) + parm->expr = gfc_copy_expr (c->initializer); + + if (parm->expr == NULL) + { + gfc_error_now ("F2023 C939: Unable to find an expression " + "for the parameter %qs at %L", + c->name, &code->loc); + return false; + } + } + + return true; +} + + +#define PARAMETER_MISMATCH 99 + +static void +check_PDT_parameters (stmtblock_t *block, gfc_code *code, gfc_expr *expr, + gfc_se *se, int rtcheck, gfc_actual_arglist *param_list, + tree stat, tree label_errmsg) +{ + gfc_actual_arglist *parm, *sym_parm; + gfc_component *c; + tree tmp; + + if (IS_PDT (expr)) + c = expr->ts.u.derived->components; + else + c = CLASS_DATA (expr)->ts.u.derived->components; + parm = param_list; + sym_parm = expr->symtree->n.sym->param_list; + parm = parm == sym_parm && !(code->expr1 || rtcheck) ? NULL : parm; + for (; c && parm && sym_parm; + c = c->next, parm = parm->next, sym_parm = sym_parm->next) + { + tree p1, p2, cond; + gfc_se tmp_se; + stmtblock_t cblock; + + if (parm->spec_type != SPEC_EXPLICIT + || sym_parm->spec_type != SPEC_EXPLICIT + || c->attr.pdt_kind) + continue; + + gcc_assert (parm->expr && sym_parm->expr); + + /* Compare the parameter value from the allocate statement with + that given in the allocate object declaration. */ + gfc_init_se (&tmp_se, NULL); + gfc_conv_expr (&tmp_se, parm->expr); + p1 = tmp_se.expr; + gfc_conv_expr (&tmp_se, sym_parm->expr); + p2 = tmp_se.expr; + gfc_add_block_to_block (block, &tmp_se.pre); + cond = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, p1, p2); + cond = gfc_evaluate_now (cond, block); + + if (code->expr1) + { + /* Set 'stat' to PARAMETER_MISMATCH if there is a mismatch + in the parameter values. */ + tree c1, c2; + gfc_init_block (&cblock); + if (code->expr2 == NULL) + { + gfc_add_expr_to_block (&cblock, gfc_call_free (se->expr)); + gfc_add_modify (&cblock, + fold_convert (pvoid_type_node, se->expr), + build_int_cst (pvoid_type_node, 0)); + } + c1 = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, stat, + build_int_cst (TREE_TYPE (stat), + PARAMETER_MISMATCH)); + gfc_add_expr_to_block (&cblock, c1); + if (code->expr2 == NULL) + { + tmp = build1_v (GOTO_EXPR, label_errmsg); + gfc_add_expr_to_block (&cblock, tmp); + } + c1 = gfc_finish_block (&cblock); + c2 = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, stat, + build_int_cst (TREE_TYPE (stat), 0)); + tmp = build3_v (COND_EXPR, cond, c1, c2); + gfc_add_expr_to_block (block, tmp); + } + + if (code->expr1 && code->expr2) + { + /* Deallocate the allocate object asc required by F2023 + 9.7.1.2 p10 and jump to emit ERRMSG. */ + gfc_init_block (&cblock); + + gfc_add_expr_to_block (&cblock, gfc_call_free (se->expr)); + gfc_add_modify (&cblock, + fold_convert (pvoid_type_node, se->expr), + build_int_cst (pvoid_type_node, 0)); + gfc_add_modify (&cblock, + fold_convert (pvoid_type_node, se->expr), + build_int_cst (pvoid_type_node, 0)); + tmp = build1_v (GOTO_EXPR, label_errmsg); + gfc_add_expr_to_block (&cblock, tmp); + tmp = build3_v (COND_EXPR, cond, + gfc_finish_block (&cblock), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (block, tmp); + } + + if (rtcheck) + { + char *msg; + msg = xasprintf ("Parameter mismatch for '%s' in ALLOCATE " + "statement vs that in declaration of '%s'", + c->name, expr->symtree->n.sym->name); + gfc_trans_runtime_check (true, false, cond, block, + &expr->where, msg); + free (msg); + } + } +} + + /* Translate the ALLOCATE statement. */ tree @@ -6747,6 +6928,10 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) symbol_attribute caf_attr; gfc_actual_arglist *param_list; tree ts_string_length = NULL_TREE; + const char *allmsg = "Attempt to allocate an allocated object"; + const char *oommsg = "Insufficient virtual memory"; + const char *pdtmsg = "PDT parameter mismatch"; + if (!code->ext.alloc.list) return NULL_TREE; @@ -6786,7 +6971,6 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) /* GOTO destinations. */ label_errmsg = gfc_build_label_decl (NULL_TREE); label_finish = gfc_build_label_decl (NULL_TREE); - TREE_USED (label_finish) = 0; } /* When an expr3 is present evaluate it only once. The standards prevent a @@ -7666,7 +7850,9 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) } init_expr = NULL; - if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD) + if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD + && !(expr->symtree->n.sym->attr.dummy + && gfc_pdt_requires_hidden_arg (expr->symtree->n.sym))) { /* Initialization via SOURCE block (or static default initializer). Switch off automatic reallocation since we have just done the @@ -7747,6 +7933,7 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) else type_spec_dt = NULL; + /* Search for a usable parameter list. */ if (code->expr3 && code->expr3->param_list) param_list = code->expr3->param_list; else if (code->expr3 && code->expr3->mold @@ -7757,8 +7944,33 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) else param_list = expr->symtree->n.sym->param_list; + /* ALLOCATE a dummy with an assumed (*) type-param-value. F2023 C939 + makes this the ONLY legal use of * in an ALLOCATE type-spec. The + value is set in the caller, passed as hidden_pdt_dummy_decl and + substitued below in fixup_assumed_PDT_parameters. */ + if (type_spec_dt && code->ext.alloc.param_list + && expr->symtree->n.sym->attr.dummy + && expr->symtree->n.sym->hidden_pdt_dummy_decl != NULL_TREE) + { + declared = type_spec_dt; + param_list = code->ext.alloc.param_list; + } + gcc_assert (param_list); + /* If a LEN parameter is assumed, attempt to find a valid value if + the expression is a dummy, otherwise set STAT and emit ERRMSG, if + present, otherwise emit a runtime error. */ + if (!fixup_assumed_PDT_parameters (&block, code, param_list, expr)) + goto pdt_parameter_error; + + /* If a LEN parameter is different from an explicit value in 'expr', + emit either STAT and ERRMSG or a runtime error. If neither of + these is available, silently continue with the allocation. */ + check_PDT_parameters (&block, code, expr, &se, gfc_option.rtcheck, + param_list, stat, + code->expr2 ? label_errmsg : label_finish); + /* For array allocations the allocate-shape-spec expression has rank 0 even though the symbol is an array. Use the rank from the array descriptor when se.expr is a GFC descriptor so that @@ -7850,6 +8062,8 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) gfc_add_expr_to_block (&block, dealloc_pdt); } +pdt_parameter_error: + /* Nullify all pointers in derived type coarrays. This registers a token for them which allows their allocation. */ if (is_coarray) @@ -7906,9 +8120,7 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) /* ERRMSG - only useful if STAT is present. */ if (code->expr1 && code->expr2) { - const char *msg = "Attempt to allocate an allocated object"; - const char *oommsg = "Insufficient virtual memory"; - tree slen, dlen, errmsg_str, oom_str, oom_loc; + tree slen, dlen, errmsg_str, oom_str, oom_loc, pdt_str, pdt_loc; stmtblock_t errmsg_block; gfc_init_block (&errmsg_block); @@ -7916,9 +8128,9 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG"); gfc_add_modify (&errmsg_block, errmsg_str, gfc_build_addr_expr (pchar_type_node, - gfc_build_localized_cstring_const (msg))); + gfc_build_localized_cstring_const (allmsg))); - slen = build_int_cst (gfc_charlen_type_node, strlen (msg)); + slen = build_int_cst (gfc_charlen_type_node, strlen (allmsg)); dlen = gfc_get_expr_charlen (code->expr2); slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen, slen); @@ -7962,6 +8174,35 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) dlen, build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); + + /* Unlike the previous allocate errors the allocate object will have been + successfully allocated. F2023 9.7.1.2 p10 mandates that it should be + deallocated, so do this now. */ + + pdt_str = gfc_create_var (pchar_type_node, "PDTMSG"); + pdt_loc = gfc_build_localized_cstring_const (pdtmsg); + gfc_add_modify (&errmsg_block, pdt_str, + gfc_build_addr_expr (pchar_type_node, pdt_loc)); + + slen = build_int_cst (gfc_charlen_type_node, strlen (oommsg)); + dlen = gfc_get_expr_charlen (code->expr2); + slen = fold_build2_loc (input_location, MIN_EXPR, + TREE_TYPE (slen), dlen, slen); + + gfc_trans_string_copy (&errmsg_block, dlen, errmsg, + code->expr2->ts.kind, + slen, pdt_str, + gfc_default_character_kind); + dlen = gfc_finish_block (&errmsg_block); + + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + stat, build_int_cst (TREE_TYPE (stat), + PARAMETER_MISMATCH)); + + tmp = build3_v (COND_EXPR, tmp, + dlen, build_empty_stmt (input_location)); + + gfc_add_expr_to_block (&block, tmp); } /* STAT block. */ @@ -7989,14 +8230,17 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) gfc_add_expr_to_block (&post, tmp); } + /* The copy of the typespec parameter list is no longer needed. */ + if (code->ext.alloc.param_list) + gfc_free_actual_arglist (code->ext.alloc.param_list); gfc_add_block_to_block (&block, &se.post); gfc_add_block_to_block (&block, &post); if (code->expr3 && code->expr3->must_finalize) gfc_add_block_to_block (&block, &final_block); - return gfc_finish_block (&block); } +#undef PARAMETER_MISMATCH /* Translate a DEALLOCATE statement. */ diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index 3675f093253..f7e7f97d543 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -3540,6 +3540,16 @@ gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args, vec_safe_push (hidden_typelist, type); } + else if (gfc_pdt_requires_hidden_arg (arg) && arg->param_list) + { + if (arg->ts.type == BT_CLASS) + type = gfc_typenode_for_spec (&CLASS_DATA(arg)->ts); + else + type = gfc_typenode_for_spec (&arg->ts); + type = build_pointer_type (type); + vec_safe_push (hidden_typelist, type); + } + /* For scalar intrinsic types or derived types, VALUE passes the value, hence, the optional status cannot be transferred via a NULL pointer. Thus, we will use a hidden argument in that case. */ diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 index 4f90bdfbdaa..33644ddd539 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 @@ -15,7 +15,7 @@ ! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(4, 1, &xx.token, \\(void \\*\\) &xx, &stat.., &errmsg, 200\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(8, 1, &yy.token, \\(void \\*\\) &yy, &stat.., &errmsg, 200\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, 0, &stat..., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, 0, &stat..., &errmsg, 200.;" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, 0, 0B, 0B, 0.;" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, 0, 0B, 0B, 0.;" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 index 90998ee39aa..5fe4df849f1 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 @@ -17,7 +17,7 @@ ! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 1, &xx._data.token, \\(void \\*\\) &xx._data, &stat.., &errmsg, 200\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 1, &yy._data.token, \\(void \\*\\) &yy._data, &stat.., &errmsg, 200\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, &stat..., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, &stat..., &errmsg, 200.;" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, 0B, 0B, 0.;" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, 0B, 0B, 0.;" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 index 17f800ffe70..126d2f43ab9 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_3.f90 @@ -18,7 +18,7 @@ subroutine test ! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 1, &xx._data.token, \\(void \\*\\) &xx._data, &stat.., &errmsg, 200\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 1, &yy._data.token, \\(void \\*\\) &yy._data, &stat.., &errmsg, 200\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, &stat..., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, &stat..., &errmsg, 200.;" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, 0B, 0B, 0.;" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, 0B, 0B, 0.;" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pdt_bug15.f90 b/gcc/testsuite/gfortran.dg/pdt_bug15.f90 new file mode 100644 index 00000000000..ece03a17c43 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_bug15.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! { dg-options "-fcheck=all" } +! { dg-shouldfail "Parameter mismatch" } +! F2023 9.7.1.2 p10: a type-spec length parameter differing from the +! allocate-object's nondeferred parameter is an error condition, so STAT= +! must come back nonzero. gfortran returns 0 and allocates anyway. +program p + type :: t(n) + integer, len :: n = 1 + integer :: v(n) + end type + type(t(3)), allocatable :: a + integer :: st, parm = 5, i + character(len=80) :: msg + st = 0 + msg = '' +! First use a constant value for n. + allocate (t(4) :: a, stat=st) + if (st == 0) stop 1 + if (allocated (a)) stop 2 + + allocate (t(4) :: a, stat=st, errmsg=msg) + if (st == 0) stop 3 + if (allocated (a)) stop 4 + if (len (trim (msg)) == 0) stop 5 + + st = 0 + i = 4 + msg = '' + allocate (t(i) :: a, stat=st) + if (st == 0) stop 6 + if (allocated (a)) stop 7 + +! And now use a variable value for n. + allocate (t(i) :: a, stat=st, errmsg=msg) + if (st == 0) stop 8 + if (allocated (a)) stop 9 + if (len (trim (msg)) == 0) stop 10 + allocate (t(i) :: a) + if (allocated (a)) deallocate (a) +end program diff --git a/gcc/testsuite/gfortran.dg/pdt_bug3.f90 b/gcc/testsuite/gfortran.dg/pdt_bug3.f90 new file mode 100644 index 00000000000..eabe90b990f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_bug3.f90 @@ -0,0 +1,195 @@ +! { dg-do run } +! ICE: segfault on ALLOCATE with an assumed (*) type-param-value. +! F2023 C939 makes this the ONLY legal use of * in an ALLOCATE type-spec. +! This is the same as PR82649. +module bug3 + type :: t(n) + integer, len :: n = 1 + real :: v(n) + end type + + type, extends(t) :: u(m) + integer, len :: m = 1 + real :: mat (n,m) + end type +contains + + subroutine fill (a) + type(t(*)), allocatable, intent(out) :: a + integer :: i + allocate (t(*) :: a) ! Seg fault at trans-decl.cc:1697 + A%V = [(REAL (i, kind = kind(1.0)), i = 1, a%n)] + end subroutine + + subroutine optional_fill (a) + type(t(*)), allocatable, optional :: a + integer :: i + if (present (a)) then + if (allocated (a)) then + if (int (sum (a%v)) /= 10) stop 1001 + deallocate (a) + end if + allocate (t(*) :: a) + A%V = [(REAL (2 * i, kind = kind(1.0)), i = 1, a%n)] + endif + end subroutine + + subroutine cfill (a) + class(t(*)), allocatable, intent(out) :: a + integer :: i + allocate (t(*) :: a) + A%V = [(REAL (3 * i, kind = kind(1.0)), i = 1, a%n)] + end subroutine + + subroutine cmfill (a) + class(t(*)), allocatable, intent(out) :: a + integer :: i + allocate (u(*,4) :: a) + A%V = [(REAL (4 * i, kind = kind(1.0)), i = 1, a%n)] + select type (a) + type is (u(*,*)) + a%mat = 1 + end select + end subroutine + + subroutine array_fill (a) + type(t(*)), allocatable, intent(out) :: a(:) + integer :: i + allocate (t(*) :: a(2)) + A(2)%V = [(REAL (5 * i, kind = kind(1.0)), i = 1, a%n)] + end subroutine + + subroutine array_optional_fill (a) + type(t(*)), allocatable, optional :: a(:) + integer :: i + if (present (a)) then + if (allocated (a)) then + if (int (sum (a(2)%v)) /= 50) stop 1002 + deallocate (a) + end if + allocate (t(*) :: a(2)) + A(2)%V = [(REAL (6 * i, kind = kind(1.0)), i = 1, a%n)] + endif + end subroutine + + subroutine array_cfill (a) + class(t(*)), allocatable, intent(out) :: a(:) + integer :: i + allocate (t(*) :: a(4)) + a(2)%V = [(REAL (6 * i, kind = kind(1.0)), i = 1, a(1)%n)] + end subroutine + + subroutine array_cmfill (aaa) + class(t(*)), allocatable, intent(out) :: aaa(:) + integer :: i + allocate (u(*,4) :: aaa(2)) ! Seg fault at trans-decl.cc:1697 + aaa(2)%V = [(REAL (7 * i, kind = kind(1.0)), i = 1, aaa(1)%n)] + select type (aaa) + type is (u(*,*)) + aaa(2)%mat = 2 + end select + end subroutine + +end module + +! Module for pr82649 +module matrix_mod_assumed_02 + + implicit none + + type :: matrix(rk, n, m) + integer, kind :: rk + integer, len :: n, m + real(rk) :: entry(n, m) + end type matrix + integer, parameter :: rk=kind(1.d0) + integer, parameter :: mm=20, nn=15 + +contains + subroutine factory(o_matrix) + type(matrix(rk, *, *)), allocatable :: o_matrix + allocate(matrix(rk, *, *) :: o_matrix) + o_matrix%entry = 1.0 + end subroutine + + subroutine indirect_factory(o_matrix) + type(matrix(rk, *, *)), allocatable :: o_matrix + call factory(o_matrix) + o_matrix%entry = 2.0 + end subroutine +end module + +program bug3_allocate_star_ice + + use bug3 + type(t(4)), allocatable :: x + type(t(4)), allocatable :: xa(:) + class(t(4)), allocatable :: y + class(t(4)), allocatable :: ya(:) + +! First scalars + call fill(x) ! Original test + IF (size (x%v) /= 4) STOP 2 + if (int (sum (x%v)) /= 10) stop 3 + call optional_fill (x) ! With optional argument + if (int (sum (x%v)) /= 20) stop 4 + deallocate (x) + call optional_fill () ! With missing optional argument + if (allocated (x)) stop 5 + call cfill (y) ! Class version of original + if (int (sum (y%v)) /= 30) stop 6 + deallocate (y) + call cmfill (y) ! Class with type extension + select type (y) + type is (u(*,*)) + if (int (sum (y%v)) /= 40) stop 7 + if (int (sum (y%mat)) /= 16) stop 8 + end select + deallocate(y) + +! Now check arrays + call array_fill(xa) ! Array version of original test + if (xa%n /= 4) stop 9 + if (size (xa(1)%v, 1) /= 4) stop 10 + if (int (sum (xa(2)%v)) /= 50) stop 11 + call array_optional_fill (xa) ! With optional array argument + if (size (xa(1)%v, 1) /= 4) stop 12 + if (int (sum (xa(2)%v)) /= 60) stop 13 + deallocate (xa) + call array_optional_fill () ! With missing optional array argument + if (allocated (xa)) stop 14 + call array_cfill(ya) ! Class array version of original + if (ya(1)%n /= 4) stop 15 + if (size (ya(1)%v, 1) /= 4) stop 16 + if (int (sum (ya(2)%v)) /= 60) stop 17 + deallocate (ya) + call array_cmfill (ya) ! Class array with type extension + select type (ya) + type is (u(*,*)) + if (int (sum (ya(2)%v)) /= 70) print *,int (sum (ya(2)%v)) + if (int (sum (ya(2)%mat)) /= 32) print *,int (sum (ya(2)%mat)) + end select + deallocate (ya) +! Check PR82649 - both original and with type parameters transmitted +! Through an indirect call. + call pr82649 + +contains + + subroutine pr82649 + use matrix_mod_assumed_02 + implicit none + type(matrix(rk, nn, mm)), allocatable :: o_matrix + + call factory(o_matrix) + if (o_matrix%n /= nn .or. o_matrix%m /= mm) stop 101 + if (int (sum (o_matrix%entry)) /= nn * mm) stop 102 + deallocate (o_matrix) + + call indirect_factory(o_matrix) + if (o_matrix%n /= nn .or. o_matrix%m /= mm) stop 103 + if (int (sum (o_matrix%entry)) /= 2 * nn * mm) stop 104 + deallocate (o_matrix) + end subroutine + +end -- 2.56.0
