-/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of the GNU Fortran 95 runtime library (libgfortran).
You should have received a copy of the GNU General Public License
along with Libgfortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
+the Free Software Foundation, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
#include "config.h"
{
#ifdef HAVE_GFC_INTEGER_16
case 16:
- *((GFC_INTEGER_16 *) dest) = value;
+ {
+ GFC_INTEGER_16 tmp = value;
+ memcpy (dest, (void *) &tmp, length);
+ }
break;
#endif
case 8:
- *((GFC_INTEGER_8 *) dest) = value;
+ {
+ GFC_INTEGER_8 tmp = value;
+ memcpy (dest, (void *) &tmp, length);
+ }
break;
case 4:
- *((GFC_INTEGER_4 *) dest) = value;
+ {
+ GFC_INTEGER_4 tmp = value;
+ memcpy (dest, (void *) &tmp, length);
+ }
break;
case 2:
- *((GFC_INTEGER_2 *) dest) = value;
+ {
+ GFC_INTEGER_2 tmp = value;
+ memcpy (dest, (void *) &tmp, length);
+ }
break;
case 1:
- *((GFC_INTEGER_1 *) dest) = value;
+ {
+ GFC_INTEGER_1 tmp = value;
+ memcpy (dest, (void *) &tmp, length);
+ }
break;
default:
- internal_error ("Bad integer kind");
+ internal_error (NULL, "Bad integer kind");
}
}
value = signed_flag ? 0x7f : 0xff;
break;
default:
- internal_error ("Bad integer kind");
+ internal_error (NULL, "Bad integer kind");
}
return value;
* infinities. */
int
-convert_real (void *dest, const char *buffer, int length)
+convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
{
errno = 0;
switch (length)
{
case 4:
- *((GFC_REAL_4 *) dest) =
+ {
+ GFC_REAL_4 tmp =
#if defined(HAVE_STRTOF)
- strtof (buffer, NULL);
+ strtof (buffer, NULL);
#else
- (GFC_REAL_4) strtod (buffer, NULL);
+ (GFC_REAL_4) strtod (buffer, NULL);
#endif
+ memcpy (dest, (void *) &tmp, length);
+ }
break;
case 8:
- *((GFC_REAL_8 *) dest) = strtod (buffer, NULL);
+ {
+ GFC_REAL_8 tmp = strtod (buffer, NULL);
+ memcpy (dest, (void *) &tmp, length);
+ }
break;
#if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
case 10:
- *((GFC_REAL_10 *) dest) = strtold (buffer, NULL);
+ {
+ GFC_REAL_10 tmp = strtold (buffer, NULL);
+ memcpy (dest, (void *) &tmp, length);
+ }
break;
#endif
#if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
case 16:
- *((GFC_REAL_16 *) dest) = strtold (buffer, NULL);
+ {
+ GFC_REAL_16 tmp = strtold (buffer, NULL);
+ memcpy (dest, (void *) &tmp, length);
+ }
break;
#endif
default:
- internal_error ("Unsupported real kind during IO");
+ internal_error (&dtp->common, "Unsupported real kind during IO");
}
if (errno != 0 && errno != EINVAL)
{
- generate_error (ERROR_READ_VALUE,
+ generate_error (&dtp->common, ERROR_READ_VALUE,
"Range error during floating point read");
return 1;
}
/* read_l()-- Read a logical value */
void
-read_l (fnode * f, char *dest, int length)
+read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
char *p;
int w;
w = f->u.w;
- p = read_block (&w);
+ p = read_block (dtp, &w);
if (p == NULL)
return;
break;
default:
bad:
- generate_error (ERROR_READ_VALUE, "Bad value on logical read");
+ generate_error (&dtp->common, ERROR_READ_VALUE,
+ "Bad value on logical read");
break;
}
}
/* read_a()-- Read a character record. This one is pretty easy. */
void
-read_a (fnode * f, char *p, int length)
+read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
{
char *source;
int w, m, n;
if (w == -1) /* '(A)' edit descriptor */
w = length;
- source = read_block (&w);
+ dtp->u.p.sf_read_comma = 0;
+ source = read_block (dtp, &w);
+ dtp->u.p.sf_read_comma = 1;
if (source == NULL)
return;
if (w > length)
static char
-next_char (char **p, int *w)
+next_char (st_parameter_dt *dtp, char **p, int *w)
{
char c, *q;
if (c != ' ')
return c;
- if (g.blank_status != BLANK_UNSPECIFIED)
+ if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
return ' '; /* return a blank to signal a null */
/* At this point, the rest of the field has to be trailing blanks */
* signed values. */
void
-read_decimal (fnode * f, char *dest, int length)
+read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
GFC_UINTEGER_LARGEST value, maxv, maxv_10;
GFC_INTEGER_LARGEST v;
char c, *p;
w = f->u.w;
- p = read_block (&w);
+ p = read_block (dtp, &w);
if (p == NULL)
return;
for (;;)
{
- c = next_char (&p, &w);
+ c = next_char (dtp, &p, &w);
if (c == '\0')
break;
if (c == ' ')
{
- if (g.blank_status == BLANK_NULL) continue;
- if (g.blank_status == BLANK_ZERO) c = '0';
+ if (dtp->u.p.blank_status == BLANK_NULL) continue;
+ if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
}
if (c < '0' || c > '9')
return;
bad:
- generate_error (ERROR_READ_VALUE, "Bad value during integer read");
+ generate_error (&dtp->common, ERROR_READ_VALUE,
+ "Bad value during integer read");
return;
overflow:
- generate_error (ERROR_READ_OVERFLOW,
+ generate_error (&dtp->common, ERROR_READ_OVERFLOW,
"Value overflowed during integer read");
return;
}
* the top bit is set, the value will be incorrect. */
void
-read_radix (fnode * f, char *dest, int length, int radix)
+read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
+ int radix)
{
GFC_UINTEGER_LARGEST value, maxv, maxv_r;
GFC_INTEGER_LARGEST v;
char c, *p;
w = f->u.w;
- p = read_block (&w);
+ p = read_block (dtp, &w);
if (p == NULL)
return;
for (;;)
{
- c = next_char (&p, &w);
+ c = next_char (dtp, &p, &w);
if (c == '\0')
break;
if (c == ' ')
{
- if (g.blank_status == BLANK_NULL) continue;
- if (g.blank_status == BLANK_ZERO) c = '0';
+ if (dtp->u.p.blank_status == BLANK_NULL) continue;
+ if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
}
switch (radix)
return;
bad:
- generate_error (ERROR_READ_VALUE, "Bad value during integer read");
+ generate_error (&dtp->common, ERROR_READ_VALUE,
+ "Bad value during integer read");
return;
overflow:
- generate_error (ERROR_READ_OVERFLOW,
+ generate_error (&dtp->common, ERROR_READ_OVERFLOW,
"Value overflowed during integer read");
return;
}
the input. */
void
-read_f (fnode * f, char *dest, int length)
+read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
int w, seen_dp, exponent;
int exponent_sign, val_sign;
int i;
char *p, *buffer;
char *digits;
+ char scratch[SCRATCH_SIZE];
val_sign = 1;
seen_dp = 0;
w = f->u.w;
- p = read_block (&w);
+ p = read_block (dtp, &w);
if (p == NULL)
return;
case '9':
case ' ':
ndigits++;
- *p++;
+ p++;
w--;
break;
}
/* No exponent has been seen, so we use the current scale factor */
- exponent = -g.scale_factor;
+ exponent = -dtp->u.p.scale_factor;
goto done;
bad_float:
- generate_error (ERROR_READ_VALUE, "Bad value during floating point read");
+ generate_error (&dtp->common, ERROR_READ_VALUE,
+ "Bad value during floating point read");
return;
/* The value read is zero */
#endif
default:
- internal_error ("Unsupported real kind during IO");
+ internal_error (&dtp->common, "Unsupported real kind during IO");
}
return;
p++;
w--;
- if (g.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
+ if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
{
while (w > 0 && isdigit (*p))
{
{
if (*p == ' ')
{
- if (g.blank_status == BLANK_ZERO) *p = '0';
- if (g.blank_status == BLANK_NULL)
+ if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0';
+ if (dtp->u.p.blank_status == BLANK_NULL)
{
p++;
w--;
{
if (*digits == ' ')
{
- if (g.blank_status == BLANK_ZERO) *digits = '0';
- if (g.blank_status == BLANK_NULL)
+ if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0';
+ if (dtp->u.p.blank_status == BLANK_NULL)
{
digits++;
continue;
sprintf (p, "%d", exponent);
/* Do the actual conversion. */
- convert_real (dest, buffer, length);
+ convert_real (dtp, dest, buffer, length);
if (buffer != scratch)
free_mem (buffer);
* and never look at it. */
void
-read_x (fnode * f)
+read_x (st_parameter_dt *dtp, int n)
{
- int n;
-
- n = f->u.n;
-
- if ((current_unit->flags.pad == PAD_NO || is_internal_unit ())
- && current_unit->bytes_left < n)
- n = current_unit->bytes_left;
-
- if (n > 0)
- read_block (&n);
+ if (!is_stream_io (dtp))
+ {
+ if ((dtp->u.p.current_unit->flags.pad == PAD_NO || is_internal_unit (dtp))
+ && dtp->u.p.current_unit->bytes_left < n)
+ n = dtp->u.p.current_unit->bytes_left;
+
+ dtp->u.p.sf_read_comma = 0;
+ if (n > 0)
+ read_sf (dtp, &n, 1);
+ dtp->u.p.sf_read_comma = 1;
+ }
+ else
+ dtp->rec += (GFC_IO_INT) n;
}