Patchwork [fortran] PR37077 Implement Internal Unit I/O for character KIND=4, Part 1

login
register
mail settings
Submitter Jerry DeLisle
Date July 10, 2010, 8:46 p.m.
Message ID <4C38DC41.9080000@verizon.net>
Download mbox | patch
Permalink /patch/58494/
State New
Headers show

Comments

Jerry DeLisle - July 10, 2010, 8:46 p.m.
Hi all,

The attached patch implements the WRITE portion of KIND=4 internal unit I/O. The 
patch is fairly intrusive and yet mostly mechanical. Part 2 will be a separate 
patch to take care of READ.

Two helper functions, memset4 and memcpy4, are used to perform the basic writing 
to blocks, following the current use of memset and memcpy.  All internal unit 
byte counters and offset tracking remain untouched throughout.  The write_block 
function is modified to return an address into the kind=4 string appropriately. 
  I applied some judgement regarding how much code to dup/modify in each section.

On the front end, I use a simple modification to set common.unit = 1, for kind=4 
internal unit.  This does not conflict anywhere since is_internal_unit is used 
first before checking the unit number.  I used common.unit mostly for 
convenience and for zero impact to ABI. One drawback is that error messages 
report a locus in unit=1. This issue exists with kind=1 internal units as well. 
  (I think a follow-up patch will take care of this)

I need to dejagnuize the two test cases attached and probably add some more tests.

Regression tested on i686-linux-gnu (Atom).  Ok for trunk?

(side note: I never imagined using a Netbook for development work)

Regards,

Jerry

2010-07-10  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.
program char4_iunit_1
  implicit none
  character(kind=4,len=42) :: string
  integer :: i,j
  real :: inf, nan, large

  large = huge(large)
  inf = 2 * large
  nan = 0
  nan = nan / nan

  string = 4_"123456789x"
  print '("starting string>",a12)', string

  write(string,'(a11)') 4_"abcdefg"
  call show_string (string)
  write(string,*) 12345
  call show_string (string)
  write(string, '(i6,5x,i8,a5)') 78932, 123456, "abc"
  call show_string (string)
  print '(i6,5x,i8,a1)', 78932, 123456, "<"
  write(string, *) .true., .false. , .true.
  call show_string (string)
  write(string, *) 1.2345e-06, 4.2846e+10_8
  call show_string (string)
  write(string, *) nan, inf
  call show_string (string)
  write(string, '(10x,f3.1,3x,f9.1)') nan, inf
  call show_string (string)
  write(string, *) (1.2, 3.4 )
  call show_string (string)
end program char4_iunit_1

subroutine show_string (astring)
  character(kind=4, len=*) :: astring
  do i=1,len(astring)
    write(*, '(*(i3,1x))', advance="no") ichar(astring(i:i))
  end do
  print *
  print '(a)', "123456789012345678901234567890123456789012345678901234567890"
  print '(a,a)', astring, 4_"<"
end subroutine show_string
program char4_iunit_2
  implicit none
  character(kind=4,len=42),dimension(5,5) :: string
  integer :: i,j
  real :: inf, nan, large

  large = huge(large)
  inf = 2 * large
  nan = 0
  nan = nan / nan

  string = 4_"123456789x"
  print '("starting string>",a12)', string

  write(string,'(a11)') 4_"abcdefg"
  call show_string (string)
  write(string,*) 12345
  call show_string (string)
  write(string(4,3), '(i6,5x,i8,a5)') 78932, 123456, "abc"
  call show_string (string)
  print '(i6,5x,i8,a1)', 78932, 123456, "<"
  write(string, *) .true., .false. , .true.
  call show_string (string)
  write(string, *) 1.2345e-06, 4.2846e+10_8
  call show_string (string)
  write(string, *) nan, inf
  call show_string (string)
  write(string, '(f9.1)') nan, inf, 1.23, 4.56, 8.39
  call show_string (string)
  write(string(2,4), *) (1.2, 3.4 )
  call show_string (string)
end program char4_iunit_2

subroutine show_string (astring)
  character(kind=4, len=*),dimension(5,5) :: astring
  print *, "len(astring(1,1)=", len(astring(1,1))
  print '(2(a42))', astring
  print *, "done"
  do i=1,len(astring(1,1))
    write(*, '(*(i3,1x))', advance="no") ichar(astring(:,:)(i:i))
  end do
  print *
  print '(a)', "123456789012345678901234567890123456789012345678901234567890"
  print '(a,a)', astring, 4_"<"
end subroutine show_string

