[PATCH] Implementation for ALLOCATE(..., SOURCE=expression)

[Steve Kargl <sgk at troutmask dot apl dot washington dot edu>]

All,

First, a big 'thank you' to pault for the trans-stmt.c portion
of the patch.  I was stuck on translation to trees for a long
time; something about a forest and too many trees.

The attached patch implements the SOURCE= tag in an ALLOCATE
statement.  The three testcases show simple uses of this tag.

The patch also includes the parsing/matching of an optional
intrinsic-type-spec.  This patch does not include parsing/matching
of a derived-type-spec, which will be the subject of a follow-up
patch and is most likely required by Janus's CLASS() work.  To
succeed with the intrinsic-type-spec matching, I introduced a new
function to match only F2003 intrinsic-types-specs, which is a
stripped down version of gfc_match_type_spec().  gfc_match_type_spec()
has grown too many special cases and it's use in gfc_match_allocation()
led to 2 regression that I simply could not fix.  Note, when I 
say F2003 intrinsic-type-spec, this means neither BYTE nor 
REAL*4-like types are matched.  Given that this is a F2003 feature,
there is no need for backwards compatibility.  If someone is
stupid and does ALLOCATE(REAL*4 :: x(4)), they should be beaten
severely; unfortunately, gfortran only issues an error.

Regression tested on i686-*-freebsd.

OK for trunk?

2009-08-16  Steven G. Kargl  <kargl@gcc.gnu.org>

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

2009-08-16  Steven G. Kargl  <kargl@gcc.gnu.org>
	    Paul Thomas  <pault@gcc.gnu.org>

	* fortran/decl.c (match_char_spec): Rename function to
	gfc_match_char_spec and remove static qualifier.
	(gfc_match_type_spec, gfc_match_implicit): Update for name change.
	* fortran/gfortran.h (gfc_code): Add *expr3 struct member.
	Add prototype for gfc_match_char_spec().
	*gcc/fortran/trans-stmt.c (gfc_trans_allocate):  Translate the
	SOURCE= tag.
	* fortran/match.c (match_intrinsic_typespec):  New function to
	match a F2003 intrinsic-type-spec.
	(conformable_arrays):  New function to check conformability of
 	allocation-object and source-expr.
	(gfc_match_allocate): Add parsing/matching of SOURCE= tag.  Add
	checking for constraints.  Add parsing/matching of an optional
	F2003 intrinsic-type-spec.  Cleanup tmp gfc_expr on failures.
-- 
Steve

Index: gcc/testsuite/gfortran.dg/allocate_alloc_opt_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_alloc_opt_6.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_6.f90	(revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/allocate_alloc_opt_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_alloc_opt_5.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_5.f90	(revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/allocate_alloc_opt_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_alloc_opt_4.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_4.f90	(revision 0)
@@ -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
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 150724)
+++ gcc/fortran/decl.c	(working copy)
@@ -2103,11 +2103,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;
@@ -2323,7 +2324,7 @@ gfc_match_type_spec (gfc_typespec *ts, i
     {
       ts->type = BT_CHARACTER;
       if (implicit_flag == 0)
-	return match_char_spec (ts);
+	return gfc_match_char_spec (ts);
       else
 	return MATCH_YES;
     }
@@ -2635,7 +2636,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);
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 150724)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -1971,7 +1971,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;  */
@@ -2178,6 +2178,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);
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(revision 150724)
+++ gcc/fortran/trans-stmt.c	(working copy)
@@ -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);
 }
 
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 150724)
+++ gcc/fortran/match.c	(working copy)
@@ -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.derived = gfc_use_derived (tail->expr->ts.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;
 }