gcc/testsuite/gfortran.dg/proc_assign_1.f90

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