diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5082c0a8d722..7800cf20730c 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,21 @@ +2009-10-13 Janus Weil + + PR fortran/41581 + * decl.c (encapsulate_class_symbol): Add new component '$size'. + * resolve.c (resolve_allocate_expr): Move CLASS handling to + gfc_trans_allocate. + (resolve_class_assign): Replaced by gfc_trans_class_assign. + (resolve_code): Remove calls to resolve_class_assign. + * trans.c (gfc_trans_code): Use new function gfc_trans_class_assign. + * trans-expr.c (get_proc_ptr_comp): Fix a memory leak. + (gfc_conv_procedure_call): For CLASS dummies, set the + $size component. + (gfc_trans_class_assign): New function, replacing resolve_class_assign. + * trans-stmt.h (gfc_trans_class_assign): New prototype. + * trans-stmt.c (gfc_trans_allocate): Use correct size when allocating + CLASS variables. Do proper initialization. Move some code here from + resolve_allocate_expr. + 2009-10-11 Jerry DeLisle PR fortran/38439 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 69449a32ce98..2627e60271ac 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1028,7 +1028,8 @@ verify_c_interop_param (gfc_symbol *sym) /* Build a polymorphic CLASS entity, using the symbol that comes from build_sym. A CLASS entity is represented by an encapsulating type, which contains the declared type as '$data' component, plus an integer component '$vindex' - which determines the dynamic type. */ + which determines the dynamic type, and another integer '$size', which + contains the size of the dynamic type structure. */ static gfc_try encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr, @@ -1089,6 +1090,14 @@ encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->ts.kind = 4; c->attr.access = ACCESS_PRIVATE; c->initializer = gfc_int_expr (0); + + /* Add component '$size'. */ + if (gfc_add_component (fclass, "$size", &c) == FAILURE) + return FAILURE; + c->ts.type = BT_INTEGER; + c->ts.kind = 4; + c->attr.access = ACCESS_PRIVATE; + c->initializer = gfc_int_expr (0); } fclass->attr.extension = 1; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 5ea41c9bdf8f..9444fd10205d 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5844,7 +5844,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) symbol_attribute attr; gfc_ref *ref, *ref2; gfc_array_ref *ar; - gfc_code *init_st; gfc_symbol *sym; gfc_alloc *a; gfc_component *c; @@ -5948,41 +5947,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) return FAILURE; } - if (e->ts.type == BT_CLASS) - { - /* Initialize VINDEX for CLASS objects. */ - init_st = gfc_get_code (); - init_st->loc = code->loc; - init_st->expr1 = gfc_expr_to_initialize (e); - init_st->op = EXEC_ASSIGN; - gfc_add_component_ref (init_st->expr1, "$vindex"); - if (code->expr3 && code->expr3->ts.type == BT_CLASS) - { - /* vindex must be determined at run time. */ - init_st->expr2 = gfc_copy_expr (code->expr3); - gfc_add_component_ref (init_st->expr2, "$vindex"); - } - else - { - /* vindex is fixed at compile time. */ - int vindex; - if (code->expr3) - vindex = code->expr3->ts.u.derived->vindex; - else if (code->ext.alloc.ts.type == BT_DERIVED) - vindex = code->ext.alloc.ts.u.derived->vindex; - else if (e->ts.type == BT_CLASS) - vindex = e->ts.u.derived->components->ts.u.derived->vindex; - else - vindex = e->ts.u.derived->vindex; - init_st->expr2 = gfc_int_expr (vindex); - } - init_st->expr2->where = init_st->expr1->where = init_st->loc; - init_st->next = code->next; - code->next = init_st; - /* Only allocate the DATA component. */ - gfc_add_component_ref (e, "$data"); - } - if (pointer || dimension == 0) return SUCCESS; @@ -7567,44 +7531,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) } -/* Check an assignment to a CLASS object (pointer or ordinary assignment). */ - -static void -resolve_class_assign (gfc_code *code) -{ - gfc_code *assign_code = gfc_get_code (); - - if (code->expr2->ts.type != BT_CLASS) - { - /* Insert an additional assignment which sets the vindex. */ - assign_code->next = code->next; - code->next = assign_code; - assign_code->op = EXEC_ASSIGN; - assign_code->expr1 = gfc_copy_expr (code->expr1); - gfc_add_component_ref (assign_code->expr1, "$vindex"); - if (code->expr2->ts.type == BT_DERIVED) - /* vindex is constant, determined at compile time. */ - assign_code->expr2 = gfc_int_expr (code->expr2->ts.u.derived->vindex); - else if (code->expr2->ts.type == BT_CLASS) - { - /* vindex must be determined at run time. */ - assign_code->expr2 = gfc_copy_expr (code->expr2); - gfc_add_component_ref (assign_code->expr2, "$vindex"); - } - else if (code->expr2->expr_type == EXPR_NULL) - assign_code->expr2 = gfc_int_expr (0); - else - gcc_unreachable (); - } - - /* Modify the actual pointer assignment. */ - if (code->expr2->ts.type == BT_CLASS) - code->op = EXEC_ASSIGN; - else - gfc_add_component_ref (code->expr1, "$data"); -} - - /* Given a block of code, recursively resolve everything pointed to by this code block. */ @@ -7734,10 +7660,6 @@ resolve_code (gfc_code *code, gfc_namespace *ns) else goto call; } - - if (code->expr1->ts.type == BT_CLASS) - resolve_class_assign (code); - break; case EXEC_LABEL_ASSIGN: @@ -7759,10 +7681,6 @@ resolve_code (gfc_code *code, gfc_namespace *ns) break; gfc_check_pointer_assign (code->expr1, code->expr2); - - if (code->expr1->ts.type == BT_CLASS) - resolve_class_assign (code); - break; case EXEC_ARITHMETIC_IF: diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 77953c8e15f7..65f13ad8a8da 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1519,6 +1519,7 @@ get_proc_ptr_comp (gfc_expr *e) e2 = gfc_copy_expr (e); e2->expr_type = EXPR_VARIABLE; gfc_conv_expr (&comp_se, e2); + gfc_free_expr (e2); return build_fold_addr_expr_loc (input_location, comp_se.expr); } @@ -2775,6 +2776,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { tree data; tree vindex; + tree size; /* The derived type needs to be converted to a temporary CLASS object. */ @@ -2788,13 +2790,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, var, tmp, NULL_TREE); tmp = fsym->ts.u.derived->components->next->backend_decl; vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), + var, tmp, NULL_TREE); + tmp = fsym->ts.u.derived->components->next->next->backend_decl; + size = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), var, tmp, NULL_TREE); /* Set the vindex. */ - tmp = build_int_cst (TREE_TYPE (vindex), - e->ts.u.derived->vindex); + tmp = build_int_cst (TREE_TYPE (vindex), e->ts.u.derived->vindex); gfc_add_modify (&parmse.pre, vindex, tmp); + /* Set the size. */ + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e->ts)); + gfc_add_modify (&parmse.pre, size, + fold_convert (TREE_TYPE (size), tmp)); + /* Now set the data field. */ argss = gfc_walk_expr (e); if (argss == gfc_ss_terminator) @@ -5261,3 +5270,75 @@ gfc_trans_assign (gfc_code * code) { return gfc_trans_assignment (code->expr1, code->expr2, false); } + + +/* Translate an assignment to a CLASS object + (pointer or ordinary assignment). */ + +tree +gfc_trans_class_assign (gfc_code *code) +{ + stmtblock_t block; + tree tmp; + + gfc_start_block (&block); + + if (code->expr2->ts.type != BT_CLASS) + { + /* Insert an additional assignment which sets the '$vindex' field. */ + gfc_expr *lhs,*rhs; + lhs = gfc_copy_expr (code->expr1); + gfc_add_component_ref (lhs, "$vindex"); + if (code->expr2->ts.type == BT_DERIVED) + /* vindex is constant, determined at compile time. */ + rhs = gfc_int_expr (code->expr2->ts.u.derived->vindex); + else if (code->expr2->expr_type == EXPR_NULL) + rhs = gfc_int_expr (0); + else + gcc_unreachable (); + tmp = gfc_trans_assignment (lhs, rhs, false); + gfc_add_expr_to_block (&block, tmp); + + /* Insert another assignment which sets the '$size' field. */ + lhs = gfc_copy_expr (code->expr1); + gfc_add_component_ref (lhs, "$size"); + if (code->expr2->ts.type == BT_DERIVED) + { + /* Size is fixed at compile time. */ + gfc_se lse; + gfc_init_se (&lse, NULL); + gfc_conv_expr (&lse, lhs); + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts)); + gfc_add_modify (&block, lse.expr, + fold_convert (TREE_TYPE (lse.expr), tmp)); + } + else if (code->expr2->expr_type == EXPR_NULL) + { + rhs = gfc_int_expr (0); + tmp = gfc_trans_assignment (lhs, rhs, false); + gfc_add_expr_to_block (&block, tmp); + } + else + gcc_unreachable (); + + gfc_free_expr (lhs); + gfc_free_expr (rhs); + } + + /* Do the actual CLASS assignment. */ + if (code->expr2->ts.type == BT_CLASS) + code->op = EXEC_ASSIGN; + else + gfc_add_component_ref (code->expr1, "$data"); + + if (code->op == EXEC_ASSIGN) + tmp = gfc_trans_assign (code); + else if (code->op == EXEC_POINTER_ASSIGN) + tmp = gfc_trans_pointer_assign (code); + else + gcc_unreachable(); + + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 110534d2a5eb..7dc7405c67f3 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -3976,7 +3976,7 @@ tree gfc_trans_allocate (gfc_code * code) { gfc_alloc *al; - gfc_expr *expr, *init_e, *rhs; + gfc_expr *expr, *init_e; gfc_se se; tree tmp; tree parm; @@ -4006,7 +4006,10 @@ gfc_trans_allocate (gfc_code * code) for (al = code->ext.alloc.list; al != NULL; al = al->next) { - expr = al->expr; + expr = gfc_copy_expr (al->expr); + + if (expr->ts.type == BT_CLASS) + gfc_add_component_ref (expr, "$data"); gfc_init_se (&se, NULL); gfc_start_block (&se.pre); @@ -4022,13 +4025,14 @@ gfc_trans_allocate (gfc_code * code) /* Determine allocate size. */ if (code->expr3 && code->expr3->ts.type == BT_CLASS) { - gfc_typespec *ts; - /* TODO: Size must be determined at run time, since it must equal - the size of the dynamic type of SOURCE, not the declared type. */ - gfc_error ("Using SOURCE= with a class variable at %L not " - "supported yet", &code->loc); - ts = &code->expr3->ts.u.derived->components->ts; - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts)); + gfc_expr *sz; + gfc_se se_sz; + sz = gfc_copy_expr (code->expr3); + gfc_add_component_ref (sz, "$size"); + gfc_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, sz); + gfc_free_expr (sz); + tmp = se_sz.expr; } else if (code->expr3 && code->expr3->ts.type != BT_CLASS) tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); @@ -4070,19 +4074,122 @@ gfc_trans_allocate (gfc_code * code) /* Initialization via SOURCE block. */ if (code->expr3) { - rhs = gfc_copy_expr (code->expr3); + gfc_expr *rhs = gfc_copy_expr (code->expr3); if (rhs->ts.type == BT_CLASS) - gfc_add_component_ref (rhs, "$data"); - tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), rhs, false); + { + gfc_se dst,src,len; + gfc_expr *sz; + gfc_add_component_ref (rhs, "$data"); + sz = gfc_copy_expr (code->expr3); + gfc_add_component_ref (sz, "$size"); + gfc_init_se (&dst, NULL); + gfc_init_se (&src, NULL); + gfc_init_se (&len, NULL); + gfc_conv_expr (&dst, expr); + gfc_conv_expr (&src, rhs); + gfc_conv_expr (&len, sz); + gfc_free_expr (sz); + tmp = gfc_build_memcpy_call (dst.expr, src.expr, len.expr); + } + else + tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), + rhs, false); + gfc_free_expr (rhs); + gfc_add_expr_to_block (&block, tmp); + } + /* Default initializer for CLASS variables. */ + else if (al->expr->ts.type == BT_CLASS + && code->ext.alloc.ts.type == BT_DERIVED + && (init_e = gfc_default_initializer (&code->ext.alloc.ts))) + { + gfc_se dst,src; + gfc_init_se (&dst, NULL); + gfc_init_se (&src, NULL); + gfc_conv_expr (&dst, expr); + gfc_conv_expr (&src, init_e); + gfc_add_block_to_block (&block, &src.pre); + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); + tmp = gfc_build_memcpy_call (dst.expr, src.expr, tmp); gfc_add_expr_to_block (&block, tmp); } /* Add default initializer for those derived types that need them. */ - else if (expr->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&expr->ts))) + else if (expr->ts.type == BT_DERIVED + && (init_e = gfc_default_initializer (&expr->ts))) { - tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), init_e, true); + tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), + init_e, true); gfc_add_expr_to_block (&block, tmp); } + /* Allocation of CLASS entities. */ + gfc_free_expr (expr); + expr = al->expr; + if (expr->ts.type == BT_CLASS) + { + gfc_expr *lhs,*rhs; + /* Initialize VINDEX for CLASS objects. */ + lhs = gfc_expr_to_initialize (expr); + gfc_add_component_ref (lhs, "$vindex"); + if (code->expr3 && code->expr3->ts.type == BT_CLASS) + { + /* vindex must be determined at run time. */ + rhs = gfc_copy_expr (code->expr3); + gfc_add_component_ref (rhs, "$vindex"); + } + else + { + /* vindex is fixed at compile time. */ + int vindex; + if (code->expr3) + vindex = code->expr3->ts.u.derived->vindex; + else if (code->ext.alloc.ts.type == BT_DERIVED) + vindex = code->ext.alloc.ts.u.derived->vindex; + else if (expr->ts.type == BT_CLASS) + vindex = expr->ts.u.derived->components->ts.u.derived->vindex; + else + vindex = expr->ts.u.derived->vindex; + rhs = gfc_int_expr (vindex); + } + tmp = gfc_trans_assignment (lhs, rhs, false); + gfc_free_expr (lhs); + gfc_free_expr (rhs); + gfc_add_expr_to_block (&block, tmp); + + /* Initialize SIZE for CLASS objects. */ + lhs = gfc_expr_to_initialize (expr); + gfc_add_component_ref (lhs, "$size"); + rhs = NULL; + if (code->expr3 && code->expr3->ts.type == BT_CLASS) + { + /* Size must be determined at run time. */ + rhs = gfc_copy_expr (code->expr3); + gfc_add_component_ref (rhs, "$size"); + tmp = gfc_trans_assignment (lhs, rhs, false); + gfc_add_expr_to_block (&block, tmp); + } + else + { + /* Size is fixed at compile time. */ + gfc_typespec *ts; + gfc_se lse; + gfc_init_se (&lse, NULL); + gfc_conv_expr (&lse, lhs); + if (code->expr3) + ts = &code->expr3->ts; + else if (code->ext.alloc.ts.type == BT_DERIVED) + ts = &code->ext.alloc.ts; + else if (expr->ts.type == BT_CLASS) + ts = &expr->ts.u.derived->components->ts; + else + ts = &expr->ts; + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts)); + gfc_add_modify (&block, lse.expr, + fold_convert (TREE_TYPE (lse.expr), tmp)); + } + gfc_free_expr (lhs); + gfc_free_expr (rhs); + } + } /* STAT block. */ diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index 0b8461c4e15c..e6faacd00225 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -29,6 +29,7 @@ tree gfc_trans_code (gfc_code *); tree gfc_trans_assign (gfc_code *); tree gfc_trans_pointer_assign (gfc_code *); tree gfc_trans_init_assign (gfc_code *); +tree gfc_trans_class_assign (gfc_code *code); /* trans-stmt.c */ tree gfc_trans_cycle (gfc_code *); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 09b424c378fc..22c3e0760859 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1079,7 +1079,10 @@ gfc_trans_code (gfc_code * code) break; case EXEC_ASSIGN: - res = gfc_trans_assign (code); + if (code->expr1->ts.type == BT_CLASS) + res = gfc_trans_class_assign (code); + else + res = gfc_trans_assign (code); break; case EXEC_LABEL_ASSIGN: @@ -1087,7 +1090,10 @@ gfc_trans_code (gfc_code * code) break; case EXEC_POINTER_ASSIGN: - res = gfc_trans_pointer_assign (code); + if (code->expr1->ts.type == BT_CLASS) + res = gfc_trans_class_assign (code); + else + res = gfc_trans_pointer_assign (code); break; case EXEC_INIT_ASSIGN: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 95cddc466514..7e2258950c79 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2009-10-13 Janus Weil + + PR fortran/41581 + * gfortran.dg/class_allocate_2.f03: Modified. + * gfortran.dg/class_allocate_3.f03: New test case. + 2009-10-13 Richard Guenther PR lto/41668 diff --git a/gcc/testsuite/gfortran.dg/class_allocate_2.f03 b/gcc/testsuite/gfortran.dg/class_allocate_2.f03 index d6a5d78bd758..754faa9a9f41 100644 --- a/gcc/testsuite/gfortran.dg/class_allocate_2.f03 +++ b/gcc/testsuite/gfortran.dg/class_allocate_2.f03 @@ -7,7 +7,7 @@ type :: t end type t class(t), allocatable :: c,d allocate(t :: d) -allocate(c,source=d) ! { dg-error "not supported yet" } +allocate(c,source=d) end type, abstract :: t diff --git a/gcc/testsuite/gfortran.dg/class_allocate_3.f03 b/gcc/testsuite/gfortran.dg/class_allocate_3.f03 new file mode 100644 index 000000000000..c6128a8ab515 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_allocate_3.f03 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! PR 41581: [OOP] Allocation of a CLASS with SOURCE= does not work +! +! Contributed by Tobias Burnus + + type t + end type t + + type,extends(t) :: t2 + integer :: i = 54 + real :: r = 384.02 + end type t2 + + class(t), allocatable :: m1, m2 + + allocate(t2 :: m2) + select type(m2) + type is (t2) + print *, m2%i, m2%r + if (m2%i/=54) call abort() + if (abs(m2%r-384.02)>1E-3) call abort() + m2%i = 42 + m2%r = -4.0 + class default + call abort() + end select + + allocate(m1, source=m2) + select type(m1) + type is (t2) + print *, m1%i, m1%r + if (m1%i/=42) call abort() + if (abs(m1%r+4.0)>1E-3) call abort() + class default + call abort() + end select + +end