OSDN Git Service

(root) / pf3gnuchains / gcc-fork.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
PR fortran/29784
[pf3gnuchains/gcc-fork.git] / gcc / fortran / check.c
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 23955de..b6c47da 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -33,6 +33,21 @@ along with GCC; see the file COPYING3.  If not see
 #include "intrinsic.h"
 
 
+/* Make sure an expression is a scalar.  */
+
+static try
+scalar_check (gfc_expr *e, int n)
+{
+  if (e->rank == 0)
+    return SUCCESS;
+
+  gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
+            gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
+
+  return FAILURE;
+}
+
+
 /* Check the type of an expression.  */
 
 static try
@@ -124,6 +139,9 @@ kind_check (gfc_expr *k, int n, bt type)
   if (type_check (k, n, BT_INTEGER) == FAILURE)
     return FAILURE;
 
+  if (scalar_check (k, n) == FAILURE)
+    return FAILURE;
+
   if (k->expr_type != EXPR_CONSTANT)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant",
@@ -196,21 +214,6 @@ array_check (gfc_expr *e, int n)
 }
 
 
-/* Make sure an expression is a scalar.  */
-
-static try
-scalar_check (gfc_expr *e, int n)
-{
-  if (e->rank == 0)
-    return SUCCESS;
-
-  gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
-            gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
-
-  return FAILURE;
-}
-
-
 /* Make sure two expressions have the same type.  */
 
 static try
@@ -307,9 +310,9 @@ variable_check (gfc_expr *e, int n)
 /* Check the common DIM parameter for correctness.  */
 
 static try
-dim_check (gfc_expr *dim, int n, int optional)
+dim_check (gfc_expr *dim, int n, bool optional)
 {
-  if (optional && dim == NULL)
+  if (dim == NULL)
     return SUCCESS;
 
   if (dim == NULL)
@@ -325,7 +328,7 @@ dim_check (gfc_expr *dim, int n, int optional)
   if (scalar_check (dim, n) == FAILURE)
     return FAILURE;
 
-  if (nonoptional_check (dim, n) == FAILURE)
+  if (!optional && nonoptional_check (dim, n) == FAILURE)
     return FAILURE;
 
   return SUCCESS;
@@ -397,6 +400,42 @@ identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
 }
 
 
+/* Check whether two character expressions have the same length;
+   returns SUCCESS if they have or if the length cannot be determined.  */
+
+static try
+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);
+   else if (a->expr_type == EXPR_CONSTANT
+           && (a->ts.cl == NULL || a->ts.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);
+   else if (b->expr_type == EXPR_CONSTANT
+           && (b->ts.cl == NULL || b->ts.cl->length == NULL))
+     len_b = b->value.character.length;
+   else
+     return SUCCESS;
+
+   if (len_a == len_b)
+     return SUCCESS;
+
+   gfc_error ("Unequal character lengths (%ld and %ld) in %s intrinsic "
+             "at %L", len_a, len_b, name, &a->where);
+   return FAILURE;
+}
+
+
 /***** Check functions *****/
 
 /* Check subroutine suitable for intrinsics taking a real argument and
@@ -443,10 +482,12 @@ gfc_check_abs (gfc_expr *a)
 
 
 try
-gfc_check_achar (gfc_expr *a)
+gfc_check_achar (gfc_expr *a, gfc_expr *kind)
 {
   if (type_check (a, 0, BT_INTEGER) == FAILURE)
     return FAILURE;
+  if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -473,7 +514,7 @@ gfc_check_all_any (gfc_expr *mask, gfc_expr *dim)
   if (logical_array_check (mask, 0) == FAILURE)
     return FAILURE;
 
-  if (dim_check (dim, 1, 1) == FAILURE)
+  if (dim_check (dim, 1, false) == FAILURE)
     return FAILURE;
 
   return SUCCESS;
@@ -790,7 +831,7 @@ gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
 {
   if (logical_array_check (mask, 0) == FAILURE)
     return FAILURE;
-  if (dim_check (dim, 1, 1) == FAILURE)
+  if (dim_check (dim, 1, false) == FAILURE)
     return FAILURE;
   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
     return FAILURE;
@@ -819,7 +860,8 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
       /* TODO: more requirements on shift parameter.  */
     }
 
-  if (dim_check (dim, 2, 1) == FAILURE)
+  /* FIXME (PR33317): Allow optional DIM=.  */
+  if (dim_check (dim, 2, false) == FAILURE)
     return FAILURE;
 
   return SUCCESS;
