allocate_alloc_opt_4.f90: New test.

2009-08-22 Steven K. kargl  <kargl@gcc.gnu.org>

	* gfortran.dg/allocate_alloc_opt_4.f90: New test.
	* gfortran.dg/allocate_alloc_opt_5.f90: New test.
	* gfortran.dg/allocate_alloc_opt_6.f90: New test.

2009-08-22 Steven K. kargl  <kargl@gcc.gnu.org>

	* fortran/decl.c (match_char_spec): Rename to gfc_match_char_spec,
	and remove static.
	* fortran/gfortran.h: Add *expr3 entity to gfc_code.  Add prototype
	for gfc_match_char_spec.
	* fortran/trans-stmt.c (gfc_trans_allocate): Translate the SOURCE=
	tag.
	* fortran/match.c (match_intrinsic_typespec): New function to match
	F2003 intrinsic-type-spec.
	(conformable_arrays): New function. Check SOURCE= and
	allocation-object are conformable.
	(gfc_match_allocate): Use new functions.  Match SOURCE= tag.

From-SVN: r151023

9 files changed, 418 insertions, 18 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 635e68c..4869fe8 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+2009-08-22 Steven K. kargl  <kargl@gcc.gnu.org>
+
+	* fortran/decl.c (match_char_spec): Rename to gfc_match_char_spec,
+	and remove static.
+	* fortran/gfortran.h: Add *expr3 entity to gfc_code.  Add prototype
+	for gfc_match_char_spec.
+	* fortran/trans-stmt.c (gfc_trans_allocate): Translate the SOURCE=
+	tag.
+	* fortran/match.c (match_intrinsic_typespec): New function to match
+	F2003 intrinsic-type-spec.
+	(conformable_arrays): New function. Check SOURCE= and
+	allocation-object are conformable.
+	(gfc_match_allocate): Use new functions.  Match SOURCE= tag.
+
 2009-08-22	Bud Davis <bdavis9659@sbcglobal.net>
 
 	PR fortran/28093
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index e4813b8..1533af5 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -2104,11 +2104,12 @@ no_match:
   return m;
 }
 
+
 /* Match the various kind/length specifications in a CHARACTER
    declaration.  We don't return MATCH_NO.  */
 
-static match
-match_char_spec (gfc_typespec *ts)
+match
+gfc_match_char_spec (gfc_typespec *ts)
 {
   int kind, seen_length, is_iso_c;
   gfc_charlen *cl;
@@ -2324,7 +2325,7 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
     {
       ts->type = BT_CHARACTER;
       if (implicit_flag == 0)
-	return match_char_spec (ts);
+	return gfc_match_char_spec (ts);
       else
 	return MATCH_YES;
     }
@@ -2636,7 +2637,7 @@ gfc_match_implicit (void)
 
       /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>).  */
       if (ts.type == BT_CHARACTER)
-	m = match_char_spec (&ts);
+	m = gfc_match_char_spec (&ts);
       else
 	{
 	  m = gfc_match_kind_spec (&ts, false);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index a4a3b81..cbab000 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1977,7 +1977,7 @@ typedef struct gfc_code
 
   gfc_st_label *here, *label1, *label2, *label3;
   gfc_symtree *symtree;
-  gfc_expr *expr1, *expr2;
+  gfc_expr *expr1, *expr2, *expr3;
   /* A name isn't sufficient to identify a subroutine, we need the actual
      symbol for the interface definition.
   const char *sub_name;  */
@@ -2184,6 +2184,7 @@ gfc_finalizer;
 
 /* decl.c */
 bool gfc_in_match_data (void);
+match gfc_match_char_spec (gfc_typespec *);
 
 /* scanner.c */
 void gfc_scanner_done_1 (void);
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 3c6ef49..9ba3e09 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2221,23 +2221,186 @@ gfc_free_alloc_list (gfc_alloc *p)
 }
 
 
