BACKPORTS FROM TRUNK

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

	BACKPORTS FROM TRUNK

	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.

	PR fortran/30407
	* trans-expr.c (gfc_conv_operator_assign): New function.
	* trans.h : Add prototype for gfc_conv_operator_assign.
	* trans-stmt.c (gfc_trans_where_assign): Add a gfc_symbol for
	a potential operator assignment subroutine.  If it is non-NULL
	call gfc_conv_operator_assign instead of the first assignment.
	( gfc_trans_where_2): In the case of an operator assignment,
	extract the argument expressions from the code for the
	subroutine call and pass the symbol to gfc_trans_where_assign.
	resolve.c (resolve_where, gfc_resolve_where_code_in_forall,
	gfc_resolve_forall_body): Resolve the subroutine call for
	operator assignments.

	PR fortran/30514
	* array.c (match_array_element_spec): If the length of an array is
	negative, adjust the upper limit to make it zero length.

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

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

	PR fortran/30626
	* gfortran.dg/arrayio_12.f90: New test.

	PR fortran/30407
	* gfortran.dg/where_operator_assign_1.f90: New test.
	* gfortran.dg/where_operator_assign_2.f90: New test.
	* gfortran.dg/where_operator_assign_3.f90: New test.

	PR fortran/30514
	* gfortran.dg/zero_sized_2.f90: New test.

2007-02-12  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.

From-SVN: r121841

gcc/fortran/ChangeLog

@@ -1,3 +1,36 @@
+2007-02-12  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.
+
+	PR fortran/30407
+	* trans-expr.c (gfc_conv_operator_assign): New function.
+	* trans.h : Add prototype for gfc_conv_operator_assign.
+	* trans-stmt.c (gfc_trans_where_assign): Add a gfc_symbol for
+	a potential operator assignment subroutine.  If it is non-NULL
+	call gfc_conv_operator_assign instead of the first assignment.
+	( gfc_trans_where_2): In the case of an operator assignment,
+	extract the argument expressions from the code for the
+	subroutine call and pass the symbol to gfc_trans_where_assign.
+	resolve.c (resolve_where, gfc_resolve_where_code_in_forall,
+	gfc_resolve_forall_body): Resolve the subroutine call for
+	operator assignments.
+
+	PR fortran/30514
+	* array.c (match_array_element_spec): If the length of an array is
+	negative, adjust the upper limit to make it zero length.
+
 2007-02-12  Tobias Schlüter  <tobi@gcc.gnu.org>
 
 	PR fortran/30478

gcc/fortran/array.c

@@ -319,6 +319,15 @@ match_array_element_spec (gfc_array_spec * as)
   if (m == MATCH_NO)
     return AS_ASSUMED_SHAPE;
 
+  /* If the size is negative in this dimension, set it to zero.  */
+  if ((*lower)->expr_type == EXPR_CONSTANT
+      && (*upper)->expr_type == EXPR_CONSTANT
+      && mpz_cmp ((*upper)->value.integer, (*lower)->value.integer) < 0)
+    {
+      gfc_free_expr (*upper);
+      *upper = gfc_copy_expr (*lower);
+      mpz_sub_ui ((*upper)->value.integer, (*upper)->value.integer, 1);
+    }
   return AS_EXPLICIT;
 }
 

gcc/fortran/resolve.c

@@ -4559,6 +4559,10 @@ resolve_where (gfc_code *code, gfc_expr *mask)
                           "inconsistent shape", &cnext->expr->where);
               break;
 
+	    case EXEC_ASSIGN_CALL:
+	      resolve_call (cnext);
+	      break;
+
             /* WHERE or WHERE construct is part of a where-body-construct */
             case EXEC_WHERE:
               resolve_where (cnext, e);
@@ -4796,6 +4800,10 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
           gfc_resolve_assign_in_forall (c, nvar, var_expr);
           break;
 