Patch

Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c	(revision 162014)
+++ gcc/fortran/trans-io.c	(working copy)
@@ -1673,7 +1673,8 @@  build_dt (tree function, gfc_code * code)
 	{
 	  mask |= set_internal_unit (&block, &post_iu_block,
 				     var, dt->io_unit);
-	  set_parameter_const (&block, var, IOPARM_common_unit, 0);
+	  set_parameter_const (&block, var, IOPARM_common_unit,
+			       dt->io_unit->ts.kind == 1 ? 0 : 1);
 	}
     }
   else
Index: libgfortran/io/read.c
===================================================================
--- libgfortran/io/read.c	(revision 162014)
+++ libgfortran/io/read.c	(working copy)
@@ -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)
Index: libgfortran/io/io.h
===================================================================
--- libgfortran/io/io.h	(revision 162014)
+++ libgfortran/io/io.h	(working copy)
@@ -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.  */
Index: libgfortran/io/unit.c
===================================================================
--- libgfortran/io/unit.c	(revision 162014)
+++ libgfortran/io/unit.c	(working copy)
@@ -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;
Index: libgfortran/io/unix.c
===================================================================
--- libgfortran/io/unix.c	(revision 162014)
+++ libgfortran/io/unix.c	(working copy)
@@ -594,7 +594,6 @@  buf_init (unix_stream * s)
 
 *********************************************************************/
 
-
 char *
 mem_alloc_r (stream * strm, int * len)
 {
@@ -616,6 +615,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;
@@ -636,8 +655,28 @@  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)
 {
@@ -655,11 +694,28 @@  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)
 {
   void *p;
@@ -676,6 +732,26 @@  mem_write (stream * s, const void * buf, ssize_t n
 }
 
 
+/* 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)
 {
@@ -759,7 +835,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)
@@ -786,7 +863,35 @@  open_internal (char *base, int length, gfc_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. */
 
Index: libgfortran/io/transfer.c
===================================================================
--- libgfortran/io/transfer.c	(revision 162014)
+++ libgfortran/io/transfer.c	(working copy)
@@ -639,16 +639,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 internel 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
     {
Index: libgfortran/io/unix.h
===================================================================
--- libgfortran/io/unix.h	(revision 162014)
+++ libgfortran/io/unix.h	(working copy)
@@ -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);
 
Index: libgfortran/io/write.c
===================================================================
--- libgfortran/io/write.c	(revision 162014)
+++ libgfortran/io/write.c	(working copy)
@@ -36,10 +36,34 @@  see the files COPYING3 and COPYING.RUNTIME respect
 #include <errno.h>
 #define star_fill(p, n) memset(p, '*', n)
 
+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"
 
-typedef unsigned char uchar;
-
 /* Write out default char4.  */
 
 static void
@@ -58,7 +82,10 @@  write_default_char4 (st_parameter_dt *dtp, gfc_cha
       p = write_block (dtp, k);
       if (p == NULL)
 	return;
-      memset (p, ' ', k);
+      if (unlikely (is_char4_unit (dtp)))
+	memset4 (p, 0, ' ', k);
+      else
+	memset (p, ' ', k);
     }
 
   /* Get ready to handle delimiters if needed.  */
@@ -76,10 +103,32 @@  write_default_char4 (st_parameter_dt *dtp, gfc_cha
     }
 
   /* 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];
-    
+      if (unlikely (is_char4_unit (dtp)))
+	{
+	  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;
+	  return;
+	}
+
       /* Handle delimiters if any.  */
       if (c == d && d != ' ')
 	{
@@ -258,6 +307,18 @@  write_a (st_parameter_dt *dtp, const fnode *f, con
       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 +539,17 @@  write_l (st_parameter_dt *dtp, const fnode *f, cha
   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 +573,10 @@  write_boz (st_parameter_dt *dtp, const fnode *f, c
       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 +600,35 @@  write_boz (st_parameter_dt *dtp, const fnode *f, c
 
   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 +683,10 @@  write_decimal (st_parameter_dt *dtp, const fnode *
       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 +724,37 @@  write_decimal (st_parameter_dt *dtp, const fnode *
 
   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 +1189,12 @@  write_x (st_parameter_dt *dtp, int len, int nspace
   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 +1271,22 @@  write_integer (st_parameter_dt *dtp, const char *s
   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);
Index: libgfortran/io/write_float.def
===================================================================
--- libgfortran/io/write_float.def	(revision 162014)
+++ libgfortran/io/write_float.def	(working copy)
@@ -127,6 +127,14 @@  output_float (st_parameter_dt *dtp, const fnode *f
 	  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
   /* 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
   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
 
   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 (unlikely (is_char4_unit (dtp)))
+        memset4 (p, 0, ' ', nb);
+      else
+	memset(p, ' ', nb);
+
+      if (!isnan_flag)
+	{
+	  if (sign_bit)
 	    {
-	      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 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, co
       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);\
     }\
 }\