URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [realloc_on_assign_3.f03] - Blame information for rev 774

Go to most recent revision | Details | Compare with Previous | View Log


! { dg-do run }
! Test (re)allocation on assignment of scalars
!
! Contributed by Paul Thomas  
!
  call test_real
  call test_derived
  call test_char1
  call test_char4
  call test_deferred_char1
  call test_deferred_char4
contains
  subroutine test_real
    real, allocatable :: x
    real :: y = 42
    x = 42.0
    if (x .ne. y) call abort
    deallocate (x)
    x = y
    if (x .ne. y) call abort
  end subroutine
  subroutine test_derived
    type :: mytype
      real :: x
      character(4) :: c
    end type
    type (mytype), allocatable :: t
    t = mytype (99.0, "abcd")
    if (t%c .ne. "abcd") call abort
  end subroutine
  subroutine test_char1
    character(len = 8), allocatable :: c1
    character(len = 8) :: c2 = "abcd1234"
    c1 = "abcd1234"
    if (c1 .ne. c2) call abort
    deallocate (c1)
    c1 = c2
    if (c1 .ne. c2) call abort
  end subroutine
  subroutine test_char4
    character(len = 8, kind = 4), allocatable :: c1
    character(len = 8, kind = 4) :: c2 = 4_"abcd1234"
    c1 = 4_"abcd1234"
    if (c1 .ne. c2) call abort
    deallocate (c1)
    c1 = c2
    if (c1 .ne. c2) call abort
  end subroutine
  subroutine test_deferred_char1
    character(:), allocatable :: c
    c = "Hello"
    if (c .ne. "Hello") call abort
    if (len(c) .ne. 5) call abort
    c = "Goodbye"
    if (c .ne. "Goodbye") call abort
    if (len(c) .ne. 7) call abort
! Check that the hidden LEN dummy is passed by reference
    call test_pass_c1 (c)
    if (c .ne. "Made in test!") print *, c
    if (len(c) .ne. 13) call abort
  end subroutine
  subroutine test_pass_c1 (carg)
    character(:), allocatable :: carg
    if (carg .ne. "Goodbye") call abort
    if (len(carg) .ne. 7) call abort
    carg = "Made in test!"
  end subroutine
  subroutine test_deferred_char4
    character(:, kind = 4), allocatable :: c
    c = 4_"Hello"
    if (c .ne. 4_"Hello") call abort
    if (len(c) .ne. 5) call abort
    c = 4_"Goodbye"
    if (c .ne. 4_"Goodbye") call abort
    if (len(c) .ne. 7) call abort
! Check that the hidden LEN dummy is passed by reference
    call test_pass_c4 (c)
    if (c .ne. 4_"Made in test!") print *, c
    if (len(c) .ne. 13) call abort
  end subroutine
  subroutine test_pass_c4 (carg)
    character(:, kind = 4), allocatable :: carg
    if (carg .ne. 4_"Goodbye") call abort
    if (len(carg) .ne. 7) call abort
    carg = 4_"Made in test!"
  end subroutine
end
 

Line No.	Rev	Author	Line
1	694	jeremybenn	`! { dg-do run }`
2			`! Test (re)allocation on assignment of scalars`
3			`!`
4			`! Contributed by Paul Thomas`
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`
12			`contains`
13			`subroutine test_real`
14			`real, allocatable :: x`
15			`real :: y = 42`
16			`x = 42.0`
17			`if (x .ne. y) call abort`
18			`deallocate (x)`
19			`x = y`
20			`if (x .ne. y) call abort`
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") call abort`
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) call abort`
36			`deallocate (c1)`
37			`c1 = c2`
38			`if (c1 .ne. c2) call abort`
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) call abort`
45			`deallocate (c1)`
46			`c1 = c2`
47			`if (c1 .ne. c2) call abort`
48			`end subroutine`
49			`subroutine test_deferred_char1`
50			`character(:), allocatable :: c`
51			`c = "Hello"`
52			`if (c .ne. "Hello") call abort`
53			`if (len(c) .ne. 5) call abort`
54			`c = "Goodbye"`
55			`if (c .ne. "Goodbye") call abort`
56			`if (len(c) .ne. 7) call abort`
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) call abort`
61			`end subroutine`
62			`subroutine test_pass_c1 (carg)`
63			`character(:), allocatable :: carg`
64			`if (carg .ne. "Goodbye") call abort`
65			`if (len(carg) .ne. 7) call abort`
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") call abort`
72			`if (len(c) .ne. 5) call abort`
73			`c = 4_"Goodbye"`
74			`if (c .ne. 4_"Goodbye") call abort`
75			`if (len(c) .ne. 7) call abort`
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) call abort`
80			`end subroutine`
81			`subroutine test_pass_c4 (carg)`
82			`character(:, kind = 4), allocatable :: carg`
83			`if (carg .ne. 4_"Goodbye") call abort`
84			`if (len(carg) .ne. 7) call abort`
85			`carg = 4_"Made in test!"`
86			`end subroutine`
87			`end`
88

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [realloc_on_assign_3.f03] - Blame information for rev 774