Re: [Patch, fortran] PR24174 real(10) and complex(10) array IO broken.

[Janne Blomqvist <jblomqvi at cc dot hut dot fi>]

PING!

On Tue, Oct 11, 2005 at 08:57:38AM +0300, Janne Blomqvist wrote:
> :ADDPATCH fortran:
> 
> Hello,
> 
> attached is an updated patch for PR24174. It also fixes complex(10)
> formatted output, althought input is still broken (see 24305).
> 
> I had to add a kind argument to the transfer_array function, as the
> array descriptor contains the size and not the kind, and we cannot
> uniquely determine the kind from the size (e.g. IA-64 where AFAIK
> real(10) is padded to 16 bytes and real(16) is also available).
> 
> -- 
> Janne Blomqvist

> gfortran ChangeLog
> 
> 2005-10-11  Janne Blomqvist <jblomqvi@cc.hut.fi>
> 
> 	PR fortran/24174 
> 	* fortran/trans-io.c (gfc_build_io_library_fndecls): Add kind
> 	argument to transfer_array.
> 	(transfer_array_desc): Add kind argument.
> 
> libgfortran Changelog:
> 
> 2005-10-11  Janne Blomqvist <jblomqvi@cc.hut.fi>
> 
> 	PR fortran/24174
> 	* io/io.h: Add argument to prototypes.
> 	* io/list_read.c (list_formatted_read): Add size argument, cleanup. 
> 	* io/transfer.c: Add argument to transfer function pointer.
> 	(unformatted_read): Add size argument.
> 	(unformatted_write): Likewise.
> 	(formatted_transfer_scalar): Fix for padding with complex(10).
> 	(formatted_transfer): Add size argument, cleanup.
> 	(transfer_integer): Add size argument to transfer call.
> 	(transfer_real): Likewise.
> 	(transfer_logical): Likewise.
> 	(transfer_character): Likewise.
> 	(transfer_complex): Likewise.
> 	(transfer_array): New kind argument, use it.
> 	(data_transfer_init): Add size argument to formatted_transfer
> 	call.
> 	(iolength_transfer): Add size argument, cleanup.
> 	* io/write.c (write_complex): Fix for padding with complex(10).
> 	(list_formatted_write): Add size argument, cleanup.
> 	

> Index: gcc/fortran/trans-io.c
> ===================================================================
> RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-io.c,v
> retrieving revision 1.43
> diff -p -u -r1.43 trans-io.c
> --- gcc/fortran/trans-io.c	26 Sep 2005 20:24:43 -0000	1.43
> +++ gcc/fortran/trans-io.c	11 Oct 2005 05:33:00 -0000
> @@ -271,7 +271,8 @@ gfc_build_io_library_fndecls (void)
>    iocall_x_array =
>      gfc_build_library_function_decl (get_identifier
>  				     (PREFIX("transfer_array")),
> -				     void_type_node, 2, pvoid_type_node,
> +				     void_type_node, 3, pvoid_type_node,
> +				     gfc_int4_type_node,
>  				     gfc_charlen_type_node);
>  
>    /* Library entry points */
> @@ -1597,14 +1598,17 @@ transfer_expr (gfc_se * se, gfc_typespec
>  static void
>  transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
>  {
> -  tree args, tmp, charlen_arg;
> +  tree args, tmp, charlen_arg, kind_arg;
>  
>    if (ts->type == BT_CHARACTER)
>      charlen_arg = se->string_length;
>    else
>      charlen_arg = build_int_cstu (NULL_TREE, 0);
>  
> +  kind_arg = build_int_cst (NULL_TREE, ts->kind);
> +
>    args = gfc_chainon_list (NULL_TREE, addr_expr);
> +  args = gfc_chainon_list (args, kind_arg);
>    args = gfc_chainon_list (args, charlen_arg);
>    tmp = gfc_build_function_call (iocall_x_array, args);
>    gfc_add_expr_to_block (&se->pre, tmp);
> Index: libgfortran/io/io.h
> ===================================================================
> RCS file: /cvsroot/gcc/gcc/libgfortran/io/io.h,v
> retrieving revision 1.33
> diff -p -u -r1.33 io.h
> --- libgfortran/io/io.h	7 Oct 2005 20:02:28 -0000	1.33
> +++ libgfortran/io/io.h	11 Oct 2005 05:33:01 -0000
> @@ -617,7 +617,7 @@ internal_proto(read_decimal);
>  
>  /* list_read.c */
>  
> -extern void list_formatted_read (bt, void *, int, size_t);
> +extern void list_formatted_read (bt, void *, int, size_t, size_t);
>  internal_proto(list_formatted_read);
>  
>  extern void finish_list_read (void);
> @@ -670,7 +670,7 @@ internal_proto(write_x);
>  extern void write_z (fnode *, const char *, int);
>  internal_proto(write_z);
>  
> -extern void list_formatted_write (bt, void *, int, size_t);
> +extern void list_formatted_write (bt, void *, int, size_t, size_t);
>  internal_proto(list_formatted_write);
>  
>  /* error.c */
> Index: libgfortran/io/list_read.c
> ===================================================================
> RCS file: /cvsroot/gcc/gcc/libgfortran/io/list_read.c,v
> retrieving revision 1.28
> diff -p -u -r1.28 list_read.c
> --- libgfortran/io/list_read.c	26 Sep 2005 20:24:44 -0000	1.28
> +++ libgfortran/io/list_read.c	11 Oct 2005 05:33:02 -0000
> @@ -1408,24 +1408,18 @@ list_formatted_read_scalar (bt type, voi
>  
>  
>  void
> -list_formatted_read  (bt type, void *p, int len, size_t nelems)
> +list_formatted_read  (bt type, void *p, int kind, size_t size, size_t nelems)
>  {
>    size_t elem;
> -  int size;
>    char *tmp;
>  
>    tmp = (char *) p;
>  
> -  if (type == BT_COMPLEX)
> -    size = 2 * len;
> -  else
> -    size = len;
> -
>    /* Big loop over all the elements.  */
>    for (elem = 0; elem < nelems; elem++)
>      {
>        g.item_count++;
> -      list_formatted_read_scalar (type, tmp + size*elem, len);
> +      list_formatted_read_scalar (type, tmp + size*elem, kind);
>      }
>  }
>  
> Index: libgfortran/io/transfer.c
> ===================================================================
> RCS file: /cvsroot/gcc/gcc/libgfortran/io/transfer.c,v
> retrieving revision 1.63
> diff -p -u -r1.63 transfer.c
> --- libgfortran/io/transfer.c	7 Oct 2005 20:02:28 -0000	1.63
> +++ libgfortran/io/transfer.c	11 Oct 2005 05:33:03 -0000
> @@ -78,7 +78,7 @@ export_proto(transfer_character);
>  extern void transfer_complex (void *, int);
>  export_proto(transfer_complex);
>  
> -extern void transfer_array (gfc_array_char *, gfc_charlen_type);
> +extern void transfer_array (gfc_array_char *, int, gfc_charlen_type);
>  export_proto(transfer_array);
>  
>  gfc_unit *current_unit = NULL;
> @@ -104,7 +104,7 @@ static const st_option advance_opt[] = {
>  };
>  
>  
> -static void (*transfer) (bt, void *, int, size_t);
> +static void (*transfer) (bt, void *, int, size_t, size_t);
>  
>  
>  typedef enum
> @@ -394,36 +394,26 @@ write_block_direct (void * buf, size_t *
>  /* Master function for unformatted reads.  */
>  
>  static void
> -unformatted_read (bt type, void *dest, int length, size_t nelems)
> +unformatted_read (bt type __attribute__((unused)), void *dest,
> +                 int kind __attribute__((unused)),
> +                 size_t size, size_t nelems)
>  {
> -  size_t len;
> +  size *= nelems;
>  
> -  len = length * nelems;
> -
> -  /* Transfer functions get passed the kind of the entity, so we have
> -     to fix this for COMPLEX data which are twice the size of their
> -     kind.  */
> -  if (type == BT_COMPLEX)
> -    len *= 2;
> -
> -  read_block_direct (dest, &len);
> +  read_block_direct (dest, &size);
>  }
>  
>  
>  /* Master function for unformatted writes.  */
>  
>  static void
> -unformatted_write (bt type, void *source, int length, size_t nelems)
> +unformatted_write (bt type __attribute__((unused)), void *source,
> +                  int kind __attribute__((unused)),
> +                  size_t size, size_t nelems)
>  {
> -  size_t len;
> -
> -  len = length * nelems;
> +  size *= nelems;
>  
> -  /* Correction for kind vs. length as in unformatted_read.  */
> -  if (type == BT_COMPLEX)
> -    len *= 2;
> -
> -  write_block_direct (source, &len);
> +  write_block_direct (source, &size);
>  }
>  
>  
> @@ -518,7 +508,7 @@ require_type (bt expected, bt actual, fn
>     of the next element, then comes back here to process it.  */
>  
>  static void
> -formatted_transfer_scalar (bt type, void *p, int len)
> +formatted_transfer_scalar (bt type, void *p, int len, size_t size)
>  {
>    int pos, bytes_used;
>    fnode *f;
> @@ -530,7 +520,10 @@ formatted_transfer_scalar (bt type, void
>  
>    n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
>    if (type == BT_COMPLEX)
> -    type = BT_REAL;
> +    {
> +      type = BT_REAL;
> +      size /= 2;
> +    }
>  
>    /* If there's an EOR condition, we simulate finalizing the transfer
>       by doing nothing.  */
> @@ -893,7 +886,7 @@ formatted_transfer_scalar (bt type, void
>        if ((consume_data_flag > 0) && (n > 0))
>        {
>  	n--;
> -	p = ((char *) p) + len;
> +	p = ((char *) p) + size;
>        }
>  
>        if (g.mode == READING)
> @@ -914,24 +907,18 @@ formatted_transfer_scalar (bt type, void
>  }
>  
>  static void
> -formatted_transfer (bt type, void *p, int len, size_t nelems)
> +formatted_transfer (bt type, void *p, int kind, size_t size, size_t nelems)
>  {
>    size_t elem;
> -  int  size;
>    char *tmp;
>  
>    tmp = (char *) p;
>  
> -  if (type == BT_COMPLEX)
> -    size = 2 * len;
> -  else
> -    size = len;
> -
>    /* Big loop over all the elements.  */
>    for (elem = 0; elem < nelems; elem++)
>      {
>        g.item_count++;
> -      formatted_transfer_scalar (type, tmp + size*elem, len);
> +      formatted_transfer_scalar (type, tmp + size*elem, kind, size);
>      }
>  }
>  
> @@ -946,16 +933,22 @@ transfer_integer (void *p, int kind)
>  {
>    if (ioparm.library_return != LIBRARY_OK)
>      return;
> -  transfer (BT_INTEGER, p, kind, 1);
> +  transfer (BT_INTEGER, p, kind, kind, 1);
>  }
>  
>  
>  void
>  transfer_real (void *p, int kind)
>  {
> +  size_t size;
>    if (ioparm.library_return != LIBRARY_OK)
>      return;
> -  transfer (BT_REAL, p, kind, 1);
> +  size = kind;
> +#ifdef HAVE_GFC_REAL_10
> +  if (kind == 10)
> +    size = sizeof (GFC_REAL_10);
> +#endif
> +  transfer (BT_REAL, p, kind, size, 1);
>  }
>  
>  
> @@ -964,7 +957,7 @@ transfer_logical (void *p, int kind)
>  {
>    if (ioparm.library_return != LIBRARY_OK)
>      return;
> -  transfer (BT_LOGICAL, p, kind, 1);
> +  transfer (BT_LOGICAL, p, kind, kind, 1);
>  }
>  
>  
> @@ -973,26 +966,35 @@ transfer_character (void *p, int len)
>  {
>    if (ioparm.library_return != LIBRARY_OK)
>      return;
> -  transfer (BT_CHARACTER, p, len, 1);
> +  /* Currently we support only 1 byte chars, and the library is a bit
> +     confused of character kind vs. length, so we kludge it by setting
> +     kind = length.  */
> +  transfer (BT_CHARACTER, p, len, len, 1);
>  }
>  
>  
>  void
>  transfer_complex (void *p, int kind)
>  {
> +  size_t size;
>    if (ioparm.library_return != LIBRARY_OK)
>      return;
> -  transfer (BT_COMPLEX, p, kind, 1);
> +  size = 2 * kind;
> +#ifdef HAVE_GFC_COMPLEX_10
> +  if (kind == 10)
> +    size = sizeof (GFC_COMPLEX_10);
> +#endif
> +  transfer (BT_COMPLEX, p, kind, size, 1);
>  }
>  
>  
>  void
> -transfer_array (gfc_array_char *desc, gfc_charlen_type charlen)
> +transfer_array (gfc_array_char *desc, int kind, gfc_charlen_type charlen)
>  {
>    index_type count[GFC_MAX_DIMENSIONS];
>    index_type extent[GFC_MAX_DIMENSIONS];
>    index_type stride[GFC_MAX_DIMENSIONS];
> -  index_type stride0, rank, size, type, n, kind;
> +  index_type stride0, rank, size, type, n;
>    size_t tsize;
>    char *data;
>    bt iotype;
> @@ -1002,7 +1004,6 @@ transfer_array (gfc_array_char *desc, gf
>  
>    type = GFC_DESCRIPTOR_TYPE (desc);
>    size = GFC_DESCRIPTOR_SIZE (desc);
> -  kind = size;
>  
>    /* FIXME: What a kludge: Array descriptors and the IO library use
>       different enums for types.  */
> @@ -1022,7 +1023,6 @@ transfer_array (gfc_array_char *desc, gf
>        break;
>      case GFC_DTYPE_COMPLEX:
>        iotype = BT_COMPLEX;
> -      kind /= 2;
>        break;
>      case GFC_DTYPE_CHARACTER:
>        iotype = BT_CHARACTER;
> @@ -1070,7 +1070,7 @@ transfer_array (gfc_array_char *desc, gf
>  
>    while (data)
>      {
> -      transfer (iotype, data, kind, tsize);
> +      transfer (iotype, data, kind, size, tsize);
>        data += stride0 * size * tsize;
>        count[0] += tsize;
>        n = 0;
> @@ -1447,7 +1447,7 @@ data_transfer_init (int read_flag)
>    /* Start the data transfer if we are doing a formatted transfer.  */
>    if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format
>        && ioparm.namelist_name == NULL && ionml == NULL)
> -    formatted_transfer (0, NULL, 0, 1);
> +    formatted_transfer (0, NULL, 0, 0, 1);
>  }
>  
>  
> @@ -1774,16 +1774,13 @@ finalize_transfer (void)
>     data transfer, it just updates the length counter.  */
>  
>  static void
> -iolength_transfer (bt type, void *dest __attribute__ ((unused)),
> -		   int len, size_t nelems)
> +iolength_transfer (bt type __attribute__((unused)), 
> +		   void *dest __attribute__ ((unused)),
> +		   int kind __attribute__((unused)), 
> +		   size_t size, size_t nelems)
>  {
>    if (ioparm.iolength != NULL)
> -    {
> -      if (type == BT_COMPLEX)
> -	*ioparm.iolength += 2 * len * nelems;
> -      else
> -	*ioparm.iolength += len * nelems;
> -    }
> +    *ioparm.iolength += (GFC_INTEGER_4) size * nelems;
>  }
>  
>  
> Index: libgfortran/io/write.c
> ===================================================================
> RCS file: /cvsroot/gcc/gcc/libgfortran/io/write.c,v
> retrieving revision 1.51
> diff -p -u -r1.51 write.c
> --- libgfortran/io/write.c	7 Oct 2005 17:01:48 -0000	1.51
> +++ libgfortran/io/write.c	11 Oct 2005 05:33:04 -0000
> @@ -1396,13 +1396,22 @@ write_real (const char *source, int leng
>  static void
>  write_complex (const char *source, int len)
>  {
> +  size_t size;
> +
> +  size = len;
> +
> +#ifdef HAVE_GFC_COMPLEX_10
> +  if (len == 10)
> +    size = sizeof (GFC_COMPLEX_10) / 2;
> +#endif
> +
>    if (write_char ('('))
>      return;
>    write_real (source, len);
>  
>    if (write_char (','))
>      return;
> -  write_real (source + len, len);
> +  write_real (source + size, len);
>  
>    write_char (')');
>  }
> @@ -1474,24 +1483,18 @@ list_formatted_write_scalar (bt type, vo
>  
>  
>  void
> -list_formatted_write (bt type, void *p, int len, size_t nelems)
> +list_formatted_write (bt type, void *p, int kind, size_t size, size_t nelems)
>  {
>    size_t elem;
> -  int size;
>    char *tmp;
>  
>    tmp = (char *) p;
>  
> -  if (type == BT_COMPLEX)
> -    size = 2 * len;
> -  else
> -    size = len;
> -
>    /* Big loop over all the elements.  */
>    for (elem = 0; elem < nelems; elem++)
>      {
>        g.item_count++;
> -      list_formatted_write_scalar (type, tmp + size*elem, len);
> +      list_formatted_write_scalar (type, tmp + size*elem, kind);
>      }
>  }
>  

> ! { dg-do run }
> ! PR 24174
> program kind10_io
>   real(kind=10) :: a,b(2), c
>   complex(kind=10) :: d, e, f(2)
>   character(len=180) :: tmp
>   ! Test real(10) scalar and array formatted IO
>   b(:) = 2.0_10
>   write (tmp, *) b
>   read (tmp, *) a, c
>   if (a /= 2.0_10) call abort()
>   if (c /= 2.0_10) call abort()
>   ! Complex(10) scalar and array formatted and list formatted IO
>   f = cmplx ( 1.0_10, 2.0_10, 10)
>   d = cmplx ( huge (1.0_10), huge (2.0_10), 10)
>   write (tmp, *) d
> !  read (tmp, *) e ! List formatted read doesn't work.
> !  if (e /= d) call abort()
>   write (tmp, '(2(e12.4e5, 2x))') d
> !  read (tmp, '(2(e12.4e5, 2x))') e ! Read doesn't work either
> !  if (e /= d) call abort()
> end program kind10_io


-- 
Janne Blomqvist