gcc/testsuite/gfortran.dg/unlimited_polymorphic_2.f03

   1 ! { dg-do compile }\r
   2 !\r
   3 ! Test the most important constraints unlimited polymorphic entities\r
   4 !\r
   5 ! Contributed by Paul Thomas  <pault@gcc.gnu.org>\r
   6 !            and Tobias Burnus <burnus@gcc.gnu.org>\r
   7 !\r
   8   CHARACTER(:), allocatable, target :: chr\r
   9 ! F2008: C5100\r
  10   integer :: i(2)\r
  11   logical :: flag\r
  12   class(*), pointer :: u1, u2(:) ! { dg-error "cannot appear in COMMON" }\r
  13   common u1\r
  14   u1 => chr\r
  15 ! F2003: C625\r
  16   allocate (u1) ! { dg-error "requires either a type-spec or SOURCE tag" }\r
  17   allocate (real :: u1)\r
  18   Allocate (u1, source = 1.0)\r
  19 \r
  20 ! F2008: C4106\r
  21   u2 = [u1] ! { dg-error "shall not be unlimited polymorphic" }\r
  22 \r
  23   i = u2 ! { dg-error "Can\\'t convert CLASS\\(\\*\\)" }\r
  24 \r
  25 ! Repeats same_type_as_1.f03 for unlimited polymorphic u2\r
  26   flag = same_type_as (i, u2) ! { dg-error "cannot be of type INTEGER" }\r
  27   flag = extends_type_of (i, u2) ! { dg-error "cannot be of type INTEGER" }\r
  28 \r
  29 contains\r
  30 \r
  31 ! C717 (R735) If data-target is unlimited polymorphic,\r
  32 ! data-pointer-object shall be unlimited polymorphic, of a sequence\r
  33 ! derived type, or of a type with the BIND attribute.\r
  34 !\r
  35   subroutine bar\r
  36 \r
  37     type sq\r
  38       sequence\r
  39       integer :: i\r
  40     end type sq\r
  41 \r
  42     type(sq), target :: x\r
  43     class(*), pointer :: y\r
  44     integer, pointer :: tgt\r
  45 \r
  46     x%i = 42\r
  47     y => x\r
  48     call foo (y)\r
  49 \r
  50     y => tgt ! This is OK, of course.\r
  51     tgt => y ! { dg-error "Data-pointer-object at .1. must be unlimited polymorphic" }\r
  52 \r
  53     select type (y) ! This is the correct way to accomplish the previous\r
  54       type is (integer)\r
  55         tgt => y\r
  56     end select\r
  57 \r
  58   end subroutine bar\r
  59 \r
  60 \r
  61   subroutine foo(tgt)\r
  62     class(*), pointer, intent(in) :: tgt\r
  63     type t\r
  64       sequence\r
  65       integer :: k\r
  66     end type t\r
  67 \r
  68     type(t), pointer :: ptr\r
  69 \r
  70     ptr => tgt ! C717 allows this.\r
  71 \r
  72     select type (tgt)\r
  73 ! F03:C815 or F08:C839\r
  74       type is (t) ! { dg-error "shall not specify a sequence derived type" }\r
  75         ptr => tgt ! { dg-error "Expected TYPE IS" }\r
  76     end select\r
  77 \r
  78     print *, ptr%k\r
  79   end subroutine foo\r
  80 END\r