1! { dg-do run }
2!
3! Tests the fix for PR68216
4!
5! Reported on clf: https://groups.google.com/forum/#!topic/comp.lang.fortran/eWQTKfqKLZc
6!
7PROGRAM hello
8!
9! This is based on the first testcase, from Francisco (Ayyy LMAO). Original
10! lines are commented out. The second testcase from this thread is acalled
11! at the end of the program.
12!
13    IMPLICIT NONE
14
15    CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_lineas
16    CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_copia
17    character (3), dimension (2) :: array_fijo = ["abc","def"]
18    character (100) :: buffer
19    INTEGER :: largo , cant_lineas , i
20
21    write (buffer, "(2a3)") array_fijo
22
23!    WRITE(*,*) ' Escriba un numero para el largo de cada linea'
24!    READ(*,*) largo
25    largo = LEN (array_fijo)
26
27!    WRITE(*,*) ' Escriba la cantidad de lineas'
28!    READ(*,*) cant_lineas
29    cant_lineas = size (array_fijo, 1)
30
31    ALLOCATE(CHARACTER(LEN=largo) :: array_lineas(cant_lineas))
32
33!    WRITE(*,*) 'Escriba el array', len(array_lineas), size(array_lineas)
34    READ(buffer,"(2a3)") (array_lineas(i),i=1,cant_lineas)
35
36!    WRITE(*,*) 'Array guardado: '
37!    DO i=1,cant_lineas
38!    WRITE(*,*) array_lineas(i)
39!    ENDDO
40     if (any (array_lineas .ne. array_fijo)) STOP 1
41
42! The following are additional tests beyond that of the original.
43!
44! Check that allocation with source = another deferred length is OK
45     allocate (array_copia, source = array_lineas)
46     if (any (array_copia .ne. array_fijo)) STOP 2
47     deallocate (array_lineas, array_copia)
48
49! Check that allocation with source = a non-deferred length is OK
50     allocate (array_lineas, source = array_fijo)
51     if (any (array_lineas .ne. array_fijo)) STOP 3
52     deallocate (array_lineas)
53
54! Check that allocation with MOLD = a non-deferred length is OK
55     allocate (array_copia, mold = [array_fijo(:)(1:2), array_fijo(:)(1:2)])
56     if (size (array_copia, 1) .ne. 4) STOP 4
57     if (LEN (array_copia, 1) .ne. 2) STOP 5
58
59! Check that allocation with MOLD = another deferred length is OK
60     allocate (array_lineas, mold = array_copia)
61     if (size (array_copia, 1) .ne. 4) STOP 6
62     if (LEN (array_copia, 1) .ne. 2) STOP 7
63     deallocate (array_lineas, array_copia)
64
65!    READ(*,*)
66     call testdefchar
67contains
68     subroutine testdefchar
69!
70! This is the testcase in the above thread from Blokbuster
71!
72          implicit none
73          character(:), allocatable :: test(:)
74
75          allocate(character(3) :: test(2))
76          test(1) = 'abc'
77          test(2) = 'def'
78          if (any (test .ne. ['abc', 'def'])) STOP 8
79
80          test = ['aa','bb','cc']
81          if (any (test .ne. ['aa', 'bb', 'cc'])) STOP 9
82
83     end subroutine testdefchar
84
85END PROGRAM
86