+/* Match a Fortran 2003 intrinsic-type-spec.  This is a stripped
+   down version of gfc_match_type_spec() from decl.c.  It only includes
+   the intrinsic types from the Fortran 2003 standard.  Thus, neither
+   BYTE nor forms like REAL*4 are allowed.  Additionally, the implicit_flag
+   is not needed, so it was removed.  The handling of derived types has
+   been removed and no notion of the gfc_matching_function state
+   is needed.  In short, this functions matches only standard conforming
+   intrinsic-type-spec (R403).  */
+
+static match
+match_intrinsic_typespec (gfc_typespec *ts)
+{
+  match m;
+
+  gfc_clear_ts (ts);
+
+  if (gfc_match ("integer") == MATCH_YES)
+    {
+      ts->type = BT_INTEGER;
+      ts->kind = gfc_default_integer_kind;
+      goto kind_selector;
+    }
+
+  if (gfc_match ("real") == MATCH_YES)
+    {
+      ts->type = BT_REAL;
+      ts->kind = gfc_default_real_kind;
+      goto kind_selector;
+    }
+
+  if (gfc_match ("double precision") == MATCH_YES)
+    {
+      ts->type = BT_REAL;
+      ts->kind = gfc_default_double_kind;
+      return MATCH_YES;
+    }
+
+  if (gfc_match ("complex") == MATCH_YES)
+    {
+      ts->type = BT_COMPLEX;
+      ts->kind = gfc_default_complex_kind;
+      goto kind_selector;
+    }
+
+  if (gfc_match ("character") == MATCH_YES)
+    {
+      ts->type = BT_CHARACTER;
+      goto char_selector;
+    }
+
+  if (gfc_match ("logical") == MATCH_YES)
+    {
+      ts->type = BT_LOGICAL;
+      ts->kind = gfc_default_logical_kind;
+      goto kind_selector;
+    }
+
+  /* If an intrinsic type is not matched, simply return MATCH_NO.  */ 
+  return MATCH_NO;
+
+kind_selector:
+
+  gfc_gobble_whitespace ();
+  if (gfc_peek_ascii_char () == '*')
+    {
+      gfc_error ("Invalid type-spec at %C");
+      return MATCH_ERROR;
+    }
+
+  m = gfc_match_kind_spec (ts, false);
+
+  if (m == MATCH_NO)
+    m = MATCH_YES;		/* No kind specifier found.  */
+
+  return m;
+
+char_selector:
+
+  m = gfc_match_char_spec (ts);
+
+  if (m == MATCH_NO)
+    m = MATCH_YES;		/* No kind specifier found.  */
+
+  return m;
+}
+
+
+/* Used in gfc_match_allocate to check that a allocation-object and
+   a source-expr are conformable.  This does not catch all possible 
+   cases; in particular a runtime checking is needed.  */
+
+static gfc_try
+conformable_arrays (gfc_expr *e1, gfc_expr *e2)
+{
+  /* First compare rank.  */
+  if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
+    {
+      gfc_error ("Source-expr at %L must be scalar or have the "
+		 "same rank as the allocate-object at %L",
+		 &e1->where, &e2->where);
+      return FAILURE;
+    }
+
+  if (e1->shape)
+    {
+      int i;
+      mpz_t s;
+
+      mpz_init (s);
+
+      for (i = 0; i < e1->rank; i++)
+	{
+	  if (e2->ref->u.ar.end[i])
+	    {
+	      mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
+	      mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
+	      mpz_add_ui (s, s, 1);
+	    }
+	  else
+	    {
+	      mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
+	    }
+
+	  if (mpz_cmp (e1->shape[i], s) != 0)
+	    {
+	      gfc_error ("Source-expr at %L and allocate-object at %L must "
+			 "have the same shape", &e1->where, &e2->where);
+	      mpz_clear (s);
+   	      return FAILURE;
+	    }
+	}
+
+      mpz_clear (s);
+    }
+
+  return SUCCESS;
+}
+
+
 /* Match an ALLOCATE statement.  */
 
 match
 gfc_match_allocate (void)
 {
   gfc_alloc *head, *tail;
-  gfc_expr *stat, *errmsg, *tmp;
+  gfc_expr *stat, *errmsg, *tmp, *source;
+  gfc_typespec ts;
   match m;
-  bool saw_stat, saw_errmsg;
+  locus old_locus;
+  bool saw_stat, saw_errmsg, saw_source, b1, b2, b3;
 
   head = tail = NULL;
-  stat = errmsg = tmp = NULL;
-  saw_stat = saw_errmsg = false;
+  stat = errmsg = source = tmp = NULL;
+  saw_stat = saw_errmsg = saw_source = false;
 
   if (gfc_match_char ('(') != MATCH_YES)
     goto syntax;
 
+  /* Match an optional intrinsic-type-spec.  */
+  old_locus = gfc_current_locus;
+  m = match_intrinsic_typespec (&ts);
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  else if (m == MATCH_NO)
+    ts.type = BT_UNKNOWN;
+  else
+    {
+      if (gfc_match (" :: ") == MATCH_YES)
+	{
+	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
+			      "ALLOCATE at %L", &old_locus) == FAILURE)
+	    goto cleanup;
+	}
+      else
+	{
+	  ts.type = BT_UNKNOWN;
+	  gfc_current_locus = old_locus;
+	}
+    }
+
   for (;;)
     {
       if (head == NULL)
@@ -2263,17 +2426,46 @@ gfc_match_allocate (void)
 	  goto cleanup;
 	}
 
