gcc/testsuite/gfortran.dg/proc_assign_1.f90

   1 ! { dg-do compile }\r
   2 ! This tests the patch for PR26787 in which it was found that setting\r
   3 ! the result of one module procedure from within another produced an\r
   4 ! ICE rather than an error.\r
   5 !\r
   6 ! This is an "elaborated" version of the original testcase from\r
   7 ! Joshua Cogliati  <jjcogliati-r1@yahoo.com>\r
   8 !\r
   9 function ext1 ()\r
  10     integer ext1, ext2, arg\r
  11     ext1 = 1\r
  12     entry ext2 (arg)\r
  13     ext2 = arg\r
  14 contains\r
  15     subroutine int_1 ()\r
  16         ext1 = arg * arg     ! OK - host associated.\r
  17     end subroutine int_1\r
  18 end function ext1\r
  19 \r
  20 module simple\r
  21     implicit none\r
  22 contains\r
  23     integer function foo () \r
  24          foo = 10            ! OK - function result\r
  25          call foobar ()\r
  26     contains\r
  27         subroutine foobar ()\r
  28             integer z\r
  29             foo = 20         ! OK - host associated.\r
  30         end subroutine foobar\r
  31     end function foo\r
  32     subroutine bar()         ! This was the original bug.\r
  33         foo = 10             ! { dg-error "is not a VALUE" }\r
  34     end subroutine bar\r
  35     integer function oh_no ()\r
  36         oh_no = 1\r
  37         foo = 5              ! { dg-error "is not a VALUE" }\r
  38     end function oh_no\r
  39 end module simple\r
  40 \r
  41 module simpler\r
  42     implicit none\r
  43 contains\r
  44     integer function foo_er () \r
  45          foo_er = 10         ! OK - function result\r
  46     end function foo_er\r
  47 end module simpler\r
  48 \r
  49     use simpler\r
  50     real w, stmt_fcn\r
  51     interface\r
  52         function ext1 ()\r
  53             integer ext1\r
  54         end function ext1\r
  55         function ext2 (arg)\r
  56             integer ext2, arg\r
  57         end function ext2\r
  58     end interface\r
  59     stmt_fcn (w) = sin (w)     \r
  60     call x (y ())\r
  61     x = 10                   ! { dg-error "Expected VARIABLE" }\r
  62     y = 20                   ! { dg-error "is not a VALUE" }\r
  63     foo_er = 8               ! { dg-error "is not a VALUE" }\r
  64     ext1 = 99                ! { dg-error "is not a VALUE" }\r
  65     ext2 = 99                ! { dg-error "is not a VALUE" }\r
  66     stmt_fcn = 1.0           ! { dg-error "Expected VARIABLE" }\r
  67     w = stmt_fcn (1.0)\r
  68 contains\r
  69     subroutine x (i)\r
  70         integer i\r
  71         y = i                ! { dg-error "is not a VALUE" }\r
  72     end subroutine x\r
  73     function y ()\r
  74         integer y\r
  75         y = 2                ! OK - function result\r
  76     end function y\r
  77 end\r
  78 ! { dg-final { cleanup-modules "simple simpler" } }