re PR fortran/41582 ([OOP] Allocation of abstract types requires a type spec or a SOURCE)

2009-10-09  Tobias Burnus  <burnus@net-b.de>

        PR fortran/41582
        * decl.c (encapsulate_class_symbol): Save attr.abstract.
        * resolve.c (resolve_allocate_expr): Reject class allocate
        without typespec or source=.
        * trans-stmt.c (gfc_trans_allocate): Change gfc_warning
        into gfc_error for "not yet implemented".

2009-10-09  Tobias Burnus  <burnus@net-b.de>

        PR fortran/41582
        * gfortran.dg/class_allocate_1.f03: Modify code such that
        it compiles with the gfc_warning->gfc_error change.
        * gfortran.dg/class_allocate_1.f03: New test.

From-SVN: r152601

gcc/fortran/ChangeLog

+2009-10-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41582
+	* decl.c (encapsulate_class_symbol): Save attr.abstract.
+	* resolve.c (resolve_allocate_expr): Reject class allocate
+	without typespec or source=.
+	* trans-stmt.c (gfc_trans_allocate): Change gfc_warning
+	into gfc_error for "not yet implemented".
+
 2009-10-09  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/41579
@@ -49,8 +58,8 @@
 
 2009-10-07  Paul Thomas <pault@gcc.gnu.org>
 
-        PR fortran/41613
-        * resolve.c (check_class_members): Reset compcall.assign.
+	PR fortran/41613
+	* resolve.c (check_class_members): Reset compcall.assign.
 
 2009-10-05  Paul Thomas  <pault@gcc.gnu.org>
 
@@ -373,7 +382,6 @@
 	* parse.c (next_free): Improve error locus printing.
 	(next_fixed): Change gfc_warn to gfc_warning_now, and improve
 	locus reporting.
- 
 
 2009-09-16  Michael Matz  <matz@suse.de>
 

gcc/fortran/decl.c

@@ -1077,6 +1077,7 @@ encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       c->attr.pointer = attr->pointer || attr->dummy;
       c->attr.allocatable = attr->allocatable;
       c->attr.dimension = attr->dimension;
+      c->attr.abstract = ts->u.derived->attr.abstract;
       c->as = (*as);
       c->initializer = gfc_get_expr ();
       c->initializer->expr_type = EXPR_NULL;

gcc/fortran/resolve.c

@@ -5840,7 +5840,7 @@ gfc_expr_to_initialize (gfc_expr *e)
 static gfc_try
 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 {
-  int i, pointer, allocatable, dimension, check_intent_in;
+  int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
   symbol_attribute attr;
   gfc_ref *ref, *ref2;
   gfc_array_ref *ar;
@@ -5862,6 +5862,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
   if (e->symtree)
     sym = e->symtree->n.sym;
 
+  /* Check whether ultimate component is abstract and CLASS.  */
+  is_abstract = 0;
+
   if (e->expr_type != EXPR_VARIABLE)
     {
       allocatable = 0;
@@ -5876,6 +5879,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 	  allocatable = sym->ts.u.derived->components->attr.allocatable;
 	  pointer = sym->ts.u.derived->components->attr.pointer;
 	  dimension = sym->ts.u.derived->components->attr.dimension;
+	  is_abstract = sym->ts.u.derived->components->attr.abstract;
 	}
       else
 	{
@@ -5903,12 +5907,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 		    allocatable = c->ts.u.derived->components->attr.allocatable;
 		    pointer = c->ts.u.derived->components->attr.pointer;
 		    dimension = c->ts.u.derived->components->attr.dimension;
+		    is_abstract = c->ts.u.derived->components->attr.abstract;
 		  }
 		else
 		  {
 		    allocatable = c->attr.allocatable;
 		    pointer = c->attr.pointer;
 		    dimension = c->attr.dimension;
+		    is_abstract = c->attr.abstract;
 		  }
 		break;
 
@@ -5927,6 +5933,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
       return FAILURE;
     }
 
+  if (is_abstract && !code->expr3 && code->ext.alloc.ts.type == BT_UNKNOWN)
+    {
+      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);
+      return FAILURE;
+    }
+
   if (check_intent_in && sym->attr.intent == INTENT_IN)
     {
       gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",

gcc/fortran/trans-stmt.c

@@ -4025,8 +4025,8 @@ gfc_trans_allocate (gfc_code * code)
 	      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_warning ("Dynamic size allocation at %L not supported yet, "
-			   "using size of declared type", &code->loc);
+	      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));
 	    }

gcc/testsuite/ChangeLog

+2009-10-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41582
+	* gfortran.dg/class_allocate_1.f03: Modify code such that
+	it compiles with the gfc_warning->gfc_error change.
+	* gfortran.dg/class_allocate_1.f03: New test.
+
 2009-10-09  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/41579
@@ -448,7 +455,7 @@
 
 2009-10-02  Jack Howarth  <howarth@bromo.med.uc.edu>
 
-        * gcc.dg/guality/guality.exp: Disable on darwin.
+	* gcc.dg/guality/guality.exp: Disable on darwin.
 
 2009-10-02  Janis Johnson  <janis187@us.ibm.com>
 
@@ -5543,7 +5550,7 @@
 2009-05-12  David Billinghurst <billingd@gcc.gnu.org>
 
 	* lib/target-supports.exp (check_profiling_available): Return
- 	false for -p on *-*-cygwin* targets.
+	false for -p on *-*-cygwin* targets.
 
 2009-05-11  H.J. Lu  <hongjiu.lu@intel.com>
 

gcc/testsuite/gfortran.dg/class_allocate_1.f03

@@ -20,6 +20,7 @@
  end type
 
  class(t1),pointer :: cp, cp2
+ type(t2),pointer :: cp3
  type(t3) :: x
  integer :: i
 
@@ -67,7 +68,10 @@
 
  i = 0
  allocate(t2 :: cp2)
- allocate(cp, source = cp2)  ! { dg-warning "not supported yet" }
+! FIXME: Not yet supported: source=<class>
+! allocate(cp, source = cp2)
+ allocate(t2 :: cp3)
+ allocate(cp, source=cp3)
  select type (cp)
  type is (t1)
    i = 1

gcc/testsuite/gfortran.dg/class_allocate_2.f03

+! { dg-do compile }
+!
+! PR fortran/41582
+!
+subroutine test()
+type :: t
+end type t
+class(t), allocatable :: c,d
+allocate(t :: d)
+allocate(c,source=d) ! { dg-error "not supported yet" }
+end
+
+type, abstract :: t
+end type t
+type t2
+  class(t), pointer :: t
+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" }
+end