re PR fortran/43388 ([F2008][OOP] ALLOCATE with MOLD=)

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  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.

From-SVN: r160801

10 files changed, 197 insertions, 43 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 39cab7a..31da4d3 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+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
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 2a553d1..8867e58 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 8c43531..92c4da0 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 d5fa370..7e6b75a 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 e5636bf..ad05426 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 cacbca5..69dd222 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+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.
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 0000000..5bccefa
--- /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 <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
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 0000000..39aa363
--- /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 <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
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 0000000..e51a7ec
--- /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 <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
diff --git a/gcc/testsuite/gfortran.dg/class_allocate_2.f03 b/gcc/testsuite/gfortran.dg/class_allocate_2.f03
index 754faa9..cec05f1 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