1! { dg-do run } 2! Test (re)allocation on assignment of scalars 3! 4! Contributed by Paul Thomas <pault@gcc.gnu.org> 5! 6 call test_real 7 call test_derived 8 call test_char1 9 call test_char4 10 call test_deferred_char1 11 call test_deferred_char4 12contains 13 subroutine test_real 14 real, allocatable :: x 15 real :: y = 42 16 x = 42.0 17 if (x .ne. y) STOP 1 18 deallocate (x) 19 x = y 20 if (x .ne. y) STOP 2 21 end subroutine 22 subroutine test_derived 23 type :: mytype 24 real :: x 25 character(4) :: c 26 end type 27 type (mytype), allocatable :: t 28 t = mytype (99.0, "abcd") 29 if (t%c .ne. "abcd") STOP 3 30 end subroutine 31 subroutine test_char1 32 character(len = 8), allocatable :: c1 33 character(len = 8) :: c2 = "abcd1234" 34 c1 = "abcd1234" 35 if (c1 .ne. c2) STOP 4 36 deallocate (c1) 37 c1 = c2 38 if (c1 .ne. c2) STOP 5 39 end subroutine 40 subroutine test_char4 41 character(len = 8, kind = 4), allocatable :: c1 42 character(len = 8, kind = 4) :: c2 = 4_"abcd1234" 43 c1 = 4_"abcd1234" 44 if (c1 .ne. c2) STOP 6 45 deallocate (c1) 46 c1 = c2 47 if (c1 .ne. c2) STOP 7 48 end subroutine 49 subroutine test_deferred_char1 50 character(:), allocatable :: c 51 c = "Hello" 52 if (c .ne. "Hello") STOP 8 53 if (len(c) .ne. 5) STOP 9 54 c = "Goodbye" 55 if (c .ne. "Goodbye") STOP 10 56 if (len(c) .ne. 7) STOP 11 57! Check that the hidden LEN dummy is passed by reference 58 call test_pass_c1 (c) 59 if (c .ne. "Made in test!") print *, c 60 if (len(c) .ne. 13) STOP 12 61 end subroutine 62 subroutine test_pass_c1 (carg) 63 character(:), allocatable :: carg 64 if (carg .ne. "Goodbye") STOP 13 65 if (len(carg) .ne. 7) STOP 14 66 carg = "Made in test!" 67 end subroutine 68 subroutine test_deferred_char4 69 character(:, kind = 4), allocatable :: c 70 c = 4_"Hello" 71 if (c .ne. 4_"Hello") STOP 15 72 if (len(c) .ne. 5) STOP 16 73 c = 4_"Goodbye" 74 if (c .ne. 4_"Goodbye") STOP 17 75 if (len(c) .ne. 7) STOP 18 76! Check that the hidden LEN dummy is passed by reference 77 call test_pass_c4 (c) 78 if (c .ne. 4_"Made in test!") print *, c 79 if (len(c) .ne. 13) STOP 19 80 end subroutine 81 subroutine test_pass_c4 (carg) 82 character(:, kind = 4), allocatable :: carg 83 if (carg .ne. 4_"Goodbye") STOP 20 84 if (len(carg) .ne. 7) STOP 21 85 carg = 4_"Made in test!" 86 end subroutine 87end 88 89