+	case EXEC_ASSIGN_CALL:
+	  resolve_call (c);
+	  break;
+
         /* Because the gfc_resolve_blocks() will handle the nested FORALL,
            there is no need to handle it here.  */
         case EXEC_FORALL:

gcc/fortran/trans-expr.c

@@ -1205,6 +1205,48 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
 }
 
 
+/* Translate the call for an elemental subroutine call used in an operator
+   assignment.  This is a simplified version of gfc_conv_function_call.  */
+
+tree
+gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
+{
+  tree args;
+  tree tmp;
+  gfc_se se;
+  stmtblock_t block;
+
+  /* Only elemental subroutines with two arguments.  */
+  gcc_assert (sym->attr.elemental && sym->attr.subroutine);
+  gcc_assert (sym->formal->next->next == NULL);
+
+  gfc_init_block (&block);
+
+  gfc_add_block_to_block (&block, &lse->pre);
+  gfc_add_block_to_block (&block, &rse->pre);
+
+  /* Build the argument list for the call, including hidden string lengths.  */
+  args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr));
+  args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr));
+  if (lse->string_length != NULL_TREE)
+    args = gfc_chainon_list (args, lse->string_length);
+  if (rse->string_length != NULL_TREE)
+    args = gfc_chainon_list (args, rse->string_length);    
+
+  /* Build the function call.  */
+  gfc_init_se (&se, NULL);
+  gfc_conv_function_val (&se, sym);
+  tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
+  tmp = build3 (CALL_EXPR, tmp, se.expr, args, NULL_TREE);
+  gfc_add_expr_to_block (&block, tmp);
+
+  gfc_add_block_to_block (&block, &lse->post);
+  gfc_add_block_to_block (&block, &rse->post);
+
+  return gfc_finish_block (&block);
+}
+
+
 /* Initialize MAPPING.  */
 
 void
@@ -1596,9 +1638,9 @@ gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
    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.  */
+   handling arrays with a bigger stride in bytes than size.  */
 
-static void
+void
 gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
 		      int g77, sym_intent intent)
 {
@@ -1647,7 +1689,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
     {
       gfc_ref *char_ref = expr->ref;
 
-      for (; expr->ts.cl == NULL && char_ref; char_ref = char_ref->next)
+      for (; char_ref; char_ref = char_ref->next)
 	if (char_ref->type == REF_SUBSTRING)
 	  {
 	    gfc_se tmp_se;
@@ -1842,7 +1884,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
 /* Is true if an array reference is followed by a component or substring
    reference.  */
 
-static bool
+bool
 is_aliased_array (gfc_expr * e)
 {
   gfc_ref * ref;

gcc/fortran/trans-io.c

@@ -585,7 +585,8 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
    for an internal unit.  */
 
 static unsigned int
-set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e)
+set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
+		   tree var, gfc_expr * e)
 {
   gfc_se se;
   tree io;
@@ -623,10 +624,23 @@ set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e)
     {
       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);
+      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 ();
@@ -634,10 +648,12 @@ set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e)
   /* 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, 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;
 }
 
@@ -1370,7 +1386,7 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
 static tree
 build_dt (tree function, gfc_code * code)
 {
-  stmtblock_t block, post_block, post_end_block;
+  stmtblock_t block, post_block, post_end_block, post_iu_block;
   gfc_dt *dt;
   tree tmp, var;
   gfc_expr *nmlname;
@@ -1380,6 +1396,7 @@ build_dt (tree function, gfc_code * code)
   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");
 
@@ -1410,7 +1427,8 @@ build_dt (tree function, gfc_code * code)
     {
       if (dt->io_unit->ts.type == BT_CHARACTER)
 	{
-	  mask |= set_internal_unit (&block, var, dt->io_unit);
+	  mask |= set_internal_unit (&block, &post_iu_block,
+				     var, dt->io_unit);
 	  set_parameter_const (&block, var, IOPARM_common_unit, 0);
 	}
       else
@@ -1501,6 +1519,8 @@ build_dt (tree function, gfc_code * code)
 
   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;
 

gcc/fortran/trans-stmt.c

@@ -2843,7 +2843,8 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
 static tree
 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
 			tree mask, bool invert,
-                        tree count1, tree count2)
+                        tree count1, tree count2,
+			gfc_symbol *sym)
 {
   gfc_se lse;
   gfc_se rse;
@@ -2957,8 +2958,12 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
     maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
 
   /* Use the scalar assignment as is.  */
-  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
-				 loop.temp_ss != NULL, false);
+  if (sym == NULL)
+    tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+				   loop.temp_ss != NULL, false);
+  else
+    tmp = gfc_conv_operator_assign (&lse, &rse, sym);
+
   tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
 
   gfc_add_expr_to_block (&body, tmp);
