[Bug fortran/15809] ICE Using Pointer Functions

["paul dot richard dot thomas at cea dot fr" <gcc-bugzilla@gcc.gnu.org>]

------- Comment #18 from paul dot richard dot thomas at cea dot fr  2005-11-23 14:26 -------
(In reply to comment #15)
> I cannot tell why, but it seems to me that Paul Thomas' test case is no valid

Hej Sven!

You quite correctly picked up that it does not have an explicit interface and
so will give nonsense.  Making it contained or writing an interface converts my
rubbish into legal code.

I have made progress in converting pointer arrays into references to pointer
arrays:

The patch below works for pointer assignments with integers and characters and
returns pointer dummy arguments correctly.

There is still a problem (seg fault) with assignments of characters. This comes
about because dtype does not contain the size, as is apparent from the code at
the end of the message. (see the dtypes in the subroutine).

There are also some issues with alignment during pointer assignments.

This damn thing is going to work, legal fortran or not!!!!

Both the examples below work.

                                                      Paul Thomas 23rd Nov 2005


Danger: Cygwin source => whitespace issues.

*** trunk/gcc/fortran/trans-array.c     Wed Nov 23 14:44:18 2005
--- trunk/gcc/fortran/trans-array.c.orig        Wed Nov 23 14:45:15 2005
*************** gfc_trans_deferred_array (gfc_symbol * s
*** 4173,4179 ****

    gfc_init_block (&fnblock);

!   gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL);
    if (sym->ts.type == BT_CHARACTER
        && !INTEGER_CST_P (sym->ts.cl->backend_decl))
      gfc_trans_init_string_length (sym->ts.cl, &fnblock);
--- 4173,4181 ----

    gfc_init_block (&fnblock);

!   gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
!                 || TREE_CODE (sym->backend_decl) == PARM_DECL);
!
    if (sym->ts.type == BT_CHARACTER
        && !INTEGER_CST_P (sym->ts.cl->backend_decl))
      gfc_trans_init_string_length (sym->ts.cl, &fnblock);

*** trunk/gcc/fortran/trans-expr.c      Wed Nov 23 14:55:20 2005
--- trunk/gcc/fortran/trans-expr.c.orig Wed Nov 23 14:56:37 2005
*************** gfc_conv_variable (gfc_se * se, gfc_expr
*** 396,401 ****
--- 396,404 ----
                  || !sym->attr.dimension))
            se->expr = gfc_build_indirect_ref (se->expr);
        }
+
+       if (sym->attr.pointer && sym->attr.dummy && sym->attr.dimension)
+         se->expr = gfc_build_indirect_ref (se->expr);

        ref = expr->ref;
      }
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1608,1614 ****
                  && !formal->sym->attr.pointer
                  && formal->sym->as->type != AS_ASSUMED_SHAPE;
              f = f || !sym->attr.always_explicit;
!             gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
            }
        }

--- 1611,1619 ----
                  && !formal->sym->attr.pointer
                  && formal->sym->as->type != AS_ASSUMED_SHAPE;
              f = f || !sym->attr.always_explicit;
!             gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
!             if (formal != NULL && formal->sym->attr.pointer &&
formal->sym->attr.dimension)
!               parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
            }
        }


*** trunk/gcc/fortran/trans-types.c     Wed Nov 23 13:48:37 2005
--- trunk/gcc/fortran/trans-types.c.orig        Wed Nov 23 13:49:06 2005
*************** gfc_sym_type (gfc_symbol * sym)
*** 1333,1338 ****
--- 1333,1342 ----
          }
        else
        type = gfc_build_array_type (type, sym->as);
