Index: gcc/testsuite/gfortran.dg/compliant_elemental_intrinsics_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/compliant_elemental_intrinsics_1.f90 (revision 0) --- gcc/testsuite/gfortran.dg/compliant_elemental_intrinsics_1.f90 (revision 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 + ! + 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 Index: gcc/testsuite/gfortran.dg/initialization_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/initialization_1.f90 (revision 112441) --- gcc/testsuite/gfortran.dg/initialization_1.f90 (working copy) *************** contains *** 21,26 **** --- 21,27 ---- 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" } Index: gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 (revision 112441) --- gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 (working copy) *************** *** 1,22 **** ! ! { dg-do run { target i?86-*-* x86_64-*-* } } ! Tests the patch to implement the array version of the TRANSFER ! intrinsic (PR17298). - ! Contributed by Paul Thomas ! character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/) ! ! ! tests numeric transfers(including PR testcase). 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 () --- 1,11 ---- ! ! { dg-do run } ! Tests the patch to implement the array version of the TRANSFER ! intrinsic (PR17298). ! ! test the PR is fixed. call test1 () contains subroutine test1 () *************** contains *** 29,118 **** 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 --- 18,23 ---- Index: gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 =================================================================== *** gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 (revision 112441) --- gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 (working copy) *************** *** 1,23 **** ! ! { dg-do run { target i?86-*-* x86_64-*-* } } ! ! { dg-options "-fpack-derived" } ! call test3() 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 end --- 1,118 ---- ! ! { dg-do run } ! ! Tests the patch to implement the array version of the TRANSFER ! ! intrinsic (PR17298). ! ! Contributed by Paul Thomas ! ! ! Bigendian test posted by Perseus in comp.lang.fortran on 4 July 2005. ! ! Original had parameter but this fails, at present, with -Ox, x>0 ! ! LOGICAL :: bigend ! ! character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/) ! ! bigend = IACHAR(TRANSFER(1,"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 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 Index: gcc/fortran/array.c =================================================================== *** gcc/fortran/array.c (revision 112441) --- gcc/fortran/array.c (working copy) *************** gfc_array_dimen_size (gfc_expr * array, *** 1872,1877 **** --- 1872,1883 ---- } } + 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; Index: gcc/fortran/resolve.c =================================================================== *** gcc/fortran/resolve.c (revision 112441) --- gcc/fortran/resolve.c (working copy) *************** resolve_function (gfc_expr * expr) *** 1205,1210 **** --- 1205,1211 ---- const char *name; try t; int temp; + int i; sym = NULL; if (expr->symtree) *************** resolve_function (gfc_expr * expr) *** 1304,1309 **** --- 1305,1316 ---- 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; } } Index: gcc/fortran/iresolve.c =================================================================== *** gcc/fortran/iresolve.c (revision 112441) --- gcc/fortran/iresolve.c (working copy) *************** gfc_resolve_transfer (gfc_expr * f, gfc_ *** 1955,1960 **** --- 1955,1965 ---- { 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); + } } }