gcc/testsuite/gfortran.dg/deferred_character_2.f90

   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 !
   7 PROGRAM 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)) call abort
  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)) call abort
  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)) call abort
  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) call abort
  57      if (LEN (array_copia, 1) .ne. 2) call abort
  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) call abort
  62      if (LEN (array_copia, 1) .ne. 2) call abort
  63      deallocate (array_lineas, array_copia)
  64
  65 !    READ(*,*)
  66      call testdefchar
  67 contains
  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'])) call abort
  79
  80           test = ['aa','bb','cc']
  81           if (any (test .ne. ['aa', 'bb', 'cc'])) call abort
  82
  83      end subroutine testdefchar
  84
  85 END PROGRAM