Mercurial > hg > CbC > CbC_gcc
view gcc/testsuite/gfortran.dg/allocate_with_source_23.f03 @ 120:f93fa5091070
fix conv1.c
author | mir3636 |
---|---|
date | Thu, 08 Mar 2018 14:53:42 +0900 |
parents | 04ced10e8804 |
children | 84e7813d76e9 |
line wrap: on
line source
! { dg-do run } ! { dg-options "-fcheck=bounds" } ! { dg-shouldfail "Array bounds mismatch" } ! ! Test that pr72832 is fixed now. ! Contributed by Daan van Vugt program allocate_source type :: t integer :: i end type t type, extends(t) :: tt end type tt call test_type() call test_class_correct() call test_class_fail() contains subroutine test_class_correct() class(t), allocatable, dimension(:) :: a, b allocate(tt::a(1:2)) a(:)%i = [ 1,2 ] if (size(a) /= 2) call abort() if (any(a(:)%i /= [ 1,2])) call abort() allocate(b(1:4), source=a(1)) if (size(b) /= 4) call abort() if (any(b(:)%i /= [ 1,1,1,1])) call abort() select type (b(1)) class is (tt) continue class default call abort() end select end subroutine subroutine test_class_fail() class(t), allocatable, dimension(:) :: a, b allocate(tt::a(1:2)) a(:)%i = [ 1,2 ] if (size(a) /= 2) call abort() if (any(a(:)%i /= [ 1,2])) call abort() allocate(b(1:4), source=a) ! Fail expected: sizes do not conform if (size(b) /= 4) call abort() if (any(b(1:2)%i /= [ 1,2])) call abort() select type (b(1)) class is (tt) continue class default call abort() end select end subroutine subroutine test_type() type(t), allocatable, dimension(:) :: a, b allocate(a(1:2)) if (size(a) /= 2) call abort() allocate(b(1:4), source=a) if (size(b) /= 4) call abort() end subroutine end program allocate_source