gcc/testsuite/gfortran.dg/proc_assign_1.f90

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