diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 14 | ||||
| -rw-r--r-- | gcc/fortran/array.c | 6 | ||||
| -rw-r--r-- | gcc/fortran/iresolve.c | 5 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 7 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 74 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 26 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 2 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 12 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/compliant_elemental_intrinsics_1.f90 | 26 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/initialization_1.f90 | 1 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/missing_optional_dummy_1.f90 | 49 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 | 99 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 | 138 |
13 files changed, 316 insertions, 143 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 3743cbd..fe9ad51 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2006-04-03 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/26981 + * trans.h : Prototype for gfc_conv_missing_dummy. + * trans-expr (gfc_conv_missing_dummy): New function + (gfc_conv_function_call): Call it and tidy up some of the code. + * trans-intrinsic (gfc_conv_intrinsic_function_args): The same. + + PR fortran/26976 + * array.c (gfc_array_dimen_size): If available, return shape[dimen]. + * resolve.c (resolve_function): If available, use the argument shape for the + function expression. + * iresolve.c (gfc_resolve_transfer): Set shape[0] = size. + 2006-04-02 Erik Edelmann <eedelman@gcc.gnu.org> * trans-array.c (gfc_trans_dealloc_allocated): Take a diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 9491406..2cb3499 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1872,6 +1872,12 @@ gfc_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result) } } + if (array->shape && array->shape[dimen]) + { + mpz_init_set (*result, array->shape[dimen]); + return SUCCESS; + } + if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE) return FAILURE; diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index a517994..d07864e 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -1955,6 +1955,11 @@ gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED, { f->rank = 1; f->value.function.name = transfer1; + if (size && gfc_is_constant_expr (size)) + { + f->shape = gfc_get_shape (1); + mpz_init_set (f->shape[0], size->value.integer); + } } } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 562338f..4831d79 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1205,6 +1205,7 @@ resolve_function (gfc_expr * expr) const char *name; try t; int temp; + int i; sym = NULL; if (expr->symtree) @@ -1304,6 +1305,12 @@ resolve_function (gfc_expr * expr) if (arg->expr != NULL && arg->expr->rank > 0) { expr->rank = arg->expr->rank; + if (!expr->shape && arg->expr->shape) + { + expr->shape = gfc_get_shape (expr->rank); + for (i = 0; i < expr->rank; i++) + mpz_init_set (expr->shape[i], arg->expr->shape[i]); + } break; } } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 94921bc..1e1802e 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -142,6 +142,31 @@ gfc_conv_expr_present (gfc_symbol * sym) } +/* Converts a missing, dummy argument into a null or zero. */ + +void +gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts) +{ + tree present; + tree tmp; + + present = gfc_conv_expr_present (arg->symtree->n.sym); + tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr, + convert (TREE_TYPE (se->expr), integer_zero_node)); + tmp = gfc_evaluate_now (tmp, &se->pre); + se->expr = tmp; + if (ts.type == BT_CHARACTER) + { + tmp = convert (gfc_charlen_type_node, integer_zero_node); + tmp = build3 (COND_EXPR, gfc_charlen_type_node, present, + se->string_length, tmp); + tmp = gfc_evaluate_now (tmp, &se->pre); + se->string_length = tmp; + } + return; +} + + /* Get the character length of an expression, looking through gfc_refs if necessary. */ @@ -1805,6 +1830,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, bool callee_alloc; gfc_typespec ts; gfc_charlen cl; + gfc_expr *e; + gfc_symbol *fsym; arglist = NULL_TREE; retargs = NULL_TREE; @@ -1844,7 +1871,9 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, /* Evaluate the arguments. */ for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) { - if (arg->expr == NULL) + e = arg->expr; + fsym = formal ? formal->sym : NULL; + if (e == NULL) { if (se->ignore_optional) @@ -1872,19 +1901,19 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, { /* An elemental function inside a scalarized loop. */ gfc_init_se (&parmse, se); - gfc_conv_expr_reference (&parmse, arg->expr); + gfc_conv_expr_reference (&parmse, e); } else { /* A scalar or transformational function. */ gfc_init_se (&parmse, NULL); - argss = gfc_walk_expr (arg->expr); + argss = gfc_walk_expr (e); if (argss == gfc_ss_terminator) { - gfc_conv_expr_reference (&parmse, arg->expr); - if (formal && formal->sym->attr.pointer - && arg->expr->expr_type != EXPR_NULL) + gfc_conv_expr_reference (&parmse, e); + if (fsym && fsym->attr.pointer + && e->expr_type != EXPR_NULL) { /* Scalar pointer dummy args require an extra level of indirection. The null pointer already contains @@ -1901,27 +1930,27 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, convention, and pass the address of the array descriptor instead. Otherwise we use g77's calling convention. */ int f; - f = (formal != NULL) - && !(formal->sym->attr.pointer || formal->sym->attr.allocatable) - && formal->sym->as->type != AS_ASSUMED_SHAPE; + f = (fsym != NULL) + && !(fsym->attr.pointer || fsym->attr.allocatable) + && fsym->as->type != AS_ASSUMED_SHAPE; f = f || !sym->attr.always_explicit; - if (arg->expr->expr_type == EXPR_VARIABLE - && is_aliased_array (arg->expr)) + if (e->expr_type == EXPR_VARIABLE + && is_aliased_array (e)) /* The actual argument is a component reference to an array of derived types. In this case, the argument is converted to a temporary, which is passed and then written back after the procedure call. */ - gfc_conv_aliased_arg (&parmse, arg->expr, f); + gfc_conv_aliased_arg (&parmse, e, f); else - gfc_conv_array_parameter (&parmse, arg->expr, argss, f); + gfc_conv_array_parameter (&parmse, e, argss, f); /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ - if (formal && formal->sym->attr.allocatable - && formal->sym->attr.intent == INTENT_OUT) + if (fsym && fsym->attr.allocatable + && fsym->attr.intent == INTENT_OUT) { - tmp = arg->expr->symtree->n.sym->backend_decl; - if (arg->expr->symtree->n.sym->attr.dummy) + tmp = e->symtree->n.sym->backend_decl; + if (e->symtree->n.sym->attr.dummy) tmp = build_fold_indirect_ref (tmp); tmp = gfc_trans_dealloc_allocated (tmp); gfc_add_expr_to_block (&se->pre, tmp); @@ -1930,8 +1959,15 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, } } - if (formal && need_interface_mapping) - gfc_add_interface_mapping (&mapping, formal->sym, &parmse); + /* If an optional argument is itself an optional dummy argument, + check its presence and substitute a null if absent. */ + if (e && e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.optional + && fsym && fsym->attr.optional) + gfc_conv_missing_dummy (&parmse, e, fsym->ts); + + if (fsym && need_interface_mapping) + gfc_add_interface_mapping (&mapping, fsym, &parmse); gfc_add_block_to_block (&se->pre, &parmse.pre); gfc_add_block_to_block (&se->post, &parmse.post); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 87d3a74..b69ffef 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -165,28 +165,42 @@ static tree gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr) { gfc_actual_arglist *actual; - tree args; + gfc_expr *e; + gfc_intrinsic_arg *formal; gfc_se argse; + tree args; args = NULL_TREE; - for (actual = expr->value.function.actual; actual; actual = actual->next) + formal = expr->value.function.isym->formal; + + for (actual = expr->value.function.actual; actual; actual = actual->next, + formal = formal ? formal->next : NULL) { + e = actual->expr; /* Skip omitted optional arguments. */ - if (!actual->expr) + if (!e) continue; /* Evaluate the parameter. This will substitute scalarized references automatically. */ gfc_init_se (&argse, se); - if (actual->expr->ts.type == BT_CHARACTER) + if (e->ts.type == BT_CHARACTER) { - gfc_conv_expr (&argse, actual->expr); + gfc_conv_expr (&argse, e); gfc_conv_string_parameter (&argse); args = gfc_chainon_list (args, argse.string_length); } else - gfc_conv_expr_val (&argse, actual->expr); + gfc_conv_expr_val (&argse, e); + + /* If an optional argument is itself an optional dummy argument, + check its presence and substitute a null if absent. */ + if (e->expr_type ==EXPR_VARIABLE + && e->symtree->n.sym->attr.optional + && formal + && formal->optional) + gfc_conv_missing_dummy (&argse, e, formal->ts); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 4955fe4..0b1514e 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -317,6 +317,8 @@ void gfc_conv_structure (gfc_se *, gfc_expr *, int); /* Return an expression which determines if a dummy parameter is present. */ tree gfc_conv_expr_present (gfc_symbol *); +/* Convert a missing, dummy argument into a null or zero. */ +void gfc_conv_missing_dummy (gfc_se *, gfc_expr *, gfc_typespec); /* Generate code to allocate a string temporary. */ tree gfc_conv_string_tmp (gfc_se *, tree, tree); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 66badc3..6ae43d5 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,15 @@ +2006-04-03 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/26981 + * gfortran.dg/missing_optional_dummy_1.f90: New test. + + PR fortran/26976 + * gfortran.dg/compliant_elemental_intrinsics_1.f90: New test. + * gfortran.dg/initialization_1.f90: Make assignment compliant. + * gfortran.dg/transfer_array_intrinsic_1.f90: Simplify. + * gfortran.dg/transfer_array_intrinsic_2.f90: Make assignments compliant and detect + bigendian-ness. + 2006-04-02 Erik Edelmann <eedelman@gcc.gnu.org> * gfortran.dg/allocatable_dummy_1.f90: Also check that allocatable diff --git a/gcc/testsuite/gfortran.dg/compliant_elemental_intrinsics_1.f90 b/gcc/testsuite/gfortran.dg/compliant_elemental_intrinsics_1.f90 new file mode 100644 index 0000000..7829d97 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/compliant_elemental_intrinsics_1.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! Tests the fix for PR26976, in which non-compliant elemental +! intrinsic function results were not detected. At the same +! time, the means to tests the compliance of TRANSFER with the +! optional SIZE parameter was added. +! +! Contributed by Dominique Dhumieres <dominiq@lps.ens.fr> +! +real(4) :: pi, a(2), b(3) +character(26) :: ch + +pi = acos(-1.0) +b = pi + +a = cos(b) ! { dg-error "different shape for Array assignment" } + +a = -pi +b = cos(a) ! { dg-error "different shape for Array assignment" } + +ch = "abcdefghijklmnopqrstuvwxyz" +a = transfer (ch, pi, 3) ! { dg-error "different shape for Array assignment" } + +! This already generated an error +b = reshape ((/1.0/),(/1/)) ! { dg-error "different shape for Array assignment" } + +end diff --git a/gcc/testsuite/gfortran.dg/initialization_1.f90 b/gcc/testsuite/gfortran.dg/initialization_1.f90 index b9199fe..af7ccb0 100644 --- a/gcc/testsuite/gfortran.dg/initialization_1.f90 +++ b/gcc/testsuite/gfortran.dg/initialization_1.f90 @@ -21,6 +21,7 @@ contains real(8) :: x (1:2, *) real(8) :: y (0:,:) integer :: i + real :: z(2, 2) ! However, this gives a warning because it is an initialization expression. integer :: l1 = len (ch1) ! { dg-warning "assumed character length variable" } diff --git a/gcc/testsuite/gfortran.dg/missing_optional_dummy_1.f90 b/gcc/testsuite/gfortran.dg/missing_optional_dummy_1.f90 new file mode 100644 index 0000000..29f08f9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/missing_optional_dummy_1.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! Test the fix for PR26891, in which an optional argument, whose actual +! is a missing dummy argument would cause a segfault. +! +! Contributed by Paul Thomas <pault@gcc.gnu.org> +! + logical :: back =.false. + +! This was the case that would fail - PR case was an intrinsic call. + if (scan ("A quick brown fox jumps over the lazy dog", "lazy", back) & + .ne. myscan ("A quick brown fox jumps over the lazy dog", "lazy")) & + call abort () + +! Check that the patch works with non-intrinsic functions. + if (myscan ("A quick brown fox jumps over the lazy dog", "fox", back) & + .ne. thyscan ("A quick brown fox jumps over the lazy dog", "fox")) & + call abort () + +! Check that missing, optional character actual arguments are OK. + if (scan ("A quick brown fox jumps over the lazy dog", "over", back) & + .ne. thyscan ("A quick brown fox jumps over the lazy dog")) & + call abort () + +contains + integer function myscan (str, substr, back) + character(*), intent(in) :: str, substr + logical, optional, intent(in) :: back + myscan = scan (str, substr, back) + end function myscan + + integer function thyscan (str, substr, back) + character(*), intent(in) :: str + character(*), optional, intent(in) :: substr + logical, optional, intent(in) :: back + thyscan = isscan (str, substr, back) + end function thyscan + + integer function isscan (str, substr, back) + character(*), intent(in) :: str + character(*), optional :: substr + logical, optional, intent(in) :: back + if (.not.present(substr)) then + isscan = myscan (str, "over", back) + else + isscan = myscan (str, substr, back) + end if + end function isscan + +end diff --git a/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 index 05b4717..0d828ef 100644 --- a/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 +++ b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 @@ -1,22 +1,11 @@ -! { dg-do run { target i?86-*-* x86_64-*-* } } +! { dg-do run } ! Tests the patch to implement the array version of the TRANSFER ! intrinsic (PR17298). -! Contributed by Paul Thomas <pault@gcc.gnu.org> - character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/) - -! tests numeric transfers(including PR testcase). +! test the PR is fixed. call test1 () -! tests numeric/character transfers. - - call test2 () - -! Test dummies, automatic objects and assumed character length. - - call test3 (ch, ch, ch, 8) - contains subroutine test1 () @@ -29,90 +18,6 @@ contains cmp = transfer (z, cmp) * 2.0 if (any (cmp .ne. (/2.0, 4.0/))) call abort () -! Check that size smaller than the source word length is OK. - - z = (-1.0, -2.0) - cmp = transfer (z, cmp, 1) * 8.0 - if (any (cmp .ne. (/-8.0, 4.0/))) call abort () - -! Check multi-dimensional sources and that transfer works as an actual -! argument of reshape. - - a = reshape ((/(rand (), i = 1, 16)/), (/4,4/)) - jt = transfer (a, it) - it = reshape (jt, (/4, 2, 4/)) - if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) call abort () - end subroutine test1 - subroutine test2 () - integer(4) :: y(4), z(2) - character(4) :: ch(4) - y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) & - + ishft (i + 3, 24), i = 65, 80 , 4)/) - -! Check source array sections in both directions. - - ch = "wxyz" - ch = transfer (y(2:4:2), ch) - if (any (ch .ne. (/"EFGH","MNOP","wxyz","wxyz"/))) call abort () - ch = "wxyz" - ch = transfer (y(4:2:-2), ch) - if (any (ch .ne. (/"MNOP","EFGH","wxyz","wxyz"/))) call abort () - -! Check that a complete array transfers with size absent. - - ch = transfer (y, ch) - if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort () - -! Check that a character array section is OK - - z = transfer (ch(2:3), y) - if (any (z .ne. y(2:3))) call abort () - -! Check dest array sections in both directions. - - ch = "wxyz" - ch(3:4) = transfer (y, ch, 2) - if (any (ch .ne. (/"wxyz","wxyz","ABCD","EFGH"/))) call abort () - ch = "wxyz" - ch(3:2:-1) = transfer (y, ch, 3) - if (any (ch .ne. (/"wxyz","EFGH","ABCD","wxyz"/))) call abort () - -! Check that too large a value of size is cut off. - - ch = "wxyz" - ch(1:2) = transfer (y, ch, 3) - if (any (ch .ne. (/"ABCD","EFGH","wxyz","wxyz"/))) call abort () - -! Make sure that character to numeric is OK. - - z = transfer (ch, y) - if (any (y(1:2) .ne. z)) call abort () - - end subroutine test2 - - subroutine test3 (ch1, ch2, ch3, clen) - integer clen - character(8) :: ch1(:) - character(*) :: ch2(2) - character(clen) :: ch3(2) - character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/) - integer(8) :: ic(2) - ic = transfer (cntrl, ic) - -! Check assumed shape. - - if (any (ic .ne. transfer (ch1, ic))) call abort () - -! Check assumed character length. - - if (any (ic .ne. transfer (ch2, ic))) call abort () - -! Check automatic character length. - - if (any (ic .ne. transfer (ch3, ic))) call abort () - - end subroutine test3 - end diff --git a/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 index a787440..aaa10f8 100644 --- a/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 +++ b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 @@ -1,23 +1,119 @@ -! { dg-do run { target i?86-*-* x86_64-*-* } } -! { dg-options "-fpack-derived" } - call test3() +! { dg-do run } +! Tests the patch to implement the array version of the TRANSFER +! intrinsic (PR17298). +! Contributed by Paul Thomas <pault@gcc.gnu.org> + +! Bigendian test posted by Perseus in comp.lang.fortran on 4 July 2005. +! Original had parameter but this fails, at present, if is_gimple_var with -Ox, x>0 + + LOGICAL :: bigend + integer :: icheck = 1 + + character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/) + + bigend = IACHAR(TRANSFER(icheck,"a")) == 0 + +! tests numeric transfers other than original testscase. + + call test1 () + +! tests numeric/character transfers. + + call test2 () + +! Test dummies, automatic objects and assumed character length. + + call test3 (ch, ch, ch, 8) + contains - subroutine test3 () - type mytype - sequence - real(8) :: x = 3.14159 - character(4) :: ch = "wxyz" - integer(2) :: i = 77 - end type mytype - type(mytype) :: z(2) - character(1) :: c(32) - character(4) :: chr - real(8) :: a - integer(2) :: l - equivalence (a, c(15)), (chr, c(23)), (l, c(27)) - c = transfer(z, c) - if (a .ne. z(1)%x) call abort () - if (chr .ne. z(1)%ch) call abort () - if (l .ne. z(1)%i) call abort () - end subroutine test3 + + subroutine test1 () + real(4) :: a(4, 4) + integer(2) :: it(4, 2, 4), jt(32) + +! Check multi-dimensional sources and that transfer works as an actual +! argument of reshape. + + a = reshape ((/(rand (), i = 1, 16)/), (/4,4/)) + jt = transfer (a, it) + it = reshape (jt, (/4, 2, 4/)) + if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) call abort () + + end subroutine test1 + + subroutine test2 () + integer(4) :: y(4), z(2) + character(4) :: ch(4) + +! Allow for endian-ness + if (bigend) then + y = (/(i + 3 + ishft (i + 2, 8) + ishft (i + 1, 16) & + + ishft (i, 24), i = 65, 80 , 4)/) + else + y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) & + + ishft (i + 3, 24), i = 65, 80 , 4)/) + end if + +! Check source array sections in both directions. + + ch = "wxyz" + ch(1:2) = transfer (y(2:4:2), ch) + if (any (ch(1:2) .ne. (/"EFGH","MNOP"/))) call abort () + ch = "wxyz" + ch(1:2) = transfer (y(4:2:-2), ch) + if (any (ch(1:2) .ne. (/"MNOP","EFGH"/))) call abort () + +! Check that a complete array transfers with size absent. + + ch = transfer (y, ch) + if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort () + +! Check that a character array section is OK + + z = transfer (ch(2:3), y) + if (any (z .ne. y(2:3))) call abort () + +! Check dest array sections in both directions. + + ch = "wxyz" + ch(3:4) = transfer (y, ch, 2) + if (any (ch(3:4) .ne. (/"ABCD","EFGH"/))) call abort () + ch = "wxyz" + ch(3:2:-1) = transfer (y, ch, 2) + if (any (ch(2:3) .ne. (/"EFGH","ABCD"/))) call abort () + +! Make sure that character to numeric is OK. + + ch = "wxyz" + ch(1:2) = transfer (y, ch, 2) + if (any (ch(1:2) .ne. (/"ABCD","EFGH"/))) call abort () + + z = transfer (ch, y) + if (any (y(1:2) .ne. z)) call abort () + + end subroutine test2 + + subroutine test3 (ch1, ch2, ch3, clen) + integer clen + character(8) :: ch1(:) + character(*) :: ch2(2) + character(clen) :: ch3(2) + character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/) + integer(8) :: ic(2) + ic = transfer (cntrl, ic) + +! Check assumed shape. + + if (any (ic .ne. transfer (ch1, ic))) call abort () + +! Check assumed character length. + + if (any (ic .ne. transfer (ch2, ic))) call abort () + +! Check automatic character length. + + if (any (ic .ne. transfer (ch3, ic))) call abort () + + end subroutine test3 + end |