2009-10-23 Janus Weil <janus@gcc.gnu.org>

	PR fortran/41758
	* match.c (conformable_arrays): Move to resolve.c.
	(gfc_match_allocate): Don't resolve SOURCE expr yet, and move some
	checks to resolve_allocate_expr.
	* resolve.c (conformable_arrays): Moved here from match.c.
	(resolve_allocate_expr): Moved some checks here from gfc_match_allocate.
	(resolve_code): Resolve SOURCE tag for ALLOCATE expressions.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153494 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6a44080..0668a68 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2009-10-23  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/41758
+       * match.c (conformable_arrays): Move to resolve.c.
+       (gfc_match_allocate): Don't resolve SOURCE expr yet, and move some
+       checks to resolve_allocate_expr.
+       * resolve.c (conformable_arrays): Moved here from match.c.
+       (resolve_allocate_expr): Moved some checks here from gfc_match_allocate.
+       (resolve_code): Resolve SOURCE tag for ALLOCATE expressions.
+

 2009-10-22  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/41781
 2009-10-22  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/41781

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 0a418c8..24e292b 100644 (file)
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2388,58 +2388,6 @@ char_selector:
 }
 
 
 }
 
 

-/* 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
 /* Match an ALLOCATE statement.  */
 
 match


@@ -2620,7 +2568,7 @@ alloc_opt_list:
              goto cleanup;
            }
 
              goto cleanup;
            }
 

-         /* The next 3 conditionals check C631.  */
+         /* The next 2 conditionals check C631.  */

          if (ts.type != BT_UNKNOWN)
            {
              gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
          if (ts.type != BT_UNKNOWN)
            {
              gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",


@@ -2635,28 +2583,6 @@ alloc_opt_list:
              goto cleanup;
             }
 
              goto cleanup;
             }
 

-         gfc_resolve_expr (tmp);
-
-         if (!gfc_type_compatible (&head->expr->ts, &tmp->ts))
-           {
-             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;
 
          source = tmp;
          saw_source = true;
 

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4c10a0c..b17e8fe 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5958,6 +5958,58 @@ gfc_expr_to_initialize (gfc_expr *e)
 }
 
 
 }
 
 

+/* Used in resolve_allocate_expr 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;
+}
+
+

 /* Resolve the expression in an ALLOCATE statement, doing the additional
    checks to see whether the expression is OK or not.  The expression must
    have a trailing array reference that gives the size of the array.  */
 /* Resolve the expression in an ALLOCATE statement, doing the additional
    checks to see whether the expression is OK or not.  The expression must
    have a trailing array reference that gives the size of the array.  */


@@ -6057,7 +6109,32 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
       return FAILURE;
     }
 
       return FAILURE;
     }
 

-  if (is_abstract && !code->expr3 && code->ext.alloc.ts.type == BT_UNKNOWN)
+  /* Some checks for the SOURCE tag.  */
+  if (code->expr3)
+    {
+      /* Check F03:C631.  */
+      if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
+       {
+         gfc_error ("Type of entity at %L is type incompatible with "
+                     "source-expr at %L", &e->where, &code->expr3->where);
+         return FAILURE;
+       }
+
+      /* Check F03:C632 and restriction following Note 6.18.  */
+      if (code->expr3->rank > 0
+         && conformable_arrays (code->expr3, e) == FAILURE)
+       return FAILURE;
+
+      /* Check F03:C633.  */
+      if (code->expr3->ts.kind != e->ts.kind)
+       {
+         gfc_error ("The allocate-object at %L and the source-expr at %L "
+                     "shall have the same kind type parameter",
+                     &e->where, &code->expr3->where);
+         return FAILURE;
+       }
+    }
+  else if (is_abstract&& 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 "
     {
       gcc_assert (e->ts.type == BT_CLASS);
       gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "


@@ -7734,6 +7811,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
       if (gfc_resolve_expr (code->expr2) == FAILURE)
        t = FAILURE;
 
       if (gfc_resolve_expr (code->expr2) == FAILURE)
        t = FAILURE;
 

+      if (code->op == EXEC_ALLOCATE
+         && gfc_resolve_expr (code->expr3) == FAILURE)
+       t = FAILURE;
+

       switch (code->op)
        {
        case EXEC_NOP:
       switch (code->op)
        {
        case EXEC_NOP: