re PR fortran/37077 (Implement Internal Unit I/O for character KIND=4)

2010-07-12  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libfortran/37077
	* io/read.c: Fix comment.
	* io/io.h (is_char4_unit): New macro.
	* io/unit.c (get_internal_unit): Call new function open_internal4.
	* io/unix.c (mem_alloc_r4): New function. (mem_alloc_w4): New function.
	(mem_read4): New function, temporary stub. (mem_write4): New function.
	(open_internal4): New function to set stream pointers to use the new
	mem functions.
	* io/transfer.c (write_block): Use new mem_alloc_w4 to access internal
	units of kind=4.
	* io/unix.h: Add prototypes for open_internal4, mem_alloc_w4, and
	mem_alloc_r4.
	* io/write.c (memset4): New helper function. (memcpy4): New helper
	function. (write_default_char4): Use new helper functions.
	(write_a): Likewise. (write_l): Likewise. (write_boz): Likewise.
	(write_decimal): Likewise. (write_x): Likewise.
	(write_integer): Likewise.
	* io/write_float.def (output_float): Add code blocks to handle internal
	unit kind=4 output utilizing gfc_char4_t pointers. (write_infnan): Use
	new helper functions. (OUTPUT_FLOAT_FMT_G): Update this macro likewise.

From-SVN: r162123

9 files changed, 545 insertions, 99 deletions

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 0a69beb..f1ae1ea 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,26 @@
+2010-07-12  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR libfortran/37077
+	* io/read.c: Fix comment.
+	* io/io.h (is_char4_unit): New macro.
+	* io/unit.c (get_internal_unit): Call new function open_internal4.
+	* io/unix.c (mem_alloc_r4): New function. (mem_alloc_w4): New function.
+	(mem_read4): New function, temporary stub. (mem_write4): New function.
+	(open_internal4): New function to set stream pointers to use the new
+	mem functions.
+	* io/transfer.c (write_block): Use new mem_alloc_w4 to access internal
+	units of kind=4.
+	* io/unix.h: Add prototypes for open_internal4, mem_alloc_w4, and
+	mem_alloc_r4.
+	* io/write.c (memset4): New helper function. (memcpy4): New helper
+	function. (write_default_char4): Use new helper functions.
+	(write_a): Likewise. (write_l): Likewise. (write_boz): Likewise.
+	(write_decimal): Likewise. (write_x): Likewise.
+	(write_integer): Likewise.
+	* io/write_float.def (output_float): Add code blocks to handle internal
+	unit kind=4 output utilizing gfc_char4_t pointers. (write_infnan): Use
+	new helper functions. (OUTPUT_FLOAT_FMT_G): Update this macro likewise.
+
 2010-07-12  Rainer Orth  <ro@CeBiTec.Uni-Bielefeld.DE>
 
 	* config/fpu-387.h [__sun__ && __svr4__] Include <signal.h>,
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index acbec77..fbc2fa3 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -59,6 +59,8 @@ struct gfc_unit;
 
 #define is_stream_io(dtp) ((dtp)->u.p.current_unit->flags.access == ACCESS_STREAM)
 
+#define is_char4_unit(dtp) ((dtp)->u.p.unit_is_internal && (dtp)->common.unit)
+
 /* The array_loop_spec contains the variables for the loops over index ranges
    that are encountered.  Since the variables can be negative, ssize_t
    is used.  */
diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c
index 12aa098..92983d5 100644
--- a/libgfortran/io/read.c
+++ b/libgfortran/io/read.c
@@ -40,7 +40,7 @@ typedef unsigned char uchar;
 
 
 /* set_integer()-- All of the integer assignments come here to
- * actually place the value into memory.  */
+   actually place the value into memory.  */
 
 void
 set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index f44c025..a6e699d 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -177,18 +177,6 @@ current_mode (st_parameter_dt *dtp)
 
 /* Mid level data transfer statements.  */
 
-/* When reading sequential formatted records we have a problem.  We
-   don't know how long the line is until we read the trailing newline,
-   and we don't want to read too much.  If we read too much, we might
-   have to do a physical seek backwards depending on how much data is
-   present, and devices like terminals aren't seekable and would cause
-   an I/O error.
-
-   Given this, the solution is to read a byte at a time, stopping if
-   we hit the newline.  For small allocations, we use a static buffer.
-   For larger allocations, we are forced to allocate memory on the
-   heap.  Hopefully this won't happen very often.  */
-   
 /* Read sequential file - internal unit  */
 
 static char *
