From 374929b22f9ef8a02a0d2d1be531efc0e9949ee7 Mon Sep 17 00:00:00 2001 From: Francois-Xavier Coudert Date: Thu, 15 May 2008 21:12:53 +0000 Subject: [PATCH] trans-expr.c (gfc_conv_concat_op): Take care of nondefault character kinds. * trans-expr.c (gfc_conv_concat_op): Take care of nondefault character kinds. (gfc_build_compare_string): Add kind argument and use it. (gfc_conv_statement_function): Fix indentation. * gfortran.h (gfc_character_info): New structure. (gfc_character_kinds): New array. * trans-types.c (gfc_character_kinds, gfc_character_types, gfc_pcharacter_types): New array. (gfc_init_kinds): Fill character kinds array. (validate_character): Take care of nondefault character kinds. (gfc_build_uint_type): New function. (gfc_init_types): Take care of nondefault character kinds. (gfc_get_char_type, gfc_get_pchar_type): New functions. (gfc_get_character_type_len): Use gfc_get_char_type. * trans.h (gfc_build_compare_string): Adjust prototype. (gfor_fndecl_compare_string_char4, gfor_fndecl_concat_string_char4, gfor_fndecl_string_len_trim_char4, gfor_fndecl_string_index_char4, gfor_fndecl_string_scan_char4, gfor_fndecl_string_verify_char4, gfor_fndecl_string_trim_char4, gfor_fndecl_string_minmax_char4, gfor_fndecl_adjustl_char4, gfor_fndecl_adjustr_char4): New prototypes. * trans-types.h (gfc_get_char_type, gfc_get_pchar_type): New prototypes. * trans-decl.c (gfor_fndecl_compare_string_char4, gfor_fndecl_string_len_trim_char4, gfor_fndecl_string_index_char4, gfor_fndecl_string_scan_char4, gfor_fndecl_string_verify_char4, gfor_fndecl_string_trim_char4, gfor_fndecl_string_minmax_char4, gfor_fndecl_adjustl_char4, gfor_fndecl_adjustr_char4, gfor_fndecl_concat_string_char4): New function decls. (gfc_build_intrinsic_function_decls): Define new *_char4 function decls. * trans-intrinsic.c (gfc_conv_intrinsic_minmax_char, gfc_conv_intrinsic_len_trim, gfc_conv_intrinsic_ichar, gfc_conv_intrinsic_strcmp, gfc_conv_intrinsic_trim, gfc_conv_intrinsic_function): Deal with nondefault character kinds. From-SVN: r135397 --- gcc/fortran/ChangeLog | 38 ++++++++ gcc/fortran/gfortran.h | 9 ++ gcc/fortran/trans-decl.c | 169 +++++++++++++++++++++++++--------- gcc/fortran/trans-expr.c | 49 ++++++---- gcc/fortran/trans-intrinsic.c | 104 +++++++++++++++++---- gcc/fortran/trans-types.c | 85 +++++++++++++++-- gcc/fortran/trans-types.h | 2 + gcc/fortran/trans.h | 12 ++- 8 files changed, 376 insertions(+), 92 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c7e18e80139..fb05a79faaa 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,41 @@ +2008-05-15 Francois-Xavier Coudert + + * trans-expr.c (gfc_conv_concat_op): Take care of nondefault + character kinds. + (gfc_build_compare_string): Add kind argument and use it. + (gfc_conv_statement_function): Fix indentation. + * gfortran.h (gfc_character_info): New structure. + (gfc_character_kinds): New array. + * trans-types.c (gfc_character_kinds, gfc_character_types, + gfc_pcharacter_types): New array. + (gfc_init_kinds): Fill character kinds array. + (validate_character): Take care of nondefault character kinds. + (gfc_build_uint_type): New function. + (gfc_init_types): Take care of nondefault character kinds. + (gfc_get_char_type, gfc_get_pchar_type): New functions. + (gfc_get_character_type_len): Use gfc_get_char_type. + * trans.h (gfc_build_compare_string): Adjust prototype. + (gfor_fndecl_compare_string_char4, gfor_fndecl_concat_string_char4, + gfor_fndecl_string_len_trim_char4, gfor_fndecl_string_index_char4, + gfor_fndecl_string_scan_char4, gfor_fndecl_string_verify_char4, + gfor_fndecl_string_trim_char4, gfor_fndecl_string_minmax_char4, + gfor_fndecl_adjustl_char4, gfor_fndecl_adjustr_char4): New + prototypes. + * trans-types.h (gfc_get_char_type, gfc_get_pchar_type): New + prototypes. + * trans-decl.c (gfor_fndecl_compare_string_char4, + gfor_fndecl_string_len_trim_char4, gfor_fndecl_string_index_char4, + gfor_fndecl_string_scan_char4, gfor_fndecl_string_verify_char4, + gfor_fndecl_string_trim_char4, gfor_fndecl_string_minmax_char4, + gfor_fndecl_adjustl_char4, gfor_fndecl_adjustr_char4, + gfor_fndecl_concat_string_char4): New function decls. + (gfc_build_intrinsic_function_decls): Define new *_char4 function + decls. + * trans-intrinsic.c (gfc_conv_intrinsic_minmax_char, + gfc_conv_intrinsic_len_trim, gfc_conv_intrinsic_ichar, + gfc_conv_intrinsic_strcmp, gfc_conv_intrinsic_trim, + gfc_conv_intrinsic_function): Deal with nondefault character kinds. + 2008-05-15 Sa Liu * iso-c-binding.def: Add standard parameter to macro NAMED_INTCST. diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 33988d33ed8..bf80847391e 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1567,6 +1567,15 @@ gfc_real_info; extern gfc_real_info gfc_real_kinds[]; +typedef struct +{ + int kind, bit_size; + const char *name; +} +gfc_character_info; + +extern gfc_character_info gfc_character_kinds[]; + /* Equivalence structures. Equivalent lvalues are linked along the *eq pointer, equivalence sets are strung along the *next node. */ diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index aa3712ce4fd..49eb2aa8b41 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -116,6 +116,16 @@ tree gfor_fndecl_string_trim; tree gfor_fndecl_string_minmax; tree gfor_fndecl_adjustl; tree gfor_fndecl_adjustr; +tree gfor_fndecl_compare_string_char4; +tree gfor_fndecl_concat_string_char4; +tree gfor_fndecl_string_len_trim_char4; +tree gfor_fndecl_string_index_char4; +tree gfor_fndecl_string_scan_char4; +tree gfor_fndecl_string_verify_char4; +tree gfor_fndecl_string_trim_char4; +tree gfor_fndecl_string_minmax_char4; +tree gfor_fndecl_adjustl_char4; +tree gfor_fndecl_adjustr_char4; /* Other misc. runtime library functions. */ @@ -2007,64 +2017,145 @@ gfc_build_intrinsic_function_decls (void) tree gfc_int8_type_node = gfc_get_int_type (8); tree gfc_int16_type_node = gfc_get_int_type (16); tree gfc_logical4_type_node = gfc_get_logical_type (4); + tree pchar1_type_node = gfc_get_pchar_type (1); + tree pchar4_type_node = gfc_get_pchar_type (4); /* String functions. */ gfor_fndecl_compare_string = gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")), integer_type_node, 4, - gfc_charlen_type_node, pchar_type_node, - gfc_charlen_type_node, pchar_type_node); + gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node); gfor_fndecl_concat_string = gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")), - void_type_node, - 6, - gfc_charlen_type_node, pchar_type_node, - gfc_charlen_type_node, pchar_type_node, - gfc_charlen_type_node, pchar_type_node); + void_type_node, 6, + gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node); gfor_fndecl_string_len_trim = gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")), - gfc_int4_type_node, - 2, gfc_charlen_type_node, - pchar_type_node); + gfc_int4_type_node, 2, + gfc_charlen_type_node, pchar1_type_node); gfor_fndecl_string_index = gfc_build_library_function_decl (get_identifier (PREFIX("string_index")), - gfc_int4_type_node, - 5, gfc_charlen_type_node, pchar_type_node, - gfc_charlen_type_node, pchar_type_node, - gfc_logical4_type_node); + gfc_int4_type_node, 5, + gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, + gfc_logical4_type_node); gfor_fndecl_string_scan = gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")), - gfc_int4_type_node, - 5, gfc_charlen_type_node, pchar_type_node, - gfc_charlen_type_node, pchar_type_node, - gfc_logical4_type_node); + gfc_int4_type_node, 5, + gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, + gfc_logical4_type_node); gfor_fndecl_string_verify = gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")), - gfc_int4_type_node, - 5, gfc_charlen_type_node, pchar_type_node, - gfc_charlen_type_node, pchar_type_node, - gfc_logical4_type_node); + gfc_int4_type_node, 5, + gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, + gfc_logical4_type_node); gfor_fndecl_string_trim = gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")), - void_type_node, - 4, - build_pointer_type (gfc_charlen_type_node), - ppvoid_type_node, - gfc_charlen_type_node, - pchar_type_node); + void_type_node, 4, + build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar1_type_node), + gfc_charlen_type_node, pchar1_type_node); gfor_fndecl_string_minmax = gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")), - void_type_node, -4, - build_pointer_type (gfc_charlen_type_node), - ppvoid_type_node, integer_type_node, - integer_type_node); + void_type_node, -4, + build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar1_type_node), + integer_type_node, integer_type_node); + + gfor_fndecl_adjustl = + gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")), + void_type_node, 3, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node); + + gfor_fndecl_adjustr = + gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")), + void_type_node, 3, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node); + + gfor_fndecl_compare_string_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("compare_string_char4")), + integer_type_node, 4, + gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node); + + gfor_fndecl_concat_string_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("concat_string_char4")), + void_type_node, 6, + gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node); + + gfor_fndecl_string_len_trim_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("string_len_trim_char4")), + gfc_charlen_type_node, 2, + gfc_charlen_type_node, pchar4_type_node); + + gfor_fndecl_string_index_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("string_index_char4")), + gfc_charlen_type_node, 5, + gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, + gfc_logical4_type_node); + + gfor_fndecl_string_scan_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("string_scan_char4")), + gfc_charlen_type_node, 5, + gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, + gfc_logical4_type_node); + + gfor_fndecl_string_verify_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("string_verify_char4")), + gfc_charlen_type_node, 5, + gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, + gfc_logical4_type_node); + + gfor_fndecl_string_trim_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("string_trim_char4")), + void_type_node, 4, + build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar4_type_node), + gfc_charlen_type_node, pchar4_type_node); + + gfor_fndecl_string_minmax_char4 = + gfc_build_library_function_decl (get_identifier + (PREFIX("string_minmax_char4")), + void_type_node, -4, + build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar4_type_node), + integer_type_node, integer_type_node); + + gfor_fndecl_adjustl_char4 = + gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")), + void_type_node, 3, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node); + + gfor_fndecl_adjustr_char4 = + gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")), + void_type_node, 3, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node); + + /* Misc. functions. */ gfor_fndecl_ttynam = gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")), @@ -2089,20 +2180,6 @@ gfc_build_intrinsic_function_decls (void) gfc_charlen_type_node, gfc_int8_type_node); - gfor_fndecl_adjustl = - gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")), - void_type_node, - 3, - pchar_type_node, - gfc_charlen_type_node, pchar_type_node); - - gfor_fndecl_adjustr = - gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")), - void_type_node, - 3, - 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")), diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 08c25917355..563e840c64a 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1003,15 +1003,11 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) static void gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) { - gfc_se lse; - gfc_se rse; - tree len; - tree type; - tree var; - tree tmp; + gfc_se lse, rse; + tree len, type, var, tmp, fndecl; gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER - && expr->value.op.op2->ts.type == BT_CHARACTER); + && expr->value.op.op2->ts.type == BT_CHARACTER); gfc_init_se (&lse, se); gfc_conv_expr (&lse, expr->value.op.op1); @@ -1036,9 +1032,14 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) var = gfc_conv_string_tmp (se, type, len); /* Do the actual concatenation. */ - tmp = build_call_expr (gfor_fndecl_concat_string, 6, - len, var, - lse.string_length, lse.expr, + if (expr->ts.kind == 1) + fndecl = gfor_fndecl_concat_string; + else if (expr->ts.kind == 4) + fndecl = gfor_fndecl_concat_string_char4; + else + gcc_unreachable (); + + tmp = build_call_expr (fndecl, 6, len, var, lse.string_length, lse.expr, rse.string_length, rse.expr); gfc_add_expr_to_block (&se->pre, tmp); @@ -1212,7 +1213,8 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) gfc_conv_string_parameter (&rse); lse.expr = gfc_build_compare_string (lse.string_length, lse.expr, - rse.string_length, rse.expr); + rse.string_length, rse.expr, + expr->value.op.op1->ts.kind); rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0); gfc_add_block_to_block (&lse.post, &rse.post); } @@ -1313,7 +1315,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) subtraction of them. Otherwise, we build a library call. */ tree -gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2) +gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind) { tree sc1; tree sc2; @@ -1325,17 +1327,28 @@ gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2) sc1 = gfc_to_single_character (len1, str1); sc2 = gfc_to_single_character (len2, str2); - /* Deal with single character specially. */ if (sc1 != NULL_TREE && sc2 != NULL_TREE) { + /* Deal with single character specially. */ sc1 = fold_convert (integer_type_node, sc1); sc2 = fold_convert (integer_type_node, sc2); tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2); } - else - /* Build a call for the comparison. */ - tmp = build_call_expr (gfor_fndecl_compare_string, 4, - len1, str1, len2, str2); + else + { + /* Build a call for the comparison. */ + tree fndecl; + + if (kind == 1) + fndecl = gfor_fndecl_compare_string; + else if (kind == 4) + fndecl = gfor_fndecl_compare_string_char4; + else + gcc_unreachable (); + + tmp = build_call_expr (fndecl, 4, len1, str1, len2, str2); + } + return tmp; } @@ -2981,7 +2994,7 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) tree arglen; gcc_assert (fsym->ts.cl && fsym->ts.cl->length - && fsym->ts.cl->length->expr_type == EXPR_CONSTANT); + && fsym->ts.cl->length->expr_type == EXPR_CONSTANT); arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); tmp = gfc_build_addr_expr (build_pointer_type (type), diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 2f9cadd199a..03ddefd5e66 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1509,7 +1509,7 @@ static void gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op) { tree *args; - tree var, len, fndecl, tmp, cond; + tree var, len, fndecl, tmp, cond, function; unsigned int nargs; nargs = gfc_intrinsic_argument_list_length (expr); @@ -1524,10 +1524,17 @@ gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op) args[2] = build_int_cst (NULL_TREE, op); args[3] = build_int_cst (NULL_TREE, nargs / 2); + if (expr->ts.kind == 1) + function = gfor_fndecl_string_minmax; + else if (expr->ts.kind == 4) + function = gfor_fndecl_string_minmax_char4; + else + gcc_unreachable (); + /* Make the function call. */ - fndecl = build_addr (gfor_fndecl_string_minmax, current_function_decl); - tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_minmax)), - fndecl, nargs + 4, args); + fndecl = build_addr (function, current_function_decl); + tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl, + nargs + 4, args); gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards, if necessary. */ @@ -2691,12 +2698,20 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr) { - tree args[2]; - tree type; + int kind = expr->value.function.actual->expr->ts.kind; + tree args[2], type, fndecl; gfc_conv_intrinsic_function_args (se, expr, args, 2); type = gfc_typenode_for_spec (&expr->ts); - se->expr = build_call_expr (gfor_fndecl_string_len_trim, 2, args[0], args[1]); + + if (kind == 1) + fndecl = gfor_fndecl_string_len_trim; + else if (kind == 4) + fndecl = gfor_fndecl_string_len_trim_char4; + else + gcc_unreachable (); + + se->expr = build_call_expr (fndecl, 2, args[0], args[1]); se->expr = convert (type, se->expr); } @@ -2736,12 +2751,12 @@ gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr, static void gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr) { - tree args[2]; - tree type; + tree args[2], type, pchartype; gfc_conv_intrinsic_function_args (se, expr, args, 2); gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1]))); - args[1] = fold_build1 (NOP_EXPR, pchar_type_node, args[1]); + pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind); + args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]); type = gfc_typenode_for_spec (&expr->ts); se->expr = build_fold_indirect_ref (args[1]); @@ -3273,7 +3288,9 @@ gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op) gfc_conv_intrinsic_function_args (se, expr, args, 4); - se->expr = gfc_build_compare_string (args[0], args[1], args[2], args[3]); + se->expr + = gfc_build_compare_string (args[0], args[1], args[2], args[3], + expr->value.function.actual->expr->ts.kind); se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr, build_int_cst (TREE_TYPE (se->expr), 0)); } @@ -3828,6 +3845,7 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) tree type; tree cond; tree fndecl; + tree function; tree *args; unsigned int num_args; @@ -3843,9 +3861,16 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) args[0] = build_fold_addr_expr (len); args[1] = addr; - fndecl = build_addr (gfor_fndecl_string_trim, current_function_decl); - tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_trim)), - fndecl, num_args, args); + if (expr->ts.kind == 1) + function = gfor_fndecl_string_trim; + else if (expr->ts.kind == 4) + function = gfor_fndecl_string_trim_char4; + else + gcc_unreachable (); + + fndecl = build_addr (function, current_function_decl); + tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl, + num_args, args); gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards, if necessary. */ @@ -4033,7 +4058,8 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) { gfc_intrinsic_sym *isym; const char *name; - int lib; + int lib, kind; + tree fndecl; isym = expr->value.function.isym; @@ -4081,11 +4107,27 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_SCAN: - gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_scan); + kind = expr->value.function.actual->expr->ts.kind; + if (kind == 1) + fndecl = gfor_fndecl_string_scan; + else if (kind == 4) + fndecl = gfor_fndecl_string_scan_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); break; case GFC_ISYM_VERIFY: - gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_verify); + kind = expr->value.function.actual->expr->ts.kind; + if (kind == 1) + fndecl = gfor_fndecl_string_verify; + else if (kind == 4) + fndecl = gfor_fndecl_string_verify_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); break; case GFC_ISYM_ALLOCATED: @@ -4101,11 +4143,25 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_ADJUSTL: - gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl); + if (expr->ts.kind == 1) + fndecl = gfor_fndecl_adjustl; + else if (expr->ts.kind == 4) + fndecl = gfor_fndecl_adjustl_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_adjust (se, expr, fndecl); break; case GFC_ISYM_ADJUSTR: - gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr); + if (expr->ts.kind == 1) + fndecl = gfor_fndecl_adjustr; + else if (expr->ts.kind == 4) + fndecl = gfor_fndecl_adjustr_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_adjust (se, expr, fndecl); break; case GFC_ISYM_AIMAG: @@ -4252,7 +4308,15 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_INDEX: - gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_index); + kind = expr->value.function.actual->expr->ts.kind; + if (kind == 1) + fndecl = gfor_fndecl_string_index; + else if (kind == 4) + fndecl = gfor_fndecl_string_index_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); break; case GFC_ISYM_IOR: diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 7a735e021d9..1c15d644ab4 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -83,6 +83,11 @@ gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1]; static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1]; static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1]; +#define MAX_CHARACTER_KINDS 2 +gfc_character_info gfc_character_kinds[MAX_CHARACTER_KINDS + 1]; +static GTY(()) tree gfc_character_types[MAX_CHARACTER_KINDS + 1]; +static GTY(()) tree gfc_pcharacter_types[MAX_CHARACTER_KINDS + 1]; + /* The integer kind to use for array indices. This will be set to the proper value based on target information from the backend. */ @@ -262,7 +267,7 @@ void gfc_init_kinds (void) { enum machine_mode mode; - int i_index, r_index; + int i_index, r_index, kind; bool saw_i4 = false, saw_i8 = false; bool saw_r4 = false, saw_r8 = false, saw_r16 = false; @@ -450,8 +455,27 @@ gfc_init_kinds (void) gfc_default_logical_kind = gfc_default_integer_kind; gfc_default_complex_kind = gfc_default_real_kind; + /* We only have two character kinds: ASCII and UCS-4. + ASCII corresponds to a 8-bit integer type, if one is available. + UCS-4 corresponds to a 32-bit integer type, if one is available. */ + i_index = 0; + if ((kind = get_int_kind_from_width (8)) > 0) + { + gfc_character_kinds[i_index].kind = kind; + gfc_character_kinds[i_index].bit_size = 8; + gfc_character_kinds[i_index].name = "ascii"; + i_index++; + } + if ((kind = get_int_kind_from_width (32)) > 0) + { + gfc_character_kinds[i_index].kind = kind; + gfc_character_kinds[i_index].bit_size = 32; + gfc_character_kinds[i_index].name = "iso_10646"; + i_index++; + } + /* Choose the smallest integer kind for our default character. */ - gfc_default_character_kind = gfc_integer_kinds[0].kind; + gfc_default_character_kind = gfc_character_kinds[0].kind; gfc_character_storage_size = gfc_default_character_kind * 8; /* Choose the integer kind the same size as "void*" for our index kind. */ @@ -505,7 +529,13 @@ validate_logical (int kind) static int validate_character (int kind) { - return kind == gfc_default_character_kind ? 0 : -1; + int i; + + for (i = 0; gfc_character_kinds[i].kind; i++) + if (gfc_character_kinds[i].kind == kind) + return i; + + return -1; } /* Validate a kind given a basic type. The return value is the same @@ -579,6 +609,24 @@ gfc_build_int_type (gfc_integer_info *info) return make_signed_type (mode_precision); } +static tree +gfc_build_uint_type (int size) +{ + if (size == CHAR_TYPE_SIZE) + return unsigned_char_type_node; + if (size == SHORT_TYPE_SIZE) + return short_unsigned_type_node; + if (size == INT_TYPE_SIZE) + return unsigned_type_node; + if (size == LONG_TYPE_SIZE) + return long_unsigned_type_node; + if (size == LONG_LONG_TYPE_SIZE) + return long_long_unsigned_type_node; + + return make_unsigned_type (size); +} + + static tree gfc_build_real_type (gfc_real_info *info) { @@ -717,9 +765,17 @@ gfc_init_types (void) PUSH_TYPE (name_buf, type); } - gfc_character1_type_node = build_qualified_type (unsigned_char_type_node, - TYPE_UNQUALIFIED); - PUSH_TYPE ("character(kind=1)", gfc_character1_type_node); + for (index = 0; gfc_character_kinds[index].kind != 0; ++index) + { + type = gfc_build_uint_type (gfc_character_kinds[index].bit_size); + type = build_qualified_type (type, TYPE_UNQUALIFIED); + snprintf (name_buf, sizeof(name_buf), "character(kind=%d)", + gfc_character_kinds[index].kind); + PUSH_TYPE (name_buf, type); + gfc_character_types[index] = type; + gfc_pcharacter_types[index] = build_pointer_type (type); + } + gfc_character1_type_node = gfc_character_types[0]; PUSH_TYPE ("byte", unsigned_char_type_node); PUSH_TYPE ("void", void_type_node); @@ -799,6 +855,21 @@ gfc_get_logical_type (int kind) int index = gfc_validate_kind (BT_LOGICAL, kind, true); return index < 0 ? 0 : gfc_logical_types[index]; } + +tree +gfc_get_char_type (int kind) +{ + int index = gfc_validate_kind (BT_CHARACTER, kind, true); + return index < 0 ? 0 : gfc_character_types[index]; +} + +tree +gfc_get_pchar_type (int kind) +{ + int index = gfc_validate_kind (BT_CHARACTER, kind, true); + return index < 0 ? 0 : gfc_pcharacter_types[index]; +} + /* Create a character type with the given kind and length. */ @@ -810,7 +881,7 @@ gfc_get_character_type_len (int kind, tree len) gfc_validate_kind (BT_CHARACTER, kind, false); bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len); - type = build_array_type (gfc_character1_type_node, bounds); + type = build_array_type (gfc_get_char_type (kind), bounds); TYPE_STRING_FLAG (type) = 1; return type; diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 7b1da3e1113..0da736d6d5c 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -55,6 +55,8 @@ tree gfc_get_int_type (int); tree gfc_get_real_type (int); tree gfc_get_complex_type (int); tree gfc_get_logical_type (int); +tree gfc_get_char_type (int); +tree gfc_get_pchar_type (int); tree gfc_get_character_type (int, gfc_charlen *); tree gfc_get_character_type_len (int, tree); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 3e812a89028..0b431a52dae 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -277,7 +277,7 @@ void gfc_make_safe_expr (gfc_se * se); void gfc_conv_string_parameter (gfc_se * se); /* Compare two strings. */ -tree gfc_build_compare_string (tree, tree, tree, tree); +tree gfc_build_compare_string (tree, tree, tree, tree, int); /* Add an item to the end of TREE_LIST. */ tree gfc_chainon_list (tree, tree); @@ -550,6 +550,16 @@ extern GTY(()) tree gfor_fndecl_string_trim; extern GTY(()) tree gfor_fndecl_string_minmax; extern GTY(()) tree gfor_fndecl_adjustl; extern GTY(()) tree gfor_fndecl_adjustr; +extern GTY(()) tree gfor_fndecl_compare_string_char4; +extern GTY(()) tree gfor_fndecl_concat_string_char4; +extern GTY(()) tree gfor_fndecl_string_len_trim_char4; +extern GTY(()) tree gfor_fndecl_string_index_char4; +extern GTY(()) tree gfor_fndecl_string_scan_char4; +extern GTY(()) tree gfor_fndecl_string_verify_char4; +extern GTY(()) tree gfor_fndecl_string_trim_char4; +extern GTY(()) tree gfor_fndecl_string_minmax_char4; +extern GTY(()) tree gfor_fndecl_adjustl_char4; +extern GTY(()) tree gfor_fndecl_adjustr_char4; /* Other misc. runtime library functions. */ extern GTY(()) tree gfor_fndecl_size0; -- 2.30.2