+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>,
#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. */
/* 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)
/* 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 *
lorig = *length;
base = mem_alloc_r (dtp->u.p.current_unit->s, length);
+
if (unlikely (lorig > *length))
{
hit_eof (dtp);
}
+/* 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 *
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
{
}
/* 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;
*********************************************************************/
-
char *
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)
{
}
-/* 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)
}
-/* 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)
}
+/* 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)
{
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)
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. */
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);
#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
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. */
}
/* 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;
}
}
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
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';
}
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;
}
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);
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;
}
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);
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);
+ }
}
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);
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;
}
/* 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;
}
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)
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. */
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);\
}\
}\
projects / gcc.git / commitdiff