@@ -215,6 +203,7 @@ read_sf_internal (st_parameter_dt *dtp, int * length)
 
   lorig = *length;
   base = mem_alloc_r (dtp->u.p.current_unit->s, length);
+
   if (unlikely (lorig > *length))
     {
       hit_eof (dtp);
@@ -230,6 +219,18 @@ read_sf_internal (st_parameter_dt *dtp, int * length)
 
 }
 
+/* When reading sequential formatted records we have a problem.  We
+   don't know how long the line is until we read the trailing newline,
+   and we don't want to read too much.  If we read too much, we might
+   have to do a physical seek backwards depending on how much data is
+   present, and devices like terminals aren't seekable and would cause
+   an I/O error.
+
+   Given this, the solution is to read a byte at a time, stopping if
+   we hit the newline.  For small allocations, we use a static buffer.
+   For larger allocations, we are forced to allocate memory on the
+   heap.  Hopefully this won't happen very often.  */
+
 /* Read sequential file - external unit */
 
 static char *
@@ -639,16 +640,19 @@ write_block (st_parameter_dt *dtp, int length)
 
   if (is_internal_unit (dtp))
     {
-    dest = mem_alloc_w (dtp->u.p.current_unit->s, &length);
+      if (dtp->common.unit) /* char4 internal unit.  */
+	dest = mem_alloc_w4 (dtp->u.p.current_unit->s, &length);
+      else
+	dest = mem_alloc_w (dtp->u.p.current_unit->s, &length);
 
-    if (dest == NULL)
-      {
-        generate_error (&dtp->common, LIBERROR_END, NULL);
-        return NULL;
-      }
+      if (dest == NULL)
+	{
+          generate_error (&dtp->common, LIBERROR_END, NULL);
+          return NULL;
+	}
 
-    if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE))
-      generate_error (&dtp->common, LIBERROR_END, NULL);
+      if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE))
+	generate_error (&dtp->common, LIBERROR_END, NULL);
     }
   else
     {
diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c
index bbe1120..4e7dc5f 100644
--- a/libgfortran/io/unit.c
+++ b/libgfortran/io/unit.c
@@ -423,9 +423,13 @@ get_internal_unit (st_parameter_dt *dtp)
     }
 
   /* Set initial values for unit parameters.  */
+  if (dtp->common.unit)
+    iunit->s = open_internal4 (dtp->internal_unit - start_record,
+			       dtp->internal_unit_len, -start_record);
+  else
+    iunit->s = open_internal (dtp->internal_unit - start_record,
+			      dtp->internal_unit_len, -start_record);
 
-  iunit->s = open_internal (dtp->internal_unit - start_record,
-			    dtp->internal_unit_len, -start_record);
   iunit->bytes_left = iunit->recl;
   iunit->last_record=0;
   iunit->maxrec=0;
diff --git a/libgfortran/io/unix.c b/libgfortran/io/unix.c
index afa5f45..65decce 100644
--- a/libgfortran/io/unix.c
+++ b/libgfortran/io/unix.c
@@ -598,7 +598,6 @@ buf_init (unix_stream * s)
 
 *********************************************************************/
 
-
 char *
 mem_alloc_r (stream * strm, int * len)
 {
@@ -620,6 +619,26 @@ mem_alloc_r (stream * strm, int * len)
 
 
 char *
+mem_alloc_r4 (stream * strm, int * len)
+{
+  unix_stream * s = (unix_stream *) strm;
+  gfc_offset n;
+  gfc_offset where = s->logical_offset;
+
+  if (where < s->buffer_offset || where > s->buffer_offset + s->active)
+    return NULL;
+
+  n = s->buffer_offset + s->active - where;
+  if (*len > n)
+    *len = n;
+
+  s->logical_offset = where + *len;
+
+  return s->buffer + (where - s->buffer_offset) * 4;
+}
+
+
+char *
 mem_alloc_w (stream * strm, int * len)
 {
   unix_stream * s = (unix_stream *) strm;
@@ -640,7 +659,27 @@ mem_alloc_w (stream * strm, int * len)
 }
 
 
-/* Stream read function for internal units.  */
+char *
+mem_alloc_w4 (stream * strm, int * len)
+{
+  unix_stream * s = (unix_stream *) strm;
+  gfc_offset m;
+  gfc_offset where = s->logical_offset;
+
+  m = where + *len;
+
+  if (where < s->buffer_offset)
+    return NULL;
+
+  if (m > s->file_length)
+    return NULL;
+
+  s->logical_offset = m;
+  return s->buffer + (where - s->buffer_offset) * 4;
+}
+
+
+/* Stream read function for character(kine=1) internal units.  */
 
 static ssize_t
 mem_read (stream * s, void * buf, ssize_t nbytes)
@@ -659,9 +698,26 @@ mem_read (stream * s, void * buf, ssize_t nbytes)
 }
 
 
