PR fortran/30964

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

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index e792773..23955de 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -786,12 +786,18 @@ gfc_check_complex (gfc_expr *x, gfc_expr *y)
 
 
 try
-gfc_check_count (gfc_expr *mask, gfc_expr *dim)
+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)
     return FAILURE;
+  if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+    return FAILURE;
+  if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+                             "with KIND argument at %L",
+                             gfc_current_intrinsic, &kind->where) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -1088,13 +1094,21 @@ gfc_check_ibset (gfc_expr *i, gfc_expr *pos)
 
 
 try
-gfc_check_ichar_iachar (gfc_expr *c)
+gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
 {
   int i;
 
   if (type_check (c, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
 
+  if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
+    return FAILURE;
+
+  if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+                             "with KIND argument at %L",
+                             gfc_current_intrinsic, &kind->where) == FAILURE)
+    return FAILURE;
+
   if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
     {
       gfc_expr *start;
@@ -1181,16 +1195,23 @@ gfc_check_ieor (gfc_expr *i, gfc_expr *j)
 
 
 try
-gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back)
+gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
+                gfc_expr *kind)
 {
   if (type_check (string, 0, BT_CHARACTER) == FAILURE
       || type_check (substring, 1, BT_CHARACTER) == FAILURE)
     return FAILURE;
 
-
   if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
     return FAILURE;
 
+  if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
+    return FAILURE;
+  if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+                             "with KIND argument at %L",
+                             gfc_current_intrinsic, &kind->where) == FAILURE)
+    return FAILURE;
+
   if (string->ts.kind != substring->ts.kind)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
@@ -1335,7 +1356,7 @@ gfc_check_kind (gfc_expr *x)
 
 
 try
-gfc_check_lbound (gfc_expr *array, gfc_expr *dim)
+gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
   if (array_check (array, 0) == FAILURE)
     return FAILURE;
@@ -1348,6 +1369,31 @@ gfc_check_lbound (gfc_expr *array, gfc_expr *dim)
       if (dim_rank_check (dim, array, 1) == FAILURE)
        return FAILURE;
     }
+
+  if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+    return FAILURE;
+  if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+                             "with KIND argument at %L",
+                             gfc_current_intrinsic, &kind->where) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+try
+gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
+{
+  if (type_check (s, 0, BT_CHARACTER) == FAILURE)
+    return FAILURE;
+
+  if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
+    return FAILURE;
+  if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+                             "with KIND argument at %L",
+                             gfc_current_intrinsic, &kind->where) == FAILURE)
+    return FAILURE;
+
   return SUCCESS;
 }
 
@@ -1512,10 +1558,17 @@ gfc_check_min_max (gfc_actual_arglist *arg)
 
   x = arg->expr;
 
-  if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
+  if (x->ts.type == BT_CHARACTER)
     {
-      gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER "
-                "or REAL", gfc_current_intrinsic, &x->where);
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+                         "with CHARACTER argument at %L",
+                         gfc_current_intrinsic, &x->where) == FAILURE)
+       return FAILURE;
+    }
+  else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
+    {
+      gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
+                "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
       return FAILURE;
     }
 
@@ -2153,7 +2206,7 @@ gfc_check_scale (gfc_expr *x, gfc_expr *i)
 
 
 try
-gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z)
+gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
 {
   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
@@ -2164,6 +2217,13 @@ gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z)
   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
     return FAILURE;
 
+  if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
+    return FAILURE;
+  if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+                             "with KIND argument at %L",
+                             gfc_current_intrinsic, &kind->where) == FAILURE)
+    return FAILURE;
+
   if (same_type_check (x, 0, y, 1) == FAILURE)
     return FAILURE;
 
@@ -2269,7 +2329,7 @@ gfc_check_sign (gfc_expr *a, gfc_expr *b)
 
 
 try
-gfc_check_size (gfc_expr *array, gfc_expr *dim)
+gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
   if (array_check (array, 0) == FAILURE)
     return FAILURE;
@@ -2286,6 +2346,14 @@ gfc_check_size (gfc_expr *array, gfc_expr *dim)
        return FAILURE;
     }
 
+  if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+    return FAILURE;
+  if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+                             "with KIND argument at %L",
+                             gfc_current_intrinsic, &kind->where) == FAILURE)
+    return FAILURE;
+
+
   return SUCCESS;
 }
 
@@ -2596,7 +2664,7 @@ gfc_check_transpose (gfc_expr *matrix)
 
 
 try
-gfc_check_ubound (gfc_expr *array, gfc_expr *dim)
+gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
   if (array_check (array, 0) == FAILURE)
     return FAILURE;
@@ -2610,6 +2678,13 @@ gfc_check_ubound (gfc_expr *array, gfc_expr *dim)
        return FAILURE;
     }
 
+  if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+    return FAILURE;
+  if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+                             "with KIND argument at %L",
+                             gfc_current_intrinsic, &kind->where) == FAILURE)
+    return FAILURE;
+
   return SUCCESS;
 }
 
@@ -2634,7 +2709,7 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
 
 
 try
-gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z)
+gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
 {
   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
@@ -2645,6 +2720,13 @@ gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z)
   if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE)
     return FAILURE;
 
+  if (kind_check (kind, 3, BT_INTEGER) == FAILURE)
+    return FAILURE;
+  if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+                             "with KIND argument at %L",
+                             gfc_current_intrinsic, &kind->where) == FAILURE)
+    return FAILURE;
+
   return SUCCESS;
 }
 
@@ -2798,8 +2880,15 @@ gfc_check_random_number (gfc_expr *harvest)
 try
 gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
 {
+  unsigned int nargs = 0;
+  locus *where = NULL;
+
   if (size != NULL)
     {
+      if (size->expr_type != EXPR_VARIABLE
+         || !size->symtree->n.sym->attr.optional)
+       nargs++;
+
       if (scalar_check (size, 0) == FAILURE)
        return FAILURE;
 
@@ -2815,10 +2904,12 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
 
   if (put != NULL)
     {
-
-      if (size != NULL)
-       gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
-                   &put->where);
+      if (put->expr_type != EXPR_VARIABLE
+         || !put->symtree->n.sym->attr.optional)
+       {
+         nargs++;
+         where = &put->where;
+       }
 
       if (array_check (put, 1) == FAILURE)
        return FAILURE;
@@ -2835,10 +2926,12 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
 
   if (get != NULL)
     {
-
-      if (size != NULL || put != NULL)
-       gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic,
-                  &get->where);
+      if (get->expr_type != EXPR_VARIABLE
+         || !get->symtree->n.sym->attr.optional)
+       {
+         nargs++;
+         where = &get->where;
+       }
 
       if (array_check (get, 2) == FAILURE)
        return FAILURE;
@@ -2856,6 +2949,10 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
        return FAILURE;
     }
 
+  /* RANDOM_SEED may not have more than one non-optional argument.  */
+  if (nargs > 1)
+    gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where);
+
   return SUCCESS;
 }