re PR libfortran/35863 ([F2003] Implement ENCODING="UTF-8")

2008-06-13  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/35863
	* libgfortran.h: Change l8_to_l4_offset to big_endian and add endian_off.
	* runtime/main.c: Fix error in comment. Change l8_to_l4_offset to
	big_endian. (determine_endianness): Add endian_off and set its value
	according to big_endian.
	* gfortran.map: Add symbol for new _gfortran_transfer_character_wide.
	* io/io.h: Add prototype declarations for new functions.
	* io/list_read.c (list_formatted_read_scalar): Modify to handle kind=4.
	(list_formatted_read): Calculate stride based on kind for character type
	and use it when calling list_formatted_read_scalar.
	* io/inquire.c (inquire_via_unit): Change l8_to_l4_offset to big_endian.
	* io/open.c (st_open): Change l8_to_l4_offset to big_endian.
	* io/read.c (read_a_char4): New function to handle formatted read.
	* io/write.c: Define GFC_CHAR4(x) to improve readability of code.
	(write_a_char4): New function to handle formatted write.
	(write_character): Modify to accept the kind parameter and adjust for
	endianess of the machine. (list_formatted_write): Calculate the stride
	resulting from the kind and adjust the list_formatted_write_scalar call
	accordingly. (nml_write_obj): Adjust calls to write_character.
	(namelist_write): Likewise.
	* io/transfer.c (formatted_transfer_scaler): Rename 'len' argument to
	'kind' argument to better describe what it is. Add calls to new
	functions for kind == 4. (formatted_transfer): Modify to handle the case
	of type character and kind equals 4 to pass in the kind to the transfer
	routines. (transfer_character_wide): Add this new function.
	(transfer_array): Don't set kind to the character string length. Adjust
	strides bases on character kind.
	(unformatted_read): Adjust size based on kind for character types.
	(unformatted_write): Likewise. (data_transfer_init): Change
	l8_to_l4_offset to big_endian.

From-SVN: r136763

libgfortran/ChangeLog

+2008-06-13  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/35863
+	* libgfortran.h: Change l8_to_l4_offset to big_endian and add endian_off.
+	* runtime/main.c: Fix error in comment. Change l8_to_l4_offset to
+	big_endian. (determine_endianness): Add endian_off and set its value
+	according to big_endian.
+	* gfortran.map: Add symbol for new _gfortran_transfer_character_wide.
+	* io/io.h: Add prototype declarations for new functions.
+	* io/list_read.c (list_formatted_read_scalar): Modify to handle kind=4.
+	(list_formatted_read): Calculate stride based on kind for character type
+	and use it when calling list_formatted_read_scalar.
+	* io/inquire.c (inquire_via_unit): Change l8_to_l4_offset to big_endian.
+	* io/open.c (st_open): Change l8_to_l4_offset to big_endian.
+	* io/read.c (read_a_char4): New function to handle formatted read.
+	* io/write.c: Define GFC_CHAR4(x) to improve readability of code.
+	(write_a_char4): New function to handle formatted write.
+	(write_character): Modify to accept the kind parameter and adjust for
+	endianess of the machine. (list_formatted_write): Calculate the stride
+	resulting from the kind and adjust the list_formatted_write_scalar call
+	accordingly. (nml_write_obj): Adjust calls to write_character.
+	(namelist_write): Likewise.
+	* io/transfer.c (formatted_transfer_scaler): Rename 'len' argument to
+	'kind' argument to better describe what it is. Add calls to new
+	functions for kind == 4. (formatted_transfer): Modify to handle the case
+	of type character and kind equals 4 to pass in the kind to the transfer
+	routines. (transfer_character_wide): Add this new function.
+	(transfer_array): Don't set kind to the character string length. Adjust
+	strides bases on character kind.
+	(unformatted_read): Adjust size based on kind for character types.
+	(unformatted_write): Likewise. (data_transfer_init): Change
+	l8_to_l4_offset to big_endian. 
+
 2008-06-13  Tobias Burnus  <burnus@net-b.de>
 
 	* configure.ac (AM_CFLAGS): Remove -Werror again.

libgfortran/gfortran.map