+      /* The ALLOCATE statement had an optional typespec.  Check the
+	 constraints.  */
+      if (ts.type != BT_UNKNOWN)
+	{
+	  /* Enforce C626.  */
+	  if (ts.type != tail->expr->ts.type)
+	    {
+	      gfc_error ("Type of entity at %L is type incompatible with "
+			 "typespec", &tail->expr->where);
+	      goto cleanup;
+	    }
+
+	  /* Enforce C627.  */
+	  if (ts.kind != tail->expr->ts.kind)
+	    {
+	      gfc_error ("Kind type parameter for entity at %L differs from "
+			 "the kind type parameter of the typespec",
+			 &tail->expr->where);
+	      goto cleanup;
+	    }
+	}
+
       if (tail->expr->ts.type == BT_DERIVED)
 	tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
 
       /* FIXME: disable the checking on derived types and arrays.  */
-      if (!(tail->expr->ref
+      b1 = !(tail->expr->ref
 	   && (tail->expr->ref->type == REF_COMPONENT
-	       || tail->expr->ref->type == REF_ARRAY)) 
-	  && tail->expr->symtree->n.sym
-	  && !(tail->expr->symtree->n.sym->attr.allocatable
-	       || tail->expr->symtree->n.sym->attr.pointer
-	       || tail->expr->symtree->n.sym->attr.proc_pointer))
+		|| tail->expr->ref->type == REF_ARRAY));
+      b2 = tail->expr->symtree->n.sym
+	   && !(tail->expr->symtree->n.sym->attr.allocatable
+		|| tail->expr->symtree->n.sym->attr.pointer
+		|| tail->expr->symtree->n.sym->attr.proc_pointer);
+      b3 = tail->expr->symtree->n.sym
+	   && tail->expr->symtree->n.sym->ns
+	   && tail->expr->symtree->n.sym->ns->proc_name
+	   && (tail->expr->symtree->n.sym->ns->proc_name->attr.allocatable
+		|| tail->expr->symtree->n.sym->ns->proc_name->attr.pointer
+		|| tail->expr->symtree->n.sym->ns->proc_name->attr.proc_pointer);
+      if (b1 && b2 && !b3)
 	{
 	  gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
 		     "or an allocatable variable");
@@ -2290,10 +2482,10 @@ alloc_opt_list:
 	goto cleanup;
       if (m == MATCH_YES)
 	{
+	  /* Enforce C630.  */
 	  if (saw_stat)
 	    {
 	      gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
-	      gfc_free_expr (tmp);
 	      goto cleanup;
 	    }
 
@@ -2312,14 +2504,14 @@ alloc_opt_list:
 	goto cleanup;
       if (m == MATCH_YES)
 	{
-	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
+	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L",
 			      &tmp->where) == FAILURE)
 	    goto cleanup;
 
