intrinsic.c (add_functions): Add SELECTED_CHAR_KIND intrinsic.

	* intrinsic.c (add_functions): Add SELECTED_CHAR_KIND intrinsic.
	* intrinsic.h (gfc_check_selected_char_kind,
	gfc_simplify_selected_char_kind): New prototypes.
	* gfortran.h (gfc_isym_id): Add GFC_ISYM_SC_KIND.
	* trans.h (gfor_fndecl_sc_kind): New function decl.
	* trans-decl.c (gfor_fndecl_sc_kind): Build new decl.
	* arith.c (gfc_compare_with_Cstring): New function.
	* arith.h (gfc_compare_with_Cstring): New prototype.
	* check.c (gfc_check_selected_char_kind): New function.
	* primary.c (match_string_constant, match_kind_param): Mark
	symbols used as literal constant kind param as referenced.
	* trans-intrinsic.c (gfc_conv_intrinsic_sc_kind): New function.
	(gfc_conv_intrinsic_function): Call gfc_conv_intrinsic_sc_kind.
	* intrinsic.texi (SELECTED_CHAR_KIND): Document new intrinsic.
	* simplify.c (gfc_simplify_selected_char_kind): New function.

	* intrinsics/selected_char_kind.c: New file.
	* Makefile.am: Add intrinsics/selected_char_kind.c.
	* Makefile.in: Regenerate.

	* gfortran.dg/selected_char_kind_1.f90: New test.
	* gfortran.dg/selected_char_kind_2.f90: New test.
	* gfortran.dg/selected_char_kind_3.f90: New test.

From-SVN: r134839

17 files changed, 278 insertions, 14 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 13fb052..2abc96d 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,8 +1,26 @@
+2008-04-30  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* intrinsic.c (add_functions): Add SELECTED_CHAR_KIND intrinsic.
+	* intrinsic.h (gfc_check_selected_char_kind,
+	gfc_simplify_selected_char_kind): New prototypes.
+	* gfortran.h (gfc_isym_id): Add GFC_ISYM_SC_KIND.
+	* trans.h (gfor_fndecl_sc_kind): New function decl.
+	* trans-decl.c (gfor_fndecl_sc_kind): Build new decl.
+	* arith.c (gfc_compare_with_Cstring): New function.
+	* arith.h (gfc_compare_with_Cstring): New prototype.
+	* check.c (gfc_check_selected_char_kind): New function.
+	* primary.c (match_string_constant, match_kind_param): Mark
+	symbols used as literal constant kind param as referenced.
+	* trans-intrinsic.c (gfc_conv_intrinsic_sc_kind): New function.
+	(gfc_conv_intrinsic_function): Call gfc_conv_intrinsic_sc_kind.
+	* intrinsic.texi (SELECTED_CHAR_KIND): Document new intrinsic.
+	* simplify.c (gfc_simplify_selected_char_kind): New function.
+
 2008-04-28  Paul Thomas  <pault@gcc.gnu.org>
 
-       PR fortran/35997
-       * module.c (find_symbol): Do not return a result for a symbol
-       that has been renamed in another module.
+	PR fortran/35997
+	* module.c (find_symbol): Do not return a result for a symbol
+	that has been renamed in another module.
 
 2008-04-26  George Helffrich <george@gcc.gnu.org>
 
diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c
index fdd6f6a..4b8d45b 100644
--- a/gcc/fortran/arith.c
+++ b/gcc/fortran/arith.c
@@ -1208,7 +1208,7 @@ gfc_compare_string (gfc_expr *a, gfc_expr *b)
   alen = a->value.character.length;
   blen = b->value.character.length;
 
-  len = (alen > blen) ? alen : blen;
+  len = MAX(alen, blen);
 
   for (i = 0; i < len; i++)
     {
@@ -1224,7 +1224,40 @@ gfc_compare_string (gfc_expr *a, gfc_expr *b)
     }
 
   /* Strings are equal */