@@ -1083,6 +1083,7 @@ GFORTRAN_1.1 {
     _gfortran_string_trim_char4;
     _gfortran_string_verify_char4;
     _gfortran_st_wait;
+    _gfortran_transfer_character_wide;
     _gfortran_transpose_char4;
     _gfortran_unpack0_char4;
     _gfortran_unpack1_char4;

libgfortran/io/fbuf.c

@@ -157,7 +157,7 @@ fbuf_seek (gfc_unit * u, gfc_offset off)
   /* Moving to the left past the flushed marked would imply moving past
      the left tab limit, which is never allowed. So return error if
      that is attempted.  */
-  if (pos < u->fbuf->flushed)
+  if (pos < (gfc_offset) u->fbuf->flushed)
     return -1;
   u->fbuf->pos = pos;
   return 0;

libgfortran/io/inquire.c

@@ -268,10 +268,9 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
 	  case ENCODING_DEFAULT:
 	    p = "UNKNOWN";
 	    break;
-	  /* TODO: Enable UTF-8 case here when implemented.
 	  case ENCODING_UTF8:
 	    p = "UTF-8";
-	    break; */
+	    break;
 	  default:
 	    internal_error (&iqp->common, "inquire_via_unit(): Bad encoding");
 	  }
@@ -497,13 +496,13 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
       else
 	switch (u->flags.convert)
 	  {
-	    /*  l8_to_l4_offset is 0 for little-endian, 1 for big-endian.  */
+	    /*  big_endian is 0 for little-endian, 1 for big-endian.  */
 	  case GFC_CONVERT_NATIVE:
-	    p = l8_to_l4_offset ? "BIG_ENDIAN" : "LITTLE_ENDIAN";
+	    p = big_endian ? "BIG_ENDIAN" : "LITTLE_ENDIAN";
 	    break;
 
 	  case GFC_CONVERT_SWAP:
-	    p = l8_to_l4_offset ? "LITTLE_ENDIAN" : "BIG_ENDIAN";
+	    p = big_endian ? "LITTLE_ENDIAN" : "BIG_ENDIAN";
 	    break;
 
 	  default:

libgfortran/io/io.h

@@ -869,6 +869,9 @@ internal_proto(convert_real);
 extern void read_a (st_parameter_dt *, const fnode *, char *, int);
 internal_proto(read_a);
 
+extern void read_a_char4 (st_parameter_dt *, const fnode *, char *, int);
+internal_proto(read_a);
+
 extern void read_f (st_parameter_dt *, const fnode *, char *, int);
 internal_proto(read_f);
 
@@ -904,6 +907,9 @@ internal_proto(namelist_write);
 extern void write_a (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_a);
 
+extern void write_a_char4 (st_parameter_dt *, const fnode *, const char *, int);
+internal_proto(write_a_char4);
+
 extern void write_b (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_b);
 

libgfortran/io/list_read.c

@@ -1728,7 +1728,8 @@ list_formatted_read_scalar (st_parameter_dt *dtp, volatile bt type, void *p,
 			    int kind, size_t size)
 {
   char c;
-  int m;
+  gfc_char4_t *q;
+  int i, m;
   jmp_buf eof_jump;
 
   dtp->u.p.namelist_mode = 0;
@@ -1834,14 +1835,30 @@ list_formatted_read_scalar (st_parameter_dt *dtp, volatile bt type, void *p,
 	{
 	  m = ((int) size < dtp->u.p.saved_used)
 	      ? (int) size : dtp->u.p.saved_used;
+	  if (kind == 1)
 	    memcpy (p, dtp->u.p.saved_string, m);
+	  else
+	    {
+	      q = (gfc_char4_t *) p;
+	      for (i = 0; i < m; i++)
+		q[i] = (unsigned char) dtp->u.p.saved_string[i];
+	    }
 	}
       else
 	/* Just delimiters encountered, nothing to copy but SPACE.  */
         m = 0;
 
       if (m < (int) size)
+	{
+	  if (kind == 1)
 	    memset (((char *) p) + m, ' ', size - m);
+	  else
+	    {
+	      q = (gfc_char4_t *) p;
+	      for (i = m; i < (int) size; i++)
+		q[i] = (unsigned char) ' ';
+	    }
+	}
       break;
 
     case BT_NULL:
@@ -1862,6 +1879,8 @@ list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
 {
   size_t elem;
   char *tmp;
+  size_t stride = type == BT_CHARACTER ?
+		  size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
 
   tmp = (char *) p;
 
@@ -1869,7 +1888,7 @@ list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
   for (elem = 0; elem < nelems; elem++)
     {
       dtp->u.p.item_count++;
-      list_formatted_read_scalar (dtp, type, tmp + size*elem, kind, size);
+      list_formatted_read_scalar (dtp, type, tmp + stride*elem, kind, size);
     }
 }
 

libgfortran/io/open.c

@@ -107,7 +107,7 @@ static const st_option decimal_opt[] =
 
 static const st_option encoding_opt[] =
 {
-  /* TODO { "utf-8", ENCODING_UTF8}, */
+  { "utf-8", ENCODING_UTF8},
   { "default", ENCODING_DEFAULT},
   { NULL, 0}
 };
@@ -795,7 +795,7 @@ st_open (st_parameter_open *opp)
 	conv = compile_options.convert;
     }
   
-  /* We use l8_to_l4_offset, which is 0 on little-endian machines
+  /* We use big_endian, which is 0 on little-endian machines
      and 1 on big-endian machines.  */
   switch (conv)
     {
@@ -804,11 +804,11 @@ st_open (st_parameter_open *opp)
       break;
       
     case GFC_CONVERT_BIG:
-      conv = l8_to_l4_offset ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
+      conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
       break;
       
     case GFC_CONVERT_LITTLE:
-      conv = l8_to_l4_offset ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
+      conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
       break;
       
     default:

libgfortran/io/read.c

@@ -270,6 +270,43 @@ read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
     memset (p + m, ' ', n);
 }
 
+void
+read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
+{
+  char *s;
+  gfc_char4_t *dest;
+  int m, n, wi, status;
+  size_t w;
+
+  wi = f->u.w;
+  if (wi == -1) /* '(A)' edit descriptor  */
+    wi = length;
+
+  w = wi;
+
+  s = gfc_alloca (w);
+
+  /* Read in w bytes, treating comma as not a separator.  */
+  dtp->u.p.sf_read_comma = 0;
+  status = read_block_form (dtp, s, &w);
+  dtp->u.p.sf_read_comma =
+    dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
+  
+  if (status == FAILURE)
+    return;
+  if (w > (size_t) length)
+     s += (w - length);
+
+  m = ((int) w > length) ? length : (int) w;
+  
+  dest = (gfc_char4_t *) p;
+  
+  for (n = 0; n < m; n++, dest++, s++)
+    *dest = (unsigned char ) *s;
+
+  for (n = 0; n < length - (int) w; n++, dest++)
+    *dest = (unsigned char) ' ';
+}
 
 /* eat_leading_spaces()-- Given a character pointer and a width,
  * ignore the leading spaces.  */

libgfortran/io/transfer.c

@@ -54,6 +54,7 @@ Boston, MA 02110-1301, USA.  */
       transfer_integer
       transfer_logical
       transfer_character
+      transfer_character_wide
       transfer_real
       transfer_complex
 
@@ -76,6 +77,9 @@ export_proto(transfer_logical);
 extern void transfer_character (st_parameter_dt *, void *, int);
 export_proto(transfer_character);
 
+extern void transfer_character_wide (st_parameter_dt *, void *, int, int);
+export_proto(transfer_character_wide);
+
 extern void transfer_complex (st_parameter_dt *, void *, int);
 export_proto(transfer_complex);
 
@@ -730,16 +734,16 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
 
 static void
 unformatted_read (st_parameter_dt *dtp, bt type,
-		  void *dest, int kind __attribute__((unused)),
-		  size_t size, size_t nelems)
+		  void *dest, int kind, size_t size, size_t nelems)
 {
   size_t i, sz;
 
-  /* Currently, character implies size=1.  */
   if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE
-      || size == 1 || type == BT_CHARACTER)
+      || size == 1)
     {
       sz = size * nelems;
+      if (type == BT_CHARACTER)
+	sz *= GFC_SIZE_OF_CHAR_KIND(kind);
       read_block_direct (dtp, dest, &sz);
     }
   else