+	  /* Enforce C630.  */
 	  if (saw_errmsg)
 	    {
 	      gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
-	      gfc_free_expr (tmp);
 	      goto cleanup;
 	    }
 
@@ -2330,6 +2522,66 @@ alloc_opt_list:
 	    goto alloc_opt_list;
 	}
 
+      m = gfc_match (" source = %e", &tmp);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_YES)
+	{
+	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L",
+			      &tmp->where) == FAILURE)
+	    goto cleanup;
+
+	  /* Enforce C630.  */
+	  if (saw_source)
+	    {
+	      gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
+	      goto cleanup;
+	    }
+
+	  /* The next 3 conditionals check C631.  */
+	  if (ts.type != BT_UNKNOWN)
+	    {
+	      gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
+			 &tmp->where, &old_locus);
+	      goto cleanup;
+	    }
+
+	  if (head->next)
+	    {
+ 	      gfc_error ("SOURCE tag at %L requires only a single entity in "
+			 "the allocation-list", &tmp->where);
+	      goto cleanup;
+            }
+
+	  gfc_resolve_expr (tmp);
+
+	  if (head->expr->ts.type != tmp->ts.type)
+	    {
+	      gfc_error ("Type of entity at %L is type incompatible with "
+			 "source-expr at %L", &head->expr->where, &tmp->where);
+	      goto cleanup;
+	    }
+
+	  /* Check C633.  */
+	  if (tmp->ts.kind != head->expr->ts.kind)
+	    {
+	      gfc_error ("The allocate-object at %L and the source-expr at %L "
+			 "shall have the same kind type parameter",
+			 &head->expr->where, &tmp->where);
+	      goto cleanup;
+	    }
+
+	  /* Check C632 and restriction following Note 6.18.  */
+	  if (tmp->rank > 0 && conformable_arrays (tmp, head->expr) == FAILURE)
+	    goto cleanup;
+
+	  source = tmp;
+	  saw_source = true;
+
+	  if (gfc_match_char (',') == MATCH_YES)
+	    goto alloc_opt_list;
+	}
+
 	gfc_gobble_whitespace ();
 
 	if (gfc_peek_char () == ')')
@@ -2343,6 +2595,7 @@ alloc_opt_list:
   new_st.op = EXEC_ALLOCATE;
   new_st.expr1 = stat;
   new_st.expr2 = errmsg;
+  new_st.expr3 = source;
   new_st.ext.alloc_list = head;
 
   return MATCH_YES;
@@ -2352,7 +2605,9 @@ syntax:
 
 cleanup:
   gfc_free_expr (errmsg);
+  gfc_free_expr (source);
   gfc_free_expr (stat);
+  gfc_free_expr (tmp);
   gfc_free_alloc_list (head);
   return MATCH_ERROR;
 }
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 1ae841f..6aed99b 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -4081,6 +4081,44 @@ gfc_trans_allocate (gfc_code * code)
       gfc_add_expr_to_block (&block, tmp);
     }
 
