This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch, fortran] PR30284 and PR30626 - ICEs with internal units


:ADDPATCH fortran:

These two PRs are effectively identical and are fixed by the same patch.

The problem is that substring or components references of arrays result in element sizes that are smaller than the stride in bytes. This is fixed by using the same temporary builder that fixed a similar problem in gfc_conv_function_call. A temporary is created that is copied to and used as the internal unit for READ or is used and copied back from for WRITE. The testcases are the reporter's.

Note that I am perfectly prepared to change the names of gfc_conv_aliased_arg and is_aliased_array, if only somebody would tell me what they should be called :-)

Bootrtrapped and regtested on amd64/Cygwin_NT - OK for trunk and a week or two later for 4.2?

Paul
2007-02-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/30284
	PR fortran/30626
	* trans-expr.c (gfc_conv_aliased_arg): Remove static attribute
	from function and make sure that substring lengths are
	translated.
	(is_aliased_array): Remove static attribute.
	* trans.c : Add prototypes for gfc_conv_aliased_arg and
	is_aliased_array.
	* trans-io.c (set_internal_unit): Add the post block to the
	arguments of the function.  Use is_aliased_array to check if
	temporary is needed; if so call gfc_conv_aliased_arg.
	(build_dt): Pass the post block to set_internal_unit and
	add to the block after all io activiy is done.

2007-02-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/30284
	PR fortran/30626
	* io/transfer.c (init_loop_spec, next_array_record): Change to
	lbound rather than unity base.

