From patchwork Sat Jul 10 20:46:57 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Jerry DeLisle X-Patchwork-Id: 58494 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 1164BB6F04 for ; Sun, 11 Jul 2010 06:47:19 +1000 (EST) Received: (qmail 13541 invoked by alias); 10 Jul 2010 20:47:17 -0000 Received: (qmail 13518 invoked by uid 22791); 10 Jul 2010 20:47:13 -0000 X-SWARE-Spam-Status: No, hits=3.0 required=5.0 tests=AWL, BAYES_50, BOTNET, RCVD_IN_DNSWL_NONE, TW_CP, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from vms173017pub.verizon.net (HELO vms173017pub.verizon.net) (206.46.173.17) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sat, 10 Jul 2010 20:47:04 +0000 Received: from [192.168.1.5] ([unknown] [71.115.219.138]) by vms173017.mailsrvcs.net (Sun Java(tm) System Messaging Server 7u2-7.02 32bit (built Apr 16 2009)) with ESMTPA id <0L5D00IWP0EADHU4@vms173017.mailsrvcs.net>; Sat, 10 Jul 2010 15:47:01 -0500 (CDT) Message-id: <4C38DC41.9080000@verizon.net> Date: Sat, 10 Jul 2010 13:46:57 -0700 From: Jerry DeLisle User-Agent: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.9.1.10) Gecko/20100527 Thunderbird/3.0.5 MIME-version: 1.0 To: gfortran Cc: gcc patches Subject: [patch, fortran] PR37077 Implement Internal Unit I/O for character KIND=4, Part 1 Content-type: multipart/mixed; boundary=------------020604050506020000050701 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 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 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 #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);\ }\ }\