@@ -3067,6 +3072,7 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
   tree ppmask = NULL_TREE;
   tree cmask = NULL_TREE;
   tree pmask = NULL_TREE;
+  gfc_actual_arglist *arg;
 
   /* the WHERE statement or the WHERE construct statement.  */
   cblock = code->block;
@@ -3178,13 +3184,29 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
           switch (cnext->op)
             {
             /* WHERE assignment statement.  */
+	    case EXEC_ASSIGN_CALL:
+
+	      arg = cnext->ext.actual;
+	      expr1 = expr2 = NULL;
+	      for (; arg; arg = arg->next)
+		{
+		  if (!arg->expr)
+		    continue;
+		  if (expr1 == NULL)
+		    expr1 = arg->expr;
+		  else
+		    expr2 = arg->expr;
+		}
+	      goto evaluate;
+
             case EXEC_ASSIGN:
               expr1 = cnext->expr;
               expr2 = cnext->expr2;
+    evaluate:
               if (nested_forall_info != NULL)
                 {
                   need_temp = gfc_check_dependency (expr1, expr2, 0);
-                  if (need_temp)
+                  if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
                     gfc_trans_assign_need_temp (expr1, expr2,
 						cmask, invert,
                                                 nested_forall_info, block);
@@ -3198,7 +3220,8 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
 
                       tmp = gfc_trans_where_assign (expr1, expr2,
 						    cmask, invert,
-						    count1, count2);
+						    count1, count2,
+						    cnext->resolved_sym);
 
                       tmp = gfc_trans_nested_forall_loop (nested_forall_info,
                                                           tmp, 1);
@@ -3215,7 +3238,8 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
 
                   tmp = gfc_trans_where_assign (expr1, expr2,
 						cmask, invert,
-						count1, count2);
+						count1, count2,
+						cnext->resolved_sym);
                   gfc_add_expr_to_block (block, tmp);
 
                 }

gcc/fortran/trans.h

@@ -303,8 +303,15 @@ void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *);
 /* Does an intrinsic map directly to an external library call.  */
 int gfc_is_intrinsic_libcall (gfc_expr *);
 
+/* Used to call the elemental subroutines used in operator assignments.  */
+tree gfc_conv_operator_assign (gfc_se *, gfc_se *, gfc_symbol *);
+
 /* Also used to CALL subroutines.  */
 int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *);
+
+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.  */

gcc/testsuite/ChangeLog

@@ -1,3 +1,19 @@
+2007-02-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30284
+	* gfortran.dg/arrayio_11.f90: New test.
+
+	PR fortran/30626
+	* gfortran.dg/arrayio_12.f90: New test.
+
+	PR fortran/30407
+	* gfortran.dg/where_operator_assign_1.f90: New test.
+	* gfortran.dg/where_operator_assign_2.f90: New test.
+	* gfortran.dg/where_operator_assign_3.f90: New test.
+
+	PR fortran/30514
+	* gfortran.dg/zero_sized_2.f90: New test.
+
 2007-02-10  Tobias Schlüter  <tobi@gcc.gnu.org>
 
 	PR fortran/30478