2007-02-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/30284
	* gfortran.dg/arrayio_11.f90.f90: New test.

	PR fortran/30626
	* gfortran.dg/arrayio_12.f90.f90: New test.
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 121280)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_apply_interface_mapping (gfc_interfa
*** 1682,1690 ****
     an actual argument derived type array is copied and then returned
     after the function call.
     TODO Get rid of this kludge, when array descriptors are capable of
!    handling aliased arrays.  */
  
! static void
  gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
  		      int g77, sym_intent intent)
  {
--- 1682,1690 ----
     an actual argument derived type array is copied and then returned
     after the function call.
     TODO Get rid of this kludge, when array descriptors are capable of
!    handling arrays with a bigger stride in bytes than size.  */
  
! void
  gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
  		      int g77, sym_intent intent)
  {
*************** gfc_conv_aliased_arg (gfc_se * parmse, g
*** 1733,1739 ****
      {
        gfc_ref *char_ref = expr->ref;
  
!       for (; expr->ts.cl == NULL && char_ref; char_ref = char_ref->next)
  	if (char_ref->type == REF_SUBSTRING)
  	  {
  	    gfc_se tmp_se;
--- 1733,1739 ----
      {
        gfc_ref *char_ref = expr->ref;
  
!       for (; char_ref; char_ref = char_ref->next)
  	if (char_ref->type == REF_SUBSTRING)
  	  {
  	    gfc_se tmp_se;
*************** gfc_conv_aliased_arg (gfc_se * parmse, g
*** 1928,1934 ****
  /* Is true if an array reference is followed by a component or substring
     reference.  */
  
! static bool
  is_aliased_array (gfc_expr * e)
  {
    gfc_ref * ref;
--- 1928,1934 ----
  /* Is true if an array reference is followed by a component or substring
     reference.  */
  
! bool
  is_aliased_array (gfc_expr * e)
  {
    gfc_ref * ref;
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h	(revision 121280)
--- gcc/fortran/trans.h	(working copy)
*************** tree gfc_conv_operator_assign (gfc_se *,
*** 309,314 ****
--- 309,318 ----
  /* Also used to CALL subroutines.  */
  int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
  			    tree);
+ 
+ void gfc_conv_aliased_arg (gfc_se *, gfc_expr *, int, sym_intent);
+ bool is_aliased_array (gfc_expr *);
+ 
  /* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
  
  /* Generate code for a scalar assignment.  */
Index: gcc/fortran/trans-io.c
===================================================================
*** gcc/fortran/trans-io.c	(revision 121280)
--- gcc/fortran/trans-io.c	(working copy)
*************** set_string (stmtblock_t * block, stmtblo
*** 586,592 ****
     for an internal unit.  */
  
  static unsigned int
! set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e)
  {
    gfc_se se;
    tree io;
--- 586,593 ----
     for an internal unit.  */
  
  static unsigned int
! set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
! 		   tree var, gfc_expr * e)
  {
    gfc_se se;
    tree io;
*************** set_internal_unit (stmtblock_t * block, 
*** 624,633 ****
      {
        se.ss = gfc_walk_expr (e);
  
!       /* Return the data pointer and rank from the descriptor.  */
!       gfc_conv_expr_descriptor (&se, e, se.ss);
!       tmp = gfc_conv_descriptor_data_get (se.expr);
!       se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
      }
    else
      gcc_unreachable ();
--- 625,647 ----
      {
        se.ss = gfc_walk_expr (e);
  
!       if (is_aliased_array (e))
! 	{
! 	  /* Use a temporary for components of arrays of derived types
! 	     or substring array references.  */
! 	  gfc_conv_aliased_arg (&se, e, 0,
! 		last_dt == READ ? INTENT_IN : INTENT_OUT);
! 	  tmp = build_fold_indirect_ref (se.expr);
! 	  se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
! 	  tmp = gfc_conv_descriptor_data_get (tmp);
! 	}
!       else
! 	{
! 	  /* Return the data pointer and rank from the descriptor.  */
! 	  gfc_conv_expr_descriptor (&se, e, se.ss);
! 	  tmp = gfc_conv_descriptor_data_get (se.expr);
! 	  se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
! 	}
      }
    else
      gcc_unreachable ();
*************** set_internal_unit (stmtblock_t * block, 
*** 635,644 ****
    /* The cast is needed for character substrings and the descriptor
       data.  */
    gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
!   gfc_add_modify_expr (&se.pre, len, se.string_length);
    gfc_add_modify_expr (&se.pre, desc, se.expr);
  
    gfc_add_block_to_block (block, &se.pre);
    return mask;
  }
  
--- 649,660 ----
    /* The cast is needed for character substrings and the descriptor
       data.  */
    gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
!   gfc_add_modify_expr (&se.pre, len,
! 		       fold_convert (TREE_TYPE (len), se.string_length));
    gfc_add_modify_expr (&se.pre, desc, se.expr);
  
    gfc_add_block_to_block (block, &se.pre);
+   gfc_add_block_to_block (post_block, &se.post);
    return mask;
  }
  
*************** transfer_namelist_element (stmtblock_t *
*** 1371,1377 ****
  static tree
  build_dt (tree function, gfc_code * code)
  {
!   stmtblock_t block, post_block, post_end_block;
    gfc_dt *dt;
    tree tmp, var;
    gfc_expr *nmlname;
--- 1387,1393 ----
  static tree
  build_dt (tree function, gfc_code * code)
  {
!   stmtblock_t block, post_block, post_end_block, post_iu_block;
    gfc_dt *dt;
    tree tmp, var;
    gfc_expr *nmlname;
*************** build_dt (tree function, gfc_code * code
*** 1381,1386 ****
--- 1397,1403 ----
    gfc_start_block (&block);
    gfc_init_block (&post_block);
    gfc_init_block (&post_end_block);
+   gfc_init_block (&post_iu_block);
  
    var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
  
*************** build_dt (tree function, gfc_code * code
*** 1411,1417 ****
      {
        if (dt->io_unit->ts.type == BT_CHARACTER)
  	{
! 	  mask |= set_internal_unit (&block, var, dt->io_unit);
  	  set_parameter_const (&block, var, IOPARM_common_unit, 0);
  	}
        else
--- 1428,1435 ----
      {
        if (dt->io_unit->ts.type == BT_CHARACTER)
  	{
! 	  mask |= set_internal_unit (&block, &post_iu_block,
! 				     var, dt->io_unit);
  	  set_parameter_const (&block, var, IOPARM_common_unit, 0);
  	}
        else
*************** build_dt (tree function, gfc_code * code
*** 1502,1507 ****
--- 1520,1527 ----
  
    gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next));
  
+   gfc_add_block_to_block (&block, &post_iu_block);
+ 
    dt_parm = NULL;
    dt_post_end_block = NULL;
  
Index: libgfortran/io/transfer.c
===================================================================
*** libgfortran/io/transfer.c	(revision 121280)
--- libgfortran/io/transfer.c	(working copy)
*************** init_loop_spec (gfc_array_char *desc, ar
*** 2013,2019 ****
    index = 1;
    for (i=0; i<rank; i++)
      {
!       ls[i].idx = 1;
        ls[i].start = desc->dim[i].lbound;
        ls[i].end = desc->dim[i].ubound;
        ls[i].step = desc->dim[i].stride;
--- 2013,2019 ----
    index = 1;
    for (i=0; i<rank; i++)
      {
!       ls[i].idx = desc->dim[i].lbound;
        ls[i].start = desc->dim[i].lbound;
        ls[i].end = desc->dim[i].ubound;
        ls[i].step = desc->dim[i].stride;
*************** next_array_record (st_parameter_dt *dtp,
*** 2050,2057 ****
            else
              carry = 0;
          }
!       index = index + (ls[i].idx - 1) * ls[i].step;
      }
    return index;
  }
  
--- 2050,2058 ----
            else
              carry = 0;
          }
!       index = index + (ls[i].idx - ls[i].start) * ls[i].step;
      }
+ 
    return index;
  }
  
Index: gcc/testsuite/gfortran.dg/arrayio_11.f90
===================================================================
*** gcc/testsuite/gfortran.dg/arrayio_11.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/arrayio_11.f90	(revision 0)
***************
*** 0 ****
--- 1,45 ----
+ ! { dg-do run }
+ ! Tests the fix for PR30284, in which the substring plus
+ ! component reference for an internal file would cause an ICE.
+ !
+ ! Contributed by Harald Anlauf <anlauf@gmx.de>
+ 
+ program gfcbug51
+   implicit none
+ 
+   type :: date_t
+     character(len=12) :: date      ! yyyymmddhhmm
+   end type date_t
+ 
+   type year_t
+     integer :: year = 0
+   end type year_t
+ 
+   type(date_t) :: file(3)
+   type(year_t) :: time(3)
+ 
+   FILE%date = (/'200612231200', '200712231200', &
+                 '200812231200'/)
+ 
+   time = date_to_year (FILE)
+   if (any (time%year .ne. (/2006, 2007, 2008/))) call abort ()
+ 
+   call month_to_date ((/8, 9, 10/), FILE)
+   if ( any (file%date .ne. (/'200608231200', '200709231200', &
+                              '200810231200'/))) call abort ()
+ 
+ contains
+ 
+   function date_to_year (d) result (y)
+     type(date_t) :: d(3)
+     type(year_t) :: y(size (d, 1))
+     read (d%date(1:4),'(i4)')  time% year
+   end function date_to_year
+ 
+   subroutine month_to_date (m, d)
+     type(date_t) :: d(3)
+     integer :: m(:)
+     write (d%date(5:6),'(i2.2)')  m
+   end subroutine month_to_date
+ 
+ end program gfcbug51
Index: gcc/testsuite/gfortran.dg/arrayio_12.f90
===================================================================
*** gcc/testsuite/gfortran.dg/arrayio_12.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/arrayio_12.f90	(revision 0)
***************
*** 0 ****
--- 1,42 ----
+ ! { dg-do run }
+ ! Tests the fix for PR30626, in which the substring reference
+ ! for an internal file would cause an ICE.
+ !
+ ! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+ 
+ program gfcbug51
+   implicit none
+ 
+   character(len=12) :: cdate(3)      ! yyyymmddhhmm
+ 
+   type year_t
+     integer :: year = 0
+   end type year_t
+ 
+   type(year_t) :: time(3)
+ 
+   cdate = (/'200612231200', '200712231200', &
+             '200812231200'/)
+ 
+   time = date_to_year (cdate)
+   if (any (time%year .ne. (/2006, 2007, 2008/))) call abort ()
+ 
+   call month_to_date ((/8, 9, 10/), cdate)
+   if ( any (cdate .ne. (/'200608231200', '200709231200', &
+                          '200810231200'/))) call abort ()
+ 
+ contains
+ 
+   function date_to_year (d) result (y)
+     character(len=12) :: d(3)
+     type(year_t) :: y(size (d, 1))
+     read (cdate(:)(1:4),'(i4)')  time% year
+   end function date_to_year
+ 
+   subroutine month_to_date (m, d)
+     character(len=12) :: d(3)
+     integer :: m(:)
+     write (cdate(:)(5:6),'(i2.2)')  m
+   end subroutine month_to_date
+ 
+ end program gfcbug51

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]