+  return 0;
+}
+
+
+int
+gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
+{
+  int len, alen, blen, i, ac, bc;
+
+  alen = a->value.character.length;
+  blen = strlen (b);
+
+  len = MAX(alen, blen);
+
+  for (i = 0; i < len; i++)
+    {
+      /* We cast to unsigned char because default char, if it is signed,
+	 would lead to ac < 0 for string[i] > 127.  */
+      ac = (unsigned char) ((i < alen) ? a->value.character.string[i] : ' ');
+      bc = (unsigned char) ((i < blen) ? b[i] : ' ');
 
+      if (!case_sensitive)
+	{
+	  ac = TOLOWER (ac);
+	  bc = TOLOWER (bc);
+	}
+
+      if (ac < bc)
+	return -1;
+      if (ac > bc)
+	return 1;
+    }
+
+  /* Strings are equal */
   return 0;
 }
 
diff --git a/gcc/fortran/arith.h b/gcc/fortran/arith.h
index f370c1c..e27186a 100644
--- a/gcc/fortran/arith.h
+++ b/gcc/fortran/arith.h
@@ -40,6 +40,8 @@ arith gfc_range_check (gfc_expr *);
 
 int gfc_compare_expr (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
 int gfc_compare_string (gfc_expr *, gfc_expr *);
+int gfc_compare_with_Cstring (gfc_expr *, const char *, bool);
+
 
 /* Constant folding for gfc_expr trees.  */
 gfc_expr *gfc_parentheses (gfc_expr * op);
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index c02656c..5f78240 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2350,6 +2350,22 @@ gfc_check_secnds (gfc_expr *r)
 
 
 try
+gfc_check_selected_char_kind (gfc_expr *name)
+{
+  if (type_check (name, 0, BT_CHARACTER) == FAILURE)
+    return FAILURE;
+
+  if (kind_value_check (name, 0, gfc_default_character_kind) == FAILURE)
+    return FAILURE;
+
+  if (scalar_check (name, 0) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+try
 gfc_check_selected_int_kind (gfc_expr *r)
 {
   if (type_check (r, 0, BT_INTEGER) == FAILURE)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 6035f62..855305c 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -465,6 +465,7 @@ enum gfc_isym_id
   GFC_ISYM_RESHAPE,
   GFC_ISYM_RRSPACING,
   GFC_ISYM_RSHIFT,
+  GFC_ISYM_SC_KIND,
   GFC_ISYM_SCALE,
   GFC_ISYM_SCAN,
   GFC_ISYM_SECNDS,
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 258123b..441fbec 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -2141,6 +2141,13 @@ add_functions (void)
 
   make_generic ("secnds", GFC_ISYM_SECNDS, GFC_STD_GNU);
 
+  add_sym_1 ("selected_char_kind", GFC_ISYM_SC_KIND, CLASS_TRANSFORMATIONAL,
+	     ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003,
+	     gfc_check_selected_char_kind, gfc_simplify_selected_char_kind,
+	     NULL, nm, BT_CHARACTER, dc, REQUIRED);
+
+  make_generic ("selected_char_kind", GFC_ISYM_SC_KIND, GFC_STD_F2003);
+
   add_sym_1 ("selected_int_kind", GFC_ISYM_SI_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di,
 	     GFC_STD_F95, gfc_check_selected_int_kind,
 	     gfc_simplify_selected_int_kind, NULL, r, BT_INTEGER, di, REQUIRED);
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index dc91e77..91645fb 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -120,6 +120,7 @@ try gfc_check_scale (gfc_expr *, gfc_expr *);
 try gfc_check_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_second_sub (gfc_expr *);
 try gfc_check_secnds (gfc_expr *);
+try gfc_check_selected_char_kind (gfc_expr *);
 try gfc_check_selected_int_kind (gfc_expr *);
 try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *);
 try gfc_check_set_exponent (gfc_expr *, gfc_expr *);
@@ -287,6 +288,7 @@ gfc_expr *gfc_simplify_reshape (gfc_expr *, gfc_expr *, gfc_expr *,
 gfc_expr *gfc_simplify_rrspacing (gfc_expr *);
 gfc_expr *gfc_simplify_scale (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_selected_char_kind (gfc_expr *);
 gfc_expr *gfc_simplify_selected_int_kind (gfc_expr *);
 gfc_expr *gfc_simplify_selected_real_kind (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_set_exponent (gfc_expr *, gfc_expr *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index c2630b2..9d3553da 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -225,6 +225,7 @@ Some basic guidelines for editing this document:
 * @code{SCAN}:          SCAN,      Scan a string for the presence of a set of characters
 * @code{SECNDS}:        SECNDS,    Time function
 * @code{SECOND}:        SECOND,    CPU time function
+* @code{SELECTED_CHAR_KIND}: SELECTED_CHAR_KIND,  Choose character kind
 * @code{SELECTED_INT_KIND}: SELECTED_INT_KIND,  Choose integer kind
 * @code{SELECTED_REAL_KIND}: SELECTED_REAL_KIND,  Choose real kind
 * @code{SET_EXPONENT}:  SET_EXPONENT, Set the exponent of the model
@@ -9256,6 +9257,48 @@ seconds.
 
 
 
+@node SELECTED_CHAR_KIND
+@section @code{SELECTED_CHAR_KIND} --- Choose character kind
+@fnindex SELECTED_CHAR_KIND
+@cindex character kind
+@cindex kind, character
+
+@table @asis
+@item @emph{Description}:
+
+@code{SELECTED_CHAR_KIND(NAME)} returns the kind value for the character
+set named @var{NAME}, if a character set with such a name is supported,
+or @math{-1} otherwise. Currently, supported character sets include
+``ASCII'' and ``DEFAULT'', which are equivalent.
+
+@item @emph{Standard}:
+Fortran 2003 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = SELECTED_CHAR_KIND(NAME)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{NAME} @tab Shall be a scalar and of the default character type.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program ascii_kind
+  integer,parameter :: ascii = selected_char_kind("ascii")
+  character(kind=ascii, len=26) :: s
+
+  s = ascii_"abcdefghijklmnopqrstuvwxyz"
+  print *, s
+end program ascii_kind
+@end smallexample
+@end table
+
+
+
 @node SELECTED_INT_KIND
 @section @code{SELECTED_INT_KIND} --- Choose integer kind
 @fnindex SELECTED_INT_KIND
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 8f85873..6b7fd51 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -60,6 +60,8 @@ match_kind_param (int *kind)
   if (p != NULL)
     return MATCH_NO;
 
+  gfc_set_sym_referenced (sym);
+
   if (*kind < 0)
     return MATCH_NO;
 
@@ -907,6 +909,7 @@ match_string_constant (gfc_expr **result)
 	  gfc_error (q);
 	  return MATCH_ERROR;
 	}
+      gfc_set_sym_referenced (sym);
     }
 
   if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 2272bb5..62c1cd45 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3629,6 +3629,28 @@ gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
 
 
 gfc_expr *
+gfc_simplify_selected_char_kind (gfc_expr *e)
+{
+  int kind;
+  gfc_expr *result;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  if (gfc_compare_with_Cstring (e, "ascii", false) == 0
+      || gfc_compare_with_Cstring (e, "default", false) == 0)
+    kind = 1;
+  else
+    kind = -1;
+
+  result = gfc_int_expr (kind);
+  result->where = e->where;
+
+  return result;
+}
+
+
+gfc_expr *
 gfc_simplify_selected_int_kind (gfc_expr *e)
 {
   int i, kind, range;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 4e6dddb..d204579 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -124,7 +124,8 @@ tree gfor_fndecl_size0;
 tree gfor_fndecl_size1;
 tree gfor_fndecl_iargc;
 
-/* Intrinsic functions implemented in FORTRAN.  */
+/* Intrinsic functions implemented in Fortran.  */
+tree gfor_fndecl_sc_kind;
 tree gfor_fndecl_si_kind;
 tree gfor_fndecl_sr_kind;
 
@@ -2099,19 +2100,22 @@ gfc_build_intrinsic_function_decls (void)
 				     pchar_type_node,
 				     gfc_charlen_type_node, pchar_type_node);
 
+  gfor_fndecl_sc_kind =
+    gfc_build_library_function_decl (get_identifier
+					(PREFIX("selected_char_kind")),
+                                     gfc_int4_type_node, 2,
+				     gfc_charlen_type_node, pchar_type_node);
+
   gfor_fndecl_si_kind =
     gfc_build_library_function_decl (get_identifier
 					(PREFIX("selected_int_kind")),
-                                     gfc_int4_type_node,
-                                     1,
-                                     pvoid_type_node);
+                                     gfc_int4_type_node, 1, pvoid_type_node);
 
   gfor_fndecl_sr_kind =
     gfc_build_library_function_decl (get_identifier
 					(PREFIX("selected_real_kind")),
-                                     gfc_int4_type_node,
-                                     2, pvoid_type_node,
-                                     pvoid_type_node);
+                                     gfc_int4_type_node, 2,
+                                     pvoid_type_node, pvoid_type_node);
 
   /* Power functions.  */
   {
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index f3cd4de..9f022e7 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -3736,6 +3736,19 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
 }
 
 
+/* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function.  */
+
+static void
+gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
+{
+  tree args[2];
+
+  gfc_conv_intrinsic_function_args (se, expr, args, 2);
+  se->expr = build_call_expr (gfor_fndecl_sc_kind, 2, args[0], args[1]);
+  se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
+}
+
+
 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
 
 static void
@@ -4049,6 +4062,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_trim (se, expr);
       break;
 
+    case GFC_ISYM_SC_KIND:
+      gfc_conv_intrinsic_sc_kind (se, expr);
+      break;
+
     case GFC_ISYM_SI_KIND:
       gfc_conv_intrinsic_si_kind (se, expr);
       break;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 1dfb0a5..3e812a8 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -556,7 +556,8 @@ extern GTY(()) tree gfor_fndecl_size0;
 extern GTY(()) tree gfor_fndecl_size1;
 extern GTY(()) tree gfor_fndecl_iargc;
 
-/* Implemented in FORTRAN.  */
+/* Implemented in Fortran.  */
+extern GTY(()) tree gfor_fndecl_sc_kind;
 extern GTY(()) tree gfor_fndecl_si_kind;
 extern GTY(()) tree gfor_fndecl_sr_kind;
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0d468f0..da38b1b 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,7 +1,13 @@
+2008-04-30  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	* gfortran.dg/selected_char_kind_1.f90: New test.
+	* gfortran.dg/selected_char_kind_2.f90: New test.
+	* gfortran.dg/selected_char_kind_3.f90: New test.
+
 2008-04-28  Paul Thomas  <pault@gcc.gnu.org>
 
-       PR fortran/35997
-       * gfortran.dg/use_rename_3.f90
+	PR fortran/35997
+	* gfortran.dg/use_rename_3.f90
 
 2008-04-30  Richard Guenther  <rguenther@suse.de>
 
diff --git a/gcc/testsuite/gfortran.dg/selected_char_kind_1.f90 b/gcc/testsuite/gfortran.dg/selected_char_kind_1.f90
new file mode 100644
index 0000000..f11fd0f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/selected_char_kind_1.f90
@@ -0,0 +1,65 @@
+! { dg-do run }
+! 
+! Checks for the SELECTED_CHAR_KIND intrinsic
+!
+  integer, parameter :: ascii = selected_char_kind ("ascii")
+  integer, parameter :: default = selected_char_kind ("default")
+
+  character(kind=ascii) :: s1
+  character(kind=default) :: s2
+  character(kind=selected_char_kind ("ascii")) :: s3
+  character(kind=selected_char_kind ("default")) :: s4
+
+  if (kind (s1) /= selected_char_kind ("ascii")) call abort
+  if (kind (s2) /= selected_char_kind ("default")) call abort
+  if (kind (s3) /= ascii) call abort
+  if (kind (s4) /= default) call abort
+
+  if (selected_char_kind("ascii") /= 1) call abort
+  if (selected_char_kind("default") /= 1) call abort
+  if (selected_char_kind("defauLt") /= 1) call abort
+  if (selected_char_kind("foo") /= -1) call abort
+  if (selected_char_kind("asciiiii") /= -1) call abort
+  if (selected_char_kind("default       ") /= 1) call abort
+
+  call test("ascii", 1)
+  call test("default", 1)
+  call test("defauLt", 1)
+  call test("asciiiiii", -1)
+  call test("foo", -1)
+  call test("default     ", 1)
+  call test("default     x", -1)
+
+  call test(ascii_"ascii", 1)
+  call test(ascii_"default", 1)
+  call test(ascii_"defauLt", 1)
+  call test(ascii_"asciiiiii", -1)
+  call test(ascii_"foo", -1)
+  call test(ascii_"default     ", 1)
+  call test(ascii_"default     x", -1)
+
+  call test(default_"ascii", 1)
+  call test(default_"default", 1)
+  call test(default_"defauLt", 1)
+  call test(default_"asciiiiii", -1)
+  call test(default_"foo", -1)
+  call test(default_"default     ", 1)
+  call test(default_"default     x", -1)
+
+  if (kind (selected_char_kind ("")) /= kind(0)) call abort
+end
+
+subroutine test(s,i)
+  character(len=*,kind=selected_char_kind("ascii")) s
+  integer i
+
+  call test2(s,i)
+  if (selected_char_kind (s) /= i) call abort
+end subroutine test
+
+subroutine test2(s,i)
+  character(len=*,kind=selected_char_kind("default")) s
+  integer i
+
+  if (selected_char_kind (s) /= i) call abort
+end subroutine test2
diff --git a/gcc/testsuite/gfortran.dg/selected_char_kind_2.f90 b/gcc/testsuite/gfortran.dg/selected_char_kind_2.f90
new file mode 100644
index 0000000..28ecd96
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/selected_char_kind_2.f90
@@ -0,0 +1,14 @@
+! { dg-do compile }
+!
+! Check that nonexisting character kinds are not rejected by the compiler
+!
+  character(kind=selected_char_kind("")) :: s1 ! { dg-error "is not supported for CHARACTER" }
+  character(kind=selected_char_kind("     ")) :: s2 ! { dg-error "is not supported for CHARACTER" }
+  character(kind=selected_char_kind("asciii")) :: s3 ! { dg-error "is not supported for CHARACTER" }
+  character(kind=selected_char_kind("I don't exist")) :: s4 ! { dg-error "is not supported for CHARACTER" }
+
+  print *, selected_char_kind() ! { dg-error "Missing actual argument" }
+  print *, selected_char_kind(12) ! { dg-error "must be CHARACTER" }
+  print *, selected_char_kind(["foo", "bar"]) ! { dg-error "must be a scalar" }
+
+end
diff --git a/gcc/testsuite/gfortran.dg/selected_char_kind_3.f90 b/gcc/testsuite/gfortran.dg/selected_char_kind_3.f90
new file mode 100644
index 0000000..5cc7b11
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/selected_char_kind_3.f90
@@ -0,0 +1,10 @@
+! { dg-do compile }
+! { dg-options "-std=f95 -pedantic -Wall" }
+!
+! Check that SELECTED_CHAR_KIND is rejected with -std=f95
+!
+  implicit none
+  character(kind=selected_char_kind("ascii")) :: s ! { dg-error "is not included in the selected standard" }
+  s = "" ! { dg-error "has no IMPLICIT type" }
+  print *, s
+end