diff options
Diffstat (limited to 'gcc/fortran/trans-expr.c')
| -rw-r--r-- | gcc/fortran/trans-expr.c | 231 |
1 files changed, 165 insertions, 66 deletions
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 42f6e0c..ad26684 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -64,7 +64,7 @@ get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr) static tree conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) { - tree desc, type; + tree desc, type; type = get_scalar_to_descriptor_type (scalar, attr); desc = gfc_create_var (type, "desc"); @@ -456,9 +456,68 @@ class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e, } +/* Takes an intrinsic type expression and returns the address of a temporary + class object of the 'declared' type. */ +void +gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, + gfc_typespec class_ts) +{ + gfc_symbol *vtab; + gfc_ss *ss; + tree ctree; + tree var; + tree tmp; + + /* The intrinsic type needs to be converted to a temporary + CLASS object. */ + tmp = gfc_typenode_for_spec (&class_ts); + var = gfc_create_var (tmp, "class"); + + /* Set the vptr. */ + ctree = gfc_class_vptr_get (var); + + vtab = gfc_find_intrinsic_vtab (&e->ts); + gcc_assert (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify (&parmse->pre, ctree, + fold_convert (TREE_TYPE (ctree), tmp)); + + /* Now set the data field. */ + ctree = gfc_class_data_get (var); + if (parmse->ss && parmse->ss->info->useflags) + { + /* For an array reference in an elemental procedure call we need + to retain the ss to provide the scalarized array reference. */ + gfc_conv_expr_reference (parmse, e); + tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); + gfc_add_modify (&parmse->pre, ctree, tmp); + } + else + { + ss = gfc_walk_expr (e); + if (ss == gfc_ss_terminator) + { + parmse->ss = NULL; + gfc_conv_expr_reference (parmse, e); + tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); + gfc_add_modify (&parmse->pre, ctree, tmp); + } + else + { + parmse->ss = ss; + gfc_conv_expr_descriptor (parmse, e); + gfc_add_modify (&parmse->pre, ctree, parmse->expr); + } + } + + /* Pass the address of the class object. */ + parmse->expr = gfc_build_addr_expr (NULL_TREE, var); +} + + /* Takes a scalarized class array expression and returns the address of a temporary scalar class object of the 'declared' - type. + type. OOP-TODO: This could be improved by adding code that branched on the dynamic type being the same as the declared type. In this case the original class expression can be passed directly. @@ -567,7 +626,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, tmp = NULL_TREE; if (class_ref == NULL - && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) + && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) tmp = e->symtree->n.sym->backend_decl; else { @@ -813,6 +872,8 @@ gfc_trans_class_init_assign (gfc_code *code) gfc_conv_expr (&src, rhs); gfc_conv_expr (&memsz, sz); gfc_add_block_to_block (&block, &src.pre); + src.expr = gfc_build_addr_expr (NULL_TREE, src.expr); + tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr); } @@ -826,7 +887,7 @@ gfc_trans_class_init_assign (gfc_code *code) } gfc_add_expr_to_block (&block, tmp); - + return gfc_finish_block (&block); } @@ -867,10 +928,19 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) lhs = gfc_copy_expr (expr1); gfc_add_vptr_component (lhs); + if (UNLIMITED_POLY (expr1) + && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN) + { + rhs = gfc_get_null_expr (&expr2->where); + goto assign_vptr; + } + if (expr2->ts.type == BT_DERIVED) vtab = gfc_find_derived_vtab (expr2->ts.u.derived); else if (expr2->expr_type == EXPR_NULL) vtab = gfc_find_derived_vtab (expr1->ts.u.derived); + else + vtab = gfc_find_intrinsic_vtab (&expr2->ts); gcc_assert (vtab); rhs = gfc_get_expr (); @@ -878,13 +948,21 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st); rhs->symtree = st; rhs->ts = vtab->ts; - +assign_vptr: tmp = gfc_trans_pointer_assignment (lhs, rhs); gfc_add_expr_to_block (&block, tmp); gfc_free_expr (lhs); gfc_free_expr (rhs); } + else if (expr1->ts.type == BT_DERIVED && UNLIMITED_POLY (expr2)) + { + /* F2003:C717 only sequence and bind-C types can come here. */ + gcc_assert (expr1->ts.u.derived->attr.sequence + || expr1->ts.u.derived->attr.is_bind_c); + gfc_add_data_component (expr2); + goto assign; + } else if (CLASS_DATA (expr2)->attr.dimension) { /* Insert an additional assignment which sets the '_vptr' field. */ @@ -1110,7 +1188,7 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind) tmp = gfc_get_int_type (kind); tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location, se->expr)); - + /* Test for a NULL value. */ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present, tmp, fold_convert (TREE_TYPE (tmp), integer_one_node)); @@ -1147,9 +1225,9 @@ gfc_get_expr_charlen (gfc_expr *e) gfc_ref *r; tree length; - gcc_assert (e->expr_type == EXPR_VARIABLE + gcc_assert (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER); - + length = NULL; /* To silence compiler warning. */ if (is_subref_array (e) && e->ts.u.cl->length) @@ -1238,8 +1316,8 @@ flatten_array_ctors_without_strlen (gfc_expr* e) { case EXPR_OP: - flatten_array_ctors_without_strlen (e->value.op.op1); - flatten_array_ctors_without_strlen (e->value.op.op2); + flatten_array_ctors_without_strlen (e->value.op.op1); + flatten_array_ctors_without_strlen (e->value.op.op2); break; case EXPR_COMPCALL: @@ -1604,7 +1682,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) se_expr = gfc_get_fake_result_decl (sym, parent_flag); /* Similarly for alternate entry points. */ - else if (alternate_entry + else if (alternate_entry && (sym->ns->proc_name->backend_decl == current_function_decl || parent_flag)) { @@ -1640,7 +1718,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) /* Dereference the expression, where needed. Since characters - are entirely different from other types, they are treated + are entirely different from other types, they are treated separately. */ if (sym->ts.type == BT_CHARACTER) { @@ -1670,7 +1748,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) se->expr = build_fold_indirect_ref_loc (input_location, se->expr); - /* Dereference non-character pointer variables. + /* Dereference non-character pointer variables. These must be dummies, results, or scalars. */ if ((sym->attr.pointer || sym->attr.allocatable || gfc_is_associate_pointer (sym) @@ -1828,11 +1906,11 @@ static const unsigned char powi_table[POWI_TABLE_SIZE] = 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */ }; -/* If n is larger than lookup table's max index, we use the "window +/* If n is larger than lookup table's max index, we use the "window method". */ #define POWI_WINDOW_SIZE 3 -/* Recursive function to expand the power operator. The temporary +/* Recursive function to expand the power operator. The temporary values are put in tmpvar. The function returns tmpvar[1] ** n. */ static tree gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar) @@ -1895,7 +1973,7 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs) /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care of the asymmetric range of the integer type. */ n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m); - + type = TREE_TYPE (lhs); sgn = tree_int_cst_sgn (rhs); @@ -2006,7 +2084,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) case 4: ikind = 0; break; - + case 8: ikind = 1; break; @@ -2034,7 +2112,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) case 4: kind = 0; break; - + case 8: kind = 1; break; @@ -2050,7 +2128,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) default: gcc_unreachable (); } - + switch (expr->value.op.op1->ts.type) { case BT_INTEGER: @@ -2068,7 +2146,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) case 0: fndecl = builtin_decl_explicit (BUILT_IN_POWIF); break; - + case 1: fndecl = builtin_decl_explicit (BUILT_IN_POWI); break; @@ -2078,7 +2156,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) break; case 3: - /* Use the __builtin_powil() only if real(kind=16) is + /* Use the __builtin_powil() only if real(kind=16) is actually the C long double type. */ if (!gfc_real16_is_float128) fndecl = builtin_decl_explicit (BUILT_IN_POWIL); @@ -2089,7 +2167,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) } } - /* If we don't have a good builtin for this, go for the + /* If we don't have a good builtin for this, go for the library function. */ if (!fndecl) fndecl = gfor_fndecl_math_powi[kind][ikind].real; @@ -2497,7 +2575,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) (int)(*expr)->value.character.string[0]); if ((*expr)->ts.kind != gfc_c_int_kind) { - /* The expr needs to be compatible with a C int. If the + /* The expr needs to be compatible with a C int. If the conversion fails, then the 2 causes an ICE. */ ts.type = BT_INTEGER; ts.kind = gfc_c_int_kind; @@ -2937,8 +3015,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable) value = build_fold_indirect_ref_loc (input_location, se->expr); - - /* For character(*), use the actual argument's descriptor. */ + + /* For character(*), use the actual argument's descriptor. */ else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length) value = build_fold_indirect_ref_loc (input_location, se->expr); @@ -3347,7 +3425,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, rss = gfc_walk_expr (expr); gcc_assert (rss != gfc_ss_terminator); - + /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); gfc_add_ss_to_loop (&loop, rss); @@ -3507,7 +3585,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true); gfc_add_expr_to_block (&body, tmp); - + /* Generate the copying loops. */ gfc_trans_scalarizing_loops (&loop2, &body); @@ -3534,7 +3612,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, if (formal_ptr) { size = gfc_index_one_node; - offset = gfc_index_zero_node; + offset = gfc_index_zero_node; for (n = 0; n < dimen; n++) { tmp = gfc_conv_descriptor_ubound_get (parmse->expr, @@ -3635,7 +3713,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, && !(fsym->attr.pointer || fsym->attr.allocatable) && fsym->as->type != AS_ASSUMED_SHAPE; f = f || !sym->attr.always_explicit; - + gfc_conv_array_parameter (se, arg->expr, f, NULL, NULL, NULL); } @@ -3654,7 +3732,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type; arg->expr->ts.kind = sym->ts.u.derived->ts.kind; gfc_conv_expr_reference (se, arg->expr); - + return 1; } else if (sym->intmod_sym_id == ISOCBINDING_F_POINTER @@ -3756,14 +3834,14 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, gfc_array_index_type, stride, fold_convert (gfc_array_index_type, shapese.expr))); - /* Finish scalarization loop. */ + /* Finish scalarization loop. */ gfc_trans_scalarizing_loops (&loop, &body); gfc_add_block_to_block (&block, &loop.pre); gfc_add_block_to_block (&block, &loop.post); gfc_add_block_to_block (&block, &fptrse.post); gfc_cleanup_loop (&loop); - gfc_add_modify (&block, offset, + gfc_add_modify (&block, offset, fold_build1_loc (input_location, NEGATE_EXPR, gfc_array_index_type, offset)); gfc_conv_descriptor_offset_set (&block, desc, offset); @@ -3796,7 +3874,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, { tree eq_expr; tree not_null_expr; - + /* Given two arguments so build the arg2se from second arg. */ gfc_init_se (&arg2se, NULL); gfc_conv_expr (&arg2se, arg->next->expr); @@ -3820,7 +3898,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, return 1; } - + /* Nothing was done. */ return 0; } @@ -3994,6 +4072,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, CLASS_DATA (fsym)->attr.class_pointer || CLASS_DATA (fsym)->attr.allocatable); } + else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS) + { + /* The intrinsic type needs to be converted to a temporary + CLASS object for the unlimited polymorphic formal. */ + gfc_init_se (&parmse, se); + gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts); + } else if (se->ss && se->ss->info->useflags) { gfc_ss *ss; @@ -4051,7 +4136,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (parmse.expr), gfc_unlikely (tmp), - fold_convert (TREE_TYPE (parmse.expr), + fold_convert (TREE_TYPE (parmse.expr), null_pointer_node), parmse.expr); } @@ -4192,7 +4277,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, CLASS_DATA (fsym)->attr.class_pointer || CLASS_DATA (fsym)->attr.allocatable); - /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is + /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ if (fsym && fsym->attr.intent == INTENT_OUT && (fsym->attr.allocatable @@ -4205,7 +4290,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_init_block (&block); ptr = parmse.expr; if (e->ts.type == BT_CLASS) - ptr = gfc_class_data_get (ptr); + ptr = gfc_class_data_get (ptr); tmp = gfc_deallocate_with_status (ptr, NULL_TREE, NULL_TREE, NULL_TREE, @@ -4327,7 +4412,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* If the argument is a function call that may not create a temporary for the result, we have to check that we - can do it, i.e. that there is no alias between this + can do it, i.e. that there is no alias between this argument and another one. */ if (gfc_get_noncopying_intrinsic_argument (e) != NULL) { @@ -4387,7 +4472,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else gfc_conv_array_parameter (&parmse, e, f, fsym, sym->name, NULL); - /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is + /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ if (fsym && fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT) @@ -4404,7 +4489,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->pre, tmp); } - } + } } /* The case with fsym->attr.optional is that of a user subroutine @@ -4430,7 +4515,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && ((e->rank != 0 && sym->attr.elemental) || e->representation.length || e->ts.type == BT_CHARACTER || (e->rank != 0 - && (fsym == NULL + && (fsym == NULL || (fsym-> as && (fsym->as->type == AS_ASSUMED_SHAPE || fsym->as->type == AS_ASSUMED_RANK @@ -4600,7 +4685,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, fold_convert (TREE_TYPE (tmp), null_pointer_node)); } - + gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where, msg); free (msg); @@ -4618,8 +4703,21 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } /* Character strings are passed as two parameters, a length and a - pointer - except for Bind(c) which only passes the pointer. */ - if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c) + pointer - except for Bind(c) which only passes the pointer. + An unlimited polymorphic formal argument likewise does not + need the length. */ + if (parmse.string_length != NULL_TREE + && !sym->attr.is_bind_c + && !(fsym && UNLIMITED_POLY (fsym))) + vec_safe_push (stringargs, parmse.string_length); + + /* When calling __copy for character expressions to unlimited + polymorphic entities, the dst argument needs a string length. */ + if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER + && strncmp (sym->name, "__vtab_CHARACTER", 16) == 0 + && arg->next && arg->next->expr + && arg->next->expr->ts.type == BT_DERIVED + && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic) vec_safe_push (stringargs, parmse.string_length); /* For descriptorless coarrays and assumed-shape coarray dummies, we @@ -4656,7 +4754,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE); tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type); } - + vec_safe_push (stringargs, tmp); if (GFC_DESCRIPTOR_TYPE_P (caf_type) @@ -4752,7 +4850,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_expr (&parmse, ts.u.cl->length); gfc_add_block_to_block (&se->pre, &parmse.pre); gfc_add_block_to_block (&se->post, &parmse.post); - + tmp = fold_convert (gfc_charlen_type_node, parmse.expr); tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, tmp, @@ -5490,7 +5588,7 @@ gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr) /* Build a static initializer. EXPR is the expression for the initial value. - The other parameters describe the variable of the component being + The other parameters describe the variable of the component being initialized. EXPR may be null. */ tree @@ -5521,7 +5619,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR); return se.expr; } - + if (array && !procptr) { tree ctor; @@ -5557,7 +5655,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, case BT_CLASS: gfc_init_se (&se, NULL); if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL) - gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1); + gfc_conv_structure (&se, gfc_class_null_initializer(ts, expr), 1); else gfc_conv_structure (&se, expr, 1); gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR); @@ -5579,7 +5677,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, } } } - + static tree gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) { @@ -5626,7 +5724,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) cm->as->lower[n]->value.integer); mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1); } - + /* Associate the SS with the loop. */ gfc_add_ss_to_loop (&loop, lss); gfc_add_ss_to_loop (&loop, rss); @@ -5691,7 +5789,7 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, gfc_start_block (&block); gfc_init_se (&se, NULL); - /* Get the descriptor for the expressions. */ + /* Get the descriptor for the expressions. */ se.want_pointer = 0; gfc_conv_expr_descriptor (&se, expr); gfc_add_block_to_block (&block, &se.pre); @@ -5867,7 +5965,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) { /* NULL initialization for CLASS components. */ tmp = gfc_trans_structure_assign (dest, - gfc_class_null_initializer (&cm->ts)); + gfc_class_null_initializer (&cm->ts, expr)); gfc_add_expr_to_block (&block, tmp); } else if (cm->attr.dimension && !cm->attr.proc_pointer) @@ -5948,7 +6046,7 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr) fold_convert (TREE_TYPE (lse.expr), se.expr)); return gfc_finish_block (&block); - } + } for (c = gfc_constructor_first (expr->value.constructor); c; c = gfc_constructor_next (c), cm = cm->next) @@ -6004,13 +6102,9 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE)) continue; - if (strcmp (cm->name, "_size") == 0) - { - val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived)); - CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); - } - else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL - && strcmp (cm->name, "_extends") == 0) + if (cm->initializer && cm->initializer->expr_type != EXPR_NULL + && strcmp (cm->name, "_extends") == 0 + && cm->initializer->symtree) { tree vtab; gfc_symbol *vtabs; @@ -6018,6 +6112,11 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs)); CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab); } + else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0) + { + val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived)); + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); + } else { val = gfc_conv_initializer (c->expr, &cm->ts, @@ -6030,7 +6129,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) } } se->expr = build_constructor (type, v); - if (init) + if (init) TREE_CONSTANT (se->expr) = 1; } @@ -6309,7 +6408,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) scalar = ss == gfc_ss_terminator; if (!scalar) gfc_free_ss_chain (ss); - + if (scalar) { /* Scalar pointers. */ @@ -6794,7 +6893,7 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2) /* Functions returning pointers or allocatables need temporaries. */ c = expr2->value.function.esym - ? (expr2->value.function.esym->attr.pointer + ? (expr2->value.function.esym->attr.pointer || expr2->value.function.esym->attr.allocatable) : (expr2->symtree->n.sym->attr.pointer || expr2->symtree->n.sym->attr.allocatable); @@ -7085,7 +7184,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) correctly take care of the reallocation internally. For intrinsic calls, the array data is freed and the library takes care of allocation. TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment - to the library. */ + to the library. */ if (gfc_option.flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1) && !gfc_expr_attr (expr1).codimension @@ -7417,7 +7516,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, gfc_init_se (&lse, NULL); lse.want_pointer = 1; gfc_conv_expr (&lse, expr1); - + jump_label1 = gfc_build_label_decl (NULL_TREE); jump_label2 = gfc_build_label_decl (NULL_TREE); |