@@ -747,18 +751,26 @@ unformatted_read (st_parameter_dt *dtp, bt type,
       char buffer[16];
       char *p;
 
+      p = dest;
+
+      /* Handle wide chracters.  */
+      if (type == BT_CHARACTER && kind != 1)
+	{
+	  nelems *= size;
+	  size = kind;
+	}
+
       /* Break up complex into its constituent reals.  */
       if (type == BT_COMPLEX)
 	{
 	  nelems *= 2;
 	  size /= 2;
 	}
-      p = dest;
       
       /* By now, all complex variables have been split into their
 	 constituent reals.  */
       
-      for (i=0; i<nelems; i++)
+      for (i = 0; i < nelems; i++)
 	{
  	  read_block_direct (dtp, buffer, &size);
  	  reverse_memcpy (p, buffer, size);
@@ -775,14 +787,15 @@ unformatted_read (st_parameter_dt *dtp, bt type,
 
 static void
 unformatted_write (st_parameter_dt *dtp, bt type,
-		   void *source, int kind __attribute__((unused)),
-		   size_t size, size_t nelems)
+		   void *source, int kind, size_t size, size_t nelems)
 {
   if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE ||
-      size == 1 || type == BT_CHARACTER)
+      size == 1)
     {
-      size *= nelems;
-      write_buf (dtp, source, size);
+      size_t stride = type == BT_CHARACTER ?
+		  size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
+
+      write_buf (dtp, source, stride * nelems);
     }
   else
     {
@@ -790,6 +803,15 @@ unformatted_write (st_parameter_dt *dtp, bt type,
       char *p;
       size_t i;
 
+      p = source;
+
+      /* Handle wide chracters.  */
+      if (type == BT_CHARACTER && kind != 1)
+	{
+	  nelems *= size;
+	  size = kind;
+	}
+  
       /* Break up complex into its constituent reals.  */
       if (type == BT_COMPLEX)
 	{
@@ -797,16 +819,13 @@ unformatted_write (st_parameter_dt *dtp, bt type,
 	  size /= 2;
 	}      
 
-      p = source;
-
       /* By now, all complex variables have been split into their
 	 constituent reals.  */
 
-
-      for (i=0; i<nelems; i++)
+      for (i = 0; i < nelems; i++)
 	{
 	  reverse_memcpy(buffer, p, size);
- 	  p+= size;
+ 	  p += size;
 	  write_buf (dtp, buffer, size);
 	}
     }
@@ -904,7 +923,7 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
    of the next element, then comes back here to process it.  */
 
 static void
-formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
+formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
 			   size_t size)
 {
   char scratch[SCRATCH_SIZE];
@@ -1004,9 +1023,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
 	    return;
 
 	  if (dtp->u.p.mode == READING)
-	    read_decimal (dtp, f, p, len);
+	    read_decimal (dtp, f, p, kind);
 	  else
-	    write_i (dtp, f, p, len);
+	    write_i (dtp, f, p, kind);
 
 	  break;
 
@@ -1019,9 +1038,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
 	    return;
 
 	  if (dtp->u.p.mode == READING)
-	    read_radix (dtp, f, p, len, 2);
+	    read_radix (dtp, f, p, kind, 2);
 	  else
-	    write_b (dtp, f, p, len);
+	    write_b (dtp, f, p, kind);
 
 	  break;
 
@@ -1034,9 +1053,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
 	    return;
 
 	  if (dtp->u.p.mode == READING)
-	    read_radix (dtp, f, p, len, 8);
+	    read_radix (dtp, f, p, kind, 8);
 	  else
-	    write_o (dtp, f, p, len);
+	    write_o (dtp, f, p, kind);
 
 	  break;
 
@@ -1049,9 +1068,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
 	    return;
 
 	  if (dtp->u.p.mode == READING)
-	    read_radix (dtp, f, p, len, 16);
+	    read_radix (dtp, f, p, kind, 16);
 	  else
-	    write_z (dtp, f, p, len);
+	    write_z (dtp, f, p, kind);
 
 	  break;
 
@@ -1059,11 +1078,23 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
 	  if (n == 0)
 	    goto need_data;
 
+	  /* It is possible to have FMT_A with something not BT_CHARACTER such
+	     as when writing out hollerith strings, so check both type
+	     and kind before calling wide character routines.  */
 	  if (dtp->u.p.mode == READING)
-	    read_a (dtp, f, p, len);
+	    {
+	      if (type == BT_CHARACTER && kind == 4)
+		read_a_char4 (dtp, f, p, size);
 	      else
-	    write_a (dtp, f, p, len);
-
+		read_a (dtp, f, p, size);
+	    }
+	  else
+	    {
+	      if (type == BT_CHARACTER && kind == 4)
+		write_a_char4 (dtp, f, p, size);
+	      else
+		write_a (dtp, f, p, size);
+	    }
 	  break;
 
 	case FMT_L:
@@ -1071,9 +1102,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
 	    goto need_data;
 
 	  if (dtp->u.p.mode == READING)
-	    read_l (dtp, f, p, len);
+	    read_l (dtp, f, p, kind);
 	  else
-	    write_l (dtp, f, p, len);
+	    write_l (dtp, f, p, kind);
 
 	  break;
 
@@ -1084,9 +1115,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
 	    return;
 
 	  if (dtp->u.p.mode == READING)
-	    read_f (dtp, f, p, len);
+	    read_f (dtp, f, p, kind);
 	  else
-	    write_d (dtp, f, p, len);
+	    write_d (dtp, f, p, kind);
 
 	  break;
 
@@ -1097,9 +1128,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
 	    return;
 
 	  if (dtp->u.p.mode == READING)
-	    read_f (dtp, f, p, len);
+	    read_f (dtp, f, p, kind);
 	  else
-	    write_e (dtp, f, p, len);
+	    write_e (dtp, f, p, kind);
 	  break;
 
 	case FMT_EN:
@@ -1109,9 +1140,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
 	    return;
 
 	  if (dtp->u.p.mode == READING)
-	    read_f (dtp, f, p, len);
+	    read_f (dtp, f, p, kind);
 	  else
-	    write_en (dtp, f, p, len);
+	    write_en (dtp, f, p, kind);
 
 	  break;
 
@@ -1122,9 +1153,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
 	    return;
 
 	  if (dtp->u.p.mode == READING)
-	    read_f (dtp, f, p, len);
+	    read_f (dtp, f, p, kind);
 	  else
-	    write_es (dtp, f, p, len);
+	    write_es (dtp, f, p, kind);
 
 	  break;
 
@@ -1135,9 +1166,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
 	    return;
 
 	  if (dtp->u.p.mode == READING)
-	    read_f (dtp, f, p, len);
+	    read_f (dtp, f, p, kind);
 	  else
-	    write_f (dtp, f, p, len);
+	    write_f (dtp, f, p, kind);
 
 	  break;
 
@@ -1148,16 +1179,19 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
 	    switch (type)
 	      {
 	      case BT_INTEGER:
-		read_decimal (dtp, f, p, len);
+		read_decimal (dtp, f, p, kind);
 		break;
 	      case BT_LOGICAL:
-		read_l (dtp, f, p, len);
+		read_l (dtp, f, p, kind);
 		break;
 	      case BT_CHARACTER:
-		read_a (dtp, f, p, len);
+		if (kind == 4)
+		  read_a_char4 (dtp, f, p, size);
+		else
+		  read_a (dtp, f, p, size);
 		break;
 	      case BT_REAL:
-		read_f (dtp, f, p, len);
+		read_f (dtp, f, p, kind);
 		break;
 	      default:
 		goto bad_type;
@@ -1166,19 +1200,22 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
 	    switch (type)
 	      {
 	      case BT_INTEGER:
-		write_i (dtp, f, p, len);
+		write_i (dtp, f, p, kind);
 		break;
 	      case BT_LOGICAL:
-		write_l (dtp, f, p, len);
+		write_l (dtp, f, p, kind);	
 		break;
 	      case BT_CHARACTER:
-		write_a (dtp, f, p, len);
+		if (kind == 4)
+		  write_a_char4 (dtp, f, p, size);
+		else
+		  write_a (dtp, f, p, size);
 		break;
 	      case BT_REAL:
 		if (f->u.real.w == 0)
-		  write_real (dtp, p, len);
+		  write_real (dtp, p, kind);
 		else
-		  write_d (dtp, f, p, len);
+		  write_d (dtp, f, p, kind);
 		break;
 	      default:
 	      bad_type:
@@ -1407,12 +1444,13 @@ formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
   char *tmp;
 
   tmp = (char *) p;
-
+  size_t stride = type == BT_CHARACTER ?
+		  size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
   /* Big loop over all the elements.  */
   for (elem = 0; elem < nelems; elem++)
     {
       dtp->u.p.item_count++;
-      formatted_transfer_scalar (dtp, type, tmp + size*elem, kind, size);
+      formatted_transfer_scalar (dtp, type, tmp + stride*elem, kind, size);
     }
 }
 
@@ -1465,10 +1503,26 @@ transfer_character (st_parameter_dt *dtp, void *p, int len)
   if (len == 0 && p == NULL)
     p = empty_string;
 
-  /* 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.  */
-  dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1);
+  /* Set kind here to 1.  */
+  dtp->u.p.transfer (dtp, BT_CHARACTER, p, 1, len, 1);
+}
+
+void
+transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind)
+{
+  static char *empty_string[0];
+
+  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    return;
+
+  /* Strings of zero length can have p == NULL, which confuses the
+     transfer routines into thinking we need more data elements.  To avoid
+     this, we give them a nice pointer.  */
+  if (len == 0 && p == NULL)
+    p = empty_string;
+
+  /* Here we pass the actual kind value.  */
+  dtp->u.p.transfer (dtp, BT_CHARACTER, p, kind, len, 1);
 }
 
 
@@ -1522,13 +1576,7 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
       break;
     case GFC_DTYPE_CHARACTER:
       iotype = BT_CHARACTER;
-      /* FIXME: Currently dtype contains the charlen, which is
-	 clobbered if charlen > 2**24. That's why we use a separate
-	 argument for the charlen. However, if we want to support
-	 non-8-bit charsets we need to fix dtype to contain
-	 sizeof(chartype) and fix the code below.  */
       size = charlen;
-      kind = charlen;
       break;
     case GFC_DTYPE_DERIVED:
       internal_error (&dtp->common,
@@ -1542,7 +1590,9 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
   for (n = 0; n < rank; n++)
     {
       count[n] = 0;
-      stride[n] = desc->dim[n].stride;
+      stride[n] = iotype == BT_CHARACTER ?
+		  desc->dim[n].stride * GFC_SIZE_OF_CHAR_KIND(kind) :
+		  desc->dim[n].stride;
       extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
 
       /* If the extent of even one dimension is zero, then the entire
@@ -1815,7 +1865,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
      if (conv == GFC_CONVERT_NONE)
        conv = compile_options.convert;
 
-     /* We use l8_to_l4_offset, which is 0 on little-endian machines
+     /* We use big_endian, which is 0 on little-endian machines
 	and 1 on big-endian machines.  */
      switch (conv)
        {
@@ -1824,11 +1874,11 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
 	 break;
 	 
        case GFC_CONVERT_BIG:
-	 conv = l8_to_l4_offset ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
+	 conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
 	 break;
       
        case GFC_CONVERT_LITTLE:
-	 conv = l8_to_l4_offset ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
+	 conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
 	 break;
 	 
        default:

libgfortran/io/write.c

@@ -124,6 +124,108 @@ write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 #endif
 }
 
+
+/* The primary difference between write_a_char4 and write_a is that we have to
+   deal with writing from the first byte of the 4-byte character and take care
+   of endianess.  This currently implements encoding="default" which means we
+   write the lowest significant byte. If the 3 most significant bytes are
+   not representable emit a '?'.  TODO: Implement encoding="UTF-8"
+   which will process all 4 bytes and translate to the encoded output.  */
+
+void
+write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
+{
+  int wlen;
+  char *p;
+  gfc_char4_t *q;
+
+  wlen = f->u.string.length < 0
+	 || (f->format == FMT_G && f->u.string.length == 0)
+	 ? len : f->u.string.length;
+
+  q = (gfc_char4_t *) source;
+#ifdef HAVE_CRLF
+  /* If this is formatted STREAM IO convert any embedded line feed characters
+     to CR_LF on systems that use that sequence for newlines.  See F2003
+     Standard sections 10.6.3 and 9.9 for further information.  */
+  if (is_stream_io (dtp))
+    {
+      const char crlf[] = "\r\n";
+      int i, j, bytes;
+      gfc_char4_t *qq;
+      bytes = 0;
+
+      /* Write out any padding if needed.  */
+      if (len < wlen)
+	{
+	  p = write_block (dtp, wlen - len);
+	  if (p == NULL)
+	    return;
+	  memset (p, ' ', wlen - len);
+	}
+
+      /* Scan the source string looking for '\n' and convert it if found.  */
+      qq = (gfc_char4_t *) source;
+      for (i = 0; i < wlen; i++)
+	{
+	  if (qq[i] == '\n')
+	    {
+	      /* Write out the previously scanned characters in the string.  */
+	      if (bytes > 0)
+		{
+		  p = write_block (dtp, bytes);
+		  if (p == NULL)
+		    return;
+		  for (j = 0; j < bytes; j++)
+		    p[j] = q[j] > 255 ? '?' : (unsigned char) q[j];
+		  bytes = 0;
+		}
+
+	      /* Write out the CR_LF sequence.  */ 
+	      p = write_block (dtp, 2);
+              if (p == NULL)
+                return;
+	      memcpy (p, crlf, 2);
+	    }
+	  else
+	    bytes++;
+	}
+
+      /*  Write out any remaining bytes if no LF was found.  */
+      if (bytes > 0)
+	{
+	  p = write_block (dtp, bytes);
+	  if (p == NULL)
+	    return;
+	  for (j = 0; j < bytes; j++)
+	    p[j] = q[j] > 255 ? '?' : (unsigned char) q[j];
+	}
+    }
+  else
+    {
+#endif
+      int j;
+      p = write_block (dtp, wlen);
+      if (p == NULL)
+	return;
+
+      if (wlen < len)
+	{
+	  for (j = 0; j < wlen; j++)
+	    p[j] = q[j] > 255 ? '?' : (unsigned char) q[j];
+	}
+      else
+	{
+	  memset (p, ' ', wlen - len);
+	  for (j = wlen - len; j < wlen; j++)
+	    p[j] = q[j] > 255 ? '?' : (unsigned char) q[j];
+	}
+#ifdef HAVE_CRLF
+    }
+#endif
+}
+
+
 static GFC_INTEGER_LARGEST
 extract_int (const void *p, int len)
 {
@@ -639,10 +741,12 @@ write_integer (st_parameter_dt *dtp, const char *source, int length)
    the strings if the file has been opened in that mode.  */
 
 static void
-write_character (st_parameter_dt *dtp, const char *source, int length)
+write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
 {
   int i, extra;
   char *p, d;
+  gfc_char4_t *q;
+
 
   switch (dtp->u.p.delim_status)
     {
@@ -657,6 +761,8 @@ write_character (st_parameter_dt *dtp, const char *source, int length)
       break;
     }
 
+  if (kind == 1)
+    {
       if (d == ' ')
 	extra = 0;
       else
@@ -687,6 +793,46 @@ write_character (st_parameter_dt *dtp, const char *source, int length)
 
 	  *p = d;
 	}
+    }
+  else
+    {
+      /* We have to scan the source string looking for delimiters to determine
+	 how large the write block needs to be.  */
+      if (d == ' ')
+	extra = 0;
+      else
+	{
+	  extra = 2;
+
+	  q = (gfc_char4_t *) source;
+	  for (i = 0; i < length; i++, q++)
+	    if (*q == (gfc_char4_t) d)
+	      extra++;
+	}
+
+      p = write_block (dtp, length + extra);
+      if (p == NULL)
+	return;
+
+      if (d == ' ')
+	{
+	  q = (gfc_char4_t *) source;
+	  for (i = 0; i < length; i++, q++)
+	    p[i] = *q > 255 ? '?' : (unsigned char) *q;
+	}
+      else
+	{
+	  *p++ = d;
+	  q = (gfc_char4_t *) source;
+	  for (i = 0; i < length; i++, q++)
+	    {
+	      *p++ = *q > 255 ? '?' : (unsigned char) *q;
+	      if (*q == (gfc_char4_t) d)
+		*p++ = d;
+	    }
+	  *p = d;
+	}
+    }
 }
 
 
@@ -796,7 +942,7 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
       write_logical (dtp, p, kind);
       break;
     case BT_CHARACTER:
-      write_character (dtp, p, kind);
+      write_character (dtp, p, kind, size);
       break;
     case BT_REAL:
       write_real (dtp, p, kind);
@@ -818,6 +964,8 @@ list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
 {
   size_t elem;
   char *tmp;
+  size_t stride = type == BT_CHARACTER ?
+		  size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
 
   tmp = (char *) p;
 
@@ -825,7 +973,7 @@ list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
   for (elem = 0; elem < nelems; elem++)
     {
       dtp->u.p.item_count++;
-      list_formatted_write_scalar (dtp, type, tmp + size*elem, kind, size);
+      list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
     }
 }
 
@@ -889,9 +1037,9 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
   if (obj->type != GFC_DTYPE_DERIVED)
     {
 #ifdef HAVE_CRLF
-      write_character (dtp, "\r\n ", 3);
+      write_character (dtp, "\r\n ", 1, 3);
 #else
-      write_character (dtp, "\n ", 2);
+      write_character (dtp, "\n ", 1, 2);
 #endif
       len = 0;
       if (base)
@@ -900,15 +1048,15 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 	  for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
             {
 	      cup = toupper (base_name[dim_i]);
-	      write_character (dtp, &cup, 1);
+	      write_character (dtp, &cup, 1, 1);
             }
 	}
       for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
 	{
 	  cup = toupper (obj->var_name[dim_i]);
-	  write_character (dtp, &cup, 1);
+	  write_character (dtp, &cup, 1, 1);
 	}
-      write_character (dtp, "=", 1);
+      write_character (dtp, "=", 1, 1);
     }
 
   /* Counts the number of data output on a line, including names.  */
@@ -978,7 +1126,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 	  if (rep_ctr > 1)
 	    {
 	      sprintf(rep_buff, " %d*", rep_ctr);
-	      write_character (dtp, rep_buff, strlen (rep_buff));
+	      write_character (dtp, rep_buff, 1, strlen (rep_buff));
 	      dtp->u.p.no_leading_blank = 1;
 	    }
 	  num++;
@@ -1003,7 +1151,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 		dtp->u.p.delim_status = DELIM_QUOTE;
 	      if (dtp->u.p.nml_delim == '\'')
 		dtp->u.p.delim_status = DELIM_APOSTROPHE;
-	      write_character (dtp, p, obj->string_length);
+	      write_character (dtp, p, 1, obj->string_length);
 	      dtp->u.p.delim_status = tmp_delim;
               break;
 
@@ -1093,14 +1241,14 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 	     to column 2. Reset the repeat counter.  */
 
 	  dtp->u.p.no_leading_blank = 0;
-	  write_character (dtp, &semi_comma, 1);
+	  write_character (dtp, &semi_comma, 1, 1);
 	  if (num > 5)
 	    {
 	      num = 0;
 #ifdef HAVE_CRLF
-	      write_character (dtp, "\r\n ", 3);
+	      write_character (dtp, "\r\n ", 1, 3);
 #else
-	      write_character (dtp, "\n ", 2);
+	      write_character (dtp, "\n ", 1, 2);
 #endif
 	    }
 	  rep_ctr = 1;
@@ -1164,13 +1312,13 @@ namelist_write (st_parameter_dt *dtp)
   /* Temporarily disable namelist delimters.  */
   dtp->u.p.delim_status = DELIM_NONE;
 
-  write_character (dtp, "&", 1);
+  write_character (dtp, "&", 1, 1);
 
   /* Write namelist name in upper case - f95 std.  */
   for (i = 0 ;i < dtp->namelist_name_len ;i++ )
     {
       c = toupper (dtp->namelist_name[i]);
-      write_character (dtp, &c ,1);
+      write_character (dtp, &c, 1 ,1);
     }
 
   if (dtp->u.p.ionml != NULL)
@@ -1184,9 +1332,9 @@ namelist_write (st_parameter_dt *dtp)
     }
 
 #ifdef HAVE_CRLF
-  write_character (dtp, "  /\r\n", 5);
+  write_character (dtp, "  /\r\n", 1, 5);
 #else
-  write_character (dtp, "  /\n", 4);
+  write_character (dtp, "  /\n", 1, 4);
 #endif
 
   /* Restore the original delimiter.  */

libgfortran/libgfortran.h

@@ -272,13 +272,12 @@ typedef GFC_UINTEGER_4 gfc_char4_t;
    simply equal to the kind parameter itself.  */
 #define GFC_SIZE_OF_CHAR_KIND(kind) (kind)
 
-
 /* This will be 0 on little-endian machines and one on big-endian machines.  */
-extern int l8_to_l4_offset;
-internal_proto(l8_to_l4_offset);
+extern int big_endian;
+internal_proto(big_endian);
 
 #define GFOR_POINTER_TO_L1(p, kind) \
-  (l8_to_l4_offset * (kind - 1) + (GFC_LOGICAL_1 *)(p))
+  (big_endian * (kind - 1) + (GFC_LOGICAL_1 *)(p))
 
 #define GFC_INTEGER_1_HUGE \
   (GFC_INTEGER_1)((((GFC_UINTEGER_1)1) << 7) - 1)

libgfortran/runtime/main.c

@@ -45,10 +45,9 @@ stupid_function_name_for_static_linking (void)
   return;
 }
 
-/* This is the offset (in bytes) required to cast from logical(8)* to
-   logical(4)*. and still get the same result.  Will be 0 for little-endian
-   machines and 4 for big-endian machines.  */
-int l8_to_l4_offset = 0;
+/* This will be 0 for little-endian
+   machines and 1 for big-endian machines.  */
+int big_endian = 0;
 
 
 /* Figure out endianness for this machine.  */
@@ -64,9 +63,9 @@ determine_endianness (void)
 
   u.l8 = 1;
   if (u.l4[0])
-    l8_to_l4_offset = 0;
+    big_endian = 0;
   else if (u.l4[1])
-    l8_to_l4_offset = 1;
+    big_endian = 1;
   else
     runtime_error ("Unable to determine machine endianness");
 }