+
+       if (sym->attr.pointer && sym->attr.dummy)
+       type = build_reference_type (type);
+
      }
    else
      {


!=============================================================================
module global
    CHARACTER(14), DIMENSION(2), target :: t
end module global

program oh_no_not_pr15908_again
    CHARACTER(12), DIMENSION(:), POINTER :: ptr
    allocate (ptr(2))
    ptr = "xyz"
    call a (ptr, 12)
    IF ( .NOT. ASSOCIATED(ptr) ) THEN
        print *, "not associated in MAIN"
    else
        print *, "associated in MAIN    ", size(ptr,1), len (ptr), ptr
    END IF
contains

SUBROUTINE A(p, l)
    use global
    CHARACTER(l), DIMENSION(:), POINTER :: p

    t = "abc"
    IF ( .NOT. ASSOCIATED(p) ) THEN
        p => t
        print *, "not associated in A   ", size(p,1), len (p), p
    else
        print *, "associated in A       ", size(p,1), len (p), p
        t = "lmn"
        p => t
    END IF
END SUBROUTINE A

end program oh_no_not_pr15908_again

!=========================integer version=========================
module global
    integer, DIMENSION(2), target :: t
end module global

    integer, DIMENSION(:), POINTER :: ptr
    allocate (ptr(2))
    ptr = 123
    IF ( .NOT. ASSOCIATED(ptr) ) THEN
        print *, "not associated in MAIN"
    else
        print *, "associated in MAIN    ", size(ptr,1), ptr
    END IF
    call a (ptr, 12)
    IF ( .NOT. ASSOCIATED(ptr) ) THEN
        print *, "not associated in MAIN"
    else
        print *, "associated in MAIN    ", size(ptr,1), ptr
    END IF
contains

SUBROUTINE A(p, l)
    use global
    integer, DIMENSION(:), POINTER :: p
    t = 456
    IF ( .NOT. ASSOCIATED(p) ) THEN
        p => t
        print *, "not associated in A   ", size(p,1), p
    else
        print *, "associated in A       ", size(p,1), p
        t = 789
        p => t
        print *, "associated in A       ", size(p,1), p
    END IF
END SUBROUTINE A
end

=========================code for character version====================

a (p, l, _p)
{
  extern char t[2][1:14];
  int4 .p;

  .p = *l;
  {
    int4 S.0;

    S.0 = 1;
    while (1)
      {
        if (S.0 > 2) goto L.1; else (void) 0;
        _gfortran_copy_string (14, &t[NON_LVALUE_EXPR <S.0> + -1], 3, "abc");
        S.0 = S.0 + 1;
      }
    L.1:;
  }
  if ((char[0:][1:] *) (*p)->data != 0B == 0)
    {
      (*p)->dtype = 49;
      (*p)->dim[0].lbound = 1;
      (*p)->dim[0].ubound = 2;
      (*p)->dim[0].stride = 1;
      (*p)->data = (void *) (char[0:][1:14] *) &t[0];
      (*p)->offset = -1;
      _gfortran_filename = "pr15809.f90";
      _gfortran_line = 24;
      _gfortran_ioparm.unit = 6;
      _gfortran_ioparm.list_format = 1;
      _gfortran_st_write ();
      _gfortran_transfer_character ("not associated in A   ", 22);
      {
        int4 D.577;

        D.577 = _gfortran_size1 ((struct array1_unknown *) *p, 1);
        _gfortran_transfer_integer (&D.577, 4);
      }
      {
        int4 D.578;

        D.578 = .p;
        _gfortran_transfer_integer (&D.578, 4);
      }
      _gfortran_transfer_array ((struct array1_unknown *) *p, 1, .p);
      _gfortran_st_write_done ();
    }
  else
    {
      _gfortran_filename = "pr15809.f90";
      _gfortran_line = 26;
      _gfortran_ioparm.unit = 6;
      _gfortran_ioparm.list_format = 1;
      _gfortran_st_write ();
      _gfortran_transfer_character ("associated in A       ", 22);
      {
        int4 D.579;

        D.579 = _gfortran_size1 ((struct array1_unknown *) *p, 1);
        _gfortran_transfer_integer (&D.579, 4);
      }
      {
        int4 D.580;

        D.580 = .p;
        _gfortran_transfer_integer (&D.580, 4);
      }
      _gfortran_transfer_array ((struct array1_unknown *) *p, 1, .p);
      _gfortran_st_write_done ();
      {
        int4 S.1;

        S.1 = 1;
        while (1)
          {
            if (S.1 > 2) goto L.2; else (void) 0;
            _gfortran_copy_string (14, &t[NON_LVALUE_EXPR <S.1> + -1], 3,
"lmn";
            S.1 = S.1 + 1;
          }
        L.2:;
      }
      (*p)->dtype = 49;
      (*p)->dim[0].lbound = 1;
      (*p)->dim[0].ubound = 2;
      (*p)->dim[0].stride = 1;
      (*p)->data = (void *) (char[0:][1:14] *) &t[0];
      (*p)->offset = -1;
    }
}


MAIN__ ()
{
  struct array1_unknown ptr;
  static void a (struct array1_unknown & &, int4 &, int4);

  ptr.data = 0B;
  {
    void * * D.584;

    ptr.dtype = 1585;
    ptr.dim[0].lbound = 1;
    ptr.dim[0].ubound = 2;
    ptr.dim[0].stride = 1;
    D.584 = &ptr.data;
    _gfortran_allocate (D.584, 48, 0);
    ptr.offset = -1;
  }
  {
    int4 D.587;
    int4 D.586;
    char[0:][1:24] * D.585;

    D.585 = (char[0:][1:24] *) ptr.data;
    D.586 = ptr.offset;
    D.587 = ptr.dim[0].lbound;
    {
      int4 D.589;
      int4 S.2;

      D.589 = ptr.dim[0].stride;
      S.2 = D.587;
      while (1)
        {
          if (S.2 > ptr.dim[0].ubound) goto L.3; else (void) 0;
          _gfortran_copy_string (24, &(*D.585)[NON_LVALUE_EXPR <S.2> * D.589 +
.586], 3, "xyz");
          S.2 = S.2 + 1;
        }
      L.3:;
    }
  }
  {
    int4 C.591 = 12;

    a (&&ptr, &C.591, 24);
  }
  if ((char[0:][1:24] *) ptr.data != 0B == 0)
    {
      _gfortran_filename = "pr15809.f90";
      _gfortran_line = 11;
      _gfortran_ioparm.unit = 6;
      _gfortran_ioparm.list_format = 1;
      _gfortran_st_write ();
      _gfortran_transfer_character ("not associated in MAIN", 22);
      _gfortran_st_write_done ();
    }
  else
    {
      _gfortran_filename = "pr15809.f90";
      _gfortran_line = 13;
      _gfortran_ioparm.unit = 6;
      _gfortran_ioparm.list_format = 1;
      _gfortran_st_write ();
      _gfortran_transfer_character ("associated in MAIN    ", 22);
      {
        int4 D.592;

        D.592 = _gfortran_size1 (&ptr, 1);
        _gfortran_transfer_integer (&D.592, 4);
      }
      {
        int4 C.593 = 24;

        _gfortran_transfer_integer (&C.593, 4);
      }
      _gfortran_transfer_array (&ptr, 1, 24);
      _gfortran_st_write_done ();
    }
}


-- 


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=15809