gcc/testsuite/gfortran.dg/arrayio_11.f90

@@ -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

gcc/testsuite/gfortran.dg/arrayio_12.f90

@@ -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

gcc/testsuite/gfortran.dg/where_operator_assign_1.f90

@@ -0,0 +1,108 @@
+! { dg-do compile }
+! Tests the fix for PR30407, in which operator assignments did not work
+! in WHERE blocks or simple WHERE statements.  This is the test provided
+! by the reporter.
+!
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
+!==============================================================================
+
+MODULE kind_mod
+
+   IMPLICIT NONE
+
+   PRIVATE
+
+   INTEGER, PUBLIC, PARAMETER :: I4=SELECTED_INT_KIND(9)
+   INTEGER, PUBLIC, PARAMETER :: TF=KIND(.TRUE._I4)
+
+END MODULE kind_mod
+
+!==============================================================================
+
+MODULE pointer_mod
+
+   USE kind_mod, ONLY : I4
+
+   IMPLICIT NONE
+
+   PRIVATE
+
+   TYPE, PUBLIC :: pvt
+      INTEGER(I4), POINTER, DIMENSION(:) :: vect
+   END TYPE pvt
+
+   INTERFACE ASSIGNMENT(=)
+      MODULE PROCEDURE p_to_p
+   END INTERFACE
+
+   PUBLIC :: ASSIGNMENT(=)
+
+CONTAINS
+
+   !---------------------------------------------------------------------------
+
+   PURE ELEMENTAL SUBROUTINE p_to_p(a1, a2)
+      IMPLICIT NONE
+      TYPE(pvt), INTENT(OUT) :: a1
+      TYPE(pvt), INTENT(IN) :: a2
+      a1%vect = a2%vect
+   END SUBROUTINE p_to_p
+
+   !---------------------------------------------------------------------------
+
+END MODULE pointer_mod
+
+!==============================================================================
+
+PROGRAM test_prog
+
+   USE pointer_mod, ONLY : pvt, ASSIGNMENT(=)
+
+   USE kind_mod, ONLY : I4, TF
+
+   IMPLICIT NONE
+
+   INTEGER(I4), DIMENSION(12_I4), TARGET :: ia
+   LOGICAL(TF), DIMENSION(2_I4,3_I4) :: la
+   TYPE(pvt), DIMENSION(6_I4) :: pv
+   INTEGER(I4) :: i
+
+   ! Initialisation...
+   la(:,1_I4:3_I4:2_I4)=.TRUE._TF
+   la(:,2_I4)=.FALSE._TF
+
+   DO i=1_I4,6_I4
+      pv(i)%vect => ia((2_I4*i-1_I4):(2_I4*i))
+   END DO
+
+   ia=0_I4
+
+   DO i=1_I4,3_I4
+      WHERE(la((/1_I4,2_I4/),i))
+         pv((2_I4*i-1_I4):(2_I4*i))= iaef((/(2_I4*i-1_I4),(2_I4*i)/))
+      ELSEWHERE
+         pv((2_I4*i-1_I4):(2_I4*i))= iaef((/0_I4,0_I4/))
+      END WHERE
+   END DO
+
+   if (any (ia .ne. (/1,-1,2,-2,0,0,0,0,5,-5,6,-6/))) call abort ()
+
+CONTAINS
+
+   TYPE(pvt) ELEMENTAL FUNCTION iaef(index) RESULT(ans)
+
+      USE kind_mod, ONLY :  I4
+      USE pointer_mod, ONLY : pvt, ASSIGNMENT(=)
+
+      IMPLICIT NONE
+
+      INTEGER(I4), INTENT(IN) :: index
+
+      ALLOCATE(ans%vect(2_I4))
+      ans%vect=(/index,-index/)
+
+   END FUNCTION iaef
+
+END PROGRAM test_prog
+
+! { dg-final { cleanup-modules "kind_mod pointer_mod" } }

