1 /* Copyright (C) 2002-2003 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 In addition to the permissions in the GNU General Public License, the
12 Free Software Foundation gives you unlimited permission to link the
13 compiled version of this file into combinations with other programs,
14 and to distribute those combinations without any restriction coming
15 from the use of this file. (The General Public License restrictions
16 do apply in other respects; for example, they cover modification of
17 the file, and distribution when not linked into a combine
20 Libgfortran is distributed in the hope that it will be useful,
21 but WITHOUT ANY WARRANTY; without even the implied warranty of
22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 GNU General Public License for more details.
25 You should have received a copy of the GNU General Public License
26 along with Libgfortran; see the file COPYING. If not, write to
27 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
28 Boston, MA 02110-1301, USA. */
37 #include "libgfortran.h"
40 /* read.c -- Deal with formatted reads */
42 /* set_integer()-- All of the integer assignments come here to
43 * actually place the value into memory. */
46 set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
50 #ifdef HAVE_GFC_INTEGER_16
52 *((GFC_INTEGER_16 *) dest) = value;
56 *((GFC_INTEGER_8 *) dest) = value;
59 *((GFC_INTEGER_4 *) dest) = value;
62 *((GFC_INTEGER_2 *) dest) = value;
65 *((GFC_INTEGER_1 *) dest) = value;
68 internal_error ("Bad integer kind");
73 /* max_value()-- Given a length (kind), return the maximum signed or
77 max_value (int length, int signed_flag)
79 GFC_UINTEGER_LARGEST value;
84 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
88 for (n = 1; n < 4 * length; n++)
89 value = (value << 2) + 3;
95 value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff;
98 value = signed_flag ? 0x7fffffff : 0xffffffff;
101 value = signed_flag ? 0x7fff : 0xffff;
104 value = signed_flag ? 0x7f : 0xff;
107 internal_error ("Bad integer kind");
114 /* convert_real()-- Convert a character representation of a floating
115 * point number to the machine number. Returns nonzero if there is a
116 * range problem during conversion. TODO: handle not-a-numbers and
120 convert_real (void *dest, const char *buffer, int length)
129 #if defined(HAVE_STRTOF)
130 strtof (buffer, NULL);
132 (GFC_REAL_4) strtod (buffer, NULL);
134 memcpy (dest, (void *) &tmp, length);
139 GFC_REAL_8 tmp = strtod (buffer, NULL);
140 memcpy (dest, (void *) &tmp, length);
143 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
146 GFC_REAL_10 tmp = strtold (buffer, NULL);
147 memcpy (dest, (void *) &tmp, length);
151 #if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
154 GFC_REAL_16 tmp = strtold (buffer, NULL);
155 memcpy (dest, (void *) &tmp, length);
160 internal_error ("Unsupported real kind during IO");
163 if (errno != 0 && errno != EINVAL)
165 generate_error (ERROR_READ_VALUE,
166 "Range error during floating point read");
174 /* read_l()-- Read a logical value */
177 read_l (fnode * f, char *dest, int length)
205 set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
209 set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
213 generate_error (ERROR_READ_VALUE, "Bad value on logical read");
219 /* read_a()-- Read a character record. This one is pretty easy. */
222 read_a (fnode * f, char *p, int length)
228 if (w == -1) /* '(A)' edit descriptor */
231 source = read_block (&w);
235 source += (w - length);
237 m = (w > length) ? length : w;
238 memcpy (p, source, m);
242 memset (p + m, ' ', n);
246 /* eat_leading_spaces()-- Given a character pointer and a width,
247 * ignore the leading spaces. */
250 eat_leading_spaces (int *width, char *p)
254 if (*width == 0 || *p != ' ')
266 next_char (char **p, int *w)
281 if (g.blank_status != BLANK_UNSPECIFIED)
282 return ' '; /* return a blank to signal a null */
284 /* At this point, the rest of the field has to be trailing blanks */
298 /* read_decimal()-- Read a decimal integer value. The values here are
302 read_decimal (fnode * f, char *dest, int length)
304 GFC_UINTEGER_LARGEST value, maxv, maxv_10;
305 GFC_INTEGER_LARGEST v;
314 p = eat_leading_spaces (&w, p);
317 set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
321 maxv = max_value (length, 1);
343 /* At this point we have a digit-string */
348 c = next_char (&p, &w);
354 if (g.blank_status == BLANK_NULL) continue;
355 if (g.blank_status == BLANK_ZERO) c = '0';
358 if (c < '0' || c > '9')
367 if (value > maxv - c)
376 set_integer (dest, v, length);
380 generate_error (ERROR_READ_VALUE, "Bad value during integer read");
384 generate_error (ERROR_READ_OVERFLOW,
385 "Value overflowed during integer read");
390 /* read_radix()-- This function reads values for non-decimal radixes.
391 * The difference here is that we treat the values here as unsigned
392 * values for the purposes of overflow. If minus sign is present and
393 * the top bit is set, the value will be incorrect. */
396 read_radix (fnode * f, char *dest, int length, int radix)
398 GFC_UINTEGER_LARGEST value, maxv, maxv_r;
399 GFC_INTEGER_LARGEST v;
408 p = eat_leading_spaces (&w, p);
411 set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
415 maxv = max_value (length, 0);
416 maxv_r = maxv / radix;
437 /* At this point we have a digit-string */
442 c = next_char (&p, &w);
447 if (g.blank_status == BLANK_NULL) continue;
448 if (g.blank_status == BLANK_ZERO) c = '0';
454 if (c < '0' || c > '1')
459 if (c < '0' || c > '7')
484 c = c - 'a' + '9' + 1;
493 c = c - 'A' + '9' + 1;
507 value = radix * value;
509 if (maxv - c < value)
518 set_integer (dest, v, length);
522 generate_error (ERROR_READ_VALUE, "Bad value during integer read");
526 generate_error (ERROR_READ_OVERFLOW,
527 "Value overflowed during integer read");
532 /* read_f()-- Read a floating point number with F-style editing, which
533 is what all of the other floating point descriptors behave as. The
534 tricky part is that optional spaces are allowed after an E or D,
535 and the implicit decimal point if a decimal point is not present in
539 read_f (fnode * f, char *dest, int length)
541 int w, seen_dp, exponent;
542 int exponent_sign, val_sign;
556 p = eat_leading_spaces (&w, p);
562 if (*p == '-' || *p == '+')
571 p = eat_leading_spaces (&w, p);
575 /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
576 is required at this point */
578 if (!isdigit (*p) && *p != '.' && *p != 'd' && *p != 'D'
579 && *p != 'e' && *p != 'E')
582 /* Remember the position of the first digit. */
586 /* Scan through the string to find the exponent. */
635 /* No exponent has been seen, so we use the current scale factor */
636 exponent = -g.scale_factor;
640 generate_error (ERROR_READ_VALUE, "Bad value during floating point read");
643 /* The value read is zero */
648 *((GFC_REAL_4 *) dest) = 0;
652 *((GFC_REAL_8 *) dest) = 0;
655 #ifdef HAVE_GFC_REAL_10
657 *((GFC_REAL_10 *) dest) = 0;
661 #ifdef HAVE_GFC_REAL_16
663 *((GFC_REAL_16 *) dest) = 0;
668 internal_error ("Unsupported real kind during IO");
672 /* At this point the start of an exponent has been found */
674 while (w > 0 && *p == ' ')
695 /* At this point a digit string is required. We calculate the value
696 of the exponent in order to take account of the scale factor and
697 the d parameter before explict conversion takes place. */
706 if (g.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
708 while (w > 0 && isdigit (*p))
710 exponent = 10 * exponent + *p - '0';
715 /* Only allow trailing blanks */
725 else /* BZ or BN status is enabled */
731 if (g.blank_status == BLANK_ZERO) *p = '0';
732 if (g.blank_status == BLANK_NULL)
739 else if (!isdigit (*p))
742 exponent = 10 * exponent + *p - '0';
748 exponent = exponent * exponent_sign;
751 /* Use the precision specified in the format if no decimal point has been
754 exponent -= f->u.real.d;
773 i = ndigits + edigits + 1;
777 if (i < SCRATCH_SIZE)
780 buffer = get_mem (i);
782 /* Reformat the string into a temporary buffer. As we're using atof it's
783 easiest to just leave the decimal point in place. */
787 for (; ndigits > 0; ndigits--)
791 if (g.blank_status == BLANK_ZERO) *digits = '0';
792 if (g.blank_status == BLANK_NULL)
803 sprintf (p, "%d", exponent);
805 /* Do the actual conversion. */
806 convert_real (dest, buffer, length);
808 if (buffer != scratch)
815 /* read_x()-- Deal with the X/TR descriptor. We just read some data
816 * and never look at it. */
825 if ((current_unit->flags.pad == PAD_NO || is_internal_unit ())
826 && current_unit->bytes_left < n)
827 n = current_unit->bytes_left;