-/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
Namelist output contributed by Paul Thomas
F2003 I/O support contributed by Jerry DeLisle
-This file is part of the GNU Fortran 95 runtime library (libgfortran).
+This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
<http://www.gnu.org/licenses/>. */
#include "io.h"
+#include "format.h"
+#include "unix.h"
#include <assert.h>
#include <string.h>
#include <ctype.h>
#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 (gfc_char4_t *p, gfc_char4_t c, int k)
+{
+ int j;
+ for (j = 0; j < k; j++)
+ *p++ = c;
+}
+
+static inline void
+memcpy4 (gfc_char4_t *dest, const char *source, int k)
+{
+ int j;
+
+ const char *p = source;
+ for (j = 0; j < k; j++)
+ *dest++ = (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))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memset4 (p4, ' ', 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)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ if (wlen < len)
+ memcpy4 (p4, source, wlen);
+ else
+ {
+ memset4 (p4, ' ', wlen - len);
+ memcpy4 (p4 + wlen - len, source, len);
+ }
+ return;
+ }
+
if (wlen < len)
memcpy (p, source, wlen);
else
}
break;
#ifdef HAVE_GFC_INTEGER_16
+ case 10:
case 16:
{
- GFC_INTEGER_16 tmp;
+ GFC_INTEGER_16 tmp = 0;
memcpy ((void *) &tmp, p, len);
i = (GFC_UINTEGER_16) tmp;
}
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 (p4, ' ', wlen -1);
+ p4[wlen - 1] = (n) ? 'T' : 'F';
+ return;
+ }
+
+ memset (p, ' ', wlen -1);
p[wlen - 1] = (n) ? 'T' : 'F';
}
static void
-write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len,
- const char *(*conv) (GFC_UINTEGER_LARGEST, char *, size_t))
+write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n)
{
- GFC_UINTEGER_LARGEST n = 0;
int w, m, digits, nzero, nblank;
char *p;
- const char *q;
- char itoa_buf[GFC_BTOA_BUF_SIZE];
w = f->u.integer.w;
m = f->u.integer.m;
- n = extract_uint (source, len);
-
/* Special case: */
if (m == 0 && n == 0)
p = write_block (dtp, w);
if (p == NULL)
return;
-
- memset (p, ' ', w);
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memset4 (p4, ' ', w);
+ }
+ else
+ memset (p, ' ', w);
goto done;
}
- q = conv (n, itoa_buf, sizeof (itoa_buf));
digits = strlen (q);
/* Select a width if none was specified. The idea here is to always
nblank = w - (nzero + digits);
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ if (nblank < 0)
+ {
+ memset4 (p4, '*', w);
+ return;
+ }
+
+ if (!dtp->u.p.no_leading_blank)
+ {
+ memset4 (p4, ' ', nblank);
+ q += nblank;
+ memset4 (p4, '0', nzero);
+ q += nzero;
+ memcpy4 (p4, q, digits);
+ }
+ else
+ {
+ memset4 (p4, '0', nzero);
+ q += nzero;
+ memcpy4 (p4, q, digits);
+ q += digits;
+ memset4 (p4, ' ', nblank);
+ dtp->u.p.no_leading_blank = 0;
+ }
+ return;
+ }
+
if (nblank < 0)
{
star_fill (p, w);
goto done;
}
-
if (!dtp->u.p.no_leading_blank)
{
memset (p, ' ', nblank);
p = write_block (dtp, w);
if (p == NULL)
return;
-
- memset (p, ' ', w);
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memset4 (p4, ' ', 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, '*', w);
+ goto done;
+ }
+
+ memset4 (p4, ' ', nblank);
+ p4 += nblank;
+
+ switch (sign)
+ {
+ case S_PLUS:
+ *p4++ = '+';
+ break;
+ case S_MINUS:
+ *p4++ = '-';
+ break;
+ case S_NONE:
+ break;
+ }
+
+ memset4 (p4, '0', nzero);
+ p4 += nzero;
+
+ memcpy4 (p4, q, digits);
+ return;
+ }
+
if (nblank < 0)
{
star_fill (p, w);
return p;
}
+/* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
+ to convert large reals with kind sizes that exceed the largest integer type
+ available on certain platforms. In these cases, byte by byte conversion is
+ performed. Endianess is taken into account. */
+
+/* Conversion to binary. */
+
+static const char *
+btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
+{
+ char *q;
+ int i, j;
+
+ q = buffer;
+ if (big_endian)
+ {
+ const char *p = s;
+ for (i = 0; i < len; i++)
+ {
+ char c = *p;
+
+ /* Test for zero. Needed by write_boz later. */
+ if (*p != 0)
+ *n = 1;
+
+ for (j = 0; j < 8; j++)
+ {
+ *q++ = (c & 128) ? '1' : '0';
+ c <<= 1;
+ }
+ p++;
+ }
+ }
+ else
+ {
+ const char *p = s + len - 1;
+ for (i = 0; i < len; i++)
+ {
+ char c = *p;
+
+ /* Test for zero. Needed by write_boz later. */
+ if (*p != 0)
+ *n = 1;
+
+ for (j = 0; j < 8; j++)
+ {
+ *q++ = (c & 128) ? '1' : '0';
+ c <<= 1;
+ }
+ p--;
+ }
+ }
+
+ *q = '\0';
+
+ if (*n == 0)
+ return "0";
+
+ /* Move past any leading zeros. */
+ while (*buffer == '0')
+ buffer++;
+
+ return buffer;
+
+}
+
+/* Conversion to octal. */
+
+static const char *
+otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
+{
+ char *q;
+ int i, j, k;
+ uint8_t octet;
+
+ q = buffer + GFC_OTOA_BUF_SIZE - 1;
+ *q = '\0';
+ i = k = octet = 0;
+
+ if (big_endian)
+ {
+ const char *p = s + len - 1;
+ char c = *p;
+ while (i < len)
+ {
+ /* Test for zero. Needed by write_boz later. */
+ if (*p != 0)
+ *n = 1;
+
+ for (j = 0; j < 3 && i < len; j++)
+ {
+ octet |= (c & 1) << j;
+ c >>= 1;
+ if (++k > 7)
+ {
+ i++;
+ k = 0;
+ c = *--p;
+ }
+ }
+ *--q = '0' + octet;
+ octet = 0;
+ }
+ }
+ else
+ {
+ const char *p = s;
+ char c = *p;
+ while (i < len)
+ {
+ /* Test for zero. Needed by write_boz later. */
+ if (*p != 0)
+ *n = 1;
+
+ for (j = 0; j < 3 && i < len; j++)
+ {
+ octet |= (c & 1) << j;
+ c >>= 1;
+ if (++k > 7)
+ {
+ i++;
+ k = 0;
+ c = *++p;
+ }
+ }
+ *--q = '0' + octet;
+ octet = 0;
+ }
+ }
+
+ if (*n == 0)
+ return "0";
+
+ /* Move past any leading zeros. */
+ while (*q == '0')
+ q++;
+
+ return q;
+}
+
+/* Conversion to hexidecimal. */
+
+static const char *
+ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
+{
+ static char a[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
+ '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
+
+ char *q;
+ uint8_t h, l;
+ int i;
+
+ q = buffer;
+
+ if (big_endian)
+ {
+ const char *p = s;
+ for (i = 0; i < len; i++)
+ {
+ /* Test for zero. Needed by write_boz later. */
+ if (*p != 0)
+ *n = 1;
+
+ h = (*p >> 4) & 0x0F;
+ l = *p++ & 0x0F;
+ *q++ = a[h];
+ *q++ = a[l];
+ }
+ }
+ else
+ {
+ const char *p = s + len - 1;
+ for (i = 0; i < len; i++)
+ {
+ /* Test for zero. Needed by write_boz later. */
+ if (*p != 0)
+ *n = 1;
+
+ h = (*p >> 4) & 0x0F;
+ l = *p-- & 0x0F;
+ *q++ = a[h];
+ *q++ = a[l];
+ }
+ }
+
+ *q = '\0';
+
+ if (*n == 0)
+ return "0";
+
+ /* Move past any leading zeros. */
+ while (*buffer == '0')
+ buffer++;
+
+ return buffer;
+}
/* gfc_itoa()-- Integer to decimal conversion.
The itoa function is a widespread non-standard extension to standard
void
-write_b (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
{
- write_int (dtp, f, p, len, btoa);
+ const char *p;
+ char itoa_buf[GFC_BTOA_BUF_SIZE];
+ GFC_UINTEGER_LARGEST n = 0;
+
+ if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
+ {
+ p = btoa_big (source, itoa_buf, len, &n);
+ write_boz (dtp, f, p, n);
+ }
+ else
+ {
+ n = extract_uint (source, len);
+ p = btoa (n, itoa_buf, sizeof (itoa_buf));
+ write_boz (dtp, f, p, n);
+ }
}
void
-write_o (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
{
- write_int (dtp, f, p, len, otoa);
+ const char *p;
+ char itoa_buf[GFC_OTOA_BUF_SIZE];
+ GFC_UINTEGER_LARGEST n = 0;
+
+ if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
+ {
+ p = otoa_big (source, itoa_buf, len, &n);
+ write_boz (dtp, f, p, n);
+ }
+ else
+ {
+ n = extract_uint (source, len);
+ p = otoa (n, itoa_buf, sizeof (itoa_buf));
+ write_boz (dtp, f, p, n);
+ }
}
void
-write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+write_z (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
{
- write_int (dtp, f, p, len, gfc_xtoa);
+ const char *p;
+ char itoa_buf[GFC_XTOA_BUF_SIZE];
+ GFC_UINTEGER_LARGEST n = 0;
+
+ if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
+ {
+ p = ztoa_big (source, itoa_buf, len, &n);
+ write_boz (dtp, f, p, n);
+ }
+ else
+ {
+ n = extract_uint (source, len);
+ p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf));
+ write_boz (dtp, f, p, n);
+ }
}
if (p == NULL)
return;
if (nspaces > 0 && len - nspaces >= 0)
- memset (&p[len - nspaces], ' ', nspaces);
+ {
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memset4 (&p4[len - nspaces], ' ', nspaces);
+ }
+ else
+ memset (&p[len - nspaces], ' ', nspaces);
+ }
}
something goes wrong. */
static int
-write_char (st_parameter_dt *dtp, char c)
+write_char (st_parameter_dt *dtp, int c)
{
char *p;
p = write_block (dtp, 1);
if (p == NULL)
return 1;
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ *p4 = c;
+ return 0;
+ }
- *p = c;
+ *p = (uchar) c;
return 0;
}
p = write_block (dtp, width);
if (p == NULL)
return;
+
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ if (dtp->u.p.no_leading_blank)
+ {
+ memcpy4 (p4, q, digits);
+ memset4 (p4 + digits, ' ', width - digits);
+ }
+ else
+ {
+ memset4 (p4, ' ', width - digits);
+ memcpy4 (p4 + width - digits, q, digits);
+ }
+ return;
+ }
+
if (dtp->u.p.no_leading_blank)
{
memcpy (p, q, digits);
if (p == NULL)
return;
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t d4 = (gfc_char4_t) d;
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+
+ if (d4 == ' ')
+ memcpy4 (p4, source, length);
+ else
+ {
+ *p4++ = d4;
+
+ for (i = 0; i < length; i++)
+ {
+ *p4++ = (gfc_char4_t) source[i];
+ if (source[i] == d)
+ *p4++ = d4;
+ }
+
+ *p4 = d4;
+ }
+ return;
+ }
+
if (d == ' ')
memcpy (p, source, length);
else
p = write_block (dtp, options.separator_len);
if (p == NULL)
return;
-
- memcpy (p, options.separator, options.separator_len);
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memcpy4 (p4, options.separator, options.separator_len);
+ }
+ else
+ memcpy (p, options.separator, options.separator_len);
}
if (is_array_io (dtp))
{
gfc_offset record;
- int finished, length;
+ int finished;
- length = (int) dtp->u.p.current_unit->bytes_left;
-
/* Now that the current record has been padded out,
determine where the next record in the array is. */
record = next_array_record (dtp, dtp->u.p.current_unit->ls,
base_name_len = strlen (base_name);
for (dim_i = 0; dim_i < base_name_len; dim_i++)
{
- cup = toupper (base_name[dim_i]);
+ cup = toupper ((int) base_name[dim_i]);
write_character (dtp, &cup, 1, 1);
}
}
clen = strlen (obj->var_name);
for (dim_i = len; dim_i < clen; dim_i++)
{
- cup = toupper (obj->var_name[dim_i]);
+ cup = toupper ((int) obj->var_name[dim_i]);
write_character (dtp, &cup, 1, 1);
}
write_character (dtp, "=", 1, 1);
obj, ext_name);
}
- free_mem (obj_name);
- free_mem (ext_name);
+ free (obj_name);
+ free (ext_name);
goto obj_loop;
default:
/* Write namelist name in upper case - f95 std. */
for (i = 0 ;i < dtp->namelist_name_len ;i++ )
{
- c = toupper (dtp->namelist_name[i]);
+ c = toupper ((int) dtp->namelist_name[i]);
write_character (dtp, &c, 1 ,1);
}
OSDN Git Service
