2010-04-12 Jerry DeLisle <jvdelisle@gcc.gnu.org>

[pf3gnuchains/gcc-fork.git] / gcc / fortran / check.c

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index e19f812..bd2791a 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -31,6 +31,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "flags.h"
 #include "gfortran.h"
 #include "intrinsic.h"
+#include "constructor.h"
 
 
 /* Make sure an expression is a scalar.  */
@@ -410,20 +411,20 @@ gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
    long len_a, len_b;
    len_a = len_b = -1;
 
-   if (a->ts.cl && a->ts.cl->length
-       && a->ts.cl->length->expr_type == EXPR_CONSTANT)
-     len_a = mpz_get_si (a->ts.cl->length->value.integer);
+   if (a->ts.u.cl && a->ts.u.cl->length
+       && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+     len_a = mpz_get_si (a->ts.u.cl->length->value.integer);
    else if (a->expr_type == EXPR_CONSTANT
-           && (a->ts.cl == NULL || a->ts.cl->length == NULL))
+           && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
      len_a = a->value.character.length;
    else
      return SUCCESS;
 
-   if (b->ts.cl && b->ts.cl->length
-       && b->ts.cl->length->expr_type == EXPR_CONSTANT)
-     len_b = mpz_get_si (b->ts.cl->length->value.integer);
+   if (b->ts.u.cl && b->ts.u.cl->length
+       && b->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+     len_b = mpz_get_si (b->ts.u.cl->length->value.integer);
    else if (b->expr_type == EXPR_CONSTANT
-           && (b->ts.cl == NULL || b->ts.cl->length == NULL))
+           && (b->ts.u.cl == NULL || b->ts.u.cl->length == NULL))
      len_b = b->value.character.length;
    else
      return SUCCESS;
@@ -546,9 +547,6 @@ gfc_check_allocated (gfc_expr *array)
       return FAILURE;
     }
 
-  if (array_check (array, 0) == FAILURE)
-    return FAILURE;
-
   return SUCCESS;
 }
 
@@ -602,10 +600,8 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
 
   where = &pointer->where;
 
-  if (pointer->expr_type == EXPR_VARIABLE)
-    attr1 = gfc_variable_attr (pointer, NULL);
-  else if (pointer->expr_type == EXPR_FUNCTION)
-    attr1 = pointer->symtree->n.sym->attr;
+  if (pointer->expr_type == EXPR_VARIABLE || pointer->expr_type == EXPR_FUNCTION)
+    attr1 = gfc_expr_attr (pointer);
   else if (pointer->expr_type == EXPR_NULL)
     goto null_arg;
   else
@@ -627,10 +623,8 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
   if (target->expr_type == EXPR_NULL)
     goto null_arg;
 
-  if (target->expr_type == EXPR_VARIABLE)
-    attr2 = gfc_variable_attr (target, NULL);
-  else if (target->expr_type == EXPR_FUNCTION)
-    attr2 = target->symtree->n.sym->attr;
+  if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
+    attr2 = gfc_expr_attr (target);
   else
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
@@ -676,6 +670,19 @@ null_arg:
 
 
 gfc_try
+gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
+{
+  /* gfc_notify_std would be a wast of time as the return value
+     is seemingly used only for the generic resolution.  The error
+     will be: Too many arguments.  */
+  if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
+    return FAILURE;
+
+  return gfc_check_atan2 (y, x);
+}
+
+
+gfc_try
 gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
 {
   if (type_check (y, 0, BT_REAL) == FAILURE)
@@ -1387,12 +1394,12 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
        {
          /* Check that the argument is length one.  Non-constant lengths
             can't be checked here, so assume they are ok.  */
-         if (c->ts.cl && c->ts.cl->length)
+         if (c->ts.u.cl && c->ts.u.cl->length)
            {
              /* If we already have a length for this expression then use it.  */
-             if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
+             if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT)
                return SUCCESS;
-             i = mpz_get_si (c->ts.cl->length->value.integer);
+             i = mpz_get_si (c->ts.u.cl->length->value.integer);
            }
          else 
            return SUCCESS;
@@ -2125,9 +2132,6 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
   if (variable_check (from, 0) == FAILURE)
     return FAILURE;
 
-  if (array_check (from, 0) == FAILURE)
-    return FAILURE;
-
   attr = gfc_variable_attr (from, NULL);
   if (!attr.allocatable)
     {
@@ -2140,9 +2144,6 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
   if (variable_check (to, 0) == FAILURE)
     return FAILURE;
 
-  if (array_check (to, 0) == FAILURE)
-    return FAILURE;
-
   attr = gfc_variable_attr (to, NULL);
   if (!attr.allocatable)
     {
@@ -2152,7 +2153,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
       return FAILURE;
     }
 
-  if (same_type_check (from, 0, to, 1) == FAILURE)
+  if (same_type_check (to, 1, from, 0) == FAILURE)
     return FAILURE;
 
   if (to->rank != from->rank)
@@ -2266,7 +2267,8 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
 
          if (mask->expr_type == EXPR_ARRAY)
            {
-             gfc_constructor *mask_ctor = mask->value.constructor;
+             gfc_constructor *mask_ctor;
+             mask_ctor = gfc_constructor_first (mask->value.constructor);
              while (mask_ctor)
                {
                  if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
@@ -2278,7 +2280,7 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
                  if (mask_ctor->expr->value.logical)
                    mask_true_values++;
 
-                 mask_ctor = mask_ctor->next;
+                 mask_ctor = gfc_constructor_next (mask_ctor);
                }
            }
          else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
@@ -2508,12 +2510,9 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
       int i, extent;
       for (i = 0; i < shape_size; ++i)
        {
-         e = gfc_get_array_element (shape, i);
+         e = gfc_constructor_lookup_expr (shape->value.constructor, i);
          if (e->expr_type != EXPR_CONSTANT)
-           {
-             gfc_free_expr (e);
-             continue;
-           }
+           continue;
 
          gfc_extract_int (e, &extent);
          if (extent < 0)
@@ -2523,8 +2522,6 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
                         gfc_current_intrinsic, &e->where, extent);
              return FAILURE;
            }
-
-         gfc_free_expr (e);
        }
     }
 
@@ -2569,12 +2566,9 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
 
          for (i = 1; i <= order_size; ++i)
            {
-             e = gfc_get_array_element (order, i-1);
+             e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
              if (e->expr_type != EXPR_CONSTANT)
-               {
-                 gfc_free_expr (e);
-                 continue;
-               }
+               continue;
 
              gfc_extract_int (e, &dim);
 
@@ -2597,7 +2591,6 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
                }
 
              perm[dim-1] = 1;
-             gfc_free_expr (e);
            }
        }
     }
@@ -2613,9 +2606,10 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
          gfc_constructor *c;
          bool test;
 
-         c = shape->value.constructor;
+         
          mpz_init_set_ui (size, 1);
-         for (; c; c = c->next)
+         for (c = gfc_constructor_first (shape->value.constructor);
+              c; c = gfc_constructor_next (c))
            mpz_mul (size, size, c->expr->value.integer);
 
          test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
@@ -2637,6 +2631,46 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
 
 
 gfc_try
+gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
+{
+
+  if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L "
+                "must be of a derived type", gfc_current_intrinsic_arg[0],
+                gfc_current_intrinsic, &a->where);
+      return FAILURE;
+    }
+
+  if (!gfc_type_is_extensible (a->ts.u.derived))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L "
+                "must be of an extensible type", gfc_current_intrinsic_arg[0],
+                gfc_current_intrinsic, &a->where);
+      return FAILURE;
+    }
+
+  if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L "
+                "must be of a derived type", gfc_current_intrinsic_arg[1],
+                gfc_current_intrinsic, &b->where);
+      return FAILURE;
+    }
+
+  if (!gfc_type_is_extensible (b->ts.u.derived))
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L "
+                "must be of an extensible type", gfc_current_intrinsic_arg[1],
+                gfc_current_intrinsic, &b->where);
+      return FAILURE;
+    }
+
+  return SUCCESS;
+}
+
+
+gfc_try
 gfc_check_scale (gfc_expr *x, gfc_expr *i)
 {
   if (type_check (x, 0, BT_REAL) == FAILURE)
@@ -3184,7 +3218,8 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
       && gfc_array_size (vector, &vector_size) == SUCCESS)
     {
       int mask_true_count = 0;
-      gfc_constructor *mask_ctor = mask->value.constructor;
+      gfc_constructor *mask_ctor;
+      mask_ctor = gfc_constructor_first (mask->value.constructor);
       while (mask_ctor)
        {
          if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
@@ -3196,7 +3231,7 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
          if (mask_ctor->expr->value.logical)
            mask_true_count++;
 
-         mask_ctor = mask_ctor->next;
+         mask_ctor = gfc_constructor_next (mask_ctor);
        }
 
       if (mpz_get_si (vector_size) < mask_true_count)