+2010-06-15 Janus Weil <janus@gcc.gnu.org>
+
+ 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 <jakub@redhat.com>
PR fortran/44536
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
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;
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 () == ')')
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;
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;
}
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;
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;
}
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;
/* 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
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)
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);
+2010-06-15 Janus Weil <janus@gcc.gnu.org>
+
+ 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 <rguenther@suse.de>
* gcc.dg/tree-ssa/ssa-sccvn-4.c: Adjust.
--- /dev/null
+! { dg-do run }
+!
+! PR 43388: [F2008][OOP] ALLOCATE with MOLD=
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+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
--- /dev/null
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+! PR 43388: [F2008][OOP] ALLOCATE with MOLD=
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+type :: t
+end type
+
+class(t),allocatable :: x
+type(t) :: z
+
+allocate(x,MOLD=z) ! { dg-error "MOLD tag at" }
+
+end
--- /dev/null
+! { dg-do compile }
+!
+! PR 43388: [F2008][OOP] ALLOCATE with MOLD=
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+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
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
OSDN Git Service
