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

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);\
     }\
 }\