This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

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


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.

Attachment: test1.f03
Description: Text document

Attachment: test2.f03
Description: Text document

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

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]