-/* Stream write function for internal units. This is not actually used
-   at the moment, as all internal IO is formatted and the formatted IO
-   routines use mem_alloc_w_at.  */
+/* Stream read function for chracter(kind=4) internal units.  */
+
+static ssize_t
+mem_read4 (stream * s, void * buf, ssize_t nbytes)
+{
+  void *p;
+  int nb = nbytes;
+
+  p = mem_alloc_r (s, &nb);
+  if (p)
+    {
+      memcpy (buf, p, nb);
+      return (ssize_t) nb;
+    }
+  else
+    return 0;
+}
+
+
+/* Stream write function for character(kind=1) internal units.  */
 
 static ssize_t
 mem_write (stream * s, const void * buf, ssize_t nbytes)
@@ -680,6 +736,26 @@ mem_write (stream * s, const void * buf, ssize_t nbytes)
 }
 
 
+/* Stream write function for character(kind=4) internal units.  */
+
+static ssize_t
+mem_write4 (stream * s, const void * buf, ssize_t nwords)
+{
+  gfc_char4_t *p;
+  int nw = nwords;
+
+  p = (gfc_char4_t *) mem_alloc_w4 (s, &nw);
+  if (p)
+    {
+      while (nw--)
+	*p++ = (gfc_char4_t) *((char *) buf);
+      return nwords;
+    }
+  else
+    return 0;
+}
+
+
 static gfc_offset
 mem_seek (stream * strm, gfc_offset offset, int whence)
 {
@@ -763,7 +839,8 @@ empty_internal_buffer(stream *strm)
   memset(s->buffer, ' ', s->file_length);
 }
 
-/* open_internal()-- Returns a stream structure from an internal file */
+/* open_internal()-- Returns a stream structure from a character(kind=1)
+   internal file */
 
 stream *
 open_internal (char *base, int length, gfc_offset offset)
@@ -790,6 +867,34 @@ open_internal (char *base, int length, gfc_offset offset)
   return (stream *) s;
 }
 
+/* open_internal4()-- Returns a stream structure from a character(kind=4)
+   internal file */
+
+stream *
+open_internal4 (char *base, int length, gfc_offset offset)
+{
+  unix_stream *s;
+
+  s = get_mem (sizeof (unix_stream));
+  memset (s, '\0', sizeof (unix_stream));
+
+  s->buffer = base;
+  s->buffer_offset = offset;
+
+  s->logical_offset = 0;
+  s->active = s->file_length = length;
+
+  s->st.close = (void *) mem_close;
+  s->st.seek = (void *) mem_seek;
+  s->st.tell = (void *) mem_tell;
+  s->st.trunc = (void *) mem_truncate;
+  s->st.read = (void *) mem_read4;
+  s->st.write = (void *) mem_write4;
+  s->st.flush = (void *) mem_flush;
+
+  return (stream *) s;
+}
+
 
 /* fd_to_stream()-- Given an open file descriptor, build a stream
  * around it. */
diff --git a/libgfortran/io/unix.h b/libgfortran/io/unix.h
index c7f92a3..c69e357 100644
--- a/libgfortran/io/unix.h
+++ b/libgfortran/io/unix.h
@@ -94,12 +94,21 @@ internal_proto(open_external);
 extern stream *open_internal (char *, int, gfc_offset);
 internal_proto(open_internal);
 
+extern stream *open_internal4 (char *, int, gfc_offset);
+internal_proto(open_internal4);
+
 extern char * mem_alloc_w (stream *, int *);
 internal_proto(mem_alloc_w);
 
 extern char * mem_alloc_r (stream *, int *);
 internal_proto(mem_alloc_r);
 
