OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR libfortran/41711 ([F08] BOZ edit-descr does not support reading large kind reals)

Browse Source 
2009-10-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libgfortran/41711
	* libgfortran.h: Define larger sizes for BOZ conversion	buffers.
	* io/write.c (extract_uint): Include case where size is 10 if integer
	is large enough. (write_int): Rename to	write_boz. (write_boz): Factor
	out extract_uint and delete the	conversion function.
	(btoa_big): New binary conversion function.
	(otoa_big): New octal conversion function.
	(ztoa_big): New	hexidecimal conversion function.
	(write_b): Modify to use new function.
	(write_o): Likewise.
	(write_z): Likewise.

From-SVN: r153724
This commit is contained in:
Jerry DeLisle 2009-10-29 19:20:18 +00:00
parent 2d02c187d1
commit 486024b158
3 changed files with 272 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
libgfortran/ChangeLog
View File

@ -1,3 +1,17 @@
2009-10-29 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libgfortran/41711
* libgfortran.h: Define larger sizes for BOZ conversion buffers.
* io/write.c (extract_uint): Include case where size is 10 if integer
is large enough. (write_int): Rename to write_boz. (write_boz): Factor
out extract_uint and delete the conversion function.
(btoa_big): New binary conversion function.
(otoa_big): New octal conversion function.
(ztoa_big): New hexidecimal conversion function.
(write_b): Modify to use new function.
(write_o): Likewise.
(write_z): Likewise.
2009-10-12 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libgfortran/41683

263
libgfortran/io/write.c
View File

@ -446,9 +446,10 @@ extract_uint (const void *p, int len)
}
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;
}
@ -482,20 +483,14 @@ write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
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)
@ -511,7 +506,6 @@ write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len,
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
@ -538,7 +532,6 @@ write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len,
goto done;
}
if (!dtp->u.p.no_leading_blank)
{
memset (p, ' ', nblank);
@ -706,6 +699,202 @@ btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
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
@ -757,22 +946,64 @@ write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
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);
}
}

14
libgfortran/libgfortran.h
View File

@ -672,10 +672,18 @@ internal_proto(show_backtrace);
/* error.c */
#if defined(HAVE_GFC_REAL_16)
#define GFC_LARGEST_BUF (sizeof (GFC_REAL_16))
#elif defined(HAVE_GFC_REAL_10)
#define GFC_LARGEST_BUF (sizeof (GFC_REAL_10))
#else
#define GFC_LARGEST_BUF (sizeof (GFC_INTEGER_LARGEST))
#endif
#define GFC_ITOA_BUF_SIZE (sizeof (GFC_INTEGER_LARGEST) * 3 + 2)
#define GFC_XTOA_BUF_SIZE (sizeof (GFC_UINTEGER_LARGEST) * 2 + 1)
#define GFC_OTOA_BUF_SIZE (sizeof (GFC_INTEGER_LARGEST) * 3 + 1)
#define GFC_BTOA_BUF_SIZE (sizeof (GFC_INTEGER_LARGEST) * 8 + 1)
#define GFC_XTOA_BUF_SIZE (GFC_LARGEST_BUF * 2 + 1)
#define GFC_OTOA_BUF_SIZE (GFC_LARGEST_BUF * 3 + 1)
#define GFC_BTOA_BUF_SIZE (GFC_LARGEST_BUF * 8 + 1)
extern void sys_exit (int) __attribute__ ((noreturn));
internal_proto(sys_exit);