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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [gfortran.dg/] [alloc_comp_assign_1.f90] - Blame information for rev 816

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
! { dg-do run }
2
! Test assignments of derived type with allocatable components (PR 20541).
3
!
4
! Contributed by Erik Edelmann  
5
!            and Paul Thomas  
6
!
7
  type :: ivs
8
    character(1), allocatable :: chars(:)
9
  end type ivs
10
 
11
  type(ivs) :: a, b
12
  type(ivs) :: x(3), y(3)
13
 
14
  allocate(a%chars(5))
15
  a%chars = (/"h","e","l","l","o"/)
16
 
17
! An intrinsic assignment must deallocate the l-value and copy across
18
! the array from the r-value.
19
  b = a
20
  if (any (b%chars .ne. (/"h","e","l","l","o"/))) call abort ()
21
  if (allocated (a%chars) .eqv. .false.) call abort ()
22
 
23
! Scalar to array needs to copy the derived type, to its ultimate components,
24
! to each of the l-value elements.  */
25
  x = b
26
  x(2)%chars = (/"g","'","d","a","y"/)
27
  if (any (x(1)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
28
  if (any (x(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
29
  if (allocated (b%chars) .eqv. .false.) call abort ()
30
  deallocate (x(1)%chars, x(2)%chars, x(3)%chars)
31
 
32
! Array intrinsic assignments are like their scalar counterpart and
33
! must deallocate each element of the l-value and copy across the
34
! arrays from the r-value elements.
35
  allocate(x(1)%chars(5), x(2)%chars(5), x(3)%chars(5))
36
  x(1)%chars = (/"h","e","l","l","o"/)
37
  x(2)%chars = (/"g","'","d","a","y"/)
38
  x(3)%chars = (/"g","o","d","a","g"/)
39
  y(2:1:-1) = x(1:2)
40
  if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
41
  if (any (y(2)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
42
  if (any (x(3)%chars .ne. (/"g","o","d","a","g"/))) call abort ()
43
 
44
! In the case of an assignment where there is a dependency, so that a
45
! temporary is necessary, each element must be copied to its
46
! destination after it has been deallocated.
47
  y(2:3) = y(1:2)
48
  if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
49
  if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
50
  if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
51
 
52
! An identity assignment must not do any deallocation....!
53
  y = y
54
  if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
55
  if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
56
  if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
57
end

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.