* 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
+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>
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++)
{
}
/* 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;
}
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);
}
+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)
{
GFC_ISYM_RESHAPE,
GFC_ISYM_RRSPACING,
GFC_ISYM_RSHIFT,
+ GFC_ISYM_SC_KIND,
GFC_ISYM_SCALE,
GFC_ISYM_SCAN,
GFC_ISYM_SECNDS,
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);
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 *);
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 *);
* @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
+@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
if (p != NULL)
return MATCH_NO;
+ gfc_set_sym_referenced (sym);
+
if (*kind < 0)
return MATCH_NO;
gfc_error (q);
return MATCH_ERROR;
}
+ gfc_set_sym_referenced (sym);
}
if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
}
+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)
{
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;
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. */
{
}
+/* 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
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;
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;
+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>
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+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
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 \
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 \
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 \
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 \
@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@
@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
_gfortran_erfc_scaled_r8;
_gfortran_erfc_scaled_r10;
_gfortran_erfc_scaled_r16;
+ _gfortran_selected_char_kind;
_gfortran_st_wait;
} GFORTRAN_1.0;
--- /dev/null
+/* 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;
+}
projects / gcc.git / commitdiff