gcc/testsuite/gfortran.dg/exit_3.f08

   1 ! { dg-do run }
   2 ! { dg-options "-std=f2008 -fall-intrinsics" }
   3
   4 ! PR fortran/44602
   5 ! Check for correct behaviour of EXIT / CYCLE combined with non-loop
   6 ! constructs at run-time.
   7
   8 ! Contributed by Daniel Kraft, d@domob.eu.
   9
  10 PROGRAM main
  11   IMPLICIT NONE
  12
  13   TYPE :: t
  14   END TYPE t
  15
  16   INTEGER :: i
  17   CLASS(t), ALLOCATABLE :: var
  18
  19   ! EXIT and CYCLE without names always refer to innermost *loop*.  This
  20   ! however is checked at run-time already in exit_1.f08.
  21
  22   ! Basic EXITs from different non-loop constructs.
  23
  24   i = 2
  25   myif: IF (i == 1) THEN
  26     CALL abort ()
  27     EXIT myif
  28   ELSE IF (i == 2) THEN
  29     EXIT myif
  30     CALL abort ()
  31   ELSE
  32     CALL abort ()
  33     EXIT myif
  34   END IF myif
  35
  36   mysel: SELECT CASE (i)
  37     CASE (1)
  38       CALL abort ()
  39       EXIT mysel
  40     CASE (2)
  41       EXIT mysel
  42       CALL abort ()
  43     CASE DEFAULT
  44       CALL abort ()
  45       EXIT mysel
  46   END SELECT mysel
  47
  48   mycharsel: SELECT CASE ("foobar")
  49     CASE ("abc")
  50       CALL abort ()
  51       EXIT mycharsel
  52     CASE ("xyz")
  53       CALL abort ()
  54       EXIT mycharsel
  55     CASE DEFAULT
  56       EXIT mycharsel
  57       CALL abort ()
  58   END SELECT mycharsel
  59
  60   myblock: BLOCK
  61     EXIT myblock
  62     CALL abort ()
  63   END BLOCK myblock
  64
  65   myassoc: ASSOCIATE (x => 5 + 2)
  66     EXIT myassoc
  67     CALL abort ()
  68   END ASSOCIATE myassoc
  69
  70   ALLOCATE (t :: var)
  71   mytypesel: SELECT TYPE (var)
  72     TYPE IS (t)
  73       EXIT mytypesel
  74       CALL abort ()
  75     CLASS DEFAULT
  76       CALL abort ()
  77       EXIT mytypesel
  78   END SELECT mytypesel
  79
  80   ! Check EXIT with nested constructs.
  81   outer: BLOCK
  82     inner: IF (.TRUE.) THEN
  83       EXIT outer
  84       CALL abort ()
  85     END IF inner
  86     CALL abort ()
  87   END BLOCK outer
  88 END PROGRAM main