gcc/testsuite/gfortran.dg/where_operator_assign_2.f90

@@ -0,0 +1,106 @@
+! { dg-do compile }
+! Tests the fix for PR30407, in which operator assignments did not work
+! in WHERE blocks or simple WHERE statements.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!******************************************************************************
+module global
+  type :: a
+    integer :: b
+    integer :: c
+  end type a
+  interface assignment(=)
+    module procedure a_to_a
+  end interface
+  interface operator(.ne.)
+    module procedure a_ne_a
+  end interface
+
+  type(a) :: x(4), y(4), z(4), u(4, 4)
+  logical :: l1(4), t = .true., f= .false.
+contains
+!******************************************************************************
+  elemental subroutine a_to_a (m, n)
+    type(a), intent(in) :: n
+    type(a), intent(out) :: m
+    m%b = n%b + 1
+    m%c = n%c
+  end subroutine a_to_a
+!******************************************************************************
+  elemental logical function a_ne_a (m, n)
+    type(a), intent(in) :: n
+    type(a), intent(in) :: m
+    a_ne_a = (m%b .ne. n%b) .or. (m%c .ne. n%c)
+  end function a_ne_a
+!******************************************************************************
+  elemental function foo (m)
+    type(a) :: foo
+    type(a), intent(in) :: m
+    foo%b = 0
+    foo%c = m%c
+  end function foo  
+end module global
+!******************************************************************************
+program test
+  use global
+  x = (/a (0, 1),a (0, 2),a (0, 3),a (0, 4)/)
+  y = x
+  z = x
+  l1 = (/t, f, f, t/)
+
+  call test_where_1
+  if (any (y .ne. (/a (2, 1),a (2, 2),a (2, 3),a (2, 4)/))) call abort ()
+
+  call test_where_2
+  if (any (y .ne. (/a (1, 0),a (2, 2),a (2, 3),a (1, 0)/))) call abort ()
+  if (any (z .ne. (/a (3, 4),a (1, 0),a (1, 0),a (3, 1)/))) call abort ()
+
+  call test_where_3
+  if (any (y .ne. (/a (1, 0),a (1, 2),a (1, 3),a (1, 0)/))) call abort ()
+
+  y = x
+  call test_where_forall_1
+  if (any (u(4, :) .ne. (/a (1, 4),a (2, 2),a (2, 3),a (1, 4)/))) call abort ()
+
+  l1 = (/t, f, t, f/)
+  call test_where_4
+  if (any (x .ne. (/a (1, 1),a (2, 1),a (1, 3),a (2, 3)/))) call abort ()
+
+contains
+!******************************************************************************
+  subroutine test_where_1        ! Test a simple WHERE
+    where (l1) y = x
+  end subroutine test_where_1
+!******************************************************************************
+  subroutine test_where_2        ! Test a WHERE blocks
+    where (l1)
+      y = a (0, 0)
+      z = z(4:1:-1)
+    elsewhere
+      y = x
+      z = a (0, 0)
+    end where
+  end subroutine test_where_2
+!******************************************************************************
+  subroutine test_where_3        ! Test a simple WHERE with a function assignment
+    where (.not. l1) y = foo (x)
+  end subroutine test_where_3
+!******************************************************************************
+  subroutine test_where_forall_1 ! Test a WHERE in a FORALL block
+    forall (i = 1:4)
+      where (.not. l1)
+        u(i, :) = x
+      elsewhere
+        u(i, :) = a(0, i)
+      endwhere
+    end forall
+  end subroutine test_where_forall_1
+!******************************************************************************
+  subroutine test_where_4       ! Test a WHERE assignment with dependencies
+    where (l1(1:3))
+      x(2:4) = x(1:3)
+    endwhere
+  end subroutine test_where_4
+end program test 
+! { dg-final { cleanup-modules "global" } }
+