+  /* SOURCE block.  Note, by C631, we know that code->ext.alloc_list
+     has a single entity.  */
+  if (code->expr3)
+    {
+      gfc_ref *ref;
+      gfc_array_ref *ar;
+      int n;
+
+      /* If there is a terminating array reference, this is converted
+	 to a full array, so that gfc_trans_assignment can scalarize the
+	 expression for the source.  */
+      for (ref = code->ext.alloc_list->expr->ref; ref; ref = ref->next)
+	{
+	  if (ref->next == NULL)
+	    {
+	      if (ref->type != REF_ARRAY)
+		break;
+
+	      ref->u.ar.type = AR_FULL;
+	      ar = &ref->u.ar;
+	      ar->dimen = ar->as->rank;
+	      for (n = 0; n < ar->dimen; n++)
+		{
+		  ar->dimen_type[n] = DIMEN_RANGE;
+		  gfc_free_expr (ar->start[n]);
+		  gfc_free_expr (ar->end[n]);
+		  gfc_free_expr (ar->stride[n]);
+		  ar->start[n] = NULL;
+		  ar->end[n] = NULL;
+		  ar->stride[n] = NULL;
+		}
+	    }
+	}
+
+      tmp = gfc_trans_assignment (code->ext.alloc_list->expr, code->expr3, false);
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
   return gfc_finish_block (&block);
 }
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 8e60e36..2c8997d 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,7 +1,14 @@
+2009-08-22 Steven K. kargl  <kargl@gcc.gnu.org>
+
+	* gfortran.dg/allocate_alloc_opt_4.f90: New test.
+	* gfortran.dg/allocate_alloc_opt_5.f90: New test.
+	* gfortran.dg/allocate_alloc_opt_6.f90: New test.
+
 2009-08-22  Bud Davis  <bdavis9659@sbcglobal.net>
 
 	PR fortran/28039
 	* gfortran.dg/fmt_with_extra.f: new file.
+
 2009-08-21  Maciej W. Rozycki  <macro@codesourcery.com>
 
 	* lib/target-supports.exp
diff --git a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_4.f90 b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_4.f90
new file mode 100644
index 0000000..89052ef
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_4.f90
@@ -0,0 +1,27 @@
+! { dg-do compile }
+program a
+
+  implicit none
+
+  integer n, m(3,3)
+  integer(kind=8) k
+  integer, allocatable :: i(:), j(:)
+  real, allocatable :: x(:)
+
+  n = 42
+  m = n
+  k = 1_8
+
+  allocate(i(4), source=42, source=n) ! { dg-error "Redundant SOURCE tag found" }
+
+  allocate(integer(4) :: i(4), source=n) ! { dg-error "conflicts with the typespec" }
+
+  allocate(i(4), j(n), source=n) ! { dg-error "requires only a single entity" }
+
+  allocate(x(4), source=n) ! { dg-error "type incompatible with" }
+
+  allocate(i(4), source=m) ! { dg-error "must be scalar or have the same rank" }
+
+  allocate(i(4), source=k) ! { dg-error "shall have the same kind type" }
+
+end program a
diff --git a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_5.f90 b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_5.f90
new file mode 100644
index 0000000..d7e3ea9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_5.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+program a
+
+  implicit none
+
+  integer n
+  character(len=70) str
+  integer, allocatable :: i(:)
+
+  n = 42
+  allocate(i(4), source=n) ! { dg-error "Fortran 2003: SOURCE tag" }
+  allocate(i(4), stat=n, errmsg=str) ! { dg-error "Fortran 2003: ERRMSG tag" }
+
+end program a
diff --git a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_6.f90 b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_6.f90
new file mode 100644
index 0000000..d470b42
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_6.f90
@@ -0,0 +1,42 @@
+! { dg-do run }
+program a
+
+  implicit none
+
+  type :: mytype
+    real ::  r
+    integer :: i
+  end type mytype
+  
+  integer n
+  integer, allocatable :: i(:)
+  real z
+  real, allocatable :: x(:)
+  type(mytype), pointer :: t
+
+  n = 42
+  z = 99.
+
+  allocate(i(4), source=n)
+  if (any(i /= 42)) call abort
+
+  allocate(x(4), source=z)
+  if (any(x /= 99.)) call abort
+
+  allocate(t, source=mytype(1.0,2))
+  if (t%r /= 1. .or. t%i /= 2) call abort
+
+  deallocate(i)
+  allocate(i(3), source=(/1, 2, 3/))
+  if (i(1) /= 1 .or. i(2) /= 2 .or. i(3) /= 3) call abort
+
+  call sub1(i)
+
+end program a
+
+subroutine sub1(j)
+   integer, intent(in) :: j(*)
+   integer, allocatable :: k(:)
+   allocate(k(2), source=j(1:2))
+   if (k(1) /= 1 .or. k(2) /= 2) call abort
+end subroutine sub1