@@ -915,7 +957,7 @@ gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
 
   if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
     {
-      gfc_error ("different shape for arguments '%s' and '%s' at %L for "
+      gfc_error ("Different shape for arguments '%s' and '%s' at %L for "
                 "intrinsic 'dot_product'", gfc_current_intrinsic_arg[0],
                 gfc_current_intrinsic_arg[1], &vector_a->where);
       return FAILURE;
@@ -953,7 +995,8 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
       /* TODO: more restrictions on boundary.  */
     }
 
-  if (dim_check (dim, 1, 1) == FAILURE)
+  /* FIXME (PR33317): Allow optional DIM=.  */
+  if (dim_check (dim, 4, false) == FAILURE)
     return FAILURE;
 
   return SUCCESS;
@@ -1231,14 +1274,8 @@ gfc_check_int (gfc_expr *x, gfc_expr *kind)
   if (numeric_check (x, 0) == FAILURE)
     return FAILURE;
 
-  if (kind != NULL)
-    {
-      if (type_check (kind, 1, BT_INTEGER) == FAILURE)
-       return FAILURE;
-
-      if (scalar_check (kind, 1) == FAILURE)
-       return FAILURE;
-    }
+  if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -1363,7 +1400,7 @@ gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 
   if (dim != NULL)
     {
-      if (dim_check (dim, 1, 1) == FAILURE)
+      if (dim_check (dim, 1, false) == FAILURE)
        return FAILURE;
 
       if (dim_rank_check (dim, array, 1) == FAILURE)
@@ -1639,7 +1676,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
       /* Check for case matrix_a has shape(m), matrix_b has shape (m, k).  */
       if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0))
        {
-         gfc_error ("different shape on dimension 1 for arguments '%s' "
+         gfc_error ("Different shape on dimension 1 for arguments '%s' "
                     "and '%s' at %L for intrinsic matmul",
                     gfc_current_intrinsic_arg[0],
                     gfc_current_intrinsic_arg[1], &matrix_a->where);
@@ -1658,7 +1695,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
         - matrix_a has shape (n,m) and matrix_b has shape (m).  */
       if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0))
        {
-         gfc_error ("different shape on dimension 2 for argument '%s' and "
+         gfc_error ("Different shape on dimension 2 for argument '%s' and "
                     "dimension 1 for argument '%s' at %L for intrinsic "
                     "matmul", gfc_current_intrinsic_arg[0],
                     gfc_current_intrinsic_arg[1], &matrix_a->where);
@@ -1712,7 +1749,7 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
       ap->next->next->expr = m;
     }
 
-  if (dim_check (d, 1, 1) == FAILURE)
+  if (d && dim_check (d, 1, false) == FAILURE)
     return FAILURE;
 
   if (d && dim_rank_check (d, a, 0) == FAILURE)
@@ -1768,7 +1805,7 @@ check_reduction (gfc_actual_arglist *ap)
       ap->next->next->expr = m;
     }
 
-  if (dim_check (d, 1, 1) == FAILURE)
+  if (d && dim_check (d, 1, false) == FAILURE)
     return FAILURE;
 
   if (d && dim_rank_check (d, a, 0) == FAILURE)
@@ -1822,9 +1859,13 @@ gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
   if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
     return FAILURE;
 
+  if (tsource->ts.type == BT_CHARACTER)
+    return check_same_strlen (tsource, fsource, "MERGE");
+
   return SUCCESS;
 }
 
+
 try
 gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
 {
@@ -2336,10 +2377,7 @@ gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 
   if (dim != NULL)
     {
-      if (type_check (dim, 1, BT_INTEGER) == FAILURE)
-       return FAILURE;
-
-      if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
+      if (dim_check (dim, 1, true) == FAILURE)
        return FAILURE;
 
       if (dim_rank_check (dim, array, 0) == FAILURE)
@@ -2390,7 +2428,10 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
       return FAILURE;
     }
 
-  if (dim_check (dim, 1, 0) == FAILURE)
+  if (dim == NULL)
+    return FAILURE;
+
+  if (dim_check (dim, 1, false) == FAILURE)
     return FAILURE;
 
   if (type_check (ncopies, 2, BT_INTEGER) == FAILURE)
@@ -2671,7 +2712,7 @@ gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 
   if (dim != NULL)
     {
-      if (dim_check (dim, 1, 1) == FAILURE)
+      if (dim_check (dim, 1, false) == FAILURE)
        return FAILURE;
 
       if (dim_rank_check (dim, array, 0) == FAILURE)
@@ -3232,6 +3273,28 @@ gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
 
 
 try
+gfc_check_getarg (gfc_expr *pos, gfc_expr *value)
+{
+  if (type_check (pos, 0, BT_INTEGER) == FAILURE)
+    return FAILURE;
+
+  if (pos->ts.kind > gfc_default_integer_kind)
+    {
+      gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind "
+                "not wider than the default kind (%d)",
+                gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+                &pos->where, gfc_default_integer_kind);
+      return FAILURE;
+    }
+
+  if (type_check (value, 1, BT_CHARACTER) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+try
 gfc_check_getlog (gfc_expr *msg)
 {
   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
About OSDN
Find Software
Develop Software
Help