From c7421e06ca1de11fa125ed9d8619680d17bfb6f8 Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Tue, 13 Jul 2010 02:12:08 +0000 Subject: [PATCH] re PR fortran/37077 (Implement Internal Unit I/O for character KIND=4) 2010-07-12 Jerry DeLisle 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 --- libgfortran/ChangeLog | 23 ++++ libgfortran/io/io.h | 2 + libgfortran/io/read.c | 2 +- libgfortran/io/transfer.c | 44 +++--- libgfortran/io/unit.c | 8 +- libgfortran/io/unix.c | 117 +++++++++++++++- libgfortran/io/unix.h | 9 ++ libgfortran/io/write.c | 198 ++++++++++++++++++++++++--- libgfortran/io/write_float.def | 241 ++++++++++++++++++++++++++------- 9 files changed, 545 insertions(+), 99 deletions(-) diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 0a69beba590..f1ae1ea3a9d 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,26 @@ +2010-07-12 Jerry DeLisle + + 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 * config/fpu-387.h [__sun__ && __svr4__] Include , diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index acbec77e62a..fbc2fa354ab 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 12aa0988f6d..92983d51278 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 f44c02538a9..a6e699d4a33 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 bbe112010ba..4e7dc5f3d12 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 afa5f453bd2..65decce1be3 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) { @@ -619,6 +618,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) { @@ -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 c7f92a34c6f..c69e3574d86 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 ee2ce0c3915..07c9f54dfc4 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 #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 45c2a17a50d..02e1b8b9b13 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);\ }\ }\ -- 2.30.2