re PR fortran/29600 ([F03] MINLOC and MAXLOC take an optional KIND argument)

	PR fortran/29600

	* intrinsic.c (add_functions): Add KIND arguments to COUNT,
	IACHAR, ICHAR, INDEX, LBOUND, LEN, LEN_TRIM, SCAN, SIZE, UBOUND
	and VERIFY.
	* iresolve.c (gfc_resolve_count): Add kind argument.
	(gfc_resolve_iachar): New function.
	(gfc_resolve_ichar): Add kind argument.
	(gfc_resolve_index_func): Likewise.
	(gfc_resolve_lbound): Likewise.
	(gfc_resolve_len): Likewise.
	(gfc_resolve_len_trim): Likewise.
	(gfc_resolve_scan): Likewise.
	(gfc_resolve_size): New function.
	(gfc_resolve_ubound): Add kind argument.
	(gfc_resolve_verify): Likewise.
	* trans-decl.c (gfc_get_extern_function_decl): Allow specific
	intrinsics to have 4 arguments.
	* check.c (gfc_check_count): Add kind argument.
	(gfc_check_ichar_iachar): Likewise.
	(gfc_check_index): Likewise.
	(gfc_check_lbound): Likewise.
	(gfc_check_len_lentrim): New function.
	(gfc_check_scan): Add kind argument.
	(gfc_check_size): Likewise.
	(gfc_check_ubound): Likewise.
	(gfc_check_verify): Likewise.
	* intrinsic.texi: Update documentation for COUNT, IACHAR, ICHAR,
	INDEX, LBOUND, LEN, LEN_TRIM, SCAN, SIZE, UBOUND and VERIFY.
	* simplify.c (get_kind): Whitespace fix.
	(int_expr_with_kind): New function.
	(gfc_simplify_iachar): Add kind argument.
	(gfc_simplify_iachar): Likewise.
	(gfc_simplify_ichar): Likewise.
	(gfc_simplify_index): Likewise.
	(simplify_bound_dim): Likewise.
	(simplify_bound): Likewise.
	(gfc_simplify_lbound): Likewise.
	(gfc_simplify_len): Likewise.
	(gfc_simplify_len_trim): Likewise.
	(gfc_simplify_scan): Likewise.
	(gfc_simplify_shape): Pass NULL as kind argument to gfc_simplify_size.
	(gfc_simplify_size): Add kind argument.
	(gfc_simplify_ubound): Likewise.
	(gfc_simplify_verify): Likewise.
	* intrinsic.h: Update prototypes and add new ones.
	* trans-intrinsic.c (gfc_conv_intrinsic_index): Rename into
	gfc_conv_intrinsic_index_scan_verify.
	(gfc_conv_intrinsic_scan, gfc_conv_intrinsic_verify): Remove.
	(gfc_conv_intrinsic_function): Call
	gfc_conv_intrinsic_index_scan_verify to translate the INDEX,
	SCAN and VERIFY intrinsics.

	* gfortran.dg/intrinsics_kind_argument_1.f90: New test.
	* gfortran.dg/pure_dummy_length_1.f90: Adapt to new error wording.

From-SVN: r127380

1 files changed, 70 insertions, 18 deletions

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index d0a73bf..e318615 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -520,10 +520,13 @@ gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
 
 
 void
-gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim)
+gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
 {
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
 
   if (dim != NULL)
     {
@@ -856,10 +859,25 @@ gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED)
 
 
 void
-gfc_resolve_ichar (gfc_expr *f, gfc_expr *c)
+gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
 {
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
+}
+
+
+void
+gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
   f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind);
 }
 
@@ -920,12 +938,16 @@ gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j)
 
 void
 gfc_resolve_index_func (gfc_expr *f, gfc_expr *str,
-			gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back)
+			gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back,
+			gfc_expr *kind)
 {
   gfc_typespec ts;
 
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
 
   if (back && back->ts.kind != gfc_default_integer_kind)
     {
@@ -1057,12 +1079,15 @@ gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
 
 
 void
-gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
   static char lbound[] = "__lbound";
 
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
 
   if (dim == NULL)
     {
@@ -1076,10 +1101,13 @@ gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
 
 
 void
-gfc_resolve_len (gfc_expr *f, gfc_expr *string)
+gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
 {
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
   f->value.function.name
     = gfc_get_string ("__len_%d_i%d", string->ts.kind,
 		      gfc_default_integer_kind);
@@ -1087,10 +1115,13 @@ gfc_resolve_len (gfc_expr *f, gfc_expr *string)
 
 
 void
-gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string)
+gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
 {
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
   f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind);
 }
 
@@ -1776,10 +1807,13 @@ gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i)
 void
 gfc_resolve_scan (gfc_expr *f, gfc_expr *string,
 		  gfc_expr *set ATTRIBUTE_UNUSED,
-		  gfc_expr *back ATTRIBUTE_UNUSED)
+		  gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
 {
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
   f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind);
 }
 
@@ -1873,6 +1907,18 @@ gfc_resolve_sinh (gfc_expr *f, gfc_expr *x)
 
 
 void
+gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
+		  gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind)
+{
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+}
+
+
+void
 gfc_resolve_spacing (gfc_expr *f, gfc_expr *x)
 {
   int k; 
@@ -2265,12 +2311,15 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
 
 
 void
-gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
   static char ubound[] = "__ubound";
 
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
 
   if (dim == NULL)
     {
@@ -2343,10 +2392,13 @@ gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
 void
 gfc_resolve_verify (gfc_expr *f, gfc_expr *string,
 		    gfc_expr *set ATTRIBUTE_UNUSED,
-		    gfc_expr *back ATTRIBUTE_UNUSED)
+		    gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind)
 {
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
   f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind);
 }