Index: gcc/fortran/expr.c =================================================================== --- gcc/fortran/expr.c (revision 215645) +++ gcc/fortran/expr.c (working copy) @@ -3289,16 +3289,6 @@ gfc_check_assign (gfc_expr *lvalue, gfc_ return false; } - /* Assignment is the only case where character variables of different - kind values can be converted into one another. */ - if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER) - { - if (lvalue->ts.kind != rvalue->ts.kind) - gfc_convert_chartype (rvalue, &lvalue->ts); - - return true; - } - return gfc_convert_type (rvalue, &lvalue->ts, 1); } Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (revision 215645) +++ gcc/fortran/gfortran.h (working copy) @@ -2914,7 +2914,6 @@ char gfc_type_letter (bt); gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *); bool gfc_convert_type (gfc_expr *, gfc_typespec *, int); bool gfc_convert_type_warn (gfc_expr *, gfc_typespec *, int, int); -bool gfc_convert_chartype (gfc_expr *, gfc_typespec *); int gfc_generic_intrinsic (const char *); int gfc_specific_intrinsic (const char *); bool gfc_is_intrinsic (gfc_symbol*, int, locus); Index: gcc/fortran/intrinsic.c =================================================================== --- gcc/fortran/intrinsic.c (revision 215645) +++ gcc/fortran/intrinsic.c (working copy) @@ -39,10 +39,9 @@ gfc_intrinsic_arg *gfc_current_intrinsic locus *gfc_current_intrinsic_where; static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym; -static gfc_intrinsic_sym *char_conversions; static gfc_intrinsic_arg *next_arg; -static int nfunc, nsub, nargs, nconv, ncharconv; +static int nfunc, nsub, nargs, nconv; static enum { SZ_NOTHING = 0, SZ_SUBS, SZ_FUNCS, SZ_CONVS } @@ -152,28 +151,6 @@ find_conv (gfc_typespec *from, gfc_types } -/* Given a pair of CHARACTER typespecs, find the gfc_intrinsic_sym node - that corresponds to the conversion. Returns NULL if the conversion - isn't found. */ - -static gfc_intrinsic_sym * -find_char_conv (gfc_typespec *from, gfc_typespec *to) -{ - gfc_intrinsic_sym *sym; - const char *target; - int i; - - target = conv_name (from, to); - sym = char_conversions; - - for (i = 0; i < ncharconv; i++, sym++) - if (target == sym->name) - return sym; - - return NULL; -} - - /* Check TS29113, C407b for assumed type and C535b for assumed-rank, and a likewise check for NO_ARG_CHECK. */ @@ -3637,52 +3614,6 @@ add_conversions (void) } -static void -add_char_conversions (void) -{ - int n, i, j; - - /* Count possible conversions. */ - for (i = 0; gfc_character_kinds[i].kind != 0; i++) - for (j = 0; gfc_character_kinds[j].kind != 0; j++) - if (i != j) - ncharconv++; - - /* Allocate memory. */ - char_conversions = XCNEWVEC (gfc_intrinsic_sym, ncharconv); - - /* Add the conversions themselves. */ - n = 0; - for (i = 0; gfc_character_kinds[i].kind != 0; i++) - for (j = 0; gfc_character_kinds[j].kind != 0; j++) - { - gfc_typespec from, to; - - if (i == j) - continue; - - gfc_clear_ts (&from); - from.type = BT_CHARACTER; - from.kind = gfc_character_kinds[i].kind; - - gfc_clear_ts (&to); - to.type = BT_CHARACTER; - to.kind = gfc_character_kinds[j].kind; - - char_conversions[n].name = conv_name (&from, &to); - char_conversions[n].lib_name = char_conversions[n].name; - char_conversions[n].simplify.cc = gfc_convert_char_constant; - char_conversions[n].standard = GFC_STD_F2003; - char_conversions[n].elemental = 1; - char_conversions[n].pure = 1; - char_conversions[n].conversion = 0; - char_conversions[n].ts = to; - char_conversions[n].id = GFC_ISYM_CONVERSION; - - n++; - } -} - /* Initialize the table of intrinsics. */ void @@ -3717,9 +3648,6 @@ gfc_intrinsic_init_1 (void) add_functions (); add_subroutines (); add_conversions (); - - /* Character conversion intrinsics need to be treated separately. */ - add_char_conversions (); } @@ -3728,7 +3656,6 @@ gfc_intrinsic_done_1 (void) { free (functions); free (conversion); - free (char_conversions); gfc_free_namespace (gfc_intrinsic_namespace); } @@ -4080,8 +4007,7 @@ do_simplify (gfc_intrinsic_sym *specific a1 = arg->expr; arg = arg->next; - if (specific->simplify.cc == gfc_convert_constant - || specific->simplify.cc == gfc_convert_char_constant) + if (specific->simplify.cc == gfc_convert_constant) { result = specific->simplify.cc (a1, specific->ts.type, specific->ts.kind); goto finish; @@ -4744,60 +4670,6 @@ bad: } -bool -gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts) -{ - gfc_intrinsic_sym *sym; - locus old_where; - gfc_expr *new_expr; - int rank; - mpz_t *shape; - - gcc_assert (expr->ts.type == BT_CHARACTER && ts->type == BT_CHARACTER); - - sym = find_char_conv (&expr->ts, ts); - gcc_assert (sym); - - /* Insert a pre-resolved function call to the right function. */ - old_where = expr->where; - rank = expr->rank; - shape = expr->shape; - - new_expr = gfc_get_expr (); - *new_expr = *expr; - - new_expr = gfc_build_conversion (new_expr); - new_expr->value.function.name = sym->lib_name; - new_expr->value.function.isym = sym; - new_expr->where = old_where; - new_expr->rank = rank; - new_expr->shape = gfc_copy_shape (shape, rank); - - gfc_get_ha_sym_tree (sym->name, &new_expr->symtree); - new_expr->symtree->n.sym->ts = *ts; - new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE; - new_expr->symtree->n.sym->attr.function = 1; - new_expr->symtree->n.sym->attr.elemental = 1; - new_expr->symtree->n.sym->attr.referenced = 1; - gfc_intrinsic_symbol(new_expr->symtree->n.sym); - gfc_commit_symbol (new_expr->symtree->n.sym); - - *expr = *new_expr; - - free (new_expr); - expr->ts = *ts; - - if (gfc_is_constant_expr (expr->value.function.actual->expr) - && !do_simplify (sym, expr)) - { - /* Error already generated in do_simplify() */ - return false; - } - - return true; -} - - /* Check if the passed name is name of an intrinsic (taking into account the current -std=* and -fall-intrinsic settings). If it is, see if we should warn about this as a user-procedure having the same name as an intrinsic Index: gcc/fortran/intrinsic.h =================================================================== --- gcc/fortran/intrinsic.h (revision 215645) +++ gcc/fortran/intrinsic.h (working copy) @@ -409,7 +409,6 @@ gfc_expr *gfc_simplify_xor (gfc_expr *, /* Constant conversion simplification. */ gfc_expr *gfc_convert_constant (gfc_expr *, bt, int); -gfc_expr *gfc_convert_char_constant (gfc_expr *, bt, int); /* Resolution functions. */ Index: gcc/fortran/simplify.c =================================================================== --- gcc/fortran/simplify.c (revision 215645) +++ gcc/fortran/simplify.c (working copy) @@ -6847,80 +6847,6 @@ gfc_convert_constant (gfc_expr *e, bt ty } -/* Function for converting character constants. */ -gfc_expr * -gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind) -{ - gfc_expr *result; - int i; - - if (!gfc_is_constant_expr (e)) - return NULL; - - if (e->expr_type == EXPR_CONSTANT) - { - /* Simple case of a scalar. */ - result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where); - if (result == NULL) - return &gfc_bad_expr; - - result->value.character.length = e->value.character.length; - result->value.character.string - = gfc_get_wide_string (e->value.character.length + 1); - memcpy (result->value.character.string, e->value.character.string, - (e->value.character.length + 1) * sizeof (gfc_char_t)); - - /* Check we only have values representable in the destination kind. */ - for (i = 0; i < result->value.character.length; i++) - if (!gfc_check_character_range (result->value.character.string[i], - kind)) - { - gfc_error ("Character '%s' in string at %L cannot be converted " - "into character kind %d", - gfc_print_wide_char (result->value.character.string[i]), - &e->where, kind); - return &gfc_bad_expr; - } - - return result; - } - else if (e->expr_type == EXPR_ARRAY) - { - /* For an array constructor, we convert each constructor element. */ - gfc_constructor *c; - - result = gfc_get_array_expr (type, kind, &e->where); - result->shape = gfc_copy_shape (e->shape, e->rank); - result->rank = e->rank; - result->ts.u.cl = e->ts.u.cl; - - for (c = gfc_constructor_first (e->value.constructor); - c; c = gfc_constructor_next (c)) - { - gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind); - if (tmp == &gfc_bad_expr) - { - gfc_free_expr (result); - return &gfc_bad_expr; - } - - if (tmp == NULL) - { - gfc_free_expr (result); - return NULL; - } - - gfc_constructor_append_expr (&result->value.constructor, - tmp, &c->where); - } - - return result; - } - else - return NULL; -} - - gfc_expr * gfc_simplify_compiler_options (void) { Index: gcc/testsuite/gfortran.dg/allocate_deferred_char_scalar_1.f03 =================================================================== --- gcc/testsuite/gfortran.dg/allocate_deferred_char_scalar_1.f03 (revision 215645) +++ gcc/testsuite/gfortran.dg/allocate_deferred_char_scalar_1.f03 (working copy) @@ -235,7 +235,7 @@ contains a(1:5) = 4_'ABCDE' if(len(a) /= 50) call abort() if(a(1:5) /= 4_"ABCDE") call abort() - loc = '12345' + loc = 4_'12345' p => loc if (len(p) /= 5) call abort() if (p /= 4_'12345') call abort() Index: gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 (revision 215645) +++ gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 (working copy) @@ -732,728 +732,5 @@ subroutine char_test() .or. ustr1b(3) /= 4_"ZZZ") call abort() end if - ! ============== char1 <-> char4 ===================== - - ! ---------- Assign to coindexed variable ------------- - - ! - - - - - scalar = scalar - - ! SCALAR - kind 1 <- 4 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr1a = 4_"abc" - str1a = 1_"XXXXXXX" - if (this_image() == num_images()) then - str2a[1] = ustr1a - end if - sync all - if (this_image() == 1) then - if (str2a /= 1_"abc ") call abort() - else - if (str2a /= 1_"XXXXXXX") call abort() - end if - - ! SCALAR - kind 4 <- 1 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str1a = 4_"abc" - ustr2a = 1_"XXXXXXX" - if (this_image() == num_images()) then - ustr2a[1] = str1a - end if - sync all - if (this_image() == 1) then - if (ustr2a /= 4_"abc ") call abort() - else - if (ustr2a /= 4_"XXXXXXX") call abort() - end if - - ! SCALAR - kind 1 <- 4 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr2a = 4_"abcde" - str1a = 1_"XXX" - if (this_image() == num_images()) then - str1a[1] = ustr2a - end if - sync all - if (this_image() == 1) then - if (str1a /= 1_"abc") call abort() - else - if (str1a /= 1_"XXX") call abort() - end if - - ! SCALAR - kind 4 <- 1 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str2a = 4_"abcde" - ustr1a = 1_"XXX" - if (this_image() == num_images()) then - ustr1a[1] = str2a - end if - sync all - if (this_image() == 1) then - if (ustr1a /= 4_"abc") call abort() - else - if (ustr1a /= 4_"XXX") call abort() - end if - - ! - - - - - array = array - - ! contiguous ARRAY - kind 1 <- 4 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr1b(1) = 4_"abc" - ustr1b(2) = 4_"def" - ustr1b(3) = 4_"gjh" - str2b(1) = 1_"XXXXXXX" - str2b(2) = 1_"YYYYYYY" - str2b(3) = 1_"ZZZZZZZ" - if (this_image() == num_images()) then - str2b(:)[1] = ustr1b - end if - sync all - if (this_image() == 1) then - if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"def " & - .or. str2b(3) /= 1_"gjh ") call abort() - else - if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & - .or. str2b(3) /= 1_"ZZZZZZZ") call abort() - end if - - ! contiguous ARRAY - kind 4 <- 1 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str1b(1) = 1_"abc" - str1b(2) = 1_"def" - str1b(3) = 1_"gjh" - ustr2b(1) = 4_"XXXXXXX" - ustr2b(2) = 4_"YYYYYYY" - ustr2b(3) = 4_"ZZZZZZZ" - if (this_image() == num_images()) then - ustr2b(:)[1] = str1b - end if - sync all - if (this_image() == 1) then - if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"def " & - .or. ustr2b(3) /= 4_"gjh ") call abort() - else - if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & - .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort() - end if - - ! contiguous ARRAY - kind 1 <- 4 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr2b(1) = 4_"abcdefg" - ustr2b(2) = 4_"hijklmn" - ustr2b(3) = 4_"opqrstu" - str1b(1) = 1_"XXX" - str1b(2) = 1_"YYY" - str1b(3) = 1_"ZZZ" - if (this_image() == num_images()) then - str1b(:)[1] = ustr2b - end if - sync all - if (this_image() == 1) then - if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"hij" & - .or. str1b(3) /= 1_"opq") call abort() - else - if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & - .or. str1b(3) /= 1_"ZZZ") call abort() - end if - - ! contiguous ARRAY - kind 4 <- 1 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str2b(1) = 1_"abcdefg" - str2b(2) = 1_"hijklmn" - str2b(3) = 1_"opqrstu" - ustr1b(1) = 4_"XXX" - ustr1b(2) = 4_"YYY" - ustr1b(3) = 4_"ZZZ" - if (this_image() == num_images()) then - ustr1b(:)[1] = str2b - end if - sync all - if (this_image() == 1) then - if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"hij" & - .or. ustr1b(3) /= 4_"opq") call abort() - else - if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & - .or. ustr1b(3) /= 4_"ZZZ") call abort() - end if - - ! - - - - - array = scalar - - ! contiguous ARRAY - kind 1 <- 4 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr1a = 4_"abc" - str2b(1) = 1_"XXXXXXX" - str2b(2) = 1_"YYYYYYY" - str2b(3) = 1_"ZZZZZZZ" - if (this_image() == num_images()) then - str2b(:)[1] = ustr1a - end if - sync all - if (this_image() == 1) then - if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"abc " & - .or. str2b(3) /= 1_"abc ") call abort() - else - if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & - .or. str2b(3) /= 1_"ZZZZZZZ") call abort() - end if - - ! contiguous ARRAY - kind 4 <- 1 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str1a = 1_"abc" - ustr2b(1) = 4_"XXXXXXX" - ustr2b(2) = 4_"YYYYYYY" - ustr2b(3) = 4_"ZZZZZZZ" - if (this_image() == num_images()) then - ustr2b(:)[1] = str1a - end if - sync all - if (this_image() == 1) then - if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"abc " & - .or. ustr2b(3) /= 4_"abc ") call abort() - else - if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & - .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort() - end if - - ! contiguous ARRAY - kind 1 <- 4 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr2a = 4_"abcdefg" - str1b(1) = 1_"XXX" - str1b(2) = 1_"YYY" - str1b(3) = 1_"ZZZ" - if (this_image() == num_images()) then - str1b(:)[1] = ustr2a - end if - sync all - if (this_image() == 1) then - if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"abc" & - .or. str1b(3) /= 1_"abc") call abort() - else - if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & - .or. str1b(3) /= 1_"ZZZ") call abort() - end if - - ! contiguous ARRAY - kind 4 <- 1 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str2a = 1_"abcdefg" - ustr1b(1) = 4_"XXX" - ustr1b(2) = 4_"YYY" - ustr1b(3) = 4_"ZZZ" - if (this_image() == num_images()) then - ustr1b(:)[1] = str2a - end if - sync all - if (this_image() == 1) then - if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"abc" & - .or. ustr1b(3) /= 4_"abc") call abort() - else - if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & - .or. ustr1b(3) /= 4_"ZZZ") call abort() - end if - - ! ---------- Take from a coindexed variable ------------- - - ! - - - - - scalar = scalar - - ! SCALAR - kind 1 <- 4 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr1a = 4_"abc" - str2a = 1_"XXXXXXX" - if (this_image() == num_images()) then - str2a = ustr1a[1] - end if - sync all - if (this_image() == num_images()) then - if (str2a /= 1_"abc ") call abort() - else - if (str2a /= 1_"XXXXXXX") call abort() - end if - - ! SCALAR - kind 4 <- 1 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str1a = 1_"abc" - ustr2a = 4_"XXXXXXX" - if (this_image() == num_images()) then - ustr2a = str1a[1] - end if - sync all - if (this_image() == num_images()) then - if (ustr2a /= 4_"abc ") call abort() - else - if (ustr2a /= 4_"XXXXXXX") call abort() - end if - - ! SCALAR - kind 1 <- 4 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr2a = 4_"abcde" - str1a = 1_"XXX" - if (this_image() == num_images()) then - str1a = ustr2a[1] - end if - sync all - if (this_image() == num_images()) then - if (str1a /= 1_"abc") call abort() - else - if (str1a /= 1_"XXX") call abort() - end if - - ! SCALAR - kind 4 <- 1 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str2a = 1_"abcde" - ustr1a = 4_"XXX" - if (this_image() == num_images()) then - ustr1a = str2a[1] - end if - sync all - if (this_image() == num_images()) then - if (ustr1a /= 4_"abc") call abort() - else - if (ustr1a /= 4_"XXX") call abort() - end if - - ! - - - - - array = array - - ! contiguous ARRAY - kind 1 <- 4 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr1b(1) = 4_"abc" - ustr1b(2) = 4_"def" - ustr1b(3) = 4_"gjh" - str2b(1) = 1_"XXXXXXX" - str2b(2) = 1_"YYYYYYY" - str2b(3) = 1_"ZZZZZZZ" - if (this_image() == num_images()) then - str2b = ustr1b(:)[1] - end if - sync all - if (this_image() == num_images()) then - if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"def " & - .or. str2b(3) /= 1_"gjh ") call abort() - else - if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & - .or. str2b(3) /= 1_"ZZZZZZZ") call abort() - end if - - ! contiguous ARRAY - kind 4 <- 1 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str1b(1) = 1_"abc" - str1b(2) = 1_"def" - str1b(3) = 1_"gjh" - ustr2b(1) = 4_"XXXXXXX" - ustr2b(2) = 4_"YYYYYYY" - ustr2b(3) = 4_"ZZZZZZZ" - if (this_image() == num_images()) then - ustr2b = str1b(:)[1] - end if - sync all - if (this_image() == num_images()) then - if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"def " & - .or. ustr2b(3) /= 4_"gjh ") call abort() - else - if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & - .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort() - end if - - ! contiguous ARRAY - kind 1 <- 4 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr2b(1) = 4_"abcdefg" - ustr2b(2) = 4_"hijklmn" - ustr2b(3) = 4_"opqrstu" - str1b(1) = 1_"XXX" - str1b(2) = 1_"YYY" - str1b(3) = 1_"ZZZ" - if (this_image() == num_images()) then - str1b = ustr2b(:)[1] - end if - sync all - if (this_image() == num_images()) then - if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"hij" & - .or. str1b(3) /= 1_"opq") call abort() - else - if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & - .or. str1b(3) /= 1_"ZZZ") call abort() - end if - - ! contiguous ARRAY - kind 4 <- 1 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str2b(1) = 1_"abcdefg" - str2b(2) = 1_"hijklmn" - str2b(3) = 1_"opqrstu" - ustr1b(1) = 4_"XXX" - ustr1b(2) = 4_"YYY" - ustr1b(3) = 4_"ZZZ" - if (this_image() == num_images()) then - ustr1b = str2b(:)[1] - end if - sync all - if (this_image() == num_images()) then - if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"hij" & - .or. ustr1b(3) /= 4_"opq") call abort() - else - if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & - .or. ustr1b(3) /= 4_"ZZZ") call abort() - end if - - ! - - - - - array = scalar - - ! contiguous ARRAY - kind 1 <- 4 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr1a = 4_"abc" - str2b(1) = 1_"XXXXXXX" - str2b(2) = 1_"YYYYYYY" - str2b(3) = 1_"ZZZZZZZ" - if (this_image() == num_images()) then - str2b = ustr1a[1] - end if - sync all - if (this_image() == num_images()) then - if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"abc " & - .or. str2b(3) /= 1_"abc ") call abort() - else - if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & - .or. str2b(3) /= 1_"ZZZZZZZ") call abort() - end if - - ! contiguous ARRAY - kind 4 <- 1 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str1a = 1_"abc" - ustr2b(1) = 4_"XXXXXXX" - ustr2b(2) = 4_"YYYYYYY" - ustr2b(3) = 4_"ZZZZZZZ" - if (this_image() == num_images()) then - ustr2b = str1a[1] - end if - sync all - if (this_image() == num_images()) then - if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"abc " & - .or. ustr2b(3) /= 4_"abc ") call abort() - else - if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & - .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort() - end if - - ! contiguous ARRAY - kind 1 <- 4 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr2a = 4_"abcdefg" - str1b(1) = 1_"XXX" - str1b(2) = 1_"YYY" - str1b(3) = 1_"ZZZ" - if (this_image() == num_images()) then - str1b = ustr2a[1] - end if - sync all - if (this_image() == num_images()) then - if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"abc" & - .or. str1b(3) /= 1_"abc") call abort() - else - if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & - .or. str1b(3) /= 1_"ZZZ") call abort() - end if - - ! contiguous ARRAY - kind 4 <- 1 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str2a = 1_"abcdefg" - ustr1b(1) = 4_"XXX" - ustr1b(2) = 4_"YYY" - ustr1b(3) = 4_"ZZZ" - if (this_image() == num_images()) then - ustr1b = str2a[1] - end if - sync all - if (this_image() == num_images()) then - if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"abc" & - .or. ustr1b(3) /= 4_"abc") call abort() - else - if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & - .or. ustr1b(3) /= 4_"ZZZ") call abort() - end if - - - ! ---------- coindexed to coindexed variable ------------- - - ! - - - - - scalar = scalar - - ! SCALAR - kind 1 <- 4 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr1a = 4_"abc" - str2a = 1_"XXXXXXX" - if (this_image() == num_images()) then - str2a[1] = ustr1a[mod(1, num_images())+1] - end if - sync all - if (this_image() == 1) then - if (str2a /= 1_"abc ") call abort() - else - if (str2a /= 1_"XXXXXXX") call abort() - end if - - ! SCALAR - kind 4 <- 1 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str1a = 1_"abc" - ustr2a = 4_"XXXXXXX" - if (this_image() == num_images()) then - ustr2a[1] = str1a[mod(1, num_images())+1] - end if - sync all - if (this_image() == 1) then - if (ustr2a /= 4_"abc ") call abort() - else - if (ustr2a /= 4_"XXXXXXX") call abort() - end if - - ! SCALAR - kind 1 <- 4 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr2a = 4_"abcde" - str1a = 1_"XXX" - if (this_image() == num_images()) then - str1a[1] = ustr2a[mod(1, num_images())+1] - end if - sync all - if (this_image() == 1) then - if (str1a /= 1_"abc") call abort() - else - if (str1a /= 1_"XXX") call abort() - end if - - ! SCALAR - kind 4 <- 1 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str2a = 1_"abcde" - ustr1a = 4_"XXX" - if (this_image() == num_images()) then - ustr1a[1] = str2a[mod(1, num_images())+1] - end if - sync all - if (this_image() == 1) then - if (ustr1a /= 4_"abc") call abort() - else - if (ustr1a /= 4_"XXX") call abort() - end if - - ! - - - - - array = array - - ! contiguous ARRAY - kind 1 <- 4 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr1b(1) = 4_"abc" - ustr1b(2) = 4_"def" - ustr1b(3) = 4_"gjh" - str2b(1) = 1_"XXXXXXX" - str2b(2) = 1_"YYYYYYY" - str2b(3) = 1_"ZZZZZZZ" - if (this_image() == num_images()) then - str2b(:)[1] = ustr1b(:)[mod(1, num_images())+1] - end if - sync all - if (this_image() == 1) then - if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"def " & - .or. str2b(3) /= 1_"gjh ") call abort() - else - if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & - .or. str2b(3) /= 1_"ZZZZZZZ") call abort() - end if - - ! contiguous ARRAY - kind 4 <- 1 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str1b(1) = 1_"abc" - str1b(2) = 1_"def" - str1b(3) = 1_"gjh" - ustr2b(1) = 4_"XXXXXXX" - ustr2b(2) = 4_"YYYYYYY" - ustr2b(3) = 4_"ZZZZZZZ" - if (this_image() == num_images()) then - ustr2b(:)[1] = str1b(:)[mod(1, num_images())+1] - end if - sync all - if (this_image() == 1) then - if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"def " & - .or. ustr2b(3) /= 4_"gjh ") call abort() - else - if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & - .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort() - end if - - ! contiguous ARRAY - kind 1 <- 4 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr2b(1) = 4_"abcdefg" - ustr2b(2) = 4_"hijklmn" - ustr2b(3) = 4_"opqrstu" - str1b(1) = 1_"XXX" - str1b(2) = 1_"YYY" - str1b(3) = 1_"ZZZ" - if (this_image() == num_images()) then - str1b(:)[1] = ustr2b(:)[mod(1, num_images())+1] - end if - sync all - if (this_image() == 1) then - if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"hij" & - .or. str1b(3) /= 1_"opq") call abort() - else - if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & - .or. str1b(3) /= 1_"ZZZ") call abort() - end if - - ! contiguous ARRAY - kind 4 <- 1 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str2b(1) = 1_"abcdefg" - str2b(2) = 1_"hijklmn" - str2b(3) = 1_"opqrstu" - ustr1b(1) = 4_"XXX" - ustr1b(2) = 4_"YYY" - ustr1b(3) = 4_"ZZZ" - if (this_image() == num_images()) then - ustr1b(:)[1] = str2b(:)[mod(1, num_images())+1] - end if - sync all - if (this_image() == 1) then - if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"hij" & - .or. ustr1b(3) /= 4_"opq") call abort() - else - if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & - .or. ustr1b(3) /= 4_"ZZZ") call abort() - end if - - ! - - - - - array = scalar - - ! contiguous ARRAY - kind 1 <- 4 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr1a = 4_"abc" - str2b(1) = 1_"XXXXXXX" - str2b(2) = 1_"YYYYYYY" - str2b(3) = 1_"ZZZZZZZ" - if (this_image() == num_images()) then - str2b(:)[1] = ustr1a[mod(1, num_images())+1] - end if - sync all - if (this_image() == 1) then - if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"abc " & - .or. str2b(3) /= 1_"abc ") call abort() - else - if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & - .or. str2b(3) /= 1_"ZZZZZZZ") call abort() - end if - - ! contiguous ARRAY - kind 4 <- 1 - with padding - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str1a = 1_"abc" - ustr2b(1) = 4_"XXXXXXX" - ustr2b(2) = 4_"YYYYYYY" - ustr2b(3) = 4_"ZZZZZZZ" - if (this_image() == num_images()) then - ustr2b(:)[1] = str1a[mod(1, num_images())+1] - end if - sync all - if (this_image() == 1) then - if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"abc " & - .or. ustr2b(3) /= 4_"abc ") call abort() - else - if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & - .or. ustr2b(3) /= 4_"ZZZZZZZ") call abort() - end if - - ! contiguous ARRAY - kind 1 <- 4 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - ustr2a = 4_"abcdefg" - str1b(1) = 1_"XXX" - str1b(2) = 1_"YYY" - str1b(3) = 1_"ZZZ" - if (this_image() == num_images()) then - str1b(:)[1] = ustr2a[mod(1, num_images())+1] - end if - sync all - if (this_image() == 1) then - if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"abc" & - .or. str1b(3) /= 1_"abc") call abort() - else - if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & - .or. str1b(3) /= 1_"ZZZ") call abort() - end if - - ! contiguous ARRAY - kind 4 <- 1 - with trimming - str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" - str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" - ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" - str2a = 1_"abcdefg" - ustr1b(1) = 4_"XXX" - ustr1b(2) = 4_"YYY" - ustr1b(3) = 4_"ZZZ" - if (this_image() == num_images()) then - ustr1b(:)[1] = str2a[mod(1, num_images())+1] - end if - sync all - if (this_image() == 1) then - if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"abc" & - .or. ustr1b(3) /= 4_"abc") call abort() - else - if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & - .or. ustr1b(3) /= 4_"ZZZ") call abort() - end if - end subroutine char_test end program test Index: gcc/testsuite/gfortran.dg/index_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/index_2.f90 (revision 215645) +++ gcc/testsuite/gfortran.dg/index_2.f90 (working copy) @@ -5,8 +5,8 @@ implicit none character(len=10,kind=1) string1 character(len=10,kind=4) string4 - string1 = 'ABCDEEDCBA' - string4 = 'ABCDEEDCBA' + string1 = 1_'ABCDEEDCBA' + string4 = 4_'ABCDEEDCBA' if(index(string1,1_'A') /= 1) call abort() if(index(string4,4_'A') /= 1) call abort() Index: gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 =================================================================== --- gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 (revision 215645) +++ gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 (working copy) @@ -134,8 +134,8 @@ contains end subroutine subroutine test7 character(kind=4, len=100), allocatable, dimension(:) :: str - character(kind=4, len=3) :: test = "abc" - str = [ "abc" ] + character(kind=4, len=3) :: test = 4_"abc" + str = [ 4_"abc" ] if (TRIM(str(1)) .ne. test) call abort if (len(str) .ne. 100) call abort end subroutine Index: gcc/testsuite/gfortran.dg/widechar_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/widechar_1.f90 (revision 215645) +++ gcc/testsuite/gfortran.dg/widechar_1.f90 (working copy) @@ -10,16 +10,14 @@ s1 = "foo\u0101" ! { dg-error "is not representable" } s1 = "foo\U00000101" ! { dg-error "is not representable" } - s1 = 4_"foo bar" - s1 = 4_"foo\u00ff" - s1 = 4_"foo\u0101" ! { dg-error "cannot be converted" } - s1 = 4_"foo\u1101" ! { dg-error "cannot be converted" } - s1 = 4_"foo\UFFFFFFFF" ! { dg-error "cannot be converted" } + s1 = 4_"foo bar" ! { dg-error "Can't convert" } + s1 = 4_"foo\u00ff" ! { dg-error "Can't convert" } + s1 = 4_"foo\u0101" ! { dg-error "Can't convert" } + s1 = 4_"foo\u1101" ! { dg-error "Can't convert" } + s1 = 4_"foo\UFFFFFFFF" ! { dg-error "Can't convert" } - s4 = "foo\u0000" - s4 = "foo\u00ff" - s4 = "foo\u0100" ! { dg-error "is not representable" } - s4 = "foo\U00000100" ! { dg-error "is not representable" } + s4 = "foo\u0000" ! { dg-error "Can't convert" } + s4 = "foo\u00ff" ! { dg-error "Can't convert" } s4 = 4_"foo bar" s4 = 4_"\xFF\x96" Index: gcc/testsuite/gfortran.dg/widechar_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/widechar_2.f90 (revision 215645) +++ gcc/testsuite/gfortran.dg/widechar_2.f90 (working copy) @@ -1,69 +0,0 @@ -! { dg-do run } -! { dg-options "-fbackslash" } - - character(kind=1,len=20) :: s1 - character(kind=4,len=20) :: s4 - - s1 = "this is me!" - s4 = s1 - call check(s1, 4_"this is me! ") - call check2(s1, 4_"this is me! ") - s4 = "this is me!" - call check(s1, 4_"this is me! ") - call check2(s1, 4_"this is me! ") - - s1 = "" - s4 = s1 - call check(s1, 4_" ") - call check2(s1, 4_" ") - s4 = "" - call check(s1, 4_" ") - call check2(s1, 4_" ") - - s1 = " \xFF" - s4 = s1 - call check(s1, 4_" \xFF ") - call check2(s1, 4_" \xFF ") - s4 = " \xFF" - call check(s1, 4_" \xFF ") - call check2(s1, 4_" \xFF ") - - s1 = " \xFF" - s4 = s1 - call check(s1, 4_" \xFF ") - call check2(s1, 4_" \xFF ") - s4 = " \xFF" - call check(s1, 4_" \xFF ") - call check2(s1, 4_" \xFF ") - -contains - subroutine check(s1,s4) - character(kind=1,len=20) :: s1, t1 - character(kind=4,len=20) :: s4 - t1 = s4 - if (t1 /= s1) call abort - if (len(s1) /= len(t1)) call abort - if (len(s1) /= len(s4)) call abort - if (len_trim(s1) /= len_trim(t1)) call abort - if (len_trim(s1) /= len_trim(s4)) call abort - end subroutine check - - subroutine check2(s1,s4) - character(kind=1,len=*) :: s1 - character(kind=4,len=*) :: s4 - character(kind=1,len=len(s1)) :: t1 - character(kind=4,len=len(s4)) :: t4 - - t1 = s4 - t4 = s1 - if (t1 /= s1) call abort - if (t4 /= s4) call abort - if (len(s1) /= len(t1)) call abort - if (len(s1) /= len(s4)) call abort - if (len(s1) /= len(t4)) call abort - if (len_trim(s1) /= len_trim(t1)) call abort - if (len_trim(s1) /= len_trim(s4)) call abort - if (len_trim(s1) /= len_trim(t4)) call abort - end subroutine check2 - -end Index: gcc/testsuite/gfortran.dg/widechar_7.f90 =================================================================== --- gcc/testsuite/gfortran.dg/widechar_7.f90 (revision 215645) +++ gcc/testsuite/gfortran.dg/widechar_7.f90 (working copy) @@ -1,19 +0,0 @@ -! { dg-do compile } -! { dg-options "-fdump-tree-original" } - -program test - - character(kind=1,len=10) :: s1 = 4_"foobargee", t1 = 4_"" - character(kind=4,len=10) :: s4 = "foobargee", t4 = "" - - t1(5:5) = s1(6:6) - t4(5:5) = s4(6:6) - t4(5:5) = s1(6:6) - t1(5:5) = s4(6:6) - - call sub (t1, t4) - -end program test - -! { dg-final { scan-tree-dump-times "memmove" 0 "original" } } -! { dg-final { cleanup-tree-dump "original" } } Index: gcc/testsuite/gfortran.dg/widechar_IO_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/widechar_IO_2.f90 (revision 215645) +++ gcc/testsuite/gfortran.dg/widechar_IO_2.f90 (working copy) @@ -13,7 +13,7 @@ program chkdata if (buffer /= "def5678ghi9012abc1234") call abort write(buffer,'(3(a))') mychar if (buffer /= "abc1234def5678ghi9012") call abort - mychar = "" + mychar = k4_"" read(buffer,'(3(a))') mychar if (any(mychar.ne.[ k4_"abc1234",k4_"def5678",k4_"ghi9012" ])) call abort end program chkdata Index: gcc/testsuite/gfortran.dg/widechar_IO_3.f90 =================================================================== --- gcc/testsuite/gfortran.dg/widechar_IO_3.f90 (revision 215645) +++ gcc/testsuite/gfortran.dg/widechar_IO_3.f90 (working copy) @@ -10,12 +10,12 @@ program test1 open(10, form="unformatted", status="scratch") write(10) wide rewind(10) - wide = "wrong" + wide = k4_"wrong" read(10) wide if (wide /= k4_"abcdefg") call abort rewind(10) write(10) widearray(2:4,3:7) - widearray(2:4,3:7)="" + widearray(2:4,3:7) = k4_"" rewind(10) read(10) widearray(2:4,3:7) close(10) Index: gcc/testsuite/gfortran.dg/widechar_IO_4.f90 =================================================================== --- gcc/testsuite/gfortran.dg/widechar_IO_4.f90 (revision 215645) +++ gcc/testsuite/gfortran.dg/widechar_IO_4.f90 (working copy) @@ -10,7 +10,7 @@ character(kind=4,len=20) :: str = k4_'X\ buffer = "" write(buffer,'(3a)')':',trim(str),':' if (buffer.ne.':X\xF8öABC: ') call abort -str = "" +str = k4_"" read(buffer,'(3a)') c1,str(1:6),c2 if (c1.ne.':') call abort if (str.ne.k4_'X\xF8öAB') call abort Index: gcc/testsuite/gfortran.dg/widechar_intrinsics_10.f90 =================================================================== --- gcc/testsuite/gfortran.dg/widechar_intrinsics_10.f90 (revision 215645) +++ gcc/testsuite/gfortran.dg/widechar_intrinsics_10.f90 (working copy) @@ -6,8 +6,7 @@ character(kind=4,len=3) :: s4(3) s1 = [ "abc", "def", "ghi" ] - s4 = s1 - s4 = [ "abc", "def", "ghi" ] + s4 = [ 4_"abc", 4_"def", 4_"ghi" ] if (any (cshift (s1, 0) /= s1)) call abort if (any (cshift (s4, 0) /= s4)) call abort Index: gcc/testsuite/gfortran.dg/widechar_intrinsics_4.f90 =================================================================== --- gcc/testsuite/gfortran.dg/widechar_intrinsics_4.f90 (revision 215645) +++ gcc/testsuite/gfortran.dg/widechar_intrinsics_4.f90 (working copy) @@ -16,11 +16,11 @@ s1 = "\0 foo bar \xFF" ; s4 = 4_"\0 foo bar \xFF" call test_adjust2 (s1, s4) - s4 = "\0 foo bar \xFF" + s4 = 4_"\0 foo bar \xFF" if (adjustl (s4) /= adjustl (4_"\0 foo bar \xFF ")) call abort if (adjustr (s4) /= adjustr (4_"\0 foo bar \xFF ")) call abort - s4 = " \0 foo bar \xFF" + s4 = 4_" \0 foo bar \xFF" if (adjustl (s4) /= adjustl (4_" \0 foo bar \xFF ")) call abort if (adjustr (s4) /= adjustr (4_" \0 foo bar \xFF ")) call abort @@ -45,8 +45,8 @@ contains if (len_trim(s1) /= len_trim (s4)) call abort - t1 = adjustl (s4) - t4 = adjustl (s1) + t1 = to1 (adjustl (s4)) + t4 = to4 (adjustl (s1)) if (t1 /= adjustl (s1)) call abort if (t4 /= adjustl (s4)) call abort if (len_trim (t1) /= len_trim (t4)) call abort @@ -58,8 +58,8 @@ contains if (len_trim (t4) /= len (trim (t4))) call abort if (len_trim (s4) /= len (trim (s4))) call abort - t1 = adjustr (s4) - t4 = adjustr (s1) + t1 = to1 (adjustr (s4)) + t4 = to4 (adjustr (s1)) if (t1 /= adjustr (s1)) call abort if (t4 /= adjustr (s4)) call abort if (len_trim (t1) /= len_trim (t4)) call abort @@ -88,8 +88,8 @@ contains if (len_trim(s1) /= len_trim (s4)) call abort - t1 = adjustl (s4) - t4 = adjustl (s1) + t1 = to1 (adjustl (s4)) + t4 = to4 (adjustl (s1)) if (t1 /= adjustl (s1)) call abort if (t4 /= adjustl (s4)) call abort if (len_trim (t1) /= len_trim (t4)) call abort @@ -101,8 +101,8 @@ contains if (len_trim (t4) /= len (trim (t4))) call abort if (len_trim (s4) /= len (trim (s4))) call abort - t1 = adjustr (s4) - t4 = adjustr (s1) + t1 = to1 (adjustr (s4)) + t4 = to4 (adjustr (s1)) if (t1 /= adjustr (s1)) call abort if (t4 /= adjustr (s4)) call abort if (len_trim (t1) /= len_trim (t4)) call abort @@ -118,4 +118,30 @@ contains end subroutine test_adjust2 + + ! Functions to convert between character kinds, assuming + ! only representable characters are used. + + function to4 (s1) + implicit none + character(kind=1, len=*), intent(in) :: s1 + character(kind=4, len=len(s1)) :: to4 + integer :: i + + do i = 1, len(s1) + to4(i:i) = achar(iachar(s1(i:i)), kind=4) + end do + end function + + function to1 (s4) + implicit none + character(kind=4, len=*), intent(in) :: s4 + character(kind=1, len=len(s4)) :: to1 + integer :: i + + do i = 1, len(s4) + to1(i:i) = achar(iachar(s4(i:i)), kind=1) + end do + end function + end Index: gcc/testsuite/gfortran.dg/widechar_intrinsics_9.f90 =================================================================== --- gcc/testsuite/gfortran.dg/widechar_intrinsics_9.f90 (revision 215645) +++ gcc/testsuite/gfortran.dg/widechar_intrinsics_9.f90 (working copy) @@ -51,8 +51,16 @@ contains implicit none character(kind=1,len=*), intent(in) :: s1, s2, smin, smax character(kind=4,len=len(s1)) :: w1, w2, wmin, wmax + integer :: i + + ! Translate the short strings into wide strings + do i = 1, len(s1) + w1(i:i) = achar(iachar(s1(i:i)), kind=4) + w2(i:i) = achar(iachar(s2(i:i)), kind=4) + wmin(i:i) = achar(iachar(smin(i:i)), kind=4) + wmax(i:i) = achar(iachar(smax(i:i)), kind=4) + end do - w1 = s1 ; w2 = s2 ; wmin = smin ; wmax = smax if (min (w1, w2) /= wmin) call abort if (max (w1, w2) /= wmax) call abort if (min (s1, s2) /= smin) call abort