gcc/testsuite/gfortran.dg/where_operator_assign_3.f90

@@ -0,0 +1,81 @@
+! { dg-do compile }
+! Tests the fix for PR30407, in which operator assignments did not work
+! in WHERE blocks or simple WHERE statements. This tests that the character
+! lengths are transmitted OK.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!******************************************************************************
+module global
+  type :: a
+    integer :: b
+    character(8):: c
+  end type a
+  interface assignment(=)
+    module procedure a_to_a, c_to_a, a_to_c
+  end interface
+  interface operator(.ne.)
+    module procedure a_ne_a
+  end interface
+
+  type(a) :: x(4), y(4)
+  logical :: l1(4), t = .true., f= .false.
+contains
+!******************************************************************************
+  elemental subroutine a_to_a (m, n)
+    type(a), intent(in) :: n
+    type(a), intent(out) :: m
+    m%b = len ( trim(n%c))
+    m%c = n%c
+  end subroutine a_to_a
+  elemental subroutine c_to_a (m, n)
+    character(8), intent(in) :: n
+    type(a), intent(out) :: m
+    m%b = m%b + 1
+    m%c = n
+  end subroutine c_to_a
+  elemental subroutine a_to_c (m, n)
+    type(a), intent(in) :: n
+    character(8), intent(out) :: m
+    m = n%c
+  end subroutine a_to_c
+!******************************************************************************
+  elemental logical function a_ne_a (m, n)
+    type(a), intent(in) :: n
+    type(a), intent(in) :: m
+    a_ne_a = (m%b .ne. n%b) .or. (m%c .ne. n%c)
+  end function a_ne_a
+!******************************************************************************
+  elemental function foo (m)
+    type(a) :: foo
+    type(a), intent(in) :: m
+    foo%b = 0
+    foo%c = m%c
+  end function foo  
+end module global
+!******************************************************************************
+program test
+  use global
+  x = (/a (0, "one"),a (0, "two"),a (0, "three"),a (0, "four")/)
+  y = x
+  l1 = (/t,f,f,t/)
+
+  call test_where_char1
+  call test_where_char2
+  if (any(y .ne. &
+    (/a(4, "null"), a(8, "non-null"), a(8, "non-null"), a(4, "null")/))) call abort ()
+contains
+  subroutine test_where_char1   ! Test a WHERE blocks
+    where (l1)
+      y = a (0, "null")
+    elsewhere
+      y = x
+    end where
+  end subroutine test_where_char1
+  subroutine test_where_char2   ! Test a WHERE blocks
+    where (y%c .ne. "null")
+      y = a (99, "non-null")
+    endwhere
+  end subroutine test_where_char2
+end program test 
+! { dg-final { cleanup-modules "global" } }
+

gcc/testsuite/gfortran.dg/zero_sized_2.f90

@@ -0,0 +1,13 @@
+! { dg-do compile }
+! Tests the fix for PR30514 in which the bounds on m would cause an
+! error and the rest would cause the compiler to go into an infinite
+! loop.
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+integer :: i(2:0), j(1:0), m(1:-1)
+integer, parameter :: k(2:0) = 0, l(1:0) = 0
+i = k
+j = l
+m = 5
+end
+

libgfortran/ChangeLog

@@ -1,3 +1,10 @@
+2007-02-12  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-01-30  Thomas Koenig  <Thomas.Koenig@online.de>
 
 	Backport from trunk

libgfortran/io/transfer.c

@@ -2003,7 +2003,7 @@ init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
   index = 1;
   for (i=0; i<rank; i++)
     {
-      ls[i].idx = 1;
+      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;
@@ -2040,8 +2040,9 @@ next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
           else
             carry = 0;
         }
-      index = index + (ls[i].idx - 1) * ls[i].step;
+      index = index + (ls[i].idx - ls[i].start) * ls[i].step;
     }
+
   return index;
 }