From 59e2a584a5a474f8e332869f04ce7b8c22b42921 Mon Sep 17 00:00:00 2001 From: fxcoudert Date: Wed, 30 Apr 2008 21:45:02 +0000 Subject: [PATCH] * 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@134839 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 24 +++++++- gcc/fortran/arith.c | 35 +++++++++++- gcc/fortran/arith.h | 2 + gcc/fortran/check.c | 16 ++++++ gcc/fortran/gfortran.h | 1 + gcc/fortran/intrinsic.c | 7 +++ gcc/fortran/intrinsic.h | 2 + gcc/fortran/intrinsic.texi | 43 ++++++++++++++ gcc/fortran/primary.c | 3 + gcc/fortran/simplify.c | 22 ++++++++ gcc/fortran/trans-decl.c | 18 +++--- gcc/fortran/trans-intrinsic.c | 17 ++++++ gcc/fortran/trans.h | 3 +- gcc/testsuite/ChangeLog | 10 +++- gcc/testsuite/gfortran.dg/selected_char_kind_1.f90 | 65 ++++++++++++++++++++++ gcc/testsuite/gfortran.dg/selected_char_kind_2.f90 | 14 +++++ gcc/testsuite/gfortran.dg/selected_char_kind_3.f90 | 10 ++++ libgfortran/ChangeLog | 7 +++ libgfortran/Makefile.am | 1 + libgfortran/Makefile.in | 24 +++++--- libgfortran/gfortran.map | 1 + libgfortran/intrinsics/selected_char_kind.c | 49 ++++++++++++++++ 22 files changed, 353 insertions(+), 21 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/selected_char_kind_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/selected_char_kind_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/selected_char_kind_3.f90 create mode 100644 libgfortran/intrinsics/selected_char_kind.c diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 13fb0528e55..2abc96d0098 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,8 +1,26 @@ +2008-04-30 Francois-Xavier Coudert + + * 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 - 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 diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index fdd6f6a7d77..4b8d45b189b 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 f370c1cbce8..e27186ae92f 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 c02656ce669..5f782400dd3 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 6035f629f56..855305cb278 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 258123b92b5..441fbecdc17 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 dc91e77caaf..91645fbb1e5 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 c2630b249be..9d3553da111 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 8f85873ce03..6b7fd519d6a 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 2272bb567b5..62c1cd45aec 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 4e6dddbf501..d204579c75f 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 f3cd4de9bca..9f022e7a09d 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 1dfb0a59dab..3e812a89028 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 0d468f09c28..da38b1bedcb 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,7 +1,13 @@ +2008-04-30 Francois-Xavier Coudert + + * 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 - PR fortran/35997 - * gfortran.dg/use_rename_3.f90 + PR fortran/35997 + * gfortran.dg/use_rename_3.f90 2008-04-30 Richard Guenther 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 00000000000..f11fd0fb3f4 --- /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 00000000000..28ecd96ba3e --- /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 00000000000..5cc7b112496 --- /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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 0ee684858ad..dbdaa0decee 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,10 @@ +2008-04-30 Francois-Xavier Coudert + + * 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 PR libfortran/35993 diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am index 62ae5f31db8..93a4072d7d8 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -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 \ diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index 42192604bc2..686308a7fa0 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -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 diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index 2d0537246e3..0c6b7b1b7af 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -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 index 00000000000..c10d5b2efaf --- /dev/null +++ b/libgfortran/intrinsics/selected_char_kind.c @@ -0,0 +1,49 @@ +/* Copyright 2008 Free Software Foundation, Inc. + Contributed by Paul Brook + +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 + + +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; +} -- 2.11.0