From a39faface6511df98bd39a8f6134a992a3feee35 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois-Xavier=20Coudert?= Date: Wed, 30 Apr 2008 21:45:02 +0000 Subject: 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 --- 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 ++++ 17 files changed, 278 insertions(+), 14 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 (limited to 'gcc') 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 + + * 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 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 + + * 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 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 -- cgit v1.1