gcc/testsuite/gfortran.dg/recursive_check_6.f03

   1 ! { dg-do compile }
   2
   3 ! PR fortran/37779
   4 ! Check that a call to a procedure's containing procedure counts as recursive
   5 ! and is rejected if the containing procedure is not RECURSIVE.
   6
   7 MODULE m
   8   IMPLICIT NONE
   9
  10 CONTAINS
  11
  12   SUBROUTINE test_sub ()
  13     CALL bar ()
  14   CONTAINS
  15     SUBROUTINE bar ()
  16       IMPLICIT NONE
  17       PROCEDURE(test_sub), POINTER :: procptr
  18
  19       CALL test_sub () ! { dg-error "not RECURSIVE" }
  20       procptr => test_sub ! { dg-warning "Non-RECURSIVE" }
  21       CALL foobar (test_sub) ! { dg-warning "Non-RECURSIVE" }
  22     END SUBROUTINE bar
  23   END SUBROUTINE test_sub
  24
  25   INTEGER FUNCTION test_func () RESULT (x)
  26     x = bar ()
  27   CONTAINS
  28     INTEGER FUNCTION bar ()
  29       IMPLICIT NONE
  30       PROCEDURE(test_func), POINTER :: procptr
  31
  32       bar = test_func () ! { dg-error "not RECURSIVE" }
  33       procptr => test_func ! { dg-warning "Non-RECURSIVE" }
  34       CALL foobar (test_func) ! { dg-warning "Non-RECURSIVE" }
  35     END FUNCTION bar
  36   END FUNCTION test_func
  37
  38   SUBROUTINE sub_entries ()
  39   ENTRY sub_entry_1 ()
  40   ENTRY sub_entry_2 ()
  41     CALL bar ()
  42   CONTAINS
  43     SUBROUTINE bar ()
  44       CALL sub_entry_1 () ! { dg-error "is not RECURSIVE" }
  45     END SUBROUTINE bar
  46   END SUBROUTINE sub_entries
  47
  48   INTEGER FUNCTION func_entries () RESULT (x)
  49   ENTRY func_entry_1 () RESULT (x)
  50   ENTRY func_entry_2 () RESULT (x)
  51     x = bar ()
  52   CONTAINS
  53     INTEGER FUNCTION bar ()
  54       bar = func_entry_1 () ! { dg-error "is not RECURSIVE" }
  55     END FUNCTION bar
  56   END FUNCTION func_entries
  57
  58   SUBROUTINE main ()
  59     CALL test_sub ()
  60     CALL sub_entries ()
  61     PRINT *, test_func (), func_entries ()
  62   END SUBROUTINE main
  63
  64 END MODULE m