view gcc/testsuite/gfortran.dg/assumed_rank_9.f90 @ 158:494b0b89df80 default tip

...
author Shinji KONO <kono@ie.u-ryukyu.ac.jp>
date Mon, 25 May 2020 18:13:55 +0900
parents 84e7813d76e9
children
line wrap: on
line source

! { dg-do run }
! { dg-additional-sources assumed_rank_8_c.c }
!
! PR fortran/48820
!
! Scalars to assumed-rank tests
!
program main
  implicit none

  type t
    integer :: i
  end type t

  interface
    subroutine check (x)
      integer :: x(..)
    end subroutine check
    subroutine check2 (x)
      import t
      class(t) :: x(..)
    end subroutine check2
  end interface

  integer :: j

  type(t), target :: y
  class(t), allocatable, target :: yac
  
  y%i = 489
  allocate (yac)
  yac%i = 489
  j = 0
  call fc()
  call fc(null())
  call fc(y)
  call fc(yac)
  if (j /= 2) STOP 1

  j = 0
  call gc(null())
  call gc(y)
  call gc(yac)
  deallocate (yac)
  call gc(yac)
  if (j /= 2) STOP 2

  j = 0
  call hc(yac)
  allocate (yac)
  yac%i = 489
  call hc(yac)
  if (j /= 1) STOP 3

  j = 0
  call ft()
  call ft(null())
  call ft(y)
  call ft(yac)
  if (j /= 2) STOP 4

  j = 0
  call gt(null())
  call gt(y)
  call gt(yac)
  deallocate (yac)
  call gt(yac)
  if (j /= 2) STOP 5

  j = 0
  call ht(yac)
  allocate (yac)
  yac%i = 489
  call ht(yac)
  if (j /= 1) STOP 6

contains

  subroutine fc (x)
    class(t), optional :: x(..)

    if (.not. present (x)) return
    if (.not. SAME_TYPE_AS (x, yac)) STOP 7
    if (rank (x) /= 0) STOP 1
    call check2 (x)
    j = j + 1
  end subroutine

  subroutine gc (x)
    class(t), pointer, intent(in) :: x(..)

    if (.not. associated (x)) return
    if (.not. SAME_TYPE_AS (x, yac)) STOP 8
    if (rank (x) /= 0) STOP 9
    call check2 (x)
    j = j + 1
  end subroutine

  subroutine hc (x)
    class(t), allocatable :: x(..)

    if (.not. allocated (x)) return
    if (.not. SAME_TYPE_AS (x, yac)) STOP 10
    if (rank (x) /= 0) STOP 2
    call check2 (x)
    j = j + 1
  end subroutine

  subroutine ft (x)
    type(t), optional :: x(..)

    if (.not. present (x)) return
    if (.not. SAME_TYPE_AS (x, yac)) STOP 11
    if (rank (x) /= 0) STOP 3
    call check2 (x)
    j = j + 1
  end subroutine

  subroutine gt (x)
    type(t), pointer, intent(in) :: x(..)

    if (.not. associated (x)) return
    if (.not. SAME_TYPE_AS (x, yac)) STOP 12
    if (rank (x) /= 0) STOP 13
    call check2 (x)
    j = j + 1
  end subroutine

  subroutine ht (x)
    type(t), allocatable :: x(..)

    if (.not. allocated (x)) return
    if (.not. SAME_TYPE_AS (x, yac)) STOP 14
    if (rank (x) /= 0) STOP 4
    call check2 (x)
    j = j + 1
  end subroutine

end program main