+extern char * mem_alloc_w4 (stream *, int *);
+internal_proto(mem_alloc_w4);
+
+extern char * mem_alloc_r4 (stream *, int *);
+internal_proto(mem_alloc_r4);
+
 extern stream *input_stream (void);
 internal_proto(input_stream);
 
diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
index ee2ce0c..07c9f54 100644
--- a/libgfortran/io/write.c
+++ b/libgfortran/io/write.c
@@ -36,10 +36,34 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #include <errno.h>
 #define star_fill(p, n) memset(p, '*', n)
 
-#include "write_float.def"
-
 typedef unsigned char uchar;
 
+/* Helper functions for character(kind=4) internal units.  These are needed
+   by write_float.def.  */
+
+static inline void
+memset4 (void *p,  int offs, uchar c, int k)
+{
+  int j;
+  gfc_char4_t *q = (gfc_char4_t *) (p + offs * 4);
+  for (j = 0; j < k; j++)
+    *q++ = c;
+}
+
+static inline void
+memcpy4 (void *dest,  int offs, const char *source, int k)
+{
+  int j;
+  
+  const char *p = source;
+  gfc_char4_t *q = (gfc_char4_t *) (dest + offs * 4);
+  for (j = 0; j < k; j++)
+    *q++ = (gfc_char4_t) *p++;
+}
+
+/* This include contains the heart and soul of formatted floating point.  */
+#include "write_float.def"
+
 /* Write out default char4.  */
 
 static void
@@ -58,7 +82,10 @@ write_default_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
       p = write_block (dtp, k);
       if (p == NULL)
 	return;
-      memset (p, ' ', k);
+      if (is_char4_unit (dtp))
+	memset4 (p, 0, ' ', k);
+      else
+	memset (p, ' ', k);
     }
 
   /* Get ready to handle delimiters if needed.  */
@@ -76,25 +103,48 @@ write_default_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
     }
 
   /* Now process the remaining characters, one at a time.  */
-  for (j = k; j < src_len; j++)
+  for (j = 0; j < src_len; j++)
     {
       c = source[j];
-    
-      /* Handle delimiters if any.  */
-      if (c == d && d != ' ')
+      if (is_char4_unit (dtp))
 	{
-	  p = write_block (dtp, 2);
-	  if (p == NULL)
-	    return;
-	  *p++ = (uchar) c;
+	  gfc_char4_t *q;
+	  /* Handle delimiters if any.  */
+	  if (c == d && d != ' ')
+	    {
+	      p = write_block (dtp, 2);
+	      if (p == NULL)
+		return;
+	      q = (gfc_char4_t *) p;
+	      *q++ = c;
+	    }
+	  else
+	    {
+	      p = write_block (dtp, 1);
+	      if (p == NULL)
+		return;
+	      q = (gfc_char4_t *) p;
+	    }
+	  *q = c;
 	}
       else
 	{
-	  p = write_block (dtp, 1);
-	  if (p == NULL)
-	    return;
+	  /* Handle delimiters if any.  */
+	  if (c == d && d != ' ')
+	    {
+	      p = write_block (dtp, 2);
+	      if (p == NULL)
+		return;
+	      *p++ = (uchar) c;
+	    }
+          else
+	    {
+	      p = write_block (dtp, 1);
+	      if (p == NULL)
+		return;
+	    }
+	    *p = c > 255 ? '?' : (uchar) c;
 	}
-      *p = c > 255 ? '?' : (uchar) c;
     }
 }
 
@@ -258,6 +308,18 @@ write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
       if (p == NULL)
 	return;
 
+      if (unlikely (is_char4_unit (dtp)))
+	{
+	  if (wlen < len)
+	    memcpy4 (p, 0, source, wlen);
+	  else
+	    {
+	      memset4 (p, 0, ' ', wlen - len);
+	      memcpy4 (p, wlen - len, source, len);
+	    }
+	  return;
+	}
+
       if (wlen < len)
 	memcpy (p, source, wlen);
       else
@@ -478,8 +540,17 @@ write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
   if (p == NULL)
     return;
 
-  memset (p, ' ', wlen - 1);
   n = extract_int (source, len);
+
+  if (unlikely (is_char4_unit (dtp)))
+    {
+      gfc_char4_t *p4 = (gfc_char4_t *) p;
+      memset4 (p, 0, ' ', wlen -1);
+      p4[wlen - 1] = (n) ? 'T' : 'F';
+      return;
+    }
+
+  memset (p, ' ', wlen -1);
   p[wlen - 1] = (n) ? 'T' : 'F';
 }
 
