re PR fortran/37077 (Implement Internal Unit I/O for character KIND=4)
2010-07-12 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. From-SVN: r162123
This commit is contained in:
Jerry DeLisle
parent
c8dce2cfdd
commit
c7421e06ca
|
|
@ -1,3 +1,26 @@
|
|||
2010-07-12 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.
|
||||
|
||||
2010-07-12 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
|
||||
|
||||
* config/fpu-387.h [__sun__ && __svr4__] Include <signal.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. */
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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. */
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
||||
|
|
|
|||
|
|
@ -36,10 +36,34 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <errno.h>
|
||||
#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);
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
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;
|
||||
}
|
||||
|
||||
if (unlikely (is_char4_unit (dtp)))
|
||||
memset4 (p, 0, ' ', nb);
|
||||
else
|
||||
memset(p, ' ', nb);
|
||||
|
||||
if (!isnan_flag)
|
||||
{
|
||||
if (sign_bit)
|
||||
{
|
||||
memset (p, '*',nb);
|
||||
/* 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' */
|
||||
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' */
|
||||
memcpy4 (p4, nb - 3, "Inf", 3);
|
||||
|
||||
if (nb < 9 && nb > 3)
|
||||
/* Put the sign in front of Inf */
|
||||
p4[nb - 4] = (gfc_char4_t) fin;
|
||||
else if (nb > 8)
|
||||
/* Put the sign in front of Infinity */
|
||||
p4[nb - 9] = (gfc_char4_t) fin;
|
||||
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 (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 > 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 */
|
||||
}
|
||||
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);\
|
||||
}\
|
||||
}\
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue