Re: 2nd ICE on PR20541 - allocatable components of derived types (TR15581)

["THOMAS Paul Richard 169137" <Paul dot Richard dot THOMAS at cea dot fr>]

Salvatore,

Here is a reduced (and re-embellished!) version of your second test:

  subroutine foo(p)
    type atype
      integer, allocatable :: m(:)
    end type atype

    type btype
      type(atype), pointer       :: d => null()
    end type btype

    type ctype
      type(atype), allocatable       :: d(:)
    end type ctype

    type(ctype) :: c
    type(btype) :: p
    type(atype), pointer :: ptr

    deallocate (c%d)                    ! Check that this produces
					! correct code
    ptr => p%d
    deallocate (ptr)                    ! This caused the ICE too.

!==================This was the original problem==================
    if (associated(p%d)) then 
      call bar(p%d%m)                   ! OK
      deallocate(p%d)                   ! Original ICE
!=================================================================
    else 
      allocate(p%d)                     ! OK
    endif

  end subroutine foo

The code shows that deallocate is trying to deallocate the components
of the ultimate pointer component p->d.  This should not happen, since
the target could be multiply pointed to.

The fix below.  Please excuse me if I do not provide a diff of a diff;
I will emit a complete patch, for as far as I have gone, tonight 
before departing on vacation.

Replace the if statement at trans_stmt.c:3672 by a new if statement:

      if (expr->ts.type == BT_DERIVED
	    && expr->ts.derived->attr.alloc_comp)
        {
	  gfc_ref *ref;
	  gfc_ref *last = NULL;
	  for (ref = expr->ref; ref; ref = ref->next)
	    if (ref->type == REF_COMPONENT)
	      last = ref;

	  /* Do not deallocate the components of a derived type
	     ultimate pointer component.  */
	  if (!(last && last->u.c.component->pointer)
		   && !(!last && expr->symtree->n.sym->attr.pointer))
	    {
	      tmp = deallocate_alloc_comp (expr->ts.derived, se.expr,
					   expr->rank);
	      gfc_add_expr_to_block (&se.pre, tmp);
	    }
	}

The same restraint has to be put on the final clean up before going out
of scope. I should have that done by tonight.

Paul