@@ -503,8 +574,10 @@ write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n)
       p = write_block (dtp, w);
       if (p == NULL)
         return;
-
-      memset (p, ' ', w);
+      if (unlikely (is_char4_unit (dtp)))
+	memset4 (p, 0, ' ', w);
+      else
+	memset (p, ' ', w);
       goto done;
     }
 
@@ -528,6 +601,35 @@ write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n)
 
   nblank = w - (nzero + digits);
 
+  if (unlikely (is_char4_unit (dtp)))
+    {
+      gfc_char4_t *p4 = (gfc_char4_t *) p;
+      if (nblank < 0)
+	{
+	  memset4 (p4, 0, '*', w);
+	  return;
+	}
+
+      if (!dtp->u.p.no_leading_blank)
+	{
+	  memset4 (p4, 0, ' ', nblank);
+	  q += nblank;
+	  memset4 (p4, 0, '0', nzero);
+	  q += nzero;
+	  memcpy4 (p4, 0, q, digits);
+	}
+      else
+	{
+	  memset4 (p4, 0, '0', nzero);
+	  q += nzero;
+	  memcpy4 (p4, 0, q, digits);
+	  q += digits;
+	  memset4 (p4, 0, ' ', nblank);
+	  dtp->u.p.no_leading_blank = 0;
+	}
+      return;
+    }
+
   if (nblank < 0)
     {
       star_fill (p, w);
@@ -582,8 +684,10 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
       p = write_block (dtp, w);
       if (p == NULL)
         return;
-
-      memset (p, ' ', w);
+      if (unlikely (is_char4_unit (dtp)))
+	memset4 (p, 0, ' ', w);
+      else
+	memset (p, ' ', w);
       goto done;
     }
 
@@ -621,6 +725,37 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
 
   nblank = w - (nsign + nzero + digits);
 
+  if (unlikely (is_char4_unit (dtp)))
+    {
+      gfc_char4_t * p4 = (gfc_char4_t *) p;
+      if (nblank < 0)
+	{
+	  memset4 (p4, 0, '*', w);
+	  goto done;
+	}
+
+      memset4 (p4, 0, ' ', nblank);
+      p4 += nblank;
+
+      switch (sign)
+	{
+	case S_PLUS:
+	  *p4++ = '+';
+	  break;
+	case S_MINUS:
+	  *p4++ = '-';
+	  break;
+	case S_NONE:
+	  break;
+	}
+
+      memset4 (p4, 0, '0', nzero);
+      p4 += nzero;
+
+      memcpy4 (p4, 0, q, digits);
+      return;
+    }
+
   if (nblank < 0)
     {
       star_fill (p, w);
@@ -1055,7 +1190,12 @@ write_x (st_parameter_dt *dtp, int len, int nspaces)
   if (p == NULL)
     return;
   if (nspaces > 0 && len - nspaces >= 0)
-    memset (&p[len - nspaces], ' ', nspaces);
+    {
+      if (unlikely (is_char4_unit (dtp)))
+	memset4 (p, len - nspaces, ' ', nspaces);
+      else
+	memset (&p[len - nspaces], ' ', nspaces);
+    }
 }
 
 
@@ -1132,6 +1272,22 @@ write_integer (st_parameter_dt *dtp, const char *source, int length)
   p = write_block (dtp, width);
   if (p == NULL)
     return;
+
+  if (unlikely (is_char4_unit (dtp)))
+    {
+      if (dtp->u.p.no_leading_blank)
+	{
+	  memcpy4 (p, 0, q, digits);
+	  memset4 (p, digits, ' ', width - digits);
+	}
+      else
+	{
+	  memset4 (p, 0, ' ', width - digits);
+	  memcpy4 (p, width - digits, q, digits);
+	}
+      return;
+    }
+
   if (dtp->u.p.no_leading_blank)
     {
       memcpy (p, q, digits);
diff --git a/libgfortran/io/write_float.def b/libgfortran/io/write_float.def
index 45c2a17..02e1b8b 100644
--- a/libgfortran/io/write_float.def
+++ b/libgfortran/io/write_float.def
@@ -127,6 +127,14 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
 	  out = write_block (dtp, w);
 	  if (out == NULL)
 	    return;
+
+	  if (unlikely (is_char4_unit (dtp)))
+	    {
+	      gfc_char4_t *out4 = (gfc_char4_t *) out;
+	      *out4 = '0';
+	      return;
+	    }
+
 	  *out = '0';
 	  return;
 	}
@@ -430,6 +438,11 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
   /* Check the value fits in the specified field width.  */
   if (nblanks < 0 || edigits == -1)
     {
+      if (unlikely (is_char4_unit (dtp)))
+	{
+	  memset4 (out, 0, '*', w);
+	  return;
+	}
       star_fill (out, w);
       return;
     }
@@ -443,6 +456,105 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
   else
     leadzero = 0;
 
+  /* For internal character(kind=4) units, we duplicate the code used for
+     regular output slightly modified.  This needs to be maintained
+     consistent with the regular code that follows this block.  */
+  if (unlikely (is_char4_unit (dtp)))
+    {
+      gfc_char4_t *out4 = (gfc_char4_t *) out;
+      /* Pad to full field width.  */
+
+      if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
+	{
+	  memset4 (out, 0, ' ', nblanks);
+	  out4 += nblanks;
+	}
+
+      /* Output the initial sign (if any).  */
+      if (sign == S_PLUS)
+	*(out4++) = '+';
+      else if (sign == S_MINUS)
+	*(out4++) = '-';
+
+      /* Output an optional leading zero.  */
+      if (leadzero)
+	*(out4++) = '0';
+
+      /* Output the part before the decimal point, padding with zeros.  */
+      if (nbefore > 0)
+	{
+	  if (nbefore > ndigits)
+	    {
+	      i = ndigits;
+	      memcpy4 (out4, 0, digits, i);
+	      ndigits = 0;
+	      while (i < nbefore)
+		out4[i++] = '0';
+	    }
+	  else
+	    {
+	      i = nbefore;
+	      memcpy4 (out4, 0, digits, i);
+	      ndigits -= i;
+	    }
+
+	  digits += i;
+	  out4 += nbefore;
+	}
+
+      /* Output the decimal point.  */
+      *(out4++) = dtp->u.p.current_unit->decimal_status
+		    == DECIMAL_POINT ? '.' : ',';
+
+      /* Output leading zeros after the decimal point.  */
+      if (nzero > 0)
+	{
+	  for (i = 0; i < nzero; i++)
+	    *(out4++) = '0';
+	}
+
+      /* Output digits after the decimal point, padding with zeros.  */
+      if (nafter > 0)
+	{
+	  if (nafter > ndigits)
+	    i = ndigits;
+	  else
+	    i = nafter;
+
+	  memcpy4 (out4, 0, digits, i);
+	  while (i < nafter)
+	    out4[i++] = '0';
+
+	  digits += i;
+	  ndigits -= i;
+	  out4 += nafter;
+	}
+
+      /* Output the exponent.  */
+      if (expchar)
+	{
+	  if (expchar != ' ')
+	    {
+	      *(out4++) = expchar;
+	      edigits--;
+	    }
+#if HAVE_SNPRINTF
+	  snprintf (buffer, size, "%+0*d", edigits, e);
+#else
+	  sprintf (buffer, "%+0*d", edigits, e);
+#endif
+	  memcpy4 (out4, 0, buffer, edigits);
+	}
+
+      if (dtp->u.p.no_leading_blank)
+	{
+	  out4 += edigits;
+	  memset4 (out4 , 0, ' ' , nblanks);
+	  dtp->u.p.no_leading_blank = 0;
+	}
+      return;
+    } /* End of character(kind=4) internal unit code.  */
+
   /* Pad to full field width.  */
 
   if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
@@ -549,66 +661,94 @@ write_infnan (st_parameter_dt *dtp, const fnode *f, int isnan_flag, int sign_bit
 
   if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
     {
-	  nb =  f->u.real.w;
-	  
-	  /* If the field width is zero, the processor must select a width 
-	     not zero.  4 is chosen to allow output of '-Inf' or '+Inf' */
-	     
-	  if (nb == 0) nb = 4;
-	  p = write_block (dtp, nb);
-          if (p == NULL)
-            return;
-	  if (nb < 3)
-	    {
-	      memset (p, '*',nb);
-	      return;
-	    }
+      nb =  f->u.real.w;
+  
+      /* If the field width is zero, the processor must select a width 
+	 not zero.  4 is chosen to allow output of '-Inf' or '+Inf' */
+     
+      if (nb == 0) nb = 4;
+      p = write_block (dtp, nb);
+      if (p == NULL)
+	return;
+      if (nb < 3)
+	{
+	  if (unlikely (is_char4_unit (dtp)))
+	    memset4 (p, 0, '*', nb);
+	  else
+	    memset (p, '*', nb);
+	  return;
+	}
 
-	  memset(p, ' ', nb);
-	  if (!isnan_flag)
-	    {
-	      if (sign_bit)
-	        {
-	        
-	          /* If the sign is negative and the width is 3, there is
-	             insufficient room to output '-Inf', so output asterisks */
-	             
-	          if (nb == 3)
-	            {
-	              memset (p, '*',nb);
-	              return;
-	            }
-	            
-	          /* The negative sign is mandatory */
-	            
-	          fin = '-';
-		}    
-	      else
-	      
-	          /* The positive sign is optional, but we output it for
-	             consistency */
-		  fin = '+';
+      if (unlikely (is_char4_unit (dtp)))
+        memset4 (p, 0, ' ', nb);
+      else
+	memset(p, ' ', nb);
 
+      if (!isnan_flag)
+	{
+	  if (sign_bit)
+	    {
+	      /* If the sign is negative and the width is 3, there is
+		 insufficient room to output '-Inf', so output asterisks */
+	      if (nb == 3)
+		{
+		  if (unlikely (is_char4_unit (dtp)))
+		    memset4 (p, 0, '*', nb);
+		  else
+		    memset (p, '*', nb);
+		  return;
+		}
+	      /* The negative sign is mandatory */
+	      fin = '-';
+	    }    
+	  else
+	    /* The positive sign is optional, but we output it for
+	       consistency */
+	    fin = '+';
+	    
+	  if (unlikely (is_char4_unit (dtp)))
+	    {
+	      gfc_char4_t *p4 = (gfc_char4_t *) p;
 	      if (nb > 8)
-	      
-	        /* We have room, so output 'Infinity' */
-		memcpy(p + nb - 8, "Infinity", 8);
+		/* We have room, so output 'Infinity' */
+		memcpy4 (p4, nb - 8, "Infinity", 8);
 	      else
-	      
-	        /* For the case of width equals 8, there is not enough room
-	           for the sign and 'Infinity' so we go with 'Inf' */
-		memcpy(p + nb - 3, "Inf", 3);
+		/* For the case of width equals 8, there is not enough room
+		   for the sign and 'Infinity' so we go with 'Inf' */
+		memcpy4 (p4, nb - 3, "Inf", 3);
 
 	      if (nb < 9 && nb > 3)
-		p[nb - 4] = fin;  /* Put the sign in front of Inf */
+	        /* Put the sign in front of Inf */
+		p4[nb - 4] = (gfc_char4_t) fin;
 	      else if (nb > 8)
-		p[nb - 9] = fin;  /* Put the sign in front of Infinity */
+	        /* Put the sign in front of Infinity */
+		p4[nb - 9] = (gfc_char4_t) fin;
+	      return;
 	    }
+
+	  if (nb > 8)
+	    /* We have room, so output 'Infinity' */
+	    memcpy(p + nb - 8, "Infinity", 8);
+	  else
+	    /* For the case of width equals 8, there is not enough room
+	       for the sign and 'Infinity' so we go with 'Inf' */
+	    memcpy(p + nb - 3, "Inf", 3);
+
+	  if (nb < 9 && nb > 3)
+	    p[nb - 4] = fin;  /* Put the sign in front of Inf */
+	  else if (nb > 8)
+	    p[nb - 9] = fin;  /* Put the sign in front of Infinity */
+	}
+      else
+        {
+	  if (unlikely (is_char4_unit (dtp)))
+	    memcpy4 (p, nb - 3, "NaN", 3);
 	  else
 	    memcpy(p + nb - 3, "NaN", 3);
-	  return;
 	}
+      return;
     }
+}
 
 
 /* Returns the value of 10**d.  */
@@ -750,7 +890,10 @@ output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \
       p = write_block (dtp, nb);\
       if (p == NULL)\
 	return;\
-      memset (p, ' ', nb);\
+      if (unlikely (is_char4_unit (dtp)))\
+	memset4 (p, 0, ' ', nb);\
+      else\
+	memset (p, ' ', nb);\
     }\
 }\