[Patch, fortran] PR26787 - Assigning to function causes ice in gfortran

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

:ADDPATCH fortran:

The message to Bugzilla was:

The following incorrect code causes:
simple.f90: In function 'bar'
simple.f90:4: internal compiler error: in gfc_conv_variable, at
fortran/trans-expr.c:355

Code:
module simple
 implicit none
contains
 integer function foo()
   foo = 10
 end function foo

 subroutine bar()
   foo = 10
 end subroutine bar
end module simple

This should cause an error, rather than an internal compiler error.

...which is clear and concise enough.  The fix required a bit of work in 
expr.c (gfc_check_assign), which speaks for itself I think  The testcase 
is intended to be fairly complete - it checks what was broken and what 
was not broken.  Notice that I have not yet attempted to sort out 
entries; this can come in a package with a number of other, related 
checks that are subjects of PRs.

Regtested on FC3/Athlon - OK for trunk and I propose, since assignment 
is so basic, a couple of weeks later on 4.1, so as to give the pact a 
good shaking down.

Paul

2006-04-13  Paul Thomas  <pault@gcc.gnu.org>

   PR fortran/26822
   * expr.c (gfc_check_assign): Extend scope of arror to include
   assignments to a procedure in the main program or, from a
   module or internal procedure that is not that represented by
   the lhs symbol.

2006-04-13  Paul Thomas  <pault@gcc.gnu.org>

   PR fortran/26822
   * gfortran.dg/proc_assign_1.f90: New test.

Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c	(revision 112712)
--- gcc/fortran/expr.c	(working copy)
*************** gfc_check_assign (gfc_expr * lvalue, gfc
*** 1863,1876 ****
        return FAILURE;
      }
  
!   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.use_assoc)
!     {
!       gfc_error ("'%s' in the assignment at %L cannot be an l-value "
! 		 "since it is a procedure", sym->name, &lvalue->where);
!       return FAILURE;
      }
  
- 
    if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
      {
        gfc_error ("Incompatible ranks %d and %d in assignment at %L",
--- 1863,1906 ----
        return FAILURE;
      }
  
!   /* A procedure symbol cannot be an lvalue if it is:  */
!   if (sym->attr.flavor == FL_PROCEDURE
! 	&& sym->attr.proc != PROC_ST_FUNCTION
! 	&& !sym->attr.external)
!     {
!       bool bad_proc;
!       bad_proc = false;
! 
!       /* (i) Use associated; */
!       if (sym->attr.use_assoc)
! 	bad_proc = true;
! 
!       /* (ii) The assignement is in the main program; or  */
!       if (gfc_current_ns->proc_name->attr.is_main_program)
! 	bad_proc = true;
! 
!       /* (iii) A module or internal procedure....  */
!       if (gfc_current_ns->parent
! 	  && gfc_current_ns->parent->parent == NULL
! 	  && gfc_current_ns->parent->proc_name->attr.flavor != FL_PROCEDURE)
! 	{
! 	  /* .... that is not a function.... */ 
! 	  if (!gfc_current_ns->proc_name->attr.function)
! 	    bad_proc = true;
! 
! 	  /* .... or is not an entry and has a different name.  */
! 	  if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
! 	    bad_proc = true;
! 	}
! 
!       if (bad_proc)
! 	{
! 	  gfc_error ("'%s' in the assignment at %L cannot be an l-value "
! 		     "since it is a procedure", sym->name, &lvalue->where);
! 	  return FAILURE;
! 	}
      }
  
    if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
      {
        gfc_error ("Incompatible ranks %d and %d in assignment at %L",

! { dg-do compile }
! This tests the patch for PR26786 in which it was found that setting
! the result of one module procedure from within another produced an
! ICE rather than an error.
!
! This is an "elaborated" version of the original testcase from
! Joshua Cogliati  <jjcogliati-r1@yahoo.com>
!
function ext1 ()
    integer ext1, ext2, arg
    ext1 = 1
    entry ext2 (arg)
    ext2 = arg
contains
    subroutine int_1 ()
        ext1 = arg * arg     ! OK - host associated.
    end subroutine int_1
end function ext1

module simple
    implicit none
contains
    integer function foo () 
         foo = 10            ! OK - function result
         call foobar ()
    contains
        subroutine foobar ()
            integer z
            foo = 20         ! OK - host associated.
        end subroutine foobar
    end function foo
    subroutine bar()         ! This was the original bug.
        foo = 10             ! { dg-error "cannot be an l-value" }
    end subroutine bar
    integer function oh_no ()
        oh_no = 1
        foo = 5              ! { dg-error "cannot be an l-value" }
    end function oh_no
end module simple

module simpler
    implicit none
contains
    integer function foo_er () 
         foo_er = 10         ! OK - function result
    end function foo_er
end module simpler

    use simpler
    real w, stmt_fcn
    interface
	function ext1 ()
	    integer ext1
	end function ext1
	function ext2 (arg)
	    integer ext2, arg
	end function ext2
    end interface
    stmt_fcn (w) = sin (w)     
    call x (y ())
    x = 10                   ! { dg-error "Expected VARIABLE" }
    y = 20                   ! { dg-error "cannot be an l-value" }
    foo_er = 8               ! { dg-error "cannot be an l-value" }
    ext1 = 99                ! { dg-error "cannot be an l-value" }
    ext2 = 99                ! { dg-error "cannot be an l-value" }
    stmt_fcn = 1.0           ! { dg-error "Expected VARIABLE" }
    w = stmt_fcn (1.0)
contains
    subroutine x (i)
        integer i
        y = i                ! { dg-error "cannot be an l-value" }
    end subroutine x
    function y ()
        integer y
        y = 2                ! OK - function result
    end function y
end
! { dg-final { cleanup-modules "simple simpler" } }