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 10PROGRAM 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 88END PROGRAM main 89