OSDN Git Service

* intrinsic.c (add_functions): Add SELECTED_CHAR_KIND intrinsic.
authorfxcoudert <fxcoudert@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 30 Apr 2008 21:45:02 +0000 (21:45 +0000)
committerfxcoudert <fxcoudert@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 30 Apr 2008 21:45:02 +0000 (21:45 +0000)
* 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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@134839 138bc75d-0d04-0410-961f-82ee72b054a4

22 files changed:
gcc/fortran/ChangeLog
gcc/fortran/arith.c
gcc/fortran/arith.h
gcc/fortran/check.c
gcc/fortran/gfortran.h
gcc/fortran/intrinsic.c
gcc/fortran/intrinsic.h
gcc/fortran/intrinsic.texi
gcc/fortran/primary.c
gcc/fortran/simplify.c
gcc/fortran/trans-decl.c
gcc/fortran/trans-intrinsic.c
gcc/fortran/trans.h
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/selected_char_kind_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/selected_char_kind_2.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/selected_char_kind_3.f90 [new file with mode: 0644]
libgfortran/ChangeLog
libgfortran/Makefile.am
libgfortran/Makefile.in
libgfortran/gfortran.map
libgfortran/intrinsics/selected_char_kind.c [new file with mode: 0644]

index 13fb052..2abc96d 100644 (file)
@@ -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>
 
index fdd6f6a..4b8d45b 100644 (file)
@@ -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;
 }
 
index f370c1c..e27186a 100644 (file)
@@ -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);
index c02656c..5f78240 100644 (file)
@@ -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)
index 6035f62..855305c 100644 (file)
@@ -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,
index 258123b..441fbec 100644 (file)
@@ -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);
index dc91e77..91645fb 100644 (file)
@@ -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 *);
index c2630b2..9d3553d 100644 (file)
@@ -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
index 8f85873..6b7fd51 100644 (file)
@@ -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)
index 2272bb5..62c1cd4 100644 (file)
@@ -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;
index 4e6dddb..d204579 100644 (file)
@@ -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.  */
   {
index f3cd4de..9f022e7 100644 (file)
@@ -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;
index 1dfb0a5..3e812a8 100644 (file)
@@ -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;
 
index 0d468f0..da38b1b 100644 (file)
@@ -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 (file)
index 0000000..f11fd0f
--- /dev/null
@@ -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 (file)
index 0000000..28ecd96
--- /dev/null
@@ -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 (file)
index 0000000..5cc7b11
--- /dev/null
@@ -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
index 0ee6848..dbdaa0d 100644 (file)
@@ -1,3 +1,10 @@
+2008-04-30  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+       * intrinsics/selected_char_kind.c: New file.
+       * gfortran.map (GFORTRAN_1.1): Add _gfortran_selected_char_kind.
+       * Makefile.am: Add intrinsics/selected_char_kind.c.
+       * Makefile.in: Regenerate.
+
 2008-04-30  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
        PR libfortran/35993
index 62ae5f3..93a4072 100644 (file)
@@ -87,6 +87,7 @@ intrinsics/mvbits.c \
 intrinsics/move_alloc.c \
 intrinsics/pack_generic.c \
 intrinsics/perror.c \
+intrinsics/selected_char_kind.c \
 intrinsics/signal.c \
 intrinsics/size.c \
 intrinsics/sleep.c \
index 4219260..686308a 100644 (file)
@@ -416,7 +416,8 @@ am__libgfortran_la_SOURCES_DIST = runtime/backtrace.c \
        intrinsics/kill.c intrinsics/link.c intrinsics/malloc.c \
        intrinsics/mvbits.c intrinsics/move_alloc.c \
        intrinsics/pack_generic.c intrinsics/perror.c \
-       intrinsics/signal.c intrinsics/size.c intrinsics/sleep.c \
+       intrinsics/selected_char_kind.c intrinsics/signal.c \
+       intrinsics/size.c intrinsics/sleep.c \
        intrinsics/spread_generic.c intrinsics/string_intrinsics.c \
        intrinsics/system.c intrinsics/rand.c intrinsics/random.c \
        intrinsics/rename.c intrinsics/reshape_generic.c \
@@ -698,12 +699,12 @@ am__objects_35 = associated.lo abort.lo access.lo args.lo \
        fnum.lo gerror.lo getcwd.lo getlog.lo getXid.lo hostnm.lo \
        ierrno.lo ishftc.lo iso_c_generated_procs.lo iso_c_binding.lo \
        kill.lo link.lo malloc.lo mvbits.lo move_alloc.lo \
-       pack_generic.lo perror.lo signal.lo size.lo sleep.lo \
-       spread_generic.lo string_intrinsics.lo system.lo rand.lo \
-       random.lo rename.lo reshape_generic.lo reshape_packed.lo \
-       selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \
-       system_clock.lo time.lo transpose_generic.lo umask.lo \
-       unlink.lo unpack_generic.lo in_pack_generic.lo \
+       pack_generic.lo perror.lo selected_char_kind.lo signal.lo \
+       size.lo sleep.lo spread_generic.lo string_intrinsics.lo \
+       system.lo rand.lo random.lo rename.lo reshape_generic.lo \
+       reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
+       stat.lo symlnk.lo system_clock.lo time.lo transpose_generic.lo \
+       umask.lo unlink.lo unpack_generic.lo in_pack_generic.lo \
        in_unpack_generic.lo
 am__objects_36 =
 am__objects_37 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
@@ -986,6 +987,7 @@ intrinsics/mvbits.c \
 intrinsics/move_alloc.c \
 intrinsics/pack_generic.c \
 intrinsics/perror.c \
+intrinsics/selected_char_kind.c \
 intrinsics/signal.c \
 intrinsics/size.c \
 intrinsics/sleep.c \
@@ -2073,6 +2075,7 @@ distclean-compile:
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/rrspacing_r4.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/rrspacing_r8.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/select.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/selected_char_kind.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/set_exponent_r10.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/set_exponent_r16.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/set_exponent_r4.Plo@am__quote@
@@ -5372,6 +5375,13 @@ perror.lo: intrinsics/perror.c
 @AMDEP_TRUE@@am__fastdepCC_FALSE@      DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 @am__fastdepCC_FALSE@  $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o perror.lo `test -f 'intrinsics/perror.c' || echo '$(srcdir)/'`intrinsics/perror.c
 
+selected_char_kind.lo: intrinsics/selected_char_kind.c
+@am__fastdepCC_TRUE@   if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT selected_char_kind.lo -MD -MP -MF "$(DEPDIR)/selected_char_kind.Tpo" -c -o selected_char_kind.lo `test -f 'intrinsics/selected_char_kind.c' || echo '$(srcdir)/'`intrinsics/selected_char_kind.c; \
+@am__fastdepCC_TRUE@   then mv -f "$(DEPDIR)/selected_char_kind.Tpo" "$(DEPDIR)/selected_char_kind.Plo"; else rm -f "$(DEPDIR)/selected_char_kind.Tpo"; exit 1; fi
+@AMDEP_TRUE@@am__fastdepCC_FALSE@      source='intrinsics/selected_char_kind.c' object='selected_char_kind.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@      DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@  $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o selected_char_kind.lo `test -f 'intrinsics/selected_char_kind.c' || echo '$(srcdir)/'`intrinsics/selected_char_kind.c
+
 signal.lo: intrinsics/signal.c
 @am__fastdepCC_TRUE@   if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT signal.lo -MD -MP -MF "$(DEPDIR)/signal.Tpo" -c -o signal.lo `test -f 'intrinsics/signal.c' || echo '$(srcdir)/'`intrinsics/signal.c; \
 @am__fastdepCC_TRUE@   then mv -f "$(DEPDIR)/signal.Tpo" "$(DEPDIR)/signal.Plo"; else rm -f "$(DEPDIR)/signal.Tpo"; exit 1; fi
index 2d05372..0c6b7b1 100644 (file)
@@ -1037,6 +1037,7 @@ GFORTRAN_1.1 {
     _gfortran_erfc_scaled_r8;
     _gfortran_erfc_scaled_r10;
     _gfortran_erfc_scaled_r16;
+    _gfortran_selected_char_kind;
     _gfortran_st_wait;
 } GFORTRAN_1.0; 
 
diff --git a/libgfortran/intrinsics/selected_char_kind.c b/libgfortran/intrinsics/selected_char_kind.c
new file mode 100644 (file)
index 0000000..c10d5b2
--- /dev/null
@@ -0,0 +1,49 @@
+/* Copyright 2008 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org>
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 2 of the License, or (at your option) any later version.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public
+License along with libgfortran; see the file COPYING.  If not,
+write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+
+#include "libgfortran.h"
+
+#include <string.h>
+
+
+extern GFC_INTEGER_4 selected_char_kind (gfc_charlen_type, char *);
+export_proto(selected_char_kind);
+
+GFC_INTEGER_4
+selected_char_kind (gfc_charlen_type name_len, char *name)
+{
+  gfc_charlen_type len = fstrlen (name, name_len);
+
+  if ((len == 5 && strncasecmp (name, "ascii", 5) == 0)
+      || (len == 7 && strncasecmp (name, "default", 7) == 0))
+    return 1;
+  else
+    return -1;
+}