diff options
Diffstat (limited to 'gcc/fortran/trans-decl.c')
| -rw-r--r-- | gcc/fortran/trans-decl.c | 80 |
1 files changed, 79 insertions, 1 deletions
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 74d8606..30477c2 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1483,6 +1483,21 @@ gfc_get_symbol_decl (gfc_symbol * sym) } } + /* PDT parameterized array components and string_lengths must have the + 'len' parameters substituted for the expressions appearing in the + declaration of the entity and memory allocated/deallocated. */ + if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) + && sym->param_list != NULL + && !(sym->attr.host_assoc || sym->attr.use_assoc || sym->attr.dummy)) + gfc_defer_symbol_init (sym); + + /* Dummy PDT 'len' parameters should be checked when they are explicit. */ + if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) + && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + && sym->param_list != NULL + && sym->attr.dummy) + gfc_defer_symbol_init (sym); + /* All deferred character length procedures need to retain the backend decl, which is a pointer to the character length in the caller's namespace and to declare a local character length. */ @@ -4159,6 +4174,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_formal_arglist *f; stmtblock_t tmpblock; bool seen_trans_deferred_array = false; + bool is_pdt_type = false; tree tmp = NULL; gfc_expr *e; gfc_se se; @@ -4269,6 +4285,68 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) if (sym->assoc) continue; + if (sym->ts.type == BT_DERIVED + && sym->ts.u.derived + && sym->ts.u.derived->attr.pdt_type) + { + is_pdt_type = true; + gfc_init_block (&tmpblock); + if (!(sym->attr.dummy + || sym->attr.pointer + || sym->attr.allocatable)) + { + tmp = gfc_allocate_pdt_comp (sym->ts.u.derived, + sym->backend_decl, + sym->as ? sym->as->rank : 0, + sym->param_list); + gfc_add_expr_to_block (&tmpblock, tmp); + tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, + sym->backend_decl, + sym->as ? sym->as->rank : 0); + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp); + } + else if (sym->attr.dummy) + { + tmp = gfc_check_pdt_dummy (sym->ts.u.derived, + sym->backend_decl, + sym->as ? sym->as->rank : 0, + sym->param_list); + gfc_add_expr_to_block (&tmpblock, tmp); + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL); + } + } + else if (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->ts.u.derived + && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type) + { + gfc_component *data = CLASS_DATA (sym); + is_pdt_type = true; + gfc_init_block (&tmpblock); + if (!(sym->attr.dummy + || CLASS_DATA (sym)->attr.pointer + || CLASS_DATA (sym)->attr.allocatable)) + { + tmp = gfc_class_data_get (sym->backend_decl); + tmp = gfc_allocate_pdt_comp (data->ts.u.derived, tmp, + data->as ? data->as->rank : 0, + sym->param_list); + gfc_add_expr_to_block (&tmpblock, tmp); + tmp = gfc_class_data_get (sym->backend_decl); + tmp = gfc_deallocate_pdt_comp (data->ts.u.derived, tmp, + data->as ? data->as->rank : 0); + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp); + } + 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); + } + } + if (sym->attr.subref_array_pointer && GFC_DECL_SPAN (sym->backend_decl) && !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl))) @@ -4601,7 +4679,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE); } - else if (!(UNLIMITED_POLY(sym))) + else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type) gcc_unreachable (); } |