From de6229046ca7a9d04c27f1d5427258d272f8bdbf Mon Sep 17 00:00:00 2001 From: janus Date: Tue, 15 Jun 2010 18:33:58 +0000 Subject: [PATCH] 2010-06-15 Janus Weil PR fortran/43388 * gfortran.h (gfc_expr): Add new member 'mold'. * match.c (gfc_match_allocate): Implement the MOLD tag. * resolve.c (resolve_allocate_expr): Ditto. * trans-stmt.c (gfc_trans_allocate): Ditto. 2010-06-15 Janus Weil PR fortran/43388 * gfortran.dg/allocate_alloc_opt_8.f90: New. * gfortran.dg/allocate_alloc_opt_9.f90: New. * gfortran.dg/allocate_alloc_opt_10.f90: New. * gfortran.dg/class_allocate_2.f03: Modified an error message. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160801 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 8 ++++ gcc/fortran/gfortran.h | 5 +- gcc/fortran/match.c | 56 +++++++++++++++++++--- gcc/fortran/resolve.c | 43 +++++++++-------- gcc/fortran/trans-stmt.c | 31 ++++++------ gcc/testsuite/ChangeLog | 8 ++++ .../gfortran.dg/allocate_alloc_opt_10.f90 | 46 ++++++++++++++++++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_8.f90 | 16 +++++++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_9.f90 | 23 +++++++++ gcc/testsuite/gfortran.dg/class_allocate_2.f03 | 4 +- 10 files changed, 197 insertions(+), 43 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/allocate_alloc_opt_10.f90 create mode 100644 gcc/testsuite/gfortran.dg/allocate_alloc_opt_8.f90 create mode 100644 gcc/testsuite/gfortran.dg/allocate_alloc_opt_9.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 39cab7a17c4..31da4d33169 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2010-06-15 Janus Weil + + PR fortran/43388 + * gfortran.h (gfc_expr): Add new member 'mold'. + * match.c (gfc_match_allocate): Implement the MOLD tag. + * resolve.c (resolve_allocate_expr): Ditto. + * trans-stmt.c (gfc_trans_allocate): Ditto. + 2010-06-15 Jakub Jelinek PR fortran/44536 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 2a553d198fa..8867e58d5b8 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1669,10 +1669,13 @@ typedef struct gfc_expr it from recurring. */ unsigned int error : 1; - /* Mark and expression where a user operator has been substituted by + /* Mark an expression where a user operator has been substituted by a function call in interface.c(gfc_extend_expr). */ unsigned int user_operator : 1; + /* Mark an expression as being a MOLD argument of ALLOCATE. */ + unsigned int mold : 1; + /* If an expression comes from a Hollerith constant or compile-time evaluation of a transfer statement, it may have a prescribed target- memory representation, and these cannot always be backformed from diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 8c43531d875..92c4da0a4b5 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -2785,16 +2785,16 @@ match gfc_match_allocate (void) { gfc_alloc *head, *tail; - gfc_expr *stat, *errmsg, *tmp, *source; + gfc_expr *stat, *errmsg, *tmp, *source, *mold; gfc_typespec ts; gfc_symbol *sym; match m; locus old_locus; - bool saw_stat, saw_errmsg, saw_source, b1, b2, b3; + bool saw_stat, saw_errmsg, saw_source, saw_mold, b1, b2, b3; head = tail = NULL; - stat = errmsg = source = tmp = NULL; - saw_stat = saw_errmsg = saw_source = false; + stat = errmsg = source = mold = tmp = NULL; + saw_stat = saw_errmsg = saw_source = saw_mold = false; if (gfc_match_char ('(') != MATCH_YES) goto syntax; @@ -2987,6 +2987,38 @@ alloc_opt_list: goto alloc_opt_list; } + m = gfc_match (" mold = %e", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: MOLD tag at %L", + &tmp->where) == FAILURE) + goto cleanup; + + /* Check F08:C636. */ + if (saw_mold) + { + gfc_error ("Redundant MOLD tag found at %L ", &tmp->where); + goto cleanup; + } + + /* Check F08:C637. */ + if (ts.type != BT_UNKNOWN) + { + gfc_error ("MOLD tag at %L conflicts with the typespec at %L", + &tmp->where, &old_locus); + goto cleanup; + } + + mold = tmp; + saw_mold = true; + mold->mold = 1; + + if (gfc_match_char (',') == MATCH_YES) + goto alloc_opt_list; + } + gfc_gobble_whitespace (); if (gfc_peek_char () == ')') @@ -2997,10 +3029,21 @@ alloc_opt_list: if (gfc_match (" )%t") != MATCH_YES) goto syntax; + /* Check F08:C637. */ + if (source && mold) + { + gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L", + &mold->where, &source->where); + goto cleanup; + } + new_st.op = EXEC_ALLOCATE; new_st.expr1 = stat; new_st.expr2 = errmsg; - new_st.expr3 = source; + if (source) + new_st.expr3 = source; + else + new_st.expr3 = mold; new_st.ext.alloc.list = head; new_st.ext.alloc.ts = ts; @@ -3013,7 +3056,8 @@ cleanup: gfc_free_expr (errmsg); gfc_free_expr (source); gfc_free_expr (stat); - gfc_free_expr (tmp); + gfc_free_expr (mold); + if (tmp && tmp->expr_type) gfc_free_expr (tmp); gfc_free_alloc_list (head); return MATCH_ERROR; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d5fa3708d4e..7e6b75aebe1 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6268,7 +6268,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) gfc_symbol *sym = NULL; gfc_alloc *a; gfc_component *c; - gfc_expr *init_e; /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ check_intent_in = 1; @@ -6401,11 +6400,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) goto failure; } } - else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN) + + /* Check F08:C629. */ + if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN + && !code->expr3) { gcc_assert (e->ts.type == BT_CLASS); gfc_error ("Allocating %s of ABSTRACT base type at %L requires a " - "type-spec or SOURCE=", sym->name, &e->where); + "type-spec or source-expr", sym->name, &e->where); goto failure; } @@ -6416,25 +6418,26 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) goto failure; } - if (!code->expr3) + if (!code->expr3 || code->expr3->mold) { /* Add default initializer for those derived types that need them. */ - if (e->ts.type == BT_DERIVED - && (init_e = gfc_default_initializer (&e->ts))) - { - gfc_code *init_st = gfc_get_code (); - init_st->loc = code->loc; - init_st->op = EXEC_INIT_ASSIGN; - init_st->expr1 = gfc_expr_to_initialize (e); - init_st->expr2 = init_e; - init_st->next = code->next; - code->next = init_st; - } - else if (e->ts.type == BT_CLASS - && ((code->ext.alloc.ts.type == BT_UNKNOWN - && (init_e = gfc_default_initializer (&CLASS_DATA (e)->ts))) - || (code->ext.alloc.ts.type == BT_DERIVED - && (init_e = gfc_default_initializer (&code->ext.alloc.ts))))) + gfc_expr *init_e = NULL; + gfc_typespec ts; + + if (code->ext.alloc.ts.type == BT_DERIVED) + ts = code->ext.alloc.ts; + else if (code->expr3) + ts = code->expr3->ts; + else + ts = e->ts; + + if (ts.type == BT_DERIVED) + init_e = gfc_default_initializer (&ts); + /* FIXME: Use default init of dynamic type (cf. PR 44541). */ + else if (e->ts.type == BT_CLASS) + init_e = gfc_default_initializer (&ts.u.derived->components->ts); + + if (init_e) { gfc_code *init_st = gfc_get_code (); init_st->loc = code->loc; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index e5636bfed53..ad054261dad 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -4155,20 +4155,23 @@ gfc_trans_allocate (gfc_code * code) /* A scalar or derived type. */ /* Determine allocate size. */ - if (code->expr3 && code->expr3->ts.type == BT_CLASS) + if (al->expr->ts.type == BT_CLASS && code->expr3) { - gfc_expr *sz; - gfc_se se_sz; - sz = gfc_copy_expr (code->expr3); - gfc_add_component_ref (sz, "$vptr"); - gfc_add_component_ref (sz, "$size"); - gfc_init_se (&se_sz, NULL); - gfc_conv_expr (&se_sz, sz); - gfc_free_expr (sz); - memsz = se_sz.expr; + if (code->expr3->ts.type == BT_CLASS) + { + gfc_expr *sz; + gfc_se se_sz; + sz = gfc_copy_expr (code->expr3); + gfc_add_component_ref (sz, "$vptr"); + gfc_add_component_ref (sz, "$size"); + gfc_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, sz); + gfc_free_expr (sz); + memsz = se_sz.expr; + } + else + memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); } - else if (code->expr3 && code->expr3->ts.type != BT_CLASS) - memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); else if (code->ext.alloc.ts.type != BT_UNKNOWN) memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); else @@ -4230,7 +4233,7 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&block, tmp); /* Initialization via SOURCE block. */ - if (code->expr3) + if (code->expr3 && !code->expr3->mold) { gfc_expr *rhs = gfc_copy_expr (code->expr3); if (al->expr->ts.type == BT_CLASS) @@ -4266,7 +4269,7 @@ gfc_trans_allocate (gfc_code * code) rhs = NULL; if (code->expr3 && code->expr3->ts.type == BT_CLASS) { - /* VPTR must be determined at run time. */ + /* Polymorphic SOURCE: VPTR must be determined at run time. */ rhs = gfc_copy_expr (code->expr3); gfc_add_component_ref (rhs, "$vptr"); tmp = gfc_trans_pointer_assignment (lhs, rhs); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index cacbca54169..69dd2228203 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2010-06-15 Janus Weil + + PR fortran/43388 + * gfortran.dg/allocate_alloc_opt_8.f90: New. + * gfortran.dg/allocate_alloc_opt_9.f90: New. + * gfortran.dg/allocate_alloc_opt_10.f90: New. + * gfortran.dg/class_allocate_2.f03: Modified an error message. + 2010-06-15 Richard Guenther * gcc.dg/tree-ssa/ssa-sccvn-4.c: Adjust. diff --git a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_10.f90 b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_10.f90 new file mode 100644 index 00000000000..5bccefaaf15 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_10.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! +! PR 43388: [F2008][OOP] ALLOCATE with MOLD= +! +! Contributed by Janus Weil + +type :: t1 + integer :: i +end type + +type,extends(t1) :: t2 + integer :: j = 4 +end type + +class(t1),allocatable :: x,y +type(t2) :: z + + +!!! first example (works) + +z%j = 5 +allocate(x,MOLD=z) + +select type (x) +type is (t2) + print *,x%j + if (x%j/=4) call abort +class default + call abort() +end select + + +!!! second example (fails) +!!! FIXME: uncomment once implemented (cf. PR 44541) + +! allocate(y,MOLD=x) +! +! select type (y) +! type is (t2) +! print *,y%j +! if (y%j/=4) call abort +! class default +! call abort() +! end select + +end diff --git a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_8.f90 b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_8.f90 new file mode 100644 index 00000000000..39aa3638b46 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_8.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR 43388: [F2008][OOP] ALLOCATE with MOLD= +! +! Contributed by Janus Weil + +type :: t +end type + +class(t),allocatable :: x +type(t) :: z + +allocate(x,MOLD=z) ! { dg-error "MOLD tag at" } + +end diff --git a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_9.f90 b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_9.f90 new file mode 100644 index 00000000000..e51a7ec868a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_9.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR 43388: [F2008][OOP] ALLOCATE with MOLD= +! +! Contributed by Janus Weil + +type :: t +end type + +type :: u +end type + +class(t),allocatable :: x +type(t) :: z1,z2 +type(u) :: z3 + +allocate(x,MOLD=z1,MOLD=z2) ! { dg-error "Redundant MOLD tag" } +allocate(x,SOURCE=z1,MOLD=z2) ! { dg-error "conflicts with SOURCE tag" } +allocate(t::x,MOLD=z1) ! { dg-error "conflicts with the typespec" } + +allocate(x,MOLD=z3) ! { dg-error "is type incompatible" } + +end diff --git a/gcc/testsuite/gfortran.dg/class_allocate_2.f03 b/gcc/testsuite/gfortran.dg/class_allocate_2.f03 index 754faa9a9f4..cec05f17a1f 100644 --- a/gcc/testsuite/gfortran.dg/class_allocate_2.f03 +++ b/gcc/testsuite/gfortran.dg/class_allocate_2.f03 @@ -18,6 +18,6 @@ end type t2 class(t), allocatable :: a,c,d type(t2) :: b -allocate(a) ! { dg-error "requires a type-spec or SOURCE" } -allocate(b%t) ! { dg-error "requires a type-spec or SOURCE" } +allocate(a) ! { dg-error "requires a type-spec or source-expr" } +allocate(b%t) ! { dg-error "requires a type-spec or source-expr" } end -- 2.11.0