diff options
| author | Tobias Burnus <burnus@gcc.gnu.org> | 2009-09-30 22:45:07 +0200 |
|---|---|---|
| committer | Tobias Burnus <burnus@gcc.gnu.org> | 2009-09-30 22:45:07 +0200 |
| commit | e56817dbc6b6219fc209f7d740e452f3cfb77abe (patch) | |
| tree | 810a3eb7f5ed1d7d3752ab8b18044d6423f8e5a3 /gcc/fortran | |
| parent | cf2b3c22a2cbd7f50db530ca9d2b14c70ba0359d (diff) | |
| download | gcc-e56817dbc6b6219fc209f7d740e452f3cfb77abe.zip gcc-e56817dbc6b6219fc209f7d740e452f3cfb77abe.tar.gz gcc-e56817dbc6b6219fc209f7d740e452f3cfb77abe.tar.bz2 | |
resolve.c (check_typebound_baseobject): Don't check for abstract types for CLASS.
fortran/
2009-09-30 Janus Weil <janus@gcc.gnu.org>
* resolve.c (check_typebound_baseobject): Don't check for
abstract types for CLASS.
(resolve_class_assign): Adapt for RHS being a CLASS.
* trans-intrinsic.c (gfc_conv_associated): Add component ref
if expr is a CLASS.
testsuite/
2009-09-30 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/select_type_4.f90: New test.
From-SVN: r152346
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 8 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 49 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 2 |
3 files changed, 37 insertions, 22 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 04aac0c..9318bae 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,13 @@ 2009-09-30 Janus Weil <janus@gcc.gnu.org> + * resolve.c (check_typebound_baseobject): Don't check for + abstract types for CLASS. + (resolve_class_assign): Adapt for RHS being a CLASS. + * trans-intrinsic.c (gfc_conv_associated): Add component ref + if expr is a CLASS. + +2009-09-30 Janus Weil <janus@gcc.gnu.org> + * check.c (gfc_check_same_type_as): New function for checking SAME_TYPE_AS and EXTENDS_TYPE_OF. * decl.c (encapsulate_class_symbol): Set ABSTRACT attribute for class diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 445753e..bb803b3 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4851,7 +4851,8 @@ check_typebound_baseobject (gfc_expr* e) return FAILURE; gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS); - if (base->ts.u.derived->attr.abstract) + + if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract) { gfc_error ("Base object for type-bound procedure call at %L is of" " ABSTRACT type '%s'", &e->where, base->ts.u.derived->name); @@ -7298,30 +7299,34 @@ resolve_class_assign (gfc_code *code) { gfc_code *assign_code = gfc_get_code (); - /* 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 (); + 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. */ - gfc_add_component_ref (code->expr1, "$data"); if (code->expr2->ts.type == BT_CLASS) - gfc_add_component_ref (code->expr2, "$data"); + code->op = EXEC_ASSIGN; + else + gfc_add_component_ref (code->expr1, "$data"); } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index b00ceba..1e7b35f 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -4608,6 +4608,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) gfc_init_se (&arg1se, NULL); gfc_init_se (&arg2se, NULL); arg1 = expr->value.function.actual; + if (arg1->expr->ts.type == BT_CLASS) + gfc_add_component_ref (arg1->expr, "$data"); arg2 = arg1->next; ss1 = gfc_